478 lines
38 KiB
COBOL
478 lines
38 KiB
COBOL
00001 IDENTIFICATION DIVISION. 09/29/98
|
|
00002 PROGRAM-ID. DTSCU001. DTSCU001
|
|
00003 AUTHOR. PROGRAM RESOURCES. LV010
|
|
00004 SKIP2 DTSCU001
|
|
00005 ***** DTSCU001
|
|
00006 * DTSCU001
|
|
00007 * NAME: DTSCU001 CL**2
|
|
00008 * DTSCU001
|
|
00009 * FUNCTION: DATE CONVERSION MODULE DTSCU001
|
|
00010 * DTSCU001
|
|
00011 * MODIFICATION LOG: DTSCU001
|
|
00012 * DTSCU001
|
|
00013 * 7/31/98 INITIAL DEVELOPMENT. MODIFIED FROM MACCU001. CL**2
|
|
00014 * WORK ORDER: PROGRAMMER: ZL1. CL**6
|
|
00015 * CL**9
|
|
00016 * 09/29/1998 ADDED L001-SLASH-8-DATE RELATED CODE. CL**9
|
|
00017 * REFERENCE: DC DEVELPMENT PROGRAMMER: EHH CL**9
|
|
00018 * DTSCU001
|
|
00019 * MM/DD/YYYY XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CL**9
|
|
00020 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX CL**9
|
|
00021 * REFERENCE: XXXXXXXXXXXXXXX PROGRAMMER: XXX CL**9
|
|
00022 * DTSCU001
|
|
00023 * DTSCU001
|
|
00024 * DESCRIPTION: DTSCU001
|
|
00025 * DTSCU001
|
|
00026 * THE FUNCTION OF DTSCU001 IS TO VALIDATE DATES CL**2
|
|
00027 * AND CONVERT AMONG VARIOUS DATE REPRESENTATIONS. DTSCU001
|
|
00028 * DTSCU001
|
|
00029 * DTSCU001
|
|
00030 * EVERY CALL RETURNS THE FOLLOWING. DTSCU001
|
|
00031 * DTSCU001
|
|
00032 * 1. CALENDAR 8 DATE - MMDDYYYY DTSCU001
|
|
00033 * 2. FEDERAL 8 DATE - YYYYMMDD DTSCU001
|
|
00034 * 3. CALENDAR 6 DATE - MMDDYY DTSCU001
|
|
00035 * 4. FEDERAL 6 DATE - YYMMDD DTSCU001
|
|
00036 * 5. JULIAN DATE - YYYYDDD DTSCU001
|
|
00037 * 6. DAY OF WEEK DTSCU001
|
|
00038 * 7. SLASHED CALENDAR DATE - MM/DD/YY CL**9
|
|
00039 * 8. JULIAN DAY NUMBER - DAYS SINCE 4500 BC DTSCU001
|
|
00040 * 9. NINES COMPLEMENT OF FEDERAL 8 DATE. DTSCU001
|
|
00041 * 10. SLASHED-CALENDAR DATE - MM/DD/YYYY CL**9
|
|
00042 * CL**9
|
|
00043 * IF THE CALENDAR OR FEDERAL DATE SUPPLIED IS DTSCU001
|
|
00044 * NOT VALID, THE DAY OF WEEK IS RETURNED AS ZERO. DTSCU001
|
|
00045 * DTSCU001
|
|
00046 * DTSCU001
|
|
00047 * ABEND CODES: DTSCU001
|
|
00048 * DTSCU001
|
|
00049 * U001 - INVALID DATE OPTION SPECIFIED. DTSCU001
|
|
00050 * DTSCU001
|
|
00051 * DTSCU001
|
|
00052 ***** DTSCU001
|
|
00053 EJECT DTSCU001
|
|
00054 ******************************************************************DTSCU001
|
|
00055 * WORKING STORAGE *DTSCU001
|
|
00056 ******************************************************************DTSCU001
|
|
00057 ENVIRONMENT DIVISION. DTSCU001
|
|
00058 DATA DIVISION. DTSCU001
|
|
00059 WORKING-STORAGE SECTION. DTSCU001
|
|
000595 77 PAN-VALET PICTURE X(24) VALUE '010DTSCU001 09/29/98'. DTSCU001
|
|
00060 SKIP2 DTSCU001
|
|
00061 01 WS-MISC-VARIABLES. DTSCU001
|
|
00062 05 WS-ABEND-CODE PIC X(4). CL**4
|
|
00063 05 WS-L001-JUL-DATE PIC 9(7). DTSCU001
|
|
00064 05 FILLER REDEFINES WS-L001-JUL-DATE. DTSCU001
|
|
00065 10 WS-JULIAN-YR PIC 9(4). DTSCU001
|
|
00066 10 WS-JULIAN-DAYS PIC 9(3). DTSCU001
|
|
00067 05 DATE-CN PIC S9(8) COMP. DTSCU001
|
|
00068 05 DATE-YR PIC S9(8) COMP. DTSCU001
|
|
00069 05 DATE-MO PIC S9(8) COMP. DTSCU001
|
|
00070 05 DATE-DA PIC S9(8) COMP. DTSCU001
|
|
00071 05 JDATE PIC S9(8) COMP. DTSCU001
|
|
00072 05 WS-JDATE PIC S9(8) COMP. DTSCU001
|
|
00073 EJECT DTSCU001
|
|
00074 LINKAGE SECTION. DTSCU001
|
|
00075 SKIP1 DTSCU001
|
|
00076 01 DFHCOMMAREA. CL**7
|
|
00077 ++INCLUDE DTSIL001 CL**7
|
|
00078 EJECT CL**7
|
|
00079 PROCEDURE DIVISION. DTSCU001
|
|
00080 SKIP2 DTSCU001
|
|
00081 ***** DTSCU001
|
|
00082 * INITIATE PROCESSING DTSCU001
|
|
00083 ***** DTSCU001
|
|
00084 INIT0100-INITIATE-PROCESSING. DTSCU001
|
|
00085 IF L001-FROM-CAL-8 DTSCU001
|
|
00086 PERFORM PROC0100-FROM-CALENDAR THRU CL**2
|
|
00087 PROC0100-FROM-CALENDAR-EXIT CL**2
|
|
00088 ELSE DTSCU001
|
|
00089 IF L001-FROM-FED-8 DTSCU001
|
|
00090 PERFORM PROC0200-FROM-FEDERAL THRU CL**2
|
|
00091 PROC0200-FROM-FEDERAL-EXIT CL**2
|
|
00092 ELSE DTSCU001
|
|
00093 IF L001-FROM-JUL DTSCU001
|
|
00094 PERFORM PROC0300-FROM-JULIAN THRU CL**2
|
|
00095 PROC0300-FROM-JULIAN-EXIT CL**2
|
|
00096 ELSE DTSCU001
|
|
00097 IF L001-FROM-ABS-DAY DTSCU001
|
|
00098 PERFORM PROC0400-FROM-JULIAN-DAY-NMBR THRU CL**2
|
|
00099 PROC0400-FROM-JULIAN-DAY-EXIT CL**8
|
|
00100 ELSE DTSCU001
|
|
00101 IF L001-FROM-CAL-6 DTSCU001
|
|
00102 PERFORM PROC0500-FROM-CALENDAR-6 THRU CL**2
|
|
00103 PROC0500-FROM-CALENDAR-6-EXIT CL**2
|
|
00104 ELSE DTSCU001
|
|
00105 IF L001-FROM-FED-6 DTSCU001
|
|
00106 PERFORM PROC0600-FROM-FEDERAL-6 THRU CL**2
|
|
00107 PROC0600-FROM-FEDERAL-6-EXIT CL**2
|
|
00108 ELSE DTSCU001
|
|
00109 IF L001-FROM-NINES-COMPLEMENT DTSCU001
|
|
00110 PERFORM PROC0700-FROM-COMP THRU CL**2
|
|
00111 PROC0700-FROM-COMP-EXIT CL**2
|
|
00112 ELSE DTSCU001
|
|
00113 MOVE 'U001' TO WS-ABEND-CODE DTSCU001
|
|
00114 EXEC CICS ABEND ABCODE (WS-ABEND-CODE) END-EXEC CL**3
|
|
00115 STOP RUN. CL**3
|
|
00116 INIT0199-GOBACK. DTSCU001
|
|
00117 EXEC CICS DTSCU001
|
|
00118 RETURN DTSCU001
|
|
00119 END-EXEC. DTSCU001
|
|
00120 SKIP2 DTSCU001
|
|
00121 ***** DTSCU001
|
|
00122 * CONVERT FROM CALENDAR DATE DTSCU001
|
|
00123 ***** DTSCU001
|
|
00124 PROC0100-FROM-CALENDAR. DTSCU001
|
|
00125 IF L001-CAL-8-MO NOT NUMERIC DTSCU001
|
|
00126 OR L001-CAL-8-DA NOT NUMERIC DTSCU001
|
|
00127 OR L001-CAL-8-YR NOT NUMERIC DTSCU001
|
|
00128 PERFORM SERV1000-CLEAR-DWA THRU CL**2
|
|
00129 SERV1000-CLEAR-DWA-EXIT CL**2
|
|
00130 GO TO PROC0100-FROM-CALENDAR-EXIT. CL**2
|
|
00131 MOVE L001-CAL-8-MO TO L001-CAL-6-MO. DTSCU001
|
|
00132 MOVE L001-CAL-8-DA TO L001-CAL-6-DA. DTSCU001
|
|
00133 MOVE L001-CAL-8-YR TO L001-CAL-6-YR L001-FED-6-YR. DTSCU001
|
|
00134 MOVE L001-CAL-8-MO TO DATE-MO. DTSCU001
|
|
00135 MOVE L001-CAL-8-DA TO DATE-DA. DTSCU001
|
|
00136 MOVE L001-CAL-8-YR TO DATE-YR L001-FED-8-YR. DTSCU001
|
|
00137 PERFORM PROC1000-DATE-JDAY THRU CL**2
|
|
00138 PROC1000-DATE-JDAY-EXIT. CL**2
|
|
00139 MOVE JDATE TO L001-JUL-ABS-DAY WS-JDATE. DTSCU001
|
|
00140 PERFORM PROC2000-DATE-JDATE THRU CL**2
|
|
00141 PROC2000-DATE-JDATE-EXIT. CL**2
|
|
00142 IF L001-CAL-8-DA NOT EQUAL DATE-DA DTSCU001
|
|
00143 OR L001-CAL-8-MO NOT EQUAL DATE-MO DTSCU001
|
|
00144 PERFORM SERV1000-CLEAR-DWA THRU CL**8
|
|
00145 SERV1000-CLEAR-DWA-EXIT CL**2
|
|
00146 GO TO PROC0100-FROM-CALENDAR-EXIT. CL**2
|
|
00147 MOVE 01 TO DATE-DA DATE-MO. DTSCU001
|
|
00148 PERFORM PROC1000-DATE-JDAY THRU CL**2
|
|
00149 PROC1000-DATE-JDAY-EXIT. CL**2
|
|
00150 SUBTRACT L001-JUL-ABS-DAY FROM JDATE. DTSCU001
|
|
00151 COMPUTE L001-JUL-DATE EQUAL 1000 * L001-CAL-8-YR - JDATE + 1.DTSCU001
|
|
00152 PERFORM PROC3000-DAY-OF-WEEK THRU CL**2
|
|
00153 PROC3000-DAY-OF-WEEK-EXIT. CL**2
|
|
00154 PERFORM PROC4000-L001-SLASH-DATE THRU CL**2
|
|
00155 PROC4000-L001-SLASH-DATE-EXIT. CL**2
|
|
00156 PERFORM PROC5000-COMP-DATE THRU CL**2
|
|
00157 PROC5000-COMP-DATE-EXIT. CL**2
|
|
00158 PERFORM PROC6000-CHECK-YR THRU CL**2
|
|
00159 PROC6000-CHECK-YR-EXIT. CL**2
|
|
00160 PROC0100-FROM-CALENDAR-EXIT. EXIT. CL**2
|
|
00161 SKIP2 DTSCU001
|
|
00162 ***** DTSCU001
|
|
00163 * CONVERT FROM FEDERAL DATE DTSCU001
|
|
00164 ***** DTSCU001
|
|
00165 PROC0200-FROM-FEDERAL. DTSCU001
|
|
00166 IF L001-FED-8-YR NOT NUMERIC DTSCU001
|
|
00167 OR L001-FED-8-MO NOT NUMERIC DTSCU001
|
|
00168 OR L001-FED-8-DA NOT NUMERIC DTSCU001
|
|
00169 PERFORM SERV1000-CLEAR-DWA THRU CL**2
|
|
00170 SERV1000-CLEAR-DWA-EXIT CL**2
|
|
00171 GO TO PROC0200-FROM-FEDERAL-EXIT. CL**2
|
|
00172 MOVE L001-FED-8-YR TO L001-FED-6-YR L001-CAL-6-YR. DTSCU001
|
|
00173 MOVE L001-FED-8-MO TO L001-FED-6-MO. DTSCU001
|
|
00174 MOVE L001-FED-8-DA TO L001-FED-6-DA. DTSCU001
|
|
00175 MOVE L001-FED-8-YR TO DATE-YR L001-CAL-8-YR. DTSCU001
|
|
00176 MOVE L001-FED-8-MO TO DATE-MO. DTSCU001
|
|
00177 MOVE L001-FED-8-DA TO DATE-DA. DTSCU001
|
|
00178 PERFORM PROC1000-DATE-JDAY THRU CL**2
|
|
00179 PROC1000-DATE-JDAY-EXIT. CL**2
|
|
00180 MOVE JDATE TO L001-JUL-ABS-DAY WS-JDATE. DTSCU001
|
|
00181 PERFORM PROC2000-DATE-JDATE THRU CL**2
|
|
00182 PROC2000-DATE-JDATE-EXIT. CL**2
|
|
00183 IF L001-FED-8-DA NOT EQUAL DATE-DA DTSCU001
|
|
00184 OR L001-FED-8-MO NOT EQUAL DATE-MO DTSCU001
|
|
00185 PERFORM SERV1000-CLEAR-DWA THRU CL**8
|
|
00186 SERV1000-CLEAR-DWA-EXIT CL**2
|
|
00187 GO TO PROC0200-FROM-FEDERAL-EXIT. CL**2
|
|
00188 MOVE 01 TO DATE-DA DATE-MO. DTSCU001
|
|
00189 PERFORM PROC1000-DATE-JDAY THRU CL**2
|
|
00190 PROC1000-DATE-JDAY-EXIT. CL**2
|
|
00191 SUBTRACT L001-JUL-ABS-DAY FROM JDATE. DTSCU001
|
|
00192 COMPUTE L001-JUL-DATE EQUAL 1000 * L001-CAL-8-YR - JDATE + 1.DTSCU001
|
|
00193 PERFORM PROC3000-DAY-OF-WEEK THRU CL**2
|
|
00194 PROC3000-DAY-OF-WEEK-EXIT. CL**2
|
|
00195 PERFORM PROC4000-L001-SLASH-DATE THRU CL**2
|
|
00196 PROC4000-L001-SLASH-DATE-EXIT. CL**2
|
|
00197 PERFORM PROC5000-COMP-DATE THRU CL**2
|
|
00198 PROC5000-COMP-DATE-EXIT. CL**2
|
|
00199 PERFORM PROC6000-CHECK-YR THRU CL**2
|
|
00200 PROC6000-CHECK-YR-EXIT. CL**2
|
|
00201 PROC0200-FROM-FEDERAL-EXIT. EXIT. CL**2
|
|
00202 SKIP2 DTSCU001
|
|
00203 ***** DTSCU001
|
|
00204 * CONVERT FROM JULIAN DATE DTSCU001
|
|
00205 ***** DTSCU001
|
|
00206 PROC0300-FROM-JULIAN. DTSCU001
|
|
00207 IF (L001-JUL-DATE NOT NUMERIC) DTSCU001
|
|
00208 OR DTSCU001
|
|
00209 (L001-JUL-DATE NOT GREATER THAN ZERO) DTSCU001
|
|
00210 PERFORM SERV1000-CLEAR-DWA THRU CL**2
|
|
00211 SERV1000-CLEAR-DWA-EXIT CL**2
|
|
00212 GO TO PROC0300-FROM-JULIAN-EXIT. CL**2
|
|
00213 MOVE L001-JUL-DATE TO WS-L001-JUL-DATE. DTSCU001
|
|
00214 DIVIDE 4 INTO WS-JULIAN-YR DTSCU001
|
|
00215 GIVING DATE-YR REMAINDER DATE-CN. DTSCU001
|
|
00216 IF DATE-CN EQUAL ZERO DTSCU001
|
|
00217 IF WS-JULIAN-DAYS GREATER THAN 366 DTSCU001
|
|
00218 PERFORM SERV1000-CLEAR-DWA THRU CL**2
|
|
00219 SERV1000-CLEAR-DWA-EXIT CL**2
|
|
00220 GO TO PROC0300-FROM-JULIAN-EXIT CL**2
|
|
00221 ELSE DTSCU001
|
|
00222 NEXT SENTENCE DTSCU001
|
|
00223 ELSE DTSCU001
|
|
00224 IF WS-JULIAN-DAYS GREATER THAN 365 DTSCU001
|
|
00225 PERFORM SERV1000-CLEAR-DWA THRU CL**2
|
|
00226 SERV1000-CLEAR-DWA-EXIT CL**2
|
|
00227 GO TO PROC0300-FROM-JULIAN-EXIT. CL**2
|
|
00228 MOVE 01 TO DATE-DA DATE-MO. DTSCU001
|
|
00229 MOVE WS-JULIAN-YR TO DATE-YR. DTSCU001
|
|
00230 PERFORM PROC1000-DATE-JDAY THRU CL**2
|
|
00231 PROC1000-DATE-JDAY-EXIT. CL**2
|
|
00232 COMPUTE L001-JUL-ABS-DAY EQUAL JDATE + WS-JULIAN-DAYS - 1. DTSCU001
|
|
00233 MOVE L001-JUL-ABS-DAY TO JDATE WS-JDATE. DTSCU001
|
|
00234 PERFORM PROC2000-DATE-JDATE THRU CL**2
|
|
00235 PROC2000-DATE-JDATE-EXIT. CL**2
|
|
00236 MOVE DATE-MO TO L001-FED-8-MO. CL**5
|
|
00237 MOVE DATE-DA TO L001-FED-8-DA. CL**5
|
|
00238 MOVE DATE-YR TO L001-FED-8-YR L001-CAL-8-YR. CL**5
|
|
00239 MOVE L001-FED-8-YR TO L001-FED-6-YR L001-CAL-6-YR. DTSCU001
|
|
00240 MOVE L001-FED-8-MO TO L001-FED-6-MO. DTSCU001
|
|
00241 MOVE L001-FED-8-DA TO L001-FED-6-DA. DTSCU001
|
|
00242 PERFORM PROC3000-DAY-OF-WEEK THRU CL**2
|
|
00243 PROC3000-DAY-OF-WEEK-EXIT. CL**2
|
|
00244 PERFORM PROC4000-L001-SLASH-DATE THRU CL**2
|
|
00245 PROC4000-L001-SLASH-DATE-EXIT. CL**2
|
|
00246 PERFORM PROC5000-COMP-DATE THRU CL**2
|
|
00247 PROC5000-COMP-DATE-EXIT. CL**2
|
|
00248 PERFORM PROC6000-CHECK-YR THRU CL**2
|
|
00249 PROC6000-CHECK-YR-EXIT. CL**2
|
|
00250 PROC0300-FROM-JULIAN-EXIT. EXIT. CL**2
|
|
00251 SKIP2 DTSCU001
|
|
00252 ***** DTSCU001
|
|
00253 * CONVERT FROM JULIAN DAY NUMBER DTSCU001
|
|
00254 ***** DTSCU001
|
|
00255 PROC0400-FROM-JULIAN-DAY-NMBR. DTSCU001
|
|
00256 IF L001-JUL-ABS-DAY NOT GREATER THAN ZERO DTSCU001
|
|
00257 PERFORM SERV1000-CLEAR-DWA THRU CL**2
|
|
00258 SERV1000-CLEAR-DWA-EXIT CL**2
|
|
00259 GO TO PROC0400-FROM-JULIAN-DAY-EXIT. CL**8
|
|
00260 MOVE L001-JUL-ABS-DAY TO JDATE WS-JDATE. DTSCU001
|
|
00261 PERFORM PROC2000-DATE-JDATE THRU CL**2
|
|
00262 PROC2000-DATE-JDATE-EXIT. CL**2
|
|
00263 MOVE DATE-MO TO L001-CAL-8-MO. CL**5
|
|
00264 MOVE DATE-DA TO L001-CAL-8-DA. CL**5
|
|
00265 MOVE DATE-YR TO L001-FED-8-YR L001-CAL-8-YR. CL**5
|
|
00266 MOVE L001-CAL-8-MO TO L001-CAL-6-MO. DTSCU001
|
|
00267 MOVE L001-CAL-8-DA TO L001-CAL-6-DA. DTSCU001
|
|
00268 MOVE L001-CAL-8-YR TO L001-CAL-6-YR L001-FED-6-YR. DTSCU001
|
|
00269 MOVE 01 TO DATE-DA DATE-MO. DTSCU001
|
|
00270 PERFORM PROC1000-DATE-JDAY THRU CL**2
|
|
00271 PROC1000-DATE-JDAY-EXIT. CL**2
|
|
00272 SUBTRACT L001-JUL-ABS-DAY FROM JDATE. DTSCU001
|
|
00273 COMPUTE L001-JUL-DATE EQUAL 1000 * L001-CAL-8-YR - JDATE + 1.DTSCU001
|
|
00274 PERFORM PROC3000-DAY-OF-WEEK THRU CL**2
|
|
00275 PROC3000-DAY-OF-WEEK-EXIT. CL**2
|
|
00276 PERFORM PROC4000-L001-SLASH-DATE THRU CL**2
|
|
00277 PROC4000-L001-SLASH-DATE-EXIT. CL**2
|
|
00278 PERFORM PROC5000-COMP-DATE THRU CL**2
|
|
00279 PROC5000-COMP-DATE-EXIT. CL**2
|
|
00280 PERFORM PROC6000-CHECK-YR THRU CL**2
|
|
00281 PROC6000-CHECK-YR-EXIT. CL**2
|
|
00282 PROC0400-FROM-JULIAN-DAY-EXIT. EXIT . CL**8
|
|
00283 SKIP2 DTSCU001
|
|
00284 ***** DTSCU001
|
|
00285 * CONVERT FROM SIX DIGIT CALENDAR DATE DTSCU001
|
|
00286 ***** DTSCU001
|
|
00287 PROC0500-FROM-CALENDAR-6. DTSCU001
|
|
00288 IF L001-CAL-6-MO NOT NUMERIC DTSCU001
|
|
00289 OR L001-CAL-6-DA NOT NUMERIC DTSCU001
|
|
00290 OR L001-CAL-6-YR NOT NUMERIC DTSCU001
|
|
00291 PERFORM SERV1000-CLEAR-DWA THRU CL**2
|
|
00292 SERV1000-CLEAR-DWA-EXIT CL**2
|
|
00293 GO TO PROC0500-FROM-CALENDAR-6-EXIT. CL**2
|
|
00294 MOVE L001-CAL-6-YR TO L001-FED-6-YR. DTSCU001
|
|
00295 MOVE L001-CAL-6-MO TO L001-CAL-8-MO. DTSCU001
|
|
00296 MOVE L001-CAL-6-DA TO L001-CAL-8-DA. DTSCU001
|
|
00297 IF L001-CAL-6-YR < 30 DTSCU001
|
|
00298 ADD L001-CAL-6-YR 2000 GIVING L001-CAL-8-YR DTSCU001
|
|
00299 ELSE DTSCU001
|
|
00300 ADD L001-CAL-6-YR 1900 GIVING L001-CAL-8-YR. DTSCU001
|
|
00301 MOVE L001-CAL-8-MO TO DATE-MO. DTSCU001
|
|
00302 MOVE L001-CAL-8-DA TO DATE-DA. DTSCU001
|
|
00303 MOVE L001-CAL-8-YR TO DATE-YR L001-FED-8-YR. DTSCU001
|
|
00304 PERFORM PROC1000-DATE-JDAY THRU CL**2
|
|
00305 PROC1000-DATE-JDAY-EXIT. CL**2
|
|
00306 MOVE JDATE TO L001-JUL-ABS-DAY WS-JDATE. DTSCU001
|
|
00307 PERFORM PROC2000-DATE-JDATE THRU CL**2
|
|
00308 PROC2000-DATE-JDATE-EXIT. CL**2
|
|
00309 IF L001-CAL-8-DA NOT EQUAL DATE-DA DTSCU001
|
|
00310 OR L001-CAL-8-MO NOT EQUAL DATE-MO DTSCU001
|
|
00311 PERFORM SERV1000-CLEAR-DWA THRU CL**2
|
|
00312 SERV1000-CLEAR-DWA-EXIT CL**2
|
|
00313 GO TO PROC0500-FROM-CALENDAR-6-EXIT. CL**2
|
|
00314 MOVE 01 TO DATE-DA DATE-MO. DTSCU001
|
|
00315 PERFORM PROC1000-DATE-JDAY THRU CL**2
|
|
00316 PROC1000-DATE-JDAY-EXIT. CL**2
|
|
00317 SUBTRACT L001-JUL-ABS-DAY FROM JDATE. DTSCU001
|
|
00318 COMPUTE L001-JUL-DATE EQUAL 1000 * L001-CAL-8-YR - JDATE + 1.DTSCU001
|
|
00319 PERFORM PROC3000-DAY-OF-WEEK THRU CL**2
|
|
00320 PROC3000-DAY-OF-WEEK-EXIT. CL**2
|
|
00321 PERFORM PROC4000-L001-SLASH-DATE THRU CL**2
|
|
00322 PROC4000-L001-SLASH-DATE-EXIT. CL**2
|
|
00323 PERFORM PROC5000-COMP-DATE THRU CL**2
|
|
00324 PROC5000-COMP-DATE-EXIT. CL**2
|
|
00325 PROC0500-FROM-CALENDAR-6-EXIT. EXIT. CL**2
|
|
00326 SKIP2 DTSCU001
|
|
00327 ***** DTSCU001
|
|
00328 * CONVERT FROM SIX DIGIT FEDERAL DATE DTSCU001
|
|
00329 ***** DTSCU001
|
|
00330 PROC0600-FROM-FEDERAL-6. DTSCU001
|
|
00331 IF L001-FED-6-YR NOT NUMERIC DTSCU001
|
|
00332 OR L001-FED-6-MO NOT NUMERIC DTSCU001
|
|
00333 OR L001-FED-6-DA NOT NUMERIC DTSCU001
|
|
00334 PERFORM SERV1000-CLEAR-DWA THRU CL**2
|
|
00335 SERV1000-CLEAR-DWA-EXIT CL**2
|
|
00336 GO TO PROC0600-FROM-FEDERAL-6-EXIT. CL**2
|
|
00337 MOVE L001-FED-6-YR TO L001-CAL-6-YR. DTSCU001
|
|
00338 IF L001-FED-6-YR < 30 DTSCU001
|
|
00339 ADD L001-CAL-6-YR 2000 GIVING L001-FED-8-YR DTSCU001
|
|
00340 ELSE DTSCU001
|
|
00341 ADD L001-CAL-6-YR 1900 GIVING L001-FED-8-YR. DTSCU001
|
|
00342 MOVE L001-FED-6-MO TO L001-FED-8-MO. DTSCU001
|
|
00343 MOVE L001-FED-6-DA TO L001-FED-8-DA. DTSCU001
|
|
00344 MOVE L001-FED-8-YR TO DATE-YR L001-CAL-8-YR. DTSCU001
|
|
00345 MOVE L001-FED-8-MO TO DATE-MO. DTSCU001
|
|
00346 MOVE L001-FED-8-DA TO DATE-DA. DTSCU001
|
|
00347 PERFORM PROC1000-DATE-JDAY THRU CL**2
|
|
00348 PROC1000-DATE-JDAY-EXIT. CL**2
|
|
00349 MOVE JDATE TO L001-JUL-ABS-DAY WS-JDATE. DTSCU001
|
|
00350 PERFORM PROC2000-DATE-JDATE THRU CL**2
|
|
00351 PROC2000-DATE-JDATE-EXIT. CL**2
|
|
00352 IF L001-FED-8-DA NOT EQUAL DATE-DA DTSCU001
|
|
00353 OR L001-FED-8-MO NOT EQUAL DATE-MO DTSCU001
|
|
00354 PERFORM SERV1000-CLEAR-DWA THRU CL**2
|
|
00355 SERV1000-CLEAR-DWA-EXIT CL**2
|
|
00356 GO TO PROC0600-FROM-FEDERAL-6-EXIT. CL**2
|
|
00357 MOVE 01 TO DATE-DA DATE-MO. DTSCU001
|
|
00358 PERFORM PROC1000-DATE-JDAY THRU CL**2
|
|
00359 PROC1000-DATE-JDAY-EXIT. CL**2
|
|
00360 SUBTRACT L001-JUL-ABS-DAY FROM JDATE. DTSCU001
|
|
00361 COMPUTE L001-JUL-DATE EQUAL 1000 * L001-CAL-8-YR - JDATE + 1.DTSCU001
|
|
00362 PERFORM PROC3000-DAY-OF-WEEK THRU CL**2
|
|
00363 PROC3000-DAY-OF-WEEK-EXIT. CL**2
|
|
00364 PERFORM PROC4000-L001-SLASH-DATE THRU CL**2
|
|
00365 PROC4000-L001-SLASH-DATE-EXIT. CL**2
|
|
00366 PERFORM PROC5000-COMP-DATE THRU CL**2
|
|
00367 PROC5000-COMP-DATE-EXIT. CL**2
|
|
00368 PROC0600-FROM-FEDERAL-6-EXIT. EXIT. CL**2
|
|
00369 SKIP3 DTSCU001
|
|
00370 PROC0700-FROM-COMP. DTSCU001
|
|
00371 IF (L001-NINES-COMPLEMENT-DATE NOT NUMERIC) DTSCU001
|
|
00372 OR DTSCU001
|
|
00373 (L001-NINES-COMPLEMENT-DATE NOT > 0) DTSCU001
|
|
00374 PERFORM SERV1000-CLEAR-DWA THRU CL**2
|
|
00375 SERV1000-CLEAR-DWA-EXIT CL**2
|
|
00376 GO TO PROC0700-FROM-COMP-EXIT. CL**2
|
|
00377 COMPUTE L001-FED-8-DATE-9 DTSCU001
|
|
00378 = 999999999 - L001-NINES-COMPLEMENT-DATE. DTSCU001
|
|
00379 PERFORM PROC0200-FROM-FEDERAL THRU CL**2
|
|
00380 PROC0200-FROM-FEDERAL-EXIT. CL**2
|
|
00381 PROC0700-FROM-COMP-EXIT. EXIT. CL**2
|
|
00382 SKIP2 DTSCU001
|
|
00383 ***** DTSCU001
|
|
00384 * COMPUTE JULIAN DAY NUMBER FROM A GREGORIAN DATE DTSCU001
|
|
00385 ***** DTSCU001
|
|
00386 PROC1000-DATE-JDAY. DTSCU001
|
|
00387 IF DATE-MO GREATER THAN 2 DTSCU001
|
|
00388 SUBTRACT 3 FROM DATE-MO DTSCU001
|
|
00389 ELSE DTSCU001
|
|
00390 ADD 9 TO DATE-MO DTSCU001
|
|
00391 SUBTRACT 1 FROM DATE-YR. DTSCU001
|
|
00392 DIVIDE 100 INTO DATE-YR GIVING DATE-CN REMAINDER DATE-YR. DTSCU001
|
|
00393 COMPUTE JDATE EQUAL (146097 * DATE-CN) / 4. DTSCU001
|
|
00394 COMPUTE JDATE EQUAL (1461 * DATE-YR) / 4 + JDATE. DTSCU001
|
|
00395 COMPUTE JDATE EQUAL (153 * DATE-MO + 2) / 5 + JDATE. DTSCU001
|
|
00396 COMPUTE JDATE EQUAL 1721119 + DATE-DA + JDATE. DTSCU001
|
|
00397 PROC1000-DATE-JDAY-EXIT. EXIT. CL**2
|
|
00398 SKIP2 DTSCU001
|
|
00399 ***** DTSCU001
|
|
00400 * COMPUTE GREGORIAN DATE FROM JULIAN DAY NUMBER DTSCU001
|
|
00401 ***** DTSCU001
|
|
00402 PROC2000-DATE-JDATE. DTSCU001
|
|
00403 SUBTRACT 1721119 FROM JDATE. DTSCU001
|
|
00404 COMPUTE DATE-YR EQUAL (4 * JDATE - 1) / 146097. DTSCU001
|
|
00405 COMPUTE JDATE EQUAL 4 * JDATE - 1 - 146097 * DATE-YR. DTSCU001
|
|
00406 COMPUTE DATE-DA EQUAL JDATE / 4. DTSCU001
|
|
00407 COMPUTE JDATE EQUAL (4 * DATE-DA + 3) / 1461. DTSCU001
|
|
00408 COMPUTE DATE-DA EQUAL 4 * DATE-DA + 3 - 1461 * JDATE. DTSCU001
|
|
00409 COMPUTE DATE-DA EQUAL (DATE-DA + 4) / 4. DTSCU001
|
|
00410 COMPUTE DATE-MO EQUAL (5 * DATE-DA - 3) / 153. DTSCU001
|
|
00411 COMPUTE DATE-DA EQUAL 5 * DATE-DA - 3 - 153 * DATE-MO. DTSCU001
|
|
00412 COMPUTE DATE-DA EQUAL (DATE-DA + 5) / 5. DTSCU001
|
|
00413 COMPUTE DATE-YR EQUAL 100 * DATE-YR + JDATE. DTSCU001
|
|
00414 IF DATE-MO LESS THAN 10 DTSCU001
|
|
00415 ADD 3 TO DATE-MO DTSCU001
|
|
00416 ELSE DTSCU001
|
|
00417 SUBTRACT 9 FROM DATE-MO DTSCU001
|
|
00418 ADD 1 TO DATE-YR. DTSCU001
|
|
00419 PROC2000-DATE-JDATE-EXIT. EXIT. CL**2
|
|
00420 SKIP2 DTSCU001
|
|
00421 ***** DTSCU001
|
|
00422 * COMPUTE DAY OF WEEK DTSCU001
|
|
00423 ***** DTSCU001
|
|
00424 PROC3000-DAY-OF-WEEK. DTSCU001
|
|
00425 DIVIDE 7 INTO WS-JDATE DTSCU001
|
|
00426 GIVING DATE-CN REMAINDER L001-DAY-OF-WEEK. DTSCU001
|
|
00427 IF L001-DAY-OF-WEEK LESS THAN 6 DTSCU001
|
|
00428 ADD 2 TO L001-DAY-OF-WEEK DTSCU001
|
|
00429 ELSE DTSCU001
|
|
00430 SUBTRACT 5 FROM L001-DAY-OF-WEEK. DTSCU001
|
|
00431 PROC3000-DAY-OF-WEEK-EXIT. EXIT. CL**2
|
|
00432 SKIP2 DTSCU001
|
|
00433 ***** DTSCU001
|
|
00434 * FORMAT SLASHED DATE DTSCU001
|
|
00435 ***** DTSCU001
|
|
00436 PROC4000-L001-SLASH-DATE. DTSCU001
|
|
00437 MOVE ' / / ' TO L001-SLASH-DATE. DTSCU001
|
|
00438 MOVE L001-CAL-8-YR TO L001-SLASH-YR. DTSCU001
|
|
00439 MOVE L001-CAL-8-MO TO L001-SLASH-MO. DTSCU001
|
|
00440 MOVE L001-CAL-8-DA TO L001-SLASH-DA. DTSCU001
|
|
00441 CL**9
|
|
00442 MOVE ' / / ' TO L001-SLASH-8-DATE. CL**9
|
|
00443 MOVE L001-CAL-8-YR TO L001-SLASH-8-YR. CL**9
|
|
00444 MOVE L001-CAL-8-MO TO L001-SLASH-8-MO. CL**9
|
|
00445 MOVE L001-CAL-8-DA TO L001-SLASH-8-DA. CL**9
|
|
00446 PROC4000-L001-SLASH-DATE-EXIT. EXIT. CL**2
|
|
00447 SKIP3 DTSCU001
|
|
00448 PROC5000-COMP-DATE. DTSCU001
|
|
00449 COMPUTE L001-NINES-COMPLEMENT-DATE DTSCU001
|
|
00450 = 999999999 - L001-FED-8-DATE-9. DTSCU001
|
|
00451 PROC5000-COMP-DATE-EXIT. EXIT. CL**2
|
|
00452 SKIP3 DTSCU001
|
|
00453 PROC6000-CHECK-YR. DTSCU001
|
|
00454 IF (L001-FED-8-YR < 1930) DTSCU001
|
|
00455 OR DTSCU001
|
|
00456 (L001-FED-8-YR > 2029) DTSCU001
|
|
00457 PERFORM SERV1000-CLEAR-DWA THRU CL**4
|
|
00458 SERV1000-CLEAR-DWA-EXIT. CL**4
|
|
00459 PROC6000-CHECK-YR-EXIT. EXIT. CL**2
|
|
00460 SKIP2 DTSCU001
|
|
00461 ***** DTSCU001
|
|
00462 * CLEAR DATE WORK AREA DTSCU001
|
|
00463 ***** DTSCU001
|
|
00464 SERV1000-CLEAR-DWA. DTSCU001
|
|
00465 MOVE ZERO DTSCU001
|
|
00466 TO L001-FED-8-DATE-9 DTSCU001
|
|
00467 L001-CAL-8-DATE-9 DTSCU001
|
|
00468 L001-FED-6-DATE-9 DTSCU001
|
|
00469 L001-CAL-6-DATE-9 DTSCU001
|
|
00470 L001-SLASH-DATE DTSCU001
|
|
00471 L001-SLASH-8-DATE CL*10
|
|
00472 L001-JUL-DATE DTSCU001
|
|
00473 L001-NINES-COMPLEMENT-DATE DTSCU001
|
|
00474 L001-DAY-OF-WEEK. DTSCU001
|
|
00475 SERV1000-CLEAR-DWA-EXIT. EXIT. CL**2
|
|
00476 SKIP2 DTSCU001
|