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
