DATETIME TITLE 'Display or stack time and date information' 00000100 *---------------------------------------------------------------------* 00000200 * Datetime obtains the time and date via the cp diagnose * 00000300 * interface and calculates the Julian date and day of the week. * 00000400 * It will either type or stack the result. If a date is given as * 00000500 * the second parm, it is used instead of the current date for the * 00000600 * date displays The date may be specified as a standard calendar * 00000700 * date (some form of mm/dd/yy), as a Julian date (yy.ddd) or as * 00000800 * a number of days from today (+nnn or -nnn). * 00000900 * * 00001000 * Julian date may be given with or without the period i.e. yyddd * 00001100 * or yy.ddd where yy is the low order two digits of the year and * 00001200 * ddd is the day-number. In either form, the last three digits * 00001300 * may range in value from 1 to 999, inclusive. If the day-number * 00001400 * is greater than the maximum for the year given, it is reduced * 00001500 * by that maximum number, the year is increased by one and the * 00001600 * process is repeated until the day-number is reduced to a value * 00001700 * that falls properly within a valid year. * 00001800 * * 00001900 * If the standard calendar date form is specified, it may be any * 00002000 * non-ambiguous form of mm/dd/yy. Leading zeros do not have to * 00002100 * be specified in any part of the date. Also, any part of the * 00002200 * submitted date may be omitted and that part of the date will be * 00002300 * taken from today's date. For example: if today is 11/13/80, * 00002400 * then the argument '//81' would result in processing the date as * 00002500 * if it had been '11/13/81'. Both "/dd" and "dd" are treated as * 00002600 * if only the day-of-the-month had been specified. * 00002700 * * 00002800 * If the relative date form is used nnn is any number from 0-999, * 00002900 * preceded by a plus or minus sign. * 00003000 * * 00003100 * The answer provided is as follows: * 00003200 * DEFAULT FORM * 00003300 * Column 1 2 3 4 * 00003400 * 1234567890123456789012345678901234567890123456789 ... * 00003500 * Dow mm/dd/yy hh.mm.ss FLG Jul yyJul mmddyy hhmmss ... * 00003600 * * 00003700 * 5 6 7 8 * 00003800 * 012345678901234567890123456789012 * 00003900 * ... yymmdd hhmm hh:mm-xm ddmonyy ce * 00004000 * * 00004100 * LONG FORM * 00004200 * Column 1 2 3 4 5 * 00004300 * 12345678901234567890123456789012345678901234567890123456 ... * 00004400 * Dow mm/dd/ceyy hh:mm:ss FLG Jul ceyyJul mmddceyy hhmmss * 00004500 * * 00004600 * 5 6 7 8 9 * 00004700 * 78901234567890123456789012345678901 * 00004800 * ... ceyymmdd hhmm hh:mm-xm ddmonceyy ce * 00004900 * * 00005000 * Where dow is the day of the week, Jul is the Julian day and FLG * 00005100 * is either LPY if the year is a leapyear, or NOR if it is not, * 00005200 * ddmonyy is the military form of the date with two digits for * 00005300 * day-of-month, a three-letter month abbreviation, and a two * 00005400 * digit year all concatenated, and Xm is either am or pm. * 00005500 * The last piece of data, ce, is a two-digit century, i.e., if the * 00005600 * year is 2076, then yy in all cases is 76 and ce is 20. * 00005700 * * 00005800 * * 00005900 * For example: * 00006000 * Wed 08/04/76 15.43.25 LPY 217 76217 080476 154325 ... * 00006100 * ... 760804 1543 11:17-am 04Aug76 20 * 00006200 * Or (long form): * 00006300 * Wed 08/04/2076 15:43:25 LPY 217 2076217 08042076 154325 ... * 00006400 * ... 19200804 1543 11:17-am 04Aug2076 20 * 00006500 * * 00006600 *note: This code is a major revision of the DATETIME module written * 00006700 * by Jack Steitz in 1983. * 00006800 * The enhancements include: * 00006900 * * 00007000 * 1. Acceptance of the year in either 2- or 4-digit form. If * 00007100 * two digits are entered, the century number is 19, else the * 00007200 * leading two digits of the year are used for the century. * 00007300 * * 00007400 *---------------------------------------------------------------------* 00007500 EJECT 1 00007600 DATETIME CSECT 00007700 STM R14,R12,12(R13) Save regs 00007800 LR R12,R15 Establish base 00007900 USING DATETIME,R12 00008000 BAL R14,GETPARMS Save calling parameters 00008100 CLI PARM1,C'?' Explanation desired? 00008200 BNE DIAGNOSE No, continue 00008300 LA R1,STACKQMK Addr of stack parmlist 00008400 LA R14,QMS Addr of text to stack 00008500 STCM R14,B'0111',STACKQMA Addr to parmlist so reloc. 00008600 SVC 202 Issue stack LIFO HELP DATETIME 00008700 DC AL4(1) Ignore errors 00008800 B SETRC0 Return 00008900 *-------------------------------------------------------------* 00009000 * Get the time and date * 00009100 *-------------------------------------------------------------* 00009200 DIAGNOSE LA R1,CPDATA Address of data from diag 00009300 DC X'8310000C' Request date and time from CP 00009400 MVC TIMEANS,CPDATA+8 Move time into answer area 00009500 MVC DATECE,=C'19' Always assume 20th century 00009600 *-------------------------------------------------------------* 00009700 * Validate input paramters * 00009800 * * 00009900 * Arguments can be a date representation and/or the word * 00010000 * 'STACK' in either order. If two args are given, one must * 00010100 * be the word 'STACK.' If not, there's an error. * 00010200 *-------------------------------------------------------------* 00010300 SR R11,R11 Clear a work reg and set ... 00010400 ST R11,BINRYNNN ... +nnn to zero as switch 00010500 CLI PARM1,X'FF' Any parameter passed? 00010600 BE GOTDATE No, continue 00010700 CLC PARM1(6),=CL6'STACK' Is clock data to be stacked? 00010800 BE TESTDATE Yes, it's in the right place 00010900 CLI PARM2,X'FF' Is there a second argument? 00011000 BE SWAP No second arg. 00011100 CLC PARM2(6),=CL6'STACK' Is the second arg = 'STACK'? 00011200 BNE STKMERR No, it's an error 00011300 SWAP XC PARM1,PARM2 2nd parm is STACK (1st isn't) ... 00011400 XC PARM2,PARM1 ... so exchange parm 1 ... 00011500 XC PARM1,PARM2 ... and parm 2 values. 00011600 TESTDATE CLI PARM2,X'FF' Any date given? 00011700 BE GOTDATE No, today's date is good 00011800 * 00011900 * First, get the length of parm2 00012000 * 00012100 LA R1,10 Maximum parm length 00012200 LA R2,PARM2 Start of date supplied 00012300 LR R15,R2 Save start addr for length calc 00012400 LOOPA CLI 0(R2),C' ' Have we reached the end? 00012500 BE GOTPLEN Yes, go calculate length 00012600 LA R2,1(,R2) Advance to the next char 00012700 BCT R1,LOOPA Loop through 10 characters 00012800 GOTPLEN SR R2,R15 Calculate the actual length 00012900 * 00013000 * Relative day offset if +nnn or -nnn specified 00013100 * 00013200 CLI PARM2,C'+' First character a plus sign? 00013300 BE DATEISNN Yes, its a relative date 00013400 CLI PARM2,C'-' First character a minus sign? 00013500 BNE NOTOFFST No, continue checking 00013600 DATEISNN C R2,=F'4' Is the date parm <= 4 chars? 00013700 BH DTERR No, that's an error 00013800 LA R11,PARM2+1 Start of nnn 00013900 LR R10,R2 Copy length 00014000 S R10,=F'1' Number of digits entered (0=error) 00014100 BZ DTERR 00014200 LR R14,R10 Save # digits for move later 00014300 NXTDIGIT CLI 0(R11),C'0' Numeric digit? 00014400 BL DTERR No, that's an error 00014500 CLI 0(R11),C'9' Numeric digit? 00014600 BH DTERR No, that's an error 00014700 LA R11,1(,R11) Advance to next digit 00014800 BCT R10,NXTDIGIT Look at all digits 00014900 MVC BCDNNN,=CL3'000' Initialize to zeros 00015000 LA R10,3 Maximum field length to move 00015100 SR R10,R14 Minus digits entered=offset 00015200 LA R11,BCDNNN(R10) First digit placement address 00015300 BCTR R14,0 Length -1 for executed move 00015400 EX R14,SETNNN Move in n or nn or nnn right just. 00015500 PACK NNN,BCDNNN Pack the number 00015600 CVB R9,NNN Convert relative date to binary 00015700 ST R9,BINRYNNN And save it for later 00015800 B GOTDATE Find today's Julian date 00015900 SETNNN MVC 0(0,R11),PARM2+1 Create nnn right justified. 00016000 * 00016100 * The argument is not an offset (+/-) from today. 00016200 * If no . or / found then it is short-form Julian date 00016300 * 00016400 NOTOFFST LA R1,PARM2 Address of date 00016500 LR R10,R2 Length to work reg 00016600 DTEST CLI 0(R1),C'.' Is there a period? 00016700 BE JULEDATE Yes, must be Julian 00016800 CLI 0(R1),C'/' or a slash? 00016900 BE STDDATE Yes, must be standard date 00017000 LA R1,1(,R1) Advance to the next char 00017100 BCT R10,DTEST Look at all chars entered 00017200 CLI PARM2,C'0' Better be numeric! 00017300 BL DTERR Nope, too bad 00017400 CLI PARM2,C'9' 00017500 BH DTERR Not numeric, go to error 00017600 C R2,=F'2' No '/' or '.', if only 1 or 2 00017700 BH CK4JULE characters, must be day in cur mo 00017800 BE MOV2 00017900 MVI BCDD,C'0' We have a 1-char offset ... 00018000 MVC BCDD+1(1),PARM2 so leading zero is supplied 00018100 B GOTDATE 00018200 MOV2 CLI PARM2+1,C'0' Better be numeric! 00018300 BL DTERR Nope, too bad 00018400 CLI PARM2+1,C'9' 00018500 BH DTERR Not numeric, go to error 00018600 MVC BCDD,PARM2 We have a two-character offset 00018700 B GOTDATE 00018800 * 00018900 * Must be no-period Julian, what form? 00019000 * 00019100 CK4JULE C R2,=F'5' 00019200 BH LONGJULE 00019300 BL DTERR Julians must only be 5 or 7 chars 00019400 MVC JPARMYY,PARM2 Make no-period short Julian ... 00019500 MVC JPARMDDD,PARM2+2 ... into std short Julian 00019600 B JULEIN2 and join Julian processing 00019700 LONGJULE DS 0H 00019800 C R2,=F'7' 00019900 BNE DTERR Julians must only be 5 or 7 chars 00020000 MVC DATECE,PARM2 Get century from input 00020100 MVC JPARMYY,PARM2+2 Save the year 00020200 MVC JPARMDDD,PARM2+4 Save the day-number 00020300 B JULEIN2 00020400 * 00020500 * Std-form Julian if period in input. 00020600 * R1 ==> '.' C(R2) = L'PARM2 00020700 * 00020800 JULEDATE DS 0H 00020900 C R2,=F'6' 00021000 BE JULEOK Probably yy.ddd 00021100 C R2,=F'8' Could be ccyy.ddd 00021200 BNE DTERR It's not, so go tell about error 00021300 JULEOK LA R10,PARM2 Locate 2nd arg 00021400 LR R3,R1 R3 ==> '.' 00021500 SR R3,R10 Find length of [cc]yy part 00021600 MVC JPARMDDD,1(R1) Assume 3 digits follow the period 00021700 C R3,=F'2' 00021800 BH LONGDOT yy part > 3, might be ccyy 00021900 BL DTERR Only 1 digit in Julian year 00022000 MVC JPARMYY,PARM2 Save yy 00022100 B JULEIN2 00022200 LONGDOT C R3,=F'4' Might be ccyy 00022300 BNE DTERR It's not, so it's an error 00022400 MVC DATECE,PARM2 Get century from input 00022500 MVC JPARMYY,PARM2+2 Save yy 00022600 B JULEIN2 00022700 * 00022800 * Slashed form 00022900 * 00023000 STDDATE DS 0H 00023100 * 00023200 * Std-form date with slashes (mm/dd/yy or mm/dd/yyy) 00023300 * R1 ==> '/' after mm, C(R2) = L'PARM2 00023400 * 00023500 LA R10,3 Limit scan to 3 characters 00023600 LA R11,PARM2 Address 1st char to scan 00023700 CLI 0(R11),C'/' Is it a leading slash? 00023800 BE SKIPMM Yes, leave mm as today's 00023900 LA R3,X'F0' Leading 0 in case only m given 00024000 NXT1 CLI 0(R11),C'/' End of mm? 00024100 BE FSLASH1 Yes, put month data in input 00024200 CLI 0(R11),C'0' Is digit numeric? 00024300 BL DTERR No, that's an error 00024400 CLI 0(R11),C'9' Is digit numeric? 00024500 BH DTERR No, that's an error 00024600 SLL R3,8 Make room for this digit 00024700 IC R3,0(R11) Get digit into build reg 00024800 LA R11,1(,R11) Advance the scan address 00024900 BCT R10,NXT1 Go look at next character 00025000 B DTERR Too many digits, bad date 00025100 FSLASH1 STCM R3,B'0011',BCMM Store mm as BCD input 00025200 SKIPMM LA R11,1(,R11) Increment address past / 00025300 CLI 0(R11),C' ' Slash followed by blank? 00025400 BE GOTDATE Yes, use today'y dd and yy 00025500 CLI 0(R11),C'/' Consecutive slashes? 00025600 BE SKIPDD Yes, request for today's dd 00025700 LA R10,3 Limit scan to 3 characters 00025800 LA R3,X'F0' Leading 0 in case only d given 00025900 NXT2 CLI 0(R11),C'/' End of dd? 00026000 BE FSLASH2 Yes, put day of month in input 00026100 CLI 0(R11),C' ' No slash at all? 00026200 BE FSLASH2 Yes, yy not given 00026300 CLI 0(R11),C'0' Is it numeric? 00026400 BL DTERR No, that's an error 00026500 CLI 0(R11),C'9' Is it numeric? 00026600 BH DTERR No, that's an error 00026700 SLL R3,8 Make room for this digit 00026800 IC R3,0(R11) Get digit into build reg 00026900 LA R11,1(,R11) Advance the scan address 00027000 BCT R10,NXT2 Go look at next character 00027100 B DTERR Too many digits, bad date 00027200 FSLASH2 STCM R3,B'0011',BCDD Store dd as BCD input 00027300 CLI 0(R11),C' ' Was dd terminated by a blank? 00027400 BE GOTDATE Yes, date complete 00027500 SKIPDD LA R11,1(,R11) Increment address past / 00027600 CLI 0(R11),C' ' Slash followed by a blank? 00027700 BE GOTDATE Yes, date is complete 00027800 LA R10,4 Limit scan to 4 characters 00027900 LA R3,X'F0' Leading 0 in case only y given 00028000 LA R15,PARM2(R2) Last char of mm/dd/yyyy 00028100 NXT3 CLI 0(R11),C' ' End of yy? 00028200 BE SAVEYY Yes, put yy in the input area 00028300 CLI 0(R11),C'0' Is it numeric? 00028400 BL DTERR No, that's an error 00028500 CLI 0(R11),C'9' Is it numeric? 00028600 BH DTERR No, that's an error 00028700 SLL R3,8 Make room for the digit 00028800 IC R3,0(R11) Get digit into build reg 00028900 LA R11,1(,R11) Advance the scan address 00029000 CR R11,R15 Now past last char in parm2? 00029100 BNL SAVEYY Yes, was full mm/yy/dd 00029200 BCT R10,NXT3 Look at the next character 00029300 B DTERR Impossible, but ... 00029400 SAVEYY STCM R3,B'0011',BCYY Store yy as BCD input 00029500 CL R3,=X'00F10000' Is it ccyy? 00029600 BL GOTDATE Branch if not 00029700 STCM R3,B'1100',DATECE Store CE as EBCDIC input 00029800 * 00029900 GOTDATE DS 0H Date as mm/dd/yy set to go 00030000 *-------------------------------------------------------------* 00030100 * Calculate Julian date from Ebcdic mm/dd/yy * 00030200 *-------------------------------------------------------------* 00030300 PACK YY,BCYY Year from FyFy --> yy 00030400 CVB R9,YY Get year as binary number 00030500 LR R8,R9 Save binary yy for possible use in +00030600 the + or -nnn date form 00030700 PACK CE,DATECE Prepare the century ... 00030800 CVB R9,CE ... for binary arithmetic 00030900 ST R9,BINCE Save binary century 00031000 BAL R14,LEAPTEST Set LeayYear values if needed 00031100 PACK MM,BCMM Month from FmFm --> mm 00031200 CVB R3,MM Get month as binary number 00031300 LTR R3,R3 Is month number zero? 00031400 BZ DTERR Yes, that's an error 00031500 LR R15,R3 Save binary month # for later 00031600 CH R3,=H'12' Is month > 12? 00031700 BH DTERR Yes, that's an error 00031800 LA R4,DAYOFYR Start of "DaysInMonth" table 00031900 SR R0,R0 Clear reg to receive ddd 00032000 NXTMON BCT R3,OKADD Month#-1 for index into table 00032100 B DUNADD Days accumulated for complete months 00032200 OKADD AH R0,0(R4) Accumulate days so far this year 00032300 LA R4,2(,R4) Address of next month in table 00032400 B NXTMON Add in all completed months 00032500 DUNADD PACK DD,BCDD Day from FdFd --> dd 00032600 CVB R3,DD Get day of month as binary number 00032700 LTR R3,R3 Is the day number zero? 00032800 BZ DTERR Yes, that's an error 00032900 LR R2,R15 Get saved index to this month 00033000 BCTR R2,0 Minus one for table indexing 00033100 SLL R2,1 Times 2 since table entries 2 bytes 00033200 CH R3,DAYOFYR(R2) Is the day number > than # of days? 00033300 BH DTERR Yes, that's an error 00033400 SLL R2,1 Times 2 to index into the month name+00033500 table which has 4 byte entries 00033600 LA R1,MONTAB(R2) Address of the entry 00033700 MVC MILMON,0(R1) Put it into the answer 00033800 AR R0,R3 Add day of the month to get ddd 00033900 * 00034000 * See if we are really processing +nnn or -nnn Julian form 00034100 * 00034200 ICM R2,B'1111',BINRYNNN Any binary increment|decrement? 00034300 BZ MAINLINE No, join common code 00034400 * 00034500 * Add or subtract the offset from today and join Julian code 00034600 * 00034700 LR R6,R0 Put binary ddd in expected reg 00034800 CLI PARM2,C'+' Increment the date? 00034900 BE ADDINCR Yes, add it to todays date 00035000 SR R6,R2 Subtract the decrement 00035100 BP DAYOK Join common Julian code 00035200 PREVYR S R8,=F'1' Decrement the year 00035300 BNM SAMECEN If below zero, reduce century 00035400 A R8,BINCE C(R8) = -1 so 1900 - 1 00035500 ST R8,BINCE 18 00035600 LA R8,99 99 00035700 LR R9,R8 Put yy into its working reg 00035800 SAMECEN BAL R14,LEAPTEST Adjust for leap year if it is one 00035900 LA R1,337 Days/year not including February 00036000 AH R1,FEB Add 28 or 29 days in Feb 00036100 AR R6,R1 Add in previous year's # of days 00036200 BP DAYOK In right year now, join common code 00036300 B PREVYR Subtract another year 00036400 ADDINCR AR R6,R2 Add user +nnn to today's Julian date 00036500 B REDODAY Join Julian code to process ddd 00036600 *-----------------------------------------------------------------* 00036700 * Julian date (or +|-nnn) supplied by the invoker * 00036800 *-----------------------------------------------------------------* 00036900 JULEIN2 PACK CE,DATECE Create binary form of input century 00037000 CVB R9,CE 00037100 ST R9,BINCE Save binary century 00037200 LA R1,5 Number of characters in yy.ddd 00037300 LA R11,JPARM2 Address of data to be validated 00037400 * 00037500 * Now make sure parm was all numric with no imbedded blanks 00037600 * 00037700 NXTJCHAR DS 0H 00037800 CLI 0(R11),C'0' Numeric? 00037900 BL DTERR No, that's an error 00038000 CLI 0(R11),C'9' Numeric? 00038100 BH DTERR No, that's an error 00038200 LA R11,1(,R11) Advance the scan address 00038300 BCT R1,NXTJCHAR Loop through all characters 00038400 PACK YY,JPARMYY Year from FyFy --> yy 00038500 CVB R9,YY Get yy as a binary number 00038600 LR R8,R9 Save yy in binary 00038700 BAL R14,LEAPTEST Make leap year adjustments if needed 00038800 PACK DD,JPARMDDD Days from FdFdFd --> ddd 00038900 CVB R6,DD Get ddd as a binary number 00039000 LTR R6,R6 Was ddd entered as zero? 00039100 BZ DTERR Yes, that's a non-existent date 00039200 REDODAY LA R1,337 Days/year not including February 00039300 AH R1,FEB Add 28|29 as appropriate 00039400 CR R6,R1 Day number > December 31? 00039500 BNH DAYOK No, in correct year go process 00039600 SR R6,R1 Yes, reduce ddd by a years worth 00039700 LA R8,1(,R8) Increment the year by one. 00039800 C R8,=F'99' 00039900 BNH SAMECEN2 If above 99, increment century 00040000 L R8,BINCE e.g., 1999 + 1 00040100 LA R8,1(,R8) should come out 00040200 ST R8,BINCE 20 00040300 SR R8,R8 00 00040400 SAMECEN2 BAL R14,LEAPTEST Make leap year adjustments if needed 00040500 B REDODAY See if we now are in the right year 00040600 DAYOK CVD R8,YY Convert binary year into packed yy 00040700 OI YY+7,SIGNF Use sign which unpacks to # nibble 00040800 UNPK BCYY,YY Put real year as FyFy in answer 00040900 L R8,BINCE Now convert the century to EBCDIC 00041000 CVD R8,CE Convert binary century to packed 00041100 OI CE+7,SIGNF Use sign which unpacks to # nibble 00041200 UNPK DATECE,CE Put real year as FyFy in answer 00041300 LR R0,R6 Binary ddd into expected reg 00041400 SR R2,R2 Clear reg used to calculate month 00041500 NEXTSUB SH R6,DAYOFYR(R2) Subtract this month's # of days 00041600 BNP GOTMO If negative or zero we have month 00041700 LA R2,2(,R2) Address the next month's table entry 00041800 B NEXTSUB Go subtract its # of days 00041900 GOTMO AH R6,DAYOFYR(R2) Must add back current month 00042000 SLL R2,1 Month# times 4 (was times 2) 00042100 LA R1,MONTAB(R2) Addr of month in Month name table 00042200 MVC MILMON,0(R1) Put month name into the answer 00042300 SRL R2,2 Divide by four to get actual mon -1 00042400 LA R2,1(,R2) Get true month# from index value 00042500 CVD R2,MM Convert binary month into packed mm 00042600 OI MM+7,SIGNF Use sign which unpacks to # nibble 00042700 UNPK BCMM,MM Put real FmFm in answer 00042800 CVD R6,DD Convert binary day into packed dd 00042900 OI DD+7,SIGNF Use sign which unpacks to # nibble 00043000 UNPK BCDD,DD Put real FdFd in answer 00043100 MAINLINE CVD R0,DD Binary Julian day to packed ddd 00043200 OI DD+7,SIGNF DD = 000000000000DDDF 00043300 MH R9,=H'365' C(R9) = # of years since 1600 00043400 AH R9,LPY1 + # of years divisible by 4 00043500 SH R9,LPY2 - # of years divisible by 100 00043600 AH R9,LPY3 + # of years divisible by 400 00043700 CLC FEB,=H'29' IS input year A LEAP YEAR? 00043800 BNE NODEDUCT NO 00043900 BCTR R9,0 Yes, don't count it twice 00044000 NODEDUCT AR R9,R0 Add days so far this year 00044100 BCTR R9,0 00044200 SR R8,R8 Prepare for fullword divide 00044300 *-------------------------------------------------------------* 00044400 * Use adjusted Julian date to calculate the day of the week * 00044500 *-------------------------------------------------------------* 00044600 LH R2,=H'7' Divisor to expected reg 00044700 DR R8,R2 Get Day# modulo 7 00044800 SLL R8,2 Times 4 to index the DayOfWeek list 00044900 LA R9,DAYTAB(R8) Locate the Day Of Week list entry 00045000 MVC DAYOFWK,0(R9) Put Day of Week in the answer 00045100 UNPK JULIAN,DD Put Julian FdFdFd in answer 00045200 *-------------------------------------------------------------* 00045300 * Propagate duplicate data * 00045400 *-------------------------------------------------------------* 00045500 LA R2,OUTSTRT DOW is already in answer area 00045600 MVC 0(6,R2),CPDATA Put mm/dd/ in answer 00045700 TM LONGFORM,X'01' 00045800 BZ SY1 00045900 MVC 6(2,R2),DATECE Make mm/dd/cc, if long form 00046000 LA R2,2(,R2) 00046100 SY1 DS 0H 00046200 MVC 6(2,R2),BCYY Make it mm/dd/[cc]yy 00046300 LA R2,9(,R2) 00046400 MVC 0(8,R2),TIMEANS Put hh:mm:ss in answer 00046500 LA R2,9(,R2) 00046600 MVC 0(3,R2),LPFLG Now the leapyear flag 00046700 LA R2,4(,R2) 00046800 MVC 0(3,R2),JULIAN Put out the Julian day number 00046900 LA R2,4(,R2) 00047000 TM LONGFORM,X'01' 00047100 BZ SY2 00047200 MVC 0(2,R2),DATECE Put out CC in [cc]yyddd Julian 00047300 LA R2,2(,R2) 00047400 SY2 MVC 0(2,R2),BCYY yy from mm/dd/yy to [cc]yyddd 00047500 MVC 2(3,R2),JULIAN ddd to [cc]yyddd 00047600 LA R2,6(,R2) 00047700 MVC 0(2,R2),BCMM MM/dd/yy to MMdd[cc]yy 00047800 MVC 2(2,R2),BCDD mm/DD/yy to mmDD[cc]yy 00047900 TM LONGFORM,X'01' 00048000 BZ SY3 00048100 MVC 4(2,R2),DATECE CC to mmdd[CC]yy 00048200 LA R2,2(,R2) 00048300 SY3 MVC 4(2,R2),BCYY mm/dd/YY to mmdd[cc]YY 00048400 LA R2,7(,R2) 00048500 MVC 0(2,R2),TIMEANS HH from HH:mm:ss to HHmmss 00048600 MVC 2(2,R2),TIMEANS+3 MM from hh:MM:ss to hhMMss 00048700 MVC 4(2,R2),TIMEANS+6 SS from hh:mm:SS to hhmmSS 00048800 LA R2,7(,R2) 00048900 TM LONGFORM,X'01' 00049000 BZ SY4 00049100 MVC 0(2,R2),DATECE CC to [CE]yymmdd 00049200 LA R2,2(,R2) 00049300 SY4 MVC 0(2,R2),BCYY mm/dd/YY to [ce]YYmmdd 00049400 MVC 2(2,R2),BCMM MM/dd/yy to [ce]yyMMdd 00049500 MVC 4(2,R2),BCDD mm/DD/yy to [ce]yymmDD 00049600 LA R2,7(,R2) 00049700 MVC 0(2,R2),TIMEANS HH to HHmm 00049800 MVC 2(2,R2),TIMEANS+3 MM to hhMM 00049900 LA R2,5(,R2) 00050000 MVC 0(5,R2),TIMEANS hh:mm to hh:mm-xm 00050100 *-------------------------------------------------------------* 00050200 * Convert military time to h:mm-xm * 00050300 *-------------------------------------------------------------* 00050400 MVC 5(3,R2),=C'-am' Assume it's am 00050500 PACK PACKEDHH(2),TIMEANS(2) Pack the hour hh 00050600 SP PACKEDHH,=PL2'12' Subtract "noon" from the hour 00050700 BM ITISAM If negative its am 00050800 MVI 6(R2),C'p' The time is pm 00050900 ITISAM BNP BEFOR1PM Zero or minus is < 1 pm 00051000 OI PACKEDHH+1,X'0F' Sign which unpacks to # nibble 00051100 UNPK TIMEANS(2),PACKEDHH(2) Put modulo 12 hour in answer 00051200 MVC 0(2,R2),TIMEANS HH to HH:mm-xm 00051300 BEFOR1PM CLI TIMEANS,C'0' Is the hour before 10:00? 00051400 BNE ENDAMPM No, hh:mm-xm complete 00051500 MVI 0(R2),C' ' Yes, suppress the leading 0 00051600 ENDAMPM DS 0H hh:mm-xm built 00051700 LA R2,9(,R2) 00051800 MVC 0(2,R2),BCDD mm/DD/yy to DDmon[cc]yy 00051900 MVC 2(3,R2),MILMON MON to ddMON[cc]yy 00052000 TM LONGFORM,X'01' 00052100 BZ SY5 00052200 MVC 5(2,R2),DATECE CC to ddmon[cc]yy 00052300 LA R2,2(,R2) 00052400 SY5 MVC 5(2,R2),BCYY yy from mm/dd/yy to ddmon[cc]yy 00052500 MVC 8(2,R2),DATECE 00052600 *-------------------------------------------------------------* 00052700 * Stack or type the answer * 00052800 *-------------------------------------------------------------* 00052900 LA R14,RETMSG Address of answer text 00053000 CLC PARM1(6),=CL6'STACK' Is answer to be stacked? 00053100 BE ITSSTACK Yes, fill in stack plist 00053200 LA R1,TYPERR Address Type plist 00053300 STCM R14,B'0111',TYPERRA Addr to parmlist so reloc. 00053400 LA R14,L'RETMSG 00053500 STCM R14,B'0011',ERRLEN 00053600 B DOIT Go issue the SVC 00053700 ITSSTACK LA R1,STACKDAT Address of Stack plist 00053800 STCM R14,B'0111',STACKDAA Addr to parmlist so reloc. 00053900 DOIT SVC 202 Issue CMS SVC 00054000 LTR R15,R15 Any errors? 00054100 BZ EXIT No, return with rc=0 00054200 *-------------------------------------------------------------* 00054300 * Return to Caller * 00054400 *-------------------------------------------------------------* 00054500 LA R15,1 Set return code to 1 00054600 B EXIT Return to caller 00054700 SETRC0 SR R15,R15 Set return code to zero 00054800 EXIT L R14,12(,R13) Get return address 00054900 LM R0,R12,20(R13) Restore registers 00055000 BR R14 Return from whence we came 00055100 *-------------------------------------------------------------* 00055200 * Issue error message and give error return code * 00055300 *-------------------------------------------------------------* 00055400 DTERR MVC ERRINPUT,PARM2 Fill in the erroneous date 00055500 LA R14,ERRMSG Address of error text 00055600 STCM R14,B'0111',TYPERRA Addr to parmlist so reloc. 00055700 LA R14,EOM1-ERRMSG Length of message 00055800 STCM R14,B'0011',ERRLEN Length of message 00055900 B ERROUT Head for home 00056000 *-------------------------------------------------------------* 00056100 PARMTOO DS 0H 00056200 LA R14,TOOMSG Address of error text 00056300 STCM R14,B'0111',TYPERRA Addr to parmlist so reloc. 00056400 LA R14,EOM4-TOOMSG Length of message 00056500 STCM R14,B'0011',ERRLEN Length of message 00056600 B ERROUT Head for home 00056700 *-------------------------------------------------------------* 00056800 PARMERR DS 0H 00056900 LA R14,PRMMSG Address of error text 00057000 STCM R14,B'0111',TYPERRA Addr to parmlist so reloc. 00057100 LA R14,EOM3-PRMMSG Length of message 00057200 STCM R14,B'0011',ERRLEN Length of message 00057300 B ERROUT Head for home 00057400 *-------------------------------------------------------------* 00057500 STKMERR DS 0H 00057600 LA R14,STKMSG Address of error text 00057700 STCM R14,B'0111',TYPERRA Addr to parmlist so reloc. 00057800 LA R14,L'STKMSG Length of message 00057900 STCM R14,B'0011',ERRLEN Length of message 00058000 B ERROUT Head for home 00058100 *-------------------------------------------------------------* 00058200 OPTERR DS 0H 00058300 LA R14,OPTMSG Address of error text 00058400 STCM R14,B'0111',TYPERRA Addr to parmlist so reloc. 00058500 LA R14,L'OPTMSG Length of message 00058600 STCM R14,B'0011',ERRLEN Length of message 00058700 ERROUT LA R1,TYPERR 00058800 SVC 202 Issue CMS SVC 00058900 DC AL4(1) Ignore errors 00059000 LA R15,4 Set error return code 00059100 B EXIT Head for home 00059200 *-------------------------------------------------------------* 00059300 * INTERNAL SUBROUTINE TO TEST FOR LEAP YEAR AND SET UP FLAGS * 00059400 * AND COUNTS. CALL IS VIA BAL R14,LEAPTEST * 00059500 * EXPECTS R8 TO BE SET WITH THE YEAR, AND SETS TES1, TES3, * 00059600 * LPY1, LPY2, LPY3 AND SETS FEBRUARY TO THE PROPER LENGTH. * 00059700 *-------------------------------------------------------------* 00059800 LEAPTEST DS 0H 00059900 L R9,BINCE 00060000 S R9,=F'16' All dates are relative to 1/1/1600 00060100 MH R9,=H'100' # of centuries since 1600 ... 00060200 AR R9,R8 + input year = # of years 00060300 * BEGIN TEST FOR LEAP YEAR 00060400 LR R0,R9 Set up for divide 00060500 SRDA R0,32 MOVE DIVIDEND TO LOW ORDER REG 00060600 D R0,=F'400' Quotient is # of years divis. by 400 00060700 STH R1,LPY3 00060800 STH R0,TES3 SAVE REMAINDER 00060900 SR R0,R0 00061000 LR R1,R9 00061100 D R0,=F'4' DIVISIBLE BY 4? 00061200 STH R1,LPY1 # of years divisible by 4 00061300 STH R0,TES1 SAVE REMAINDER 00061400 SR R0,R0 00061500 LR R1,R9 00061600 D R0,=F'100' DIVISIBLE BY 100? 00061700 STH R1,LPY2 SAVE QUOTIENT 00061800 MVC FEB,=H'28' NO-LEAPYEAR LENGTH FOR FEBRUARY 00061900 MVC LPFLG,=C'NOR' ASSUME NORMAL-TYPE YEAR 00062000 CLC TES3,=H'0' WAS IT EVENLY DIVISIBLE BY 400? 00062100 BE ISALEAP YES, IT IS ALWAYS A LEAP YEAR 00062200 CLC TES1,=H'0' WAS IT EVENLY DIVISIBLE BY 4? 00062300 BNER R14 NO, SO IT CAN'T BE A LEAP YEAR 00062400 LTR R0,R0 DIVISIBLE BY 100? 00062500 BER R14 YES, NOT A LEAPYEAR 00062600 ISALEAP MVC FEB,=H'29' SET LEAPYEAR LENGTH FOR FEB 00062700 MVC LPFLG,=C'LPY' SET EXTERNAL LEAPYEAR FLAG 00062800 BR R14 RETURN TO CALLER 00062900 *-------------------------------------------------------------* 00063000 * Internal subroutine to scan the extended plist and pick up * 00063100 * the input argument(s). If the option is any valid abbrev- * 00063200 * iation of LONG, sets LONGFORM = 1. * 00063300 *-------------------------------------------------------------* 00063400 INPARM MVC PARMW(0),0(R3) 00063500 UPCASE OC PARMW(0),=CL128' ' Upper case the input parm area 00063600 MVARG1 MVC PARM1(0),0(R6) 00063700 MVARG2 MVC PARM2(0),0(R6) 00063800 OPTCOMP CLC 0(0,R6),=C'LONG' 00063900 GETPARMS DS 0H 00064000 MVC PARM1,=CL128' ' 00064100 MVC PARM2,=CL128' ' 00064200 MVI PARM1,X'FF' Assume no parms 00064300 MVI PARM2,X'FF' 00064400 MVI LONGFORM,0 Assume short form 00064500 MVC RETMSG,=CL128' ' Clear the answer area 00064600 LR R2,R0 R2=> extended plist 00064700 L R3,4(R2) R3=> beginning of args 00064800 L R7,8(R2) R7=> end of args 00064900 SR R7,R3 Is arg list empty? 00065000 BZR R14 Yes, Parm1 and PARM2 set up ok. 00065100 BCTR R7,0 00065200 EX R7,INPARM Make a copy of the input args 00065300 EX R7,UPCASE Uppercase the input args 00065400 LA R3,PARMW-1 R3 ==> Start of input 00065500 LA R7,PARMW+1(R7) R7 ==> 1 past end of input. 00065600 BAL R8,GETTOK Get first argument 00065700 LTR R15,R15 Did we get a token? 00065800 BNZR R14 No, no args submitted 00065900 CLI 0(R6),C'(' Did we fine the start of options? 00066000 BE OPTCHK Yes, go do options 00066100 C R5,=F'9' Is parm longer than 10? 00066200 BH PARMERR Yes, it's an error 00066300 EX R5,MVARG1 Save argument in PARM1 00066400 BAL R8,GETTOK Get first argument 00066500 LTR R15,R15 Did we get a token? 00066600 BNZR R14 No, no args submitted 00066700 CLI 0(R6),C'(' Did we find the start of options? 00066800 BE OPTCHK Yes, go do options 00066900 MVC PRMNUM,=C'second ' In case there's errors 00067000 C R5,=F'9' Is parm longer than 10? 00067100 BH PARMERR Yes, it's an error 00067200 EX R5,MVARG2 Save argument in PARM2 00067300 BAL R8,GETTOK Get next argument (It should be '(' ) 00067400 LTR R15,R15 Did we get a token? 00067500 BNZR R14 No, no options submitted 00067600 CLI 0(R6),C'(' Did we find the start of options? 00067700 BNE PARMTOO No, go tell about too many args 00067800 * At this point, we have gotten 1 or two parms and R6==> '(' 00067900 OPTCHK BAL R8,GETTOK Get the next token 00068000 LTR R15,R15 Did we get a token? 00068100 BNZR R14 No, no options submitted 00068200 C R5,=F'3' Is it 1-4 characters long? 00068300 BH OPTERR No, it can't be right! 00068400 EX R5,OPTCOMP Is option= 'Long'? 00068500 BNE OPTERR No, go tell 'em 00068600 MVI LONGFORM,X'01' Set flag for long form of date output 00068700 BR R14 Return to our caller 00068800 *---------------------------------------------------------------------* 00068900 * GETTOK() Extracts the next blank- or '('-delimited token from 0(R3) 00069000 * R15 = 0 on return, R6 ==> Token start, C(R5) = MOV length of token 00069100 * R15 = 4 on return, End of input 00069200 *---------------------------------------------------------------------* 00069300 * 00069400 GETTOK DS 0H Extract next token 00069500 SR R15,R15 Assume ok return 00069600 NXTBLNK LA R3,1(,R3) Advance to next character 00069700 CR R3,R7 End of command line? 00069800 BL CBLNK Go look at next character 00069900 LA R15,4 End of parms 00070000 BR R8 Yes, no args submitted. 00070100 CBLNK CLI 0(R3),C' ' Leading blank? 00070200 BE NXTBLNK No, go look at 1st argument 00070300 LR R6,R3 Save start of first arg. 00070400 CLI 0(R3),C'(' No parms, just option? 00070500 BNE REALARG 00070600 SR R5,R5 00070700 BR R8 00070800 * 00070900 REALARG LA R3,1(,R3) Advance to next character 00071000 CR R3,R7 End of command line? 00071100 BE ENDTOK Yes, go capture argument 00071200 CLI 0(R3),C' ' End of argument? 00071300 BE ENDTOK Yes, go capture it 00071400 CLI 0(R3),C'(' Argument ended by option start? 00071500 BNE REALARG No, go process next character 00071600 ENDTOK LR R5,R3 00071700 SR R5,R6 Length of token 00071800 BCTR R5,0 For moves... 00071900 BCTR R3,0 Scan restart 00072000 BR R8 Return with token 00072100 *---------------------------------------------------------------------* 00072200 * 00072300 *-------------------------------------------------------------* 00072400 * Constants and work areas * 00072500 *-------------------------------------------------------------* 00072600 LONGFORM DC XL1'00' 00072700 PARM1 DC CL10' ' Calling parameter 00072800 PARM2 DC CL10' ' Calling parameter 00072900 JPARM2 DS 0CL5 Working copy of calling parameter 00073000 JPARMYY DS CL2 yy part of yy.ddd 00073100 JPARMDDD DS CL3 ddd part of yy.ddd 00073200 CPDATA DC 4D'0' Return area for CP request 00073300 ORG CPDATA 00073400 BCMM DS CL2 mm 00073500 DS C '/' 00073600 BCDD DS CL2 dd 00073700 DS C '/' 00073800 BCYY DS CL2 yy 00073900 ORG 00074000 STACKDAT DC CL8'ATTN',CL4'LIFO',AL1(L'RETMSG) AL3(RETMSG) next 00074100 STACKDAA DC AL3(*-*) A(RETMSG) at ex for relocatability 00074200 STACKQMK DC CL8'ATTN',CL4'LIFO',AL1(QME-QMS) AL3(QMS) must be next 00074300 STACKQMA DC AL3(*-*) A(QMS) set at ex for relocatability 00074400 MM DC D'0' Holds packed month 00074500 ORG MM 00074600 PACKEDHH DS PL2 Reuse mm for hh:mm-xm's HH 00074700 ORG MM 00074800 DD DS D Reuse mm for packed day of month 00074900 ORG MM 00075000 YY DS D Reuse mm for packed year 00075100 ORG MM 00075200 NNN DS D Holds packed +nnn relative date 00075300 ORG MM 00075400 CE DS D Holds packed century 00075500 BINCE DC F'0' Save area for binary century 00075600 BINRYNNN DC F'0' Save area for binary +nnn rel date 00075700 LPY1 DC H'0' 00075800 LPY2 DC H'0' 00075900 LPY3 DC H'0' 00076000 TES1 DC H'0' 00076100 TES3 DC H'0' 00076200 QMS DC C'HELP DATETIME' Command string which displays help 00076300 QME EQU * 00076400 PARMW DS CL128 Input parms work area 00076500 RETMSG DC CL91' ' Output area 00076600 ORG RETMSG 00076700 DAYOFWK DC CL3' ' Day of the week as Mon or Tue ... 00076800 OUTSTRT EQU *+1 00076900 ORG 00077000 * 00077100 TIMEANS DC CL8' ' Time as hh:mm:ss 00077200 LPFLG DC CL3' ' LPY|NOR LeaPYear or NORmal year flag 00077300 JULIAN DC CL3' ' Julian day as ddd 00077400 MILMON DC CL3' ' mmm in ddmmmyy 00077500 DATECE DC CL2'19' 2-digit century 00077600 BCDNNN DC CL3'000' Working +nnn relative date 00077700 * 00077800 TYPERR DC CL8'TYPLIN',X'01' next line must be AL3(ERRMSG) 00077900 TYPERRA DC AL3(*-*),C'B',X'00' for relocatability 00078000 ERRLEN DC AL2(*-*) 00078100 ERRMSG DC C'The input argument: ''' 00078200 ERRINPUT DC CL10' ' Date as supplied by caller 00078300 DC C''' generates an invalid date.' 00078400 EOM1 EQU * 00078500 * 00078600 OPTMSG DC C'The only valid option is ''Long''.' 00078700 * 00078800 STKMSG DC C'One of the two arguments must be ''STACK''' 00078900 * 00079000 PRMMSG DC C'The ' 00079100 PRMNUM DC CL7'first' 00079200 DC C'argument is not valid.' 00079300 EOM3 EQU * 00079400 * 00079500 TOOMSG DC C'There are too many arguments, only date and ''STACK''' 00079600 DC C' are allowed.' 00079700 EOM4 EQU * 00079800 * 00079900 DAYTAB DC CL32'Sun Mon Tue Wed Thu Fri Sat' 00080000 MONTAB DC CL48'Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec' 00080100 * 00080200 SIGNF EQU X'0F' Used to generate the numeric +00080300 nibble after an unpack instruction 00080400 * 00080500 * Days per month table 00080600 * 00080700 DAYOFYR DC H'31,28,31,30,31,30,31,31,30,31,30,31' 00080800 FEB EQU DAYOFYR+2,2 00080900 *-------------------------------------------------------------* 00081000 * Equates * 00081100 *-------------------------------------------------------------* 00081200 R0 EQU 0 00081300 R1 EQU 1 00081400 R2 EQU 2 00081500 R3 EQU 3 00081600 R4 EQU 4 00081700 R5 EQU 5 00081800 R6 EQU 6 00081900 R7 EQU 7 00082000 R8 EQU 8 00082100 R9 EQU 9 00082200 R10 EQU 10 00082300 R11 EQU 11 00082400 R12 EQU 12 00082500 R13 EQU 13 00082600 R14 EQU 14 00082700 R15 EQU 15 00082800 END 00082900