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
