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