I attach a Rexx program to calculate and display the biorhythm values
for a given date of birth and current or whatever other date.
If 'management' complains that home workers are not putting enough
effort into their working-from-home time, they can run this thing and
send its output to 'management' just to prove that they are in perfect
working condition and that any slow-down in productivity must be due to
external factors which are wholly beyond their control <g>.
Cheers, Chris Poncelet (retired sysprog)
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions,
send email to [email protected] with the message: INFO IBM-MAIN
/*********************************************************************/
/* Calculate Biorhythm Program */
/* */
/* Based on theory that physical, emotional and intellectual cycles */
/* vary from 1.00 to -1.00 every 23, 28 and 33 days from the date of */
/* birth onwards - where positive scores are "up days" and negative */
/* scores indicate "down days" */
/* */
/* Cycles: */
/* - Physical : 23 days */
/* - Emotional : 28 days */
/* - Intellectual : 33 days */
/* */
/* Paramters: */
/* - DATE1 : date of birth */
/* - DATE2 : current date */
/* - DEBUG : to debug this thing, if required */
/* */
/* */
/* 2020/04/04 Chris Poncelet */
/*********************************************************************/
ARG DATE1 DATE2 DEBUG
IF ABBREV(DEBUG,'D') = 1 THEN ,
TRACE I
NUMERIC DIGITS 100
/* CHECK THAT START DATE1 IS EARLIER THAN END DATE DATE2 */
IF DATE2 ¬> DATE1 THEN ,
DO
SAY 'START DATE 'DATE1' MUST BE EARLIER THAN END DATE 'DATE2'.'
SAY ' '
SAY 'PLEASE TRY AGAIN.'
SAY ' '
CALL EXIT
END /* IF */
/* CHECK THAT DATE1 DATA IS VALID AND WHETHER LEAP YEAR ETC. */
Q = DATE1
CALL CHECK_DATE
/* CONVERT DATE1 YEARS, MONTHS, DAYS TO FACTOR */
CALL GET_FACTOR
FACTOR1 = FACTOR
/* CALCULATE DAY OF THE WEEK FOR DATE1 */
DW1 = FACTOR + TRUNC(-FACTOR/7)*7
SELECT
WHEN DW1 = 0 THEN DW1 = '(SATURDAY)'
WHEN DW1 = 1 THEN DW1 = '(SUNDAY)'
WHEN DW1 = 2 THEN DW1 = '(MONDAY)'
WHEN DW1 = 3 THEN DW1 = '(TUESDAY)'
WHEN DW1 = 4 THEN DW1 = '(WEDNESDAY)'
WHEN DW1 = 5 THEN DW1 = '(THURSDAY)'
WHEN DW1 = 6 THEN DW1 = '(FRIDAY)'
OTHERWISE NOP
END /* SELECT */
SAY 'WE HAVE YEAR = 'YEAR', MONTH = 'MONTH', DAY = 'DAY' 'DW1
SAY ' '
/* CHECK THAT DATE2 DATA IS VALID AND WHETHER LEAP YEAR ETC. */
Q = DATE2
CALL CHECK_DATE
/* CONVERT DATE2 YEARS, MONTHS, DAYS TO FACTOR */
CALL GET_FACTOR
FACTOR2 = FACTOR
/* CALCULATE DAY OF THE WEEK FOR DATE2 */
DW2 = FACTOR + TRUNC(-FACTOR/7)*7
SELECT
WHEN DW2 = 0 THEN DW2 = '(SATURDAY)'
WHEN DW2 = 1 THEN DW2 = '(SUNDAY)'
WHEN DW2 = 2 THEN DW2 = '(MONDAY)'
WHEN DW2 = 3 THEN DW2 = '(TUESDAY)'
WHEN DW2 = 4 THEN DW2 = '(WEDNESDAY)'
WHEN DW2 = 5 THEN DW2 = '(THURSDAY)'
WHEN DW2 = 6 THEN DW2 = '(FRIDAY)'
OTHERWISE NOP
END /* SELECT */
SAY 'WE HAVE YEAR = 'YEAR', MONTH = 'MONTH', DAY = 'DAY' 'DW2
SAY ' '
#DAYS = FACTOR2 - FACTOR1
SAY 'ELAPSED NUMBER OF DAYS IS '#DAYS
SAY ' '
/* NOW GET PHYSICAL, EMOTIONAL AND INTELLECTUAL CYCLE SCORES */
Q = #DAYS/23
CALL GET_SINE
P = QS
IF P < 0 THEN ,
SAY 'PHYSICAL : 'FORMAT(QS,,2)
ELSE,
SAY 'PHYSICAL : 'FORMAT(QS,,2)
SAY ' '
Q = #DAYS/28
CALL GET_SINE
E = QS
IF E < 0 THEN ,
SAY 'EMOTIONAL : 'FORMAT(QS,,2)
ELSE ,
SAY 'EMOTIONAL : 'FORMAT(QS,,2)
SAY ' '
Q = #DAYS/33
CALL GET_SINE
I = QS
IF I < 0 THEN ,
SAY 'INTELLECTUAL : 'FORMAT(QS,,2)
ELSE ,
SAY 'INTELLECTUAL : 'FORMAT(QS,,2)
SAY ' '
AV = (P+E+I)/3
IF AV < 0 THEN ,
SAY 'AVERAGE : 'FORMAT(AV,,2)
ELSE ,
SAY 'AVERAGE : 'FORMAT(AV,,2)
SAY ' '
CALL EXIT
/*********************************************************************/
/* SUBROUTINES */
/*********************************************************************/
CHECK_DATE:
/* CHECK THAT DATE IS NUMERIC AND IN THE CORRECT FORMAT */
IF DATATYPE(Q,N) ¬= 1 ,
| DATATYPE(SUBSTR(Q,1,4),W) ¬= 1 ,
| DATATYPE(SUBSTR(Q,6,4),W) ¬= 1 ,
| LENGTH(Q) ¬= 9 ,
| SUBSTR(Q,5,1) ¬= '.' THEN ,
DO
SAY '"'Q'"' 'MUST BE NUMERIC IN THE FORM "yyyy.mmdd"'
SAY ' '
SAY 'PLEASE TRY AGAIN'
SAY ' '
CALL EXIT
END /* IF */
ELSE ,
DO
/* CHECK THAT DATE IS WITHIN VALID RANGES */
YEAR = TRUNC(Q)
MONTH = SUBSTR(Q,6,2)
DAY = SUBSTR(Q,8,2)
IF (YEAR < 1582 | MONTH < 1 | MONTH > 12 | DAY < 1 | DAY > 31) THEN ,
DO
IF (YEAR < 1582 ) THEN ,
SAY 'YEAR = 'YEAR' MUST BE AT LEAST 1582 (GREGORIAN CALENDAR)'
IF (MONTH < 1 | MONTH > 12) THEN ,
SAY 'MONTH = 'MONTH' CANNOT BE LESS THAN 01 OR MORE THAN 12'
IF (DAY < 1 | DAY > 31) THEN ,
SAY 'DAY = 'DAY' CANNOT BE LESS THAN 01 OR MORE THAN 31'
SAY ' '
CALL EXIT
END /* IF */
/* CHECK WHETHER THIS YEAR IS A LEAP YEAR */
LEAP = (YEAR -YEAR%4*4 = 0 & YEAR - YEAR%400*400 ¬= 0)
/* CHECK THAT DATE IS VALID FOR FEBRUARY */
IF MONTH == 02 & DAY > 29 & LEAP THEN ,
DO
SAY 'MONTH 'MONTH' IN YEAR 'YEAR' CANNOT HAVE MORE THAN 29 DAYS'
SAY ' '
CALL EXIT
END /* IF */
IF MONTH == 02 & DAY > 28 & ¬LEAP THEN ,
DO
SAY 'MONTH 'MONTH' IN YEAR 'YEAR' CANNOT HAVE MORE THAN 28 DAYS'
SAY ' '
CALL EXIT
END /* IF */
/* CHECK THAT DATE IS VALID FOR ALL OTHER MONTHS OF THE YEAR */
IF (MONTH == 01 ,
| MONTH == 03 ,
| MONTH == 05 ,
| MONTH == 07 ,
| MONTH == 08 ,
| MONTH == 10 ,
| MONTH == 12) ,
& (DAY > 31) THEN ,
DO
SAY 'MONTH 'MONTH' CANNOT HAVE MORE THAN 31 DAYS'
SAY ' '
CALL EXIT
END /* IF */
IF (MONTH == 04 ,
| MONTH == 06 ,
| MONTH == 09 ,
| MONTH == 11) ,
& (DAY > 30) THEN ,
DO
SAY 'MONTH 'MONTH' CANNOT HAVE MORE THAN 30 DAYS'
SAY ' '
CALL EXIT
END /* IF */
END /* ELSE */
RETURN
GET_FACTOR:
/* CALCULATE THE FACTOR FOR GIVEN DATE (LOGIC CRIBBED FROM MY TI-58'S ML20 */
MM = MONTH
YY = YEAR
DD = DAY
FACTOR = YY*365+DD+(MM-1)*31
SELECT
WHEN (MONTH == 01 | MONTH == 02) THEN ,
FACTOR = ,
FACTOR+TRUNC((YY-1)/4)-TRUNC((TRUNC((YY-1)/100)+1)*3/4)
OTHERWISE ,
FACTOR = ,
FACTOR-TRUNC(0.4*MM+2.3)+TRUNC(YY/4)-TRUNC((TRUNC(YY/100)+1)*3/4)
END /* SELECT */
RETURN FACTOR
GET_SINE:
/* CALCULATE THE SINE OF THE ELAPSED NUMBER OF DAYS IN RADIANS */
PI = 3.1415926535897932384626433832795
QR = Q*PI*2
T = TRUNC(QR/(PI*2))
QR = QR - T*PI*2
T = QR
F = 1
QS = T
DO I = 1 TO 52 BY 4
F = F*(I+1)*(I+2)
QS = QS-T**(I+2)/F
F = F*(I+3)*(I+4)
QS = QS+T**(I+4)/F
END I
RETURN QS
EXIT:
EXIT 0
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions,
send email to [email protected] with the message: INFO IBM-MAIN
