IBM Mainframe Forum

MDAY     CSECT
         USING *,4
         SAVE  (14,4),,*
         LR    4,15
         TIME  DEC
* TRANSLATE PL4'0CYYDDD' TO BINARY
         XC    64(4,13),64(13)
         ST    1,68(,13)
         CVB   3,64(,13)
* ISOLATE CYY AND DDD
         SR    2,2
         D     2,=F'1000'
* CONVERT CYY TO A TRUE YEAR
         LA    3,1900(,3)
* DETERMINE IF LEAP YEAR.  THIS IS THE
* FULL GREGORIAN CALENDAR LEAP YEAR TEST
         LR    14,3
         LR    15,3
         N     14,=A(B'11')
         JNZ   MD0100
* YEAR IS DIVISIBLE BY 4, TEST IF CENTURY YEAR
         D     14,=F'100'
         LTR   14,14
         JNZ   MD0200
* TEST IF CENTURY YEAR DIVISIBLE BY 400
         N     15,=A(B'11')
         JZ    MD0200
* IT'S NOT A LEAP YEAR, TEST IF DAY OF YEAR
* IS IN JANUARY OR FEBRUARY
MD0100   C     2,=A(31+28)
         JNH   MD0200
* CHANGE NON-LEAP YEAR DAY OF YEAR TO
* LEAP YEAR DAY OF YEAR
         LA    2,1(,2)
* LOAD DAY OF MONTH INTO REG 15
MD0200   SR    15,15
         IC    15,T1(2)
         RETURN (14,4),T,RC=(15)
* TABLE TO TRANSLATE DAY OF YEAR IN A LEAP
* YEAR TO DAY OF MONTH
T1       DC    32AL1(*-T1)
T2       DC    29AL1(*-T2+1)
T3       DC    31AL1(*-T3+1)
T4       DC    30AL1(*-T4+1)
T5       DC    31AL1(*-T5+1)
T6       DC    30AL1(*-T6+1)
T7       DC    31AL1(*-T7+1)
T8       DC    31AL1(*-T8+1)
T9       DC    30AL1(*-T9+1)
T10      DC    30AL1(*-T10+1)
T11      DC    30AL1(*-T11+1)
T12      DC    30AL1(*-T12+1),0D'0'
         LTORG ,
         DC    0D'0'
         END   MDAY

Identification Division.                         
Program-Id. DAYPGM.                               
Procedure Division.                               
    Move Function Current-date(7:2) to Return-Code
    GoBack                                       
    .