00001  IDENTIFICATION DIVISION.                                         05/13/99
00002  PROGRAM-ID.             DTSCU029                                 DTSCU029
00003  AUTHOR.                 TRICOASTAL CONSULTING LTD.                  LV008
00004  DATE-WRITTEN            MAY 1999.                                   CL**5
00005  DATE-COMPILED.                                                   DTSCU029
00006      SKIP3                                                        DTSCU029
00007 *****                                                             DTSCU029
00008 *                                                                 DTSCU029
00009 *    FUNCTION:   YEAR/QUARTER (PICKUP INCLUDED) FROM SCREEN          CL**5
00010 *                FORMAT/EDIT.                                        CL**5
00011 *                                                                    CL**5
00012 *                                                                 DTSCU029
00013 *    MODIFICATION LOG:                                            DTSCU029
00014 *                                                                 DTSCU029
00015 *    05/13/1999  INITIAL DEVELOPMENT.  CLONED FROM DTSCU016.         CL**5
00016 *                REFERENCE: PICKUP DIR       PROGRAMMER: EHH         CL**5
00017 *                                                                    CL**5
00018 *    MM/DD/YYYY  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX         CL**5
00019 *                XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX         CL**5
00020 *                REFERENCE: XXXXXXXXXXXXXXX  PROGRAMMER: XXX         CL**5
00021 *                                                                 DTSCU029
00022 *                                                                 DTSCU029
00023 *****                                                             DTSCU029
00024                                                                      CL**5
00025                                                                      CL**5
00026                                                                      CL**5
00027  ENVIRONMENT DIVISION.                                            DTSCU029
00028                                                                      CL**5
00029                                                                      CL**5
00030  DATA DIVISION.                                                   DTSCU029
00031                                                                      CL**5
00032                                                                      CL**5
00033  WORKING-STORAGE SECTION.                                         DTSCU029
000335 77  PAN-VALET PICTURE X(24) VALUE '008DTSCU029  05/13/99'.       DTSCU029
00034                                                                      CL**5
00035  01  WRK-AREA.                                                    DTSCU029
00036      05  WRK-PICKUP-YRQ        PIC S9(05)  COMP-3  VALUE +19924.     CL**6
00037                                                                      CL**5
00038                                                                      CL**5
00039                                                                      CL**5
00040  01  DTSIL004-COMM-AREA.                                             CL**2
00041  ++INCLUDE DTSIL004                                                  CL**3
00042      EJECT                                                           CL**5
00043  LINKAGE SECTION.                                                 DTSCU029
00044                                                                      CL**5
00045  01  DFHCOMMAREA.                                                 DTSCU029
00046  ++INCLUDE DTSIL029                                                  CL**5
00047      EJECT                                                           CL**5
00048  PROCEDURE DIVISION.                                              DTSCU029
00049                                                                      CL**5
00050                                                                      CL**5
00051      IF (L029-S-YR = SPACES OR LOW-VALUES)                           CL**5
00052              AND                                                  DTSCU029
00053         (L029-S-Q = SPACES OR LOW-VALUES)                            CL**5
00054          SET L029-NO-ENTRY TO TRUE                                   CL**5
00055          MOVE ZERO TO L029-YRQ                                       CL**5
00056          GO TO INIT0199-GO-BACK.                                     CL**5
00057                                                                      CL**5
00058                                                                      CL**5
00059      IF (L029-S-YR = 'PU')                                           CL**6
00060              AND                                                     CL**6
00061         (L029-S-Q = SPACES OR LOW-VALUES)                            CL**6
00062          SET L029-VALID TO TRUE                                      CL**6
00063          MOVE WRK-PICKUP-YRQ TO L029-YRQ                             CL**6
00064          GO TO INIT0199-GO-BACK.                                     CL**6
00065                                                                      CL**6
00066                                                                      CL**6
00067      MOVE L029-S-YR TO L004-QTR-3-YR-X.                              CL**8
00068                                                                      CL**7
00069      MOVE L029-S-Q TO L004-QTR-3-Q-X.                                CL**8
00070                                                                      CL**7
00071      PERFORM S004-FROM-3 THRU S004-EXIT.                             CL**6
00072                                                                      CL**7
00073      IF L004-VALID-QTR                                            DTSCU029
00074          IF L004-QTR-5-9 > WRK-PICKUP-YRQ                            CL**7
00075              MOVE L004-QTR-5-9 TO L029-YRQ                           CL**7
00076              SET L029-VALID TO TRUE                                  CL**7
00077          ELSE                                                        CL**7
00078              MOVE +0 TO L029-YRQ                                     CL**7
00079              SET L029-NOT-VALID TO TRUE                              CL**7
00080      ELSE                                                         DTSCU029
00081          MOVE +0 TO L029-YRQ                                         CL**5
00082          SET L029-NOT-VALID TO TRUE.                                 CL**5
00083                                                                      CL**7
00084                                                                      CL**7
00085  INIT0199-GO-BACK.                                                DTSCU029
00086      EXEC CICS                                                    DTSCU029
00087          RETURN                                                   DTSCU029
00088      END-EXEC.                                                    DTSCU029
00089                                                                      CL**7
00090      GOBACK.                                                      DTSCU029
00091      EJECT                                                           CL**7
00092  S004-FROM-3.                                                        CL**7
00093      SET L004-FROM-3 TO TRUE.                                        CL**7
00094      GO TO S004-QTR.                                                 CL**7
00095                                                                      CL**7
00096  S004-QTR.                                                           CL**7
00097      EXEC CICS                                                    DTSCU029
00098          LINK PROGRAM ('DTSCU004')                                   CL**2
00099          COMMAREA (DTSIL004-COMM-AREA)                               CL**2
00100      END-EXEC.                                                    DTSCU029
00101  S004-EXIT.                                                          CL**7
00102      EXIT.                                                        DTSCU029
