00001  IDENTIFICATION DIVISION.                                         11/19/98
00002  PROGRAM-ID.             DTSBER51.                                DTSBER51
00003  AUTHOR.                 MT DEPT OF LABOR/UI PROGRAMMING SECTION.    LV003
00004  DATE-WRITTEN.           MAY 1996.                                DTSBER51
00005  DATE-COMPILED.                                                   DTSBER51
00006      SKIP3                                                        DTSBER51
00007 *****                                                             DTSBER51
00008 *                                                                 DTSBER51
00009 *    FUNCTION:  CONTROL RECORD BUILD FOR RQC COLLECTIONS          DTSBER51
00010 *               (CS051) SAMPLING.                                 DTSBER51
00011 *                                                                 DTSBER51
00012 *                                                                 DTSBER51
00013 *    MODIFICATION HISTORY:                                        DTSBER51
00014 *                                                                 DTSBER51
00015 * 05-03-96 INITIAL DEVELOPMENT                                    DTSBER51
00016 *          REFERENCE RFP #RAP             AUTHOR OF CHANGE - SFW  DTSBER51
00017 *                                                                 DTSBER51
00018 * 11-17-98 MODIFIED TO MEET DUTAS PROGRAMMING SPECIFICATIONS.        CL**2
00019 *          REFERENCE RFP #****            AUTHOR OF CHANGE - DVS     CL**2
00020 *                                                                 DTSBER51
00021 * MM-DD-YY XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX     CL**2
00022 *          XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX     CL**2
00023 *          REFERENCE RFP #****            AUTHOR OF CHANGE - XXX     CL**2
00024 *                                                                    CL**2
00025 *                                                                 DTSBER51
00026 *    DESCRIPTION:                                                 DTSBER51
00027 *                                                                 DTSBER51
00028 *        THIS MODULE READS AN INPUT PARM AND COUNTS THE NUMBER    DTSBER51
00029 *        OF RECORDS IN THE RQC UNIVERSE IN ORDER TO PRODUCE A     DTSBER51
00030 *        CONTROL RECORD.                                          DTSBER51
00031 *                                                                 DTSBER51
00032 *                                                                 DTSBER51
00033 *    RECORDS READ:                                                DTSBER51
00034 *                                                                 DTSBER51
00035 *        RQC CS051 UNIVERSE FILE.                                 DTSBER51
00036 *        PARM FILE.                                               DTSBER51
00037 *                                                                 DTSBER51
00038 *                                                                 DTSBER51
00039 *    PRINTED OUTPUTS:                                             DTSBER51
00040 *                                                                 DTSBER51
00041 *        NONE.                                                    DTSBER51
00042 *                                                                 DTSBER51
00043 *                                                                 DTSBER51
00044 *    RECORDS WRITTEN:                                             DTSBER51
00045 *                                                                 DTSBER51
00046 *        RQC CS051 CONTROL RECORD.                                DTSBER51
00047 *                                                                 DTSBER51
00048 *                                                                 DTSBER51
00049 *    MODULES CALLED:                                              DTSBER51
00050 *                                                                 DTSBER51
00051 *        NONE.                                                    DTSBER51
00052 *                                                                 DTSBER51
00053 *                                                                 DTSBER51
00054 *****                                                             DTSBER51
00055      EJECT                                                        DTSBER51
00056  ENVIRONMENT DIVISION.                                            DTSBER51
00057      SKIP2                                                        DTSBER51
00058  INPUT-OUTPUT SECTION.                                            DTSBER51
00059      SKIP1                                                        DTSBER51
00060  FILE-CONTROL.                                                    DTSBER51
00061      SELECT PARM-FILE     ASSIGN TO PARMIN.                       DTSBER51
00062      SELECT UNIVERSE-FILE ASSIGN TO FILEIN.                       DTSBER51
00063      SELECT CONTROL-FILE  ASSIGN TO CNTRFILE.                     DTSBER51
00064      SKIP3                                                        DTSBER51
00065  DATA DIVISION.                                                   DTSBER51
00066      SKIP3                                                        DTSBER51
00067  FILE SECTION.                                                    DTSBER51
00068      SKIP2                                                        DTSBER51
00069  FD  PARM-FILE                                                    DTSBER51
00070      RECORDING MODE IS F                                          DTSBER51
00071      BLOCK CONTAINS 0 RECORDS.                                    DTSBER51
00072  01  PARM-REC.                                                    DTSBER51
00073      05  PARM-RANDOM-NUMBER          PIC  9(03).                  DTSBER51
00074      05  FILLER                      PIC  X(01).                  DTSBER51
00075      05  PARM-NUMBER-SAMPLED         PIC  9(04).                  DTSBER51
00076      05  FILLER                      PIC  X(01).                  DTSBER51
00077      05  PARM-SAMPLE-TYPE            PIC  X(02).                  DTSBER51
00078      05  FILLER                      PIC  X(01).                  DTSBER51
00079      05  PARM-YYYYMMDD               PIC  9(08).                  DTSBER51
00080      05  FILLER REDEFINES PARM-YYYYMMDD.                          DTSBER51
00081          10  PARM-YYYY               PIC  9(04).                  DTSBER51
00082          10  PARM-MM                 PIC  9(02).                  DTSBER51
00083          10  PARM-DD                 PIC  9(02).                  DTSBER51
00084      05  FILLER                      PIC  X(60).                  DTSBER51
00085      SKIP2                                                        DTSBER51
00086  FD  UNIVERSE-FILE                                                DTSBER51
00087      RECORDING MODE IS F                                          DTSBER51
00088      BLOCK CONTAINS 0 RECORDS.                                    DTSBER51
00089  01  UNIVERSE-REC                    PIC  X(71).                  DTSBER51
00090      SKIP2                                                        DTSBER51
00091  FD  CONTROL-FILE                                                 DTSBER51
00092      RECORDING MODE IS F                                          DTSBER51
00093      BLOCK CONTAINS 0 RECORDS.                                    DTSBER51
00094  01  CONTROL-REC                     PIC  X(33).                  DTSBER51
00095      EJECT                                                        DTSBER51
00096  WORKING-STORAGE SECTION.                                         DTSBER51
000965 77  PAN-VALET PICTURE X(24) VALUE '003DTSBER51  11/19/98'.       DTSBER51
00097      SKIP3                                                        DTSBER51
00098  01  WRK-AREA.                                                    DTSBER51
00099      05  WRK-ABEND-CD                PIC S9(04)  COMP  VALUE +51. DTSBER51
00100      05  FILE-DONE-IND               PIC  X(01)  VALUE 'N'.       DTSBER51
00101          88  FILE-DONE                           VALUE 'Y'.       DTSBER51
00102      SKIP1                                                        DTSBER51
00103  01  WS-CONTROL-REC.                                              DTSBER51
00104      05  CNTR-RECORD-TYPE            PIC  X(05)  VALUE 'CS051'.   DTSBER51
00105      05  CNTR-TRANS-TYPE             PIC  X(01)  VALUE '1'.       DTSBER51
00106      05  CNTR-SESA-ID                PIC  X(02)  VALUE 'DC'.         CL**3
00107      05  CNTR-RANDOM-NUMBER          PIC  9(03).                  DTSBER51
00108      05  CNTR-NUMBER-SAMPLED         PIC  9(04).                  DTSBER51
00109      05  CNTR-RECORD-COUNT           PIC  9(08)  VALUE 0.         DTSBER51
00110      05  CNTR-SAMPLE-TYPE            PIC  X(02).                  DTSBER51
00111      05  CNTR-YYYYMMDD               PIC  9(08).                  DTSBER51
00112      EJECT                                                        DTSBER51
00113  PROCEDURE DIVISION.                                              DTSBER51
00114      SKIP2                                                        DTSBER51
00115      PERFORM I1000-INITIATE THRU I1000-EXIT.                      DTSBER51
00116      PERFORM P1000-SPIN-THRU-UNIVERSE THRU P1000-EXIT             DTSBER51
00117         UNTIL FILE-DONE.                                          DTSBER51
00118      PERFORM T1000-TERMINATE THRU T1000-EXIT.                     DTSBER51
00119      SKIP2                                                        DTSBER51
00120      GOBACK.                                                      DTSBER51
00121      EJECT                                                        DTSBER51
00122  I1000-INITIATE.                                                  DTSBER51
00123      SKIP1                                                        DTSBER51
00124      OPEN INPUT  PARM-FILE UNIVERSE-FILE                          DTSBER51
00125           OUTPUT CONTROL-FILE.                                    DTSBER51
00126      READ PARM-FILE                                               DTSBER51
00127         AT END                                                    DTSBER51
00128             DISPLAY ' DTSBER51 - MISSING PARM REC '                  CL**2
00129             PERFORM S999-ABEND THRU S999-EXIT.                    DTSBER51
00130      SKIP1                                                        DTSBER51
00131      IF PARM-RANDOM-NUMBER NUMERIC                                DTSBER51
00132          MOVE PARM-RANDOM-NUMBER TO CNTR-RANDOM-NUMBER            DTSBER51
00133      ELSE                                                         DTSBER51
00134          DISPLAY ' DTSBER51 - INVALID RANDOM NUMBER '                CL**2
00135          PERFORM S999-ABEND THRU S999-EXIT.                       DTSBER51
00136      IF (PARM-NUMBER-SAMPLED NUMERIC)                             DTSBER51
00137                   AND                                             DTSBER51
00138         (PARM-NUMBER-SAMPLED > +0)                                DTSBER51
00139          MOVE PARM-NUMBER-SAMPLED TO CNTR-NUMBER-SAMPLED          DTSBER51
00140      ELSE                                                         DTSBER51
00141          DISPLAY ' DTSBER51 - INVALID NUMBER SAMPLED '               CL**2
00142          PERFORM S999-ABEND THRU S999-EXIT.                       DTSBER51
00143      IF PARM-SAMPLE-TYPE = 'A1' OR 'A2' OR 'E1' OR 'O1' OR 'O2'   DTSBER51
00144          MOVE PARM-SAMPLE-TYPE TO CNTR-SAMPLE-TYPE                DTSBER51
00145      ELSE                                                         DTSBER51
00146          DISPLAY ' DTSBER51 - INVALID SAMPLE TYPE '                  CL**2
00147          PERFORM S999-ABEND THRU S999-EXIT.                       DTSBER51
00148      IF (PARM-YYYYMMDD NUMERIC)                                   DTSBER51
00149                 AND                                               DTSBER51
00150         (PARM-YYYY > 1990) AND (PARM-YYYY < 2030)                 DTSBER51
00151                 AND                                               DTSBER51
00152         (PARM-MM > 00) AND (PARM-MM < 13)                         DTSBER51
00153                 AND                                               DTSBER51
00154         (PARM-DD > 00) AND (PARM-DD < 32)                         DTSBER51
00155          MOVE PARM-YYYYMMDD TO CNTR-YYYYMMDD                      DTSBER51
00156      ELSE                                                         DTSBER51
00157          DISPLAY ' DTSBER51 - INVALID YYYYMMDD '                     CL**2
00158          PERFORM S999-ABEND THRU S999-EXIT.                       DTSBER51
00159      DISPLAY '                                   '                DTSBER51
00160         '         1         2         3         4         5'      DTSBER51
00161         '         6         7         8'.                         DTSBER51
00162      DISPLAY '                                   '                DTSBER51
00163         '12345678901234567890123456789012345678901234567890'      DTSBER51
00164         '123456789012345678901234567890'.                         DTSBER51
00165      DISPLAY ' '.                                                 DTSBER51
00166      DISPLAY ' DTSBER51 -     PARM RECORD INPUT: ' PARM-REC.         CL**2
00167      SKIP2                                                        DTSBER51
00168  I1000-EXIT.                                                      DTSBER51
00169      EXIT.                                                        DTSBER51
00170      EJECT                                                        DTSBER51
00171  P1000-SPIN-THRU-UNIVERSE.                                        DTSBER51
00172      SKIP1                                                        DTSBER51
00173      READ UNIVERSE-FILE                                           DTSBER51
00174         AT END                                                    DTSBER51
00175             SET FILE-DONE TO TRUE                                 DTSBER51
00176             GO TO P1000-EXIT.                                     DTSBER51
00177      ADD +1 TO CNTR-RECORD-COUNT.                                 DTSBER51
00178      SKIP2                                                        DTSBER51
00179  P1000-EXIT.                                                      DTSBER51
00180      EXIT.                                                        DTSBER51
00181      EJECT                                                        DTSBER51
00182  T1000-TERMINATE.                                                 DTSBER51
00183      SKIP1                                                        DTSBER51
00184      DISPLAY ' '.                                                 DTSBER51
00185      DISPLAY ' DTSBER51 - CONTROL RECORD OUTPUT: '                   CL**2
00186         WS-CONTROL-REC.                                           DTSBER51
00187      WRITE CONTROL-REC FROM WS-CONTROL-REC.                       DTSBER51
00188      CLOSE PARM-FILE UNIVERSE-FILE                                DTSBER51
00189            CONTROL-FILE.                                          DTSBER51
00190      SKIP2                                                        DTSBER51
00191  T1000-EXIT.                                                      DTSBER51
00192      EXIT.                                                        DTSBER51
00193      EJECT                                                        DTSBER51
00194  S999-ABEND.                                                      DTSBER51
00195      SKIP1                                                        DTSBER51
00196      CALL 'DTSBU999' USING WRK-ABEND-CD.                             CL**2
00197      SKIP2                                                        DTSBER51
00198  S999-EXIT.                                                       DTSBER51
00199      EXIT.                                                        DTSBER51
