Original IBM HLASM assembler
Excerpt from the source of a date conversion utility by Jay Moseley (All rights acknowledged).
TITLE 'Y2KDFMT - FORMAT DATE FOR OUTPUT' 00010000
* * 00020000
* YY YY 222 KK KK DDDDDD FFFFFFF M MTTTTTTTT * 00030000
* YY YY 2 2 KK KK DD DD FF MM MM TT * 00040000
* YY YY 2 KK KK DD DD FF MMM MMM TT * 00050000
* YY YY 2 KKKK DD DD FFFFF MMMMMMM TT * 00060000
* YYY 222 KKKK DD DD FF MM M MM TT * 00070000
* YY 2 KK KK DD DD FF MM MM TT * 00080000
* YY 2 KK KK DD DD FF MM MM TT * 00090000
* YY 22222 KK KK DDDDDD FF MM MM TT * 00100000
* * 00110000
* ******************************************************************* * 00120000
* ******************************************************************* * 00130000
* THIS SUBROUTINE FORMATS A GIVEN GREGORIAN DATE (MMDDYYYY) IN * 00140000
* A LARGE VARIETY OF FORMATS * 00150000
* * 00160000
* 1. VALID INPUT YEARS FOR THIS ROUTINE ARE THE YEARS 1601 * 00170000
* THROUGH 3399 A. D. (INCLUSIVE) * 00180000
* * 00190000
* 2. VALID INPUT MONTH VALUES FOR THIS ROUTINE ARE 01 THROUGH 12. * 00200000
* * 00210000
* 3. VALID INPUT DAY VALUES FOR THIS ROUTINE ARE 01 THROUGH 31 * 00220000
* WITH EXCEPTIONS FOR THE MONTHS LISTED: * 00230000
* MONTH MAXIMUM DAY VALUE * 00240000
* 04 30 * 00250000
* 06 30 * 00260000
* 09 30 * 00270000
* 11 30 * 00280000
* 02 28 * 00290000
* 02 DURING LEAP YEAR 29 * 00300000
* * 00310000
* 4. THE DATE FORMAT MUST BE MMDDYYYY, WHERE MM = THE 2 DIGIT * 00320000
* MONTH VALUE, DD = THE 2 DIGIT DAY VALUE, AND YYYY = THE * 00330000
* 4 DIGIT YEAR VALUE. * 00340000
* * 00350000
* 5. THE MAJOR FORMAT CODE DETERMINES THE OVERALL OUTPUT FORMAT * 00360000
* AND THE MINOR FORMAT CODE DETERMINES SUBTLE VARIATIONS OF * 00370000
* THE FORMAT: * 00380000
* MAJOR MINOR * 00390000
* 1 = COMMERCIAL (01051997) 1 = NO INSERT * 00400000
* 1 = COMMERCIAL (01 05 1997) 2 = SPACE * 00410000
* 2 = EUROPEAN (05/01/1997) 3 = SLASH * 00420000
* 2 = EUROPEAN (05-01-1997) 4 = HYPHEN * 00430000
* 3 = F.I.P.S. (YYYY.MM.DD) 5 = PERIOD * 00440000
* --------------------------------------------------------- * 00450000
* 4 = TEXT 1 (JANUARY 5, 1997) 1 = U.S. * 00460000
* 4 = TEXT 1 (5 JANUARY 1997) 2 = EUROPEAN * 00470000
* 5 = TEXT 2 (JAN 5, 1997) 1 = U.S. * 00480000
* 6 = TEXT 3 (SUNDAY, JANUARY 5, 1997) 1 = U.S. * 00490000
* 7 = TEXT 4 (SUNDAY, 5 JAN 1997) 2 = EUROPEAN * 00500000
* 8 = TEXT 5 (SUN, JANUARY 5, 1997) 1 = U.S. * 00510000
* 9 = TEXT 6 (SUN, 5 JAN 1997) 2 = EUROPEAN * 00520000
* * 00530000
* 6. SIX FIELDS ARE PASSED AS PARAMETERS TO THE ROUTINE: * 00540000
* 1) AN 8 BYTE FIELD CONTAINING THE DATE (IN ZONED- * 00550000
* DECIMAL FORMAT) TO BE FORMATTED, * 00560000
* 2) A 1 BYTE ZONED-DECIMAL MAJOR FORMAT CODE (SEE 5 ABOVE), * 00570000
* 3) A 1 BYTE ZONED-DECIMAL MINOR FORMAT CODE (SEE 5 ABOVE), * 00580000
* 4) A 1 BYTE ZONED-DECIMAL RETURN CODE, * 00590000
* 5) A 2 BYTE FIELD WHICH WILL CONTAIN THE NUMBER OF BYTES * 00600000
* PLACED IN THE FOLLOWING FIELD (IN ZONED DECIMAL FORMAT), * 00610000
* 6) AN OUTPUT FIELD TO RECEIVE THE FORMATTED DATE (NOTE: * 00620000
* THE SIZE OF THIS FIELD DEPENDS UPON THE FORMATTING * 00630000
* CODES ... IT IS THE CALLER'S RESPONSIBILITY TO PASS A * 00640000
* FIELD LONG ENOUGH TO RECEIVE THE REQUESTED FORMAT). * 00650000
* THE ROUTINE WILL NOT ALTER THE DATE OR FORMAT CODE FIELDS. * 00660000
* * 00670000
* SUGGESTED CALLING SYNTAX FOR ALC CALLERS: * 00680000
* * 00690000
* CALL Y2KDFMT,(DATEIN) * 00700000
* . . . * 00710000
* DATEIN DS ZL8'01051997' * 00720000
* MAJOR DS CL1'1' * 00730000
* MINOR DS CL1'3' * 00740000
* RC DS ZL1'0' * 00750000
* OUTSIZE DS ZL2'00' * 00760000
* OUTDATE DS CL29' ' * 00770000
* * 00780000
* SUGGESTED CALLING SYNTAX FOR COBOL CALLERS: * 00790000
* * 00800000
* 01 DFMT-PARAMETERS. * 00810000
* 02 DATEIN PIC 9(8) VALUE 01011997. * 00820000
* 02 MAJOR PIC 9(1) VALUE 1. 00830000
* 02 MINOR PIC 9(1) VALUE 3. 00840000
* 02 RC PIC 9(1) VALUE 0. * 00850000
* 02 OUTSIZE PIC 9(2) VALUE 0. * 00860000
* 02 OUTDATE PIC X(29). * 00870000
* CALL 'Y2KDFMT' USING DFMT-PARAMETERS. * 00880000
* * 00890000
* 7. THE POSSIBLE VALUES FOR THE RETURN CODE FIELD ARE: * 00900000
* * 00910000
* 0 INDICATES SUCCESSFUL EXECUTION OF THE ROUTINE. * 00920000
* * 00930000
* 2 INDICATES INVALID DATA WAS FOUND IN THE DATE FIELD. * 00940000
* INVALID DATA ARE DETERMINED IF THE FIELD'S LOW ORDER * 00950000
* BYTE'S ZONE CONTAINS AN INVALID SIGN, (NOT ONE OF * 00960000
* X'C', X'D' OR X'F'), OR IF THE PRECEDING BYTES' ZONES * 00970000
* ARE OTHER THAN X'F', OR IF ANY BYTE'S LOW ORDER NIBBLE * 00980000
* CONTAINS A VALUE GREATER THAN X'9'. * 00990000
* * 01000000
* 4 INDICATES THE VALUE OF THE YEAR SPECIFIED WAS NOT IN * 01010000
* THE RANGE SPECIFIED IN 1 (ABOVE). * 01020000
* * 01030000
* 6 INDICATES THE VALUE OF THE MONTH SPECIFIED WAS NOT IN * 01040000
* THE RANGE SPECIFIED IN 2 (ABOVE). * 01050000
* * 01060000
* 8 INDICATES THE VALUE OF THE DAY SPECIFIED WAS NOT IN * 01070000
* THE RANGE SPECIFIED IN 3 (ABOVE). * 01080000
* * 01090000
* 3 INDICATES THE VALUE OF THE MAJOR FORMAT CODE SPECIFIED * 01100000
* WAS NOT ONE OF THE ACCEPTABLE VALUES (SEE 5 ABOVE). * 01110000
* * 01120000
* 5 INDICATES THE VALUE OF THE MINOR FORMAT CODE SPECIFIED * 01130000
* WAS NOT ONE OF THE ACCEPTABLE VALUES FOR THE MAJOR FORMAT * 01140000
* CODE SPECIFIED (SEE 5 ABOVE). * 01150000
* * 01160000
* 8. UPON SUCCESSFUL EXECUTION, THE FORMATTED DATE WILL BE * 01170000
* PLACED IN THE 6TH PARAMETER FIELD AND THE NUMBER OF BYTES * 01180000
* PLACED IN THE FIELD WILL BE PLACED IN THE 5TH FIELD. IF * 01190000
* THE RETURN CODE CONTAINS A NON-ZERO VALUE (UNSUCCESSFUL * 01200000
* EXECUTION), THE 6TH FIELD WILL NOT BE MODIFIED BY THE * 01210000
* ROUTINE AND THE 5TH FIELD WILL CONTAIN ZERO. * 01220000
* * 01230000
* ******************************************************************* * 01240000
* ******************************************************************* * 01250000
EJECT 01260000
Y2KDFMT CSECT 01270000
* PRINT NOGEN 01280001
EYEC 'FORMAT DATE WITH FOR PRINT/DISPLAY' 01290000
* 01300000
SAVE (14,12) SAVE CALLER'S REGISTERS 01310000
* 01320000
LR R12,R15 LOAD BASE WITH ENTRY ADDRESS 01330000
USING Y2KDFMT,R12 ESTABLISH ADDRESSABILITY 01340000
* 01350000
L R11,0(,R1) LOAD A(PARAMETERS) 01360000
USING $PARMS,R11 ESTABLISH ADDRESSABILITY 01370000
* 01380000
GETMAIN R,LV=$DYNLEN GETMAIN DYNAMIC WORKAREA 01390000
LR R10,R1 SAVE A(MEMORY) 01400000
* 01410000
ST R13,4(,R10) STORE A(CALLER'S SAVE AREA) 01420000
ST R10,8(,R13) BACK CHAIN A(MY SAVE AREA) 01430000
LR R13,R10 SET A(MY SAVE AREA) 01440000
USING $DYNMEM,R13 ESTABLISH ADDRESSABILITY 01450000
* 01460000
* INSERT EYECATCHER MARKS AT BEGIN/END OF GETMAIN'D AREA. 01470000
* 01480000
MVC TOPFLAG,=C'Y2KDFMT GETMAIN BEGINS->' 01490000
MVC BOTFLAG,=C'<-Y2KDFMT GETMAIN ENDS' 01500000
* 01510000
* INITIALIZE RETURN CODE AND OUTPUT BYTE COUNT. 01520000
* 01530000
MVI PRC,C'0' ASSUME GOOD RETURN 01540000
MVC PRC+1(2),PRC ZERO RETURN SIZE 01550000
* 01560000
* CALL Y2KDOWN TO VERIFY DATE AND RETURN INTEGRAL DAY NUMBER. 01570000
* 01580000
MVC DDATE,PDATE COPY YEAR TO Y2KDOWN PARM 01590000
LA R1,DOWNPARM ADDRESS OF Y2KDOWN PARMS 01600000
ST R1,PLIST STORE IN DYNAMIC AREA 01610000
LA R1,PLIST ADDRESS TO PASS 01620000
L R15,=V(Y2KDOWN) ADDRESS OF ROUTINE 01630000
BALR R14,R15 CALL ROUTINE 01640000
* 01650000
* SEE IF DATE WE RECEIVED FROM CALLER PASSED EDITS IN Y2KDOWN. 01660000
* THIS MEANS WE DON'T HAVE TO REPEAT THE EDIT CODE HERE <G>! 01670000
* 01680000
MVC PRC,DRC ADOPT RECEIVED RETURN CODE 01690000
CLI DRC,C'0' WAS EXECUTION SUCCESSFUL? 01700000
BNE RETURN IF NOT, EXIT TO CALLER 01710000
* 01720000
* TEST MAJOR FORMAT CODE FOR INVALID VALUE. 01730000
* 01740000
XR R1,R1 CLEAR WORK REGISTER 01750000
IC R1,PMAJOR GET MAJOR FORMAT CODE 01760000
LA R2,X'F1' LOWEST VALID CODE 01770000
LA R3,9 HIGHEST VALID CODE 01780000
MAJLOOP CR R1,R2 IS FORMAT VALID? 01790000
BE MAJOK YES, CONTINUE 01800000
LA R2,1(,R2) INCREMENT TO NEXT VALID CODE 01810000
BCT R3,MAJLOOP AND CONTINUE TESTING 01820000
MVI PRC,C'3' INDICATE INVALID CODE 01830000
B RETURN 01840000
* 01850000
* TEST MINOR FORMAT CODE FOR INVALID VALUE. 01860000
* 01870000
MAJOK IC R1,PMINOR GET MINOR FORMAT CODE 01880000
LA R2,X'F1' LOWEST VALID CODE 01890000
LA R3,5 HIGHEST VALID CODE FOR MAJ:1-3 01900000
CLI PMAJOR,C'4' IS MAJOR LESS THAN 4? 01910000
BL MINLOOP YES, BEGIN TEST 01920000
LA R3,2 ELSE SET HIGHEST FOR MAJ:4-9 01930000
MINLOOP CR R1,R2 IS FORMAT VALID? 01940000
BE MINOK YES, CONTINUE 01950000
LA R2,1(,R2) INCREMENT TO NEXT VALID CODE 01960000
BCT R3,MINLOOP AND CONTINUE TESTING 01970000
MVI PRC,C'5' INDICATE INVALID CODE 01980000
B RETURN 01990000
* 02000000
* BRANCH TO FORMAT ROUTINE BASED ON MAJOR FORMAT CODE 02010000
* 02020000
MINOK XR R3,R3 CLEAR WORK REGISTER 02030000
IC R3,PMAJOR GET FORMAT NUMBER 02040000
N R3,=F'15' CLEAR SIGN 02050000
BCTR R3,0 DECREMENT BY 1 (ZERO BASED) 02060000
SLL R3,2 MULTIPLY BY 4 (LENGTH OF BRANCH) 02070000
LA R3,MFMTBR(R3) LOAD ADDRESS OF BRANCH 02080000
BR R3 GO BRANCH DEPENDING ON FORMAT 02090000
* 02100000
* BRANCH TABLE TO SELECT ROUTINE FOR MAJOR FORMAT CODE 02110000
* 02120000
MFMTBR B MFMT1 02130000
B MFMT2 02140000
B MFMT3 02150000
B MFMT4 02160000
B MFMT5 02170000
B MFMT6 02180000
B MFMT7 02190000
B MFMT8 02200000
B MFMT9 02210000
* 02220000
* MAJOR FORMAT CODE 1: COMMERCIAL (MMDDYYYY) 02230000
* 02240000
MFMT1 BAL R9,MFMTSUB GO GET SEPARATOR CHARACTOR 02250000
LA R2,POUTDATE LOAD OUTPUT AREA ADDRESS 02260000
MVC 0(2,R2),PDATE MOVE MM 02270000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 02280000
LTR R3,R3 IS THERE AN INSERTION CHAR? 02290000
BZ MFMT1A NO, JUMP OVER 02300000
STC R3,0(,R2) INSERT CHARACTER 02310000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 02320000
MFMT1A MVC 0(2,R2),PDATE+2 MOVE DD 02330000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 02340000
LTR R3,R3 IS THERE AN INSERTION CHAR? 02350000
BZ MFMT1B NO, JUMP OVER 02360000
STC R3,0(,R2) INSERT CHARACTER 02370000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 02380000
MFMT1B MVC 0(4,R2),PDATE+4 MOVE YYYY 02390000
LA R2,4(,R2) BUMP OUTPUT ADDRESS 02400000
B SETSIZE SET OUTPUT FIELD SIZE 02410000
* 02420000
* MAJOR FORMAT CODE 2: EUROPEAN (DDMMYYYY) 02430000
* 02440000
MFMT2 BAL R9,MFMTSUB GO GET SEPARATOR CHARACTOR 02450000
LA R2,POUTDATE LOAD OUTPUT AREA ADDRESS 02460000
MVC 0(2,R2),PDATE+2 MOVE DD 02470000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 02480000
LTR R3,R3 IS THERE AN INSERTION CHAR? 02490000
BZ MFMT2A NO, JUMP OVER 02500000
STC R3,0(,R2) INSERT CHARACTER 02510000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 02520000
MFMT2A MVC 0(2,R2),PDATE MOVE MM 02530000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 02540000
LTR R3,R3 IS THERE AN INSERTION CHAR? 02550000
BZ MFMT2B NO, JUMP OVER 02560000
STC R3,0(,R2) INSERT CHARACTER 02570000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 02580000
MFMT2B MVC 0(4,R2),PDATE+4 MOVE YYYY 02590000
LA R2,4(,R2) BUMP OUTPUT ADDRESS 02600000
B SETSIZE SET OUTPUT FIELD SIZE 02610000
* 02620000
* MAJOR FORMAT CODE 3: F.I.P.S. (YYYYMMDD) 02630000
* 02640000
MFMT3 BAL R9,MFMTSUB GO GET SEPARATOR CHARACTOR 02650000
LA R2,POUTDATE LOAD OUTPUT AREA ADDRESS 02660000
MVC 0(4,R2),PDATE+4 MOVE YYYY 02670000
LA R2,4(,R2) BUMP OUTPUT ADDRESS 02680000
LTR R3,R3 IS THERE AN INSERTION CHAR? 02690000
BZ MFMT3A NO, JUMP OVER 02700000
STC R3,0(,R2) INSERT CHARACTER 02710000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 02720000
MFMT3A MVC 0(2,R2),PDATE MOVE MM 02730000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 02740000
LTR R3,R3 IS THERE AN INSERTION CHAR? 02750000
BZ MFMT3B NO, JUMP OVER 02760000
STC R3,0(,R2) INSERT CHARACTER 02770000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 02780000
MFMT3B MVC 0(2,R2),PDATE+2 MOVE DD 02790000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 02800000
B SETSIZE SET OUTPUT FIELD SIZE 02810000
* 02820000
* THIS SUBROUTINE PLACES THE INSERTION CHARACTER (IF ANY) INTO 02830000
* REGISTER 3 BASED UPON MINOR CODE 1 THROUGH 5 (USED BY MAJOR 02840000
* CODE ROUTINES 1 THROUGH 3 ABOVE. 02850000
* 02860000
MFMTSUB XR R3,R3 ASSUME NO SEPARATOR 02870000
XR R4,R4 CLEAR WORK REGISTER 02880000
IC R4,PMINOR GET MINOR FORMAT NUMBER 02890000
N R4,=F'15' CLEAR SIGN 02900000
BCTR R4,0 DECREMENT BY 1 (ZERO BASED) 02910000
SLL R4,2 MULTIPLY BY 4 (LENGTH OF BRANCH) 02920000
LA R4,MFMTSBR(R4) LOAD ADDRESS OF BRANCH 02930000
BR R4 GO BRANCH DEPENDING ON FORMAT 02940000
* 02950000
* BRANCH TABLE TO SELECT INSERTION CHARACTER 02960000
* 02970000
MFMTSBR B MFMTSC1 NONE 02980000
B MFMTSC2 SPACE 02990000
B MFMTSC3 SLASH 03000000
B MFMTSC4 HYPHEN 03010000
B MFMTSC5 PERIOD 03020000
* 03030000
MFMTSC1 BR R9 RETURN TO MAJOR FORMAT 03040000
MFMTSC2 LA R3,C' ' SPACE IS INSERTION CHARACTER 03050000
BR R9 RETURN TO MAJOR FORMAT 03060000
MFMTSC3 LA R3,C'/' SPACE IS INSERTION CHARACTER 03070000
BR R9 RETURN TO MAJOR FORMAT 03080000
MFMTSC4 LA R3,C'-' SPACE IS INSERTION CHARACTER 03090000
BR R9 RETURN TO MAJOR FORMAT 03100000
MFMTSC5 LA R3,C'.' SPACE IS INSERTION CHARACTER 03110000
BR R9 RETURN TO MAJOR FORMAT 03120000
* 03130000
* MAJOR FORMAT CODE 4: TEXT 1 (MMMMMMMMM D, YYYY) 03140000
* 03150000
MFMT4 LA R2,POUTDATE LOAD OUTPUT AREA ADDRESS 03160000
CLI PMINOR,C'2' EUROPEAN? 03170000
BE MFMT4A YES, USE ALTERNATE ORDER 03180000
BAL R9,MMONTHN MOVE MONTH NAME 03190000
BAL R9,MDAY MOVE DAY OF MONTH 03200000
MVC 0(2,R2),=C', ' INSERT COMMA 03210000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 03220000
B MFMT4B CONTINUE 03230000
MFMT4A BAL R9,MDAY MOVE DAY OF MONTH 03240000
MVI 0(R2),C' ' INSERT BLANK 03250000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 03260000
BAL R9,MMONTHN MOVE MONTH NAME 03270000
MFMT4B MVC 0(4,R2),PDATE+4 MOVE YYYY 03280000
LA R2,4(,R2) BUMP OUTPUT ADDRESS 03290000
B SETSIZE SET OUTPUT FIELD SIZE 03300000
* 03310000
* MAJOR FORMAT CODE 5: TEXT 2 (MMM D, YYYY) 03320000
* 03330000
MFMT5 LA R2,POUTDATE LOAD OUTPUT AREA ADDRESS 03340000
CLI PMINOR,C'2' EUROPEAN? 03350000
BE MFMT5A YES, USE ALTERNATE ORDER 03360000
BAL R9,MMONTHA MOVE MONTH ABBREVIATION 03370000
BAL R9,MDAY MOVE DAY OF MONTH 03380000
MVC 0(2,R2),=C', ' INSERT COMMA 03390000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 03400000
B MFMT5B CONTINUE 03410000
MFMT5A BAL R9,MDAY MOVE DAY OF MONTH 03420000
MVI 0(R2),C' ' INSERT BLANK 03430000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 03440000
BAL R9,MMONTHA MOVE MONTH ABBREVIATION 03450000
MFMT5B MVC 0(4,R2),PDATE+4 MOVE YYYY 03460000
LA R2,4(,R2) BUMP OUTPUT ADDRESS 03470000
B SETSIZE SET OUTPUT FIELD SIZE 03480000
* 03490000
* MAJOR FORMAT CODE 6: TEXT 3 (DAYNAME, MMMMMMMMM D, YYYY) 03500000
* 03510000
MFMT6 LA R2,POUTDATE LOAD OUTPUT AREA ADDRESS 03520000
BAL R9,MDAYN MOVE DAY OF WEEK NAME 03530000
CLI PMINOR,C'2' EUROPEAN? 03540000
BE MFMT6A YES, USE ALTERNATE ORDER 03550000
BAL R9,MMONTHN MOVE MONTH NAME 03560000
BAL R9,MDAY MOVE DAY OF MONTH 03570000
MVC 0(2,R2),=C', ' INSERT COMMA 03580000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 03590000
B MFMT6B CONTINUE 03600000
MFMT6A BAL R9,MDAY MOVE DAY OF MONTH 03610000
MVI 0(R2),C' ' INSERT BLANK 03620000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 03630000
BAL R9,MMONTHN MOVE MONTH NAME 03640000
MFMT6B MVC 0(4,R2),PDATE+4 MOVE YYYY 03650000
LA R2,4(,R2) BUMP OUTPUT ADDRESS 03660000
B SETSIZE SET OUTPUT FIELD SIZE 03670000
* 03680000
* MAJOR FORMAT CODE 7: TEXT 4 (DAYNAME, MMM D, YYYY) 03690000
* 03700000
MFMT7 LA R2,POUTDATE LOAD OUTPUT AREA ADDRESS 03710000
BAL R9,MDAYN MOVE DAY OF WEEK NAME 03720000
CLI PMINOR,C'2' EUROPEAN? 03730000
BE MFMT7A YES, USE ALTERNATE ORDER 03740000
BAL R9,MMONTHA MOVE MONTH ABBREVIATION 03750000
BAL R9,MDAY MOVE DAY OF MONTH 03760000
MVC 0(2,R2),=C', ' INSERT COMMA 03770000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 03780000
B MFMT7B CONTINUE 03790000
MFMT7A BAL R9,MDAY MOVE DAY OF MONTH 03800000
MVI 0(R2),C' ' INSERT BLANK 03810000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 03820000
BAL R9,MMONTHA MOVE MONTH ABBREVIATION 03830000
MFMT7B MVC 0(4,R2),PDATE+4 MOVE YYYY 03840000
LA R2,4(,R2) BUMP OUTPUT ADDRESS 03850000
B SETSIZE SET OUTPUT FIELD SIZE 03860000
* 03870000
* MAJOR FORMAT CODE 8: TEXT 5 (DAY, MMMMMMMMM D, YYYY) 03880000
* 03890000
MFMT8 LA R2,POUTDATE LOAD OUTPUT AREA ADDRESS 03900000
BAL R9,MDAYA MOVE DAY OF WEEK ABBREVIATION 03910000
CLI PMINOR,C'2' EUROPEAN? 03920000
BE MFMT8A YES, USE ALTERNATE ORDER 03930000
BAL R9,MMONTHN MOVE MONTH NAME 03940000
BAL R9,MDAY MOVE DAY OF MONTH 03950000
MVC 0(2,R2),=C', ' INSERT COMMA 03960000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 03970000
B MFMT8B CONTINUE 03980000
MFMT8A BAL R9,MDAY MOVE DAY OF MONTH 03990000
MVI 0(R2),C' ' INSERT BLANK 04000000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 04010000
BAL R9,MMONTHN MOVE MONTH NAME 04020000
MFMT8B MVC 0(4,R2),PDATE+4 MOVE YYYY 04030000
LA R2,4(,R2) BUMP OUTPUT ADDRESS 04040000
B SETSIZE SET OUTPUT FIELD SIZE 04050000
* 04060000
* MAJOR FORMAT CODE 9: TEXT 6 (DAY, MMM D, YYYY) 04070000
* 04080000
MFMT9 LA R2,POUTDATE LOAD OUTPUT AREA ADDRESS 04090000
BAL R9,MDAYA MOVE DAY OF WEEK ABBREVIATION 04100000
CLI PMINOR,C'2' EUROPEAN? 04110000
BE MFMT9A YES, USE ALTERNATE ORDER 04120000
BAL R9,MMONTHA MOVE MONTH NAME 04130000
BAL R9,MDAY MOVE DAY OF ABBREVIATION 04140000
MVC 0(2,R2),=C', ' INSERT COMMA 04150000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 04160000
B MFMT9B CONTINUE 04170000
MFMT9A BAL R9,MDAY MOVE DAY OF MONTH 04180000
MVI 0(R2),C' ' INSERT BLANK 04190000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 04200000
BAL R9,MMONTHA MOVE MONTH ABBREVIATION 04210000
MFMT9B MVC 0(4,R2),PDATE+4 MOVE YYYY 04220000
LA R2,4(,R2) BUMP OUTPUT ADDRESS 04230000
B SETSIZE SET OUTPUT FIELD SIZE 04240000
* 04250000
* MOVE WEEKDAY NAME TO OUTPUT AREA FOLLOWED BY ', ' (COMMON 04260000
* ROUTINE PERFORMED BY MAJOR FORMAT CODE ROUTINES 6/7 ABOVE) 04270000
* 04280000
MDAYN BAL R8,LDAY GET ADDRESS/LENGTH OF DAYNAME 04290000
BCTR R7,0 DECREMENT LENGTH FOR EX 04300000
EX R7,VARMOVE MOVE DAY NAME 04310000
LA R7,1(,R7) RESTORE FULL NAME LENGTH 04320000
AR R2,R7 BUMP OUTPUT ADDRESS 04330000
MVC 0(2,R2),=C', ' INSERT COMMA/BLANK AFTER NAME 04340000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 04350000
BR R9 AND RETURN 04360000
* 04370000
* MOVE WEEKDAY ABBR TO OUTPUT AREA FOLLOWED BY ', ' (COMMON 04380000
* ROUTINE PERFORMED BY MAJOR FORMAT CODE ROUTINES 7/8 ABOVE) 04390000
* 04400000
MDAYA BAL R8,LDAY GET ADDRESS/LENGTH OF DAYNAME 04410000
LA R7,2 ABBR LENGTH MINUS 1 FOR EX 04420000
EX R7,VARMOVE MOVE DAY NAME 04430000
LA R7,1(,R7) RESTORE FULL MOVE LENGTH 04440000
AR R2,R7 BUMP OUTPUT ADDRESS 04450000
MVC 0(2,R2),=C', ' INSERT COMMA/BLANK AFTER NAME 04460000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 04470000
BR R9 AND RETURN 04480000
* 04490000
* MOVE MONTH NAME TO OUTPUT AREA FOLLOWED BY A BLANK (COMMON 04500000
* ROUTINE PERFORMED BY MAJOR FORMAT CODE ROUTINES 4/6/8 ABOVE) 04510000
* 04520000
MMONTHN BAL R8,LMONTH GET ADDRESS/LENGTH OF MONTH 04530000
BCTR R7,0 DECREMENT LENGTH FOR EX 04540000
EX R7,VARMOVE MOVE MONTH NAME 04550000
LA R7,1(,R7) RESTORE FULL NAME LENGTH 04560000
AR R2,R7 BUMP OUTPUT ADDRESS 04570000
MVI 0(R2),C' ' INSERT BLANK AFTER NAME 04580000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 04590000
BR R9 AND RETURN 04600000
VARMOVE MVC 0(0,R2),0(R6) VARIABLE MOVE FOR EXECUTE 04610000
* 04620000
* MOVE MONTH ABBR TO OUTPUT AREA FOLLOWED BY A BLANK (COMMON 04630000
* ROUTINE PERFORMED BY MAJOR FORMAT CODE ROUTINES 5/7/9 ABOVE) 04640000
* 04650000
MMONTHA BAL R8,LMONTH GET ADDRESS/LENGTH OF MONTH 04660000
LA R7,2 ABBR LENGTH MINUS 1 FOR EX 04670000
EX R7,VARMOVE MOVE MONTH NAME 04680000
LA R7,1(,R7) RESTORE FULL MOVE LENGTH 04690000
AR R2,R7 BUMP OUTPUT ADDRESS 04700000
MVI 0(R2),C' ' INSERT BLANK AFTER NAME 04710000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 04720000
BR R9 AND RETURN 04730000
* 04740000
* MOVE DAY OF MONTH TO OUTPUT AREA (COMMON ROUTINE PERFORMED FROM 04750000
* MAJOR FORMAT CODE ROUTINES 4 THROUGH 9 ABOVE) 04760000
* 04770000
MDAY CLI PDATE+2,C'0' IS FIRST DIGIT ZERO? 04780000
BNE MDAY2 NO, MOVE BOTH DIGITS 04790000
MDAY1 MVC 0(1,R2),PDATE+3 MOVE ONLY RIGHT DIGIT 04800000
LA R2,1(,R2) BUMP OUTPUT ADDRESS 04810000
BR R9 AND RETURN 04820000
MDAY2 MVC 0(2,R2),PDATE+2 MOVE BOTH DIGITS 04830000
LA R2,2(,R2) BUMP OUTPUT ADDRESS 04840000
BR R9 AND RETURN 04850000
* 04860000
* LOAD ADDRESS OF DAY NAME IN R6, LENGTH IN R7 (COMMON ROUTINE 04870000
* PERFORMED FROM MDAYN AND MDAYA ABOVE) 04880000
* 04890000
LDAY PACK DWORK(1),DDOW(1) PACK DAY INTEGRAL NUMBER 04900000
ZAP DWORK(8),DWORK(1) EXPAND TO DOUBLEWORD 04910000
CVB R6,DWORK CONVERT TO BINARY 04920000
MH R6,=H'12' MULTIPLY BY 12 (LENGTH OF ENTRY) 04930000
LA R7,DNAME(R6) LOAD ADDRESS OF NAME'S SIZE 04940000
LA R6,2(,R7) LOAD ADDRESS OF DAY'S NAME 04950000
LH R7,0(,R7) LOAD SIZE OF DAY'S NAME 04960000
BR R8 AND RETURN 04970000
* 04980000
* LOAD ADDRESS OF MONTH NAME IN R6, LENGTH IN R7 (COMMON ROUTINE 04990000
* PERFORMED FROM MMONTHN AND MMONTHA ABOVE) 05000000
* 05010000
LMONTH PACK DWORK(2),PDATE(2) PACK MONTH INTEGRAL NUMBER 05020000
ZAP DWORK(8),DWORK(2) EXPAND TO DOUBLEWORD 05030000
CVB R6,DWORK CONVERT TO BINARY 05040000
BCTR R6,0 DECREMENT BY 1 (ZERO BASED) 05050000
MH R6,=H'12' MULTIPLY BY 12 (LENGTH OF ENTRY) 05060000
LA R7,MNAME(R6) LOAD ADDRESS OF NAME'S SIZE 05070000
LA R6,2(,R7) LOAD ADDRESS OF MONTH'S NAME 05080000
LH R7,0(,R7) LOAD SIZE OF MONTH'S NAME 05090000
BR R8 AND RETURN 05100000
* 05110000
* RETURN THE SIZE OF THE OUTPUT FIELD IN BYTES (COMMON ROUTINE 05120000
* BRANCHED TO BY ALL MAJOR FORMAT CODE ROUTINES ABOVE) 05130000
* 05140000
SETSIZE LA R1,POUTDATE GET ADDRESS OF FIELD START 05150000
SR R2,R1 COMPUTE LENGTH OF FIELD 05160000
CVD R2,DWORK CONVERT TO DECIMAL 05170000
UNPK DWORK(3),DWORK+6(2) UNPACK SIZE 05180000
OI DWORK+2,X'F0' CLEAR SIGN 05190000
MVC PSIZE,DWORK+1 MOVE TO OUTPUT FIELD 05200000
* 05210000
* RESTORE REGISTERS, FREE STORAGE, AND RETURN 05220000
* 05230000
RETURN LR R1,R13 LOAD ADDRESS OF GETMAINED AREA 05240000
L R13,4(,R13) RELOAD PREVIOUS SAVE AREA 05250000
LA R0,$DYNLEN LOAD LENGTH OF GETMAINED AREA 05260000
FREEMAIN R,LV=(0),A=(1) FREE GETMAINED AREA 05270000
RETURN (14,12),RC=0 RETURN TO CALLER WITH RC=0 05280000
* 05290000
EJECT 05300000
* ******************************************************************* * 05310000
* **************************** CONSTANTS **************************** * 05320000
* ******************************************************************* * 05330000
* 05340000
* DAY OF WEEK NAMES, PRECEEDED BY LENGTH ATTRIBUTE 05350000
* 05360000
DNAME DC H'6',CL10'MONDAY ' 05370000
DC H'7',CL10'TUESDAY ' 05380000
DC H'9',CL10'WEDNESDAY' 05390000
DC H'8',CL10'THURSDAY ' 05400000
DC H'6',CL10'FRIDAY ' 05410000
DC H'8',CL10'SATURDAY ' 05420000
DC H'6',CL10'SUNDAY ' 05430000
* 05440000
* MONTH NAMES, PRECEEDED BY LENGTH ATTRIBUTE 05450000
* 05460000
MNAME DC H'7',CL10'JANUARY ' 05470000
DC H'8',CL10'FEBRUARY ' 05480000
DC H'5',CL10'MARCH ' 05490000
DC H'5',CL10'APRIL ' 05500000
DC H'3',CL10'MAY ' 05510000
DC H'4',CL10'JUNE ' 05520000
DC H'4',CL10'JULY ' 05530000
DC H'6',CL10'AUGUST ' 05540000
DC H'9',CL10'SEPTEMBER' 05550000
DC H'7',CL10'OCTOBER ' 05560000
DC H'8',CL10'NOVEMBER ' 05570000
DC H'8',CL10'DECEMBER ' 05580000
* ******************************************************************* * 05590000
LTORG 05600000
EJECT 05610000
* ******************************************************************* * 05620000
* ***************************** EQUATES ***************************** * 05630000
* ******************************************************************* * 05640000
YREGS 05650000
* ******************************************************************* * 05660000
EJECT 05670000
* ******************************************************************* * 05680000
* ***************************** DSECTS ****************************** * 05690000
* ******************************************************************* * 05700000
$DYNMEM DSECT DYNAMICALLY ALLOCATED MEMORY 05710000
SAVEAREA DS 18F REGISTER SAVE AREA 05720000
TOPFLAG DS CL24 EYECATCHER 05730000
PLIST DS A PARMLIST ADDR FOR SUB CALLS 05740000
DOWNPARM DS 0H PARAMETERS FOR Y2KDOWN 05750000
DDATE DS CL8 INPUT DATE 05760000
DRC DS CL1 RETURN CODE 05770000
DDOW DS CL1 INTEGRAL DAY OF WEEK 05780000
DWORK DS D DOUBLEWORD WORK FIELD 05790000
BOTFLAG DS CL22 EYECATCHER 05800000
* 05810000
$DYNLEN EQU (*-$DYNMEM) LENGTH OF GETMAIN'D AREA 05820000
* 05830000
$PARMS DSECT PARAMETERS FROM/TO CALLER 05840000
PDATE DS CL8 DATE TO BE PROCESSED 05850000
PMAJOR DS CL1 MAJOR FORMAT CODE 05860000
PMINOR DS CL1 MINOR FORMAT CODE 05870000
PRC DS CL1 RETURN CODE (0, 2-6, 8) 05880000
PSIZE DS CL2 SIZE OF OUTPUT FIELD 05890000
POUTDATE DS CL1 OUTPUT DATE (SIZE WILL VARY!) 05900000
* ******************************************************************* * 05910000
END 05930000