00001  IDENTIFICATION DIVISION.                                         11/09/99
00002  PROGRAM-ID.             DTSBR125.                                DTSBR125
00003  AUTHOR.                 TRW S&ITG (FORMERLY BDM).                   LV074
00004  DATE-WRITTEN.           OCTOBER 1998.                               CL*13
00005  DATE-COMPILED.                                                      CL**4
00006                                                                      CL**5
00007 *****                                                                CL**4
00008 *                                                                    CL**4
00009 *    CALLING SEQUENCE:  DTSBD400 CALLS                               CL*23
00010 *                       DTSBE125 WHICH UPDATES DTSIR125              CL*23
00011 *                       DTSBR125 READS DTSIR125 RECORDS.             CL*23
00012 *                                                                    CL*23
00013 *    MODIFICATION HISTORY:                                           CL**4
00014 *                                                                    CL**4
00015 * MM-DD-YY MODIFIED TO TO MOVE STANDARDIZE HEADING TO REPORT.        CL*70
00016 *          REFERENCE RFP #****                   PROGRAMMER: DVS     CL*70
00017 *                                                                    CL**4
00018 *                                                                    CL**4
00019 *    DESCRIPTION:                                                    CL**4
00020 *                                                                    CL**4
00021 *        THIS MODULE PRINTS THE EMPLOYER ALPHA LIST.                 CL**8
00022 *                                                                    CL**4
00023 *    RECORDS READ:                                                   CL**4
00024 *                                                                    CL**4
00025 *        IR125.                                                      CL**8
00026 *                                                                    CL**4
00027 *                                                                    CL**4
00028 *    PRINTED OUTPUTS:                                                CL**4
00029 *                                                                    CL**4
00030 *        RPT125 EMPLOYER ALPHA LIST.                                 CL**8
00031 *                                                                    CL**4
00032 *                                                                    CL**4
00033 *    RECORDS WRITTEN:                                                CL**4
00034 *                                                                    CL**4
00035 *        NONE.                                                       CL**4
00036 *                                                                    CL**4
00037 *                                                                    CL**4
00038 *    MODULES CALLED:                                                 CL**4
00039 *                                                                    CL**8
00040 *****                                                                CL**4
00041      EJECT                                                           CL**4
00042  ENVIRONMENT DIVISION.                                               CL**4
00043  CONFIGURATION SECTION.                                              CL*20
00044  SPECIAL-NAMES.                                                      CL**9
00045      C01 IS TOP-OF-PAGE.                                             CL**9
00046  INPUT-OUTPUT SECTION.                                               CL**4
00047  FILE-CONTROL.                                                       CL**4
00048      SELECT PRINT-FILE ASSIGN TO RPT125R1.                           CL*59
00049                                                                      CL*22
00050  DATA DIVISION.                                                      CL**4
00051  FILE SECTION.                                                       CL**4
00052                                                                      CL**4
00053  FD  PRINT-FILE                                                      CL*14
00054      RECORDING MODE IS F                                             CL**8
00055      LABEL RECORDS ARE OMITTED                                       CL**8
00056      RECORD CONTAINS 133 CHARACTERS                                  CL**8
00057      DATA RECORD IS PRINT-RCD.                                       CL**8
00058  01  PRINT-RCD               PIC X(133).                             CL**8
00059      EJECT                                                           CL**4
00060                                                                      CL**8
00061  WORKING-STORAGE SECTION.                                            CL**4
000615 77  PAN-VALET PICTURE X(24) VALUE '074DTSBR125  11/09/99'.          CL**4
00062                                                                      CL**5
00063  01  WRK-AREA.                                                       CL**4
00064      05  WRK-ABEND-CD            PIC S9(04)  COMP  VALUE +125.       CL*47
00065      05  FIRST-TIME-IND          PIC  X(01)  VALUE 'Y'.              CL*47
00066      05  WRK-INVALID-DATE        PIC S9(9) COMP-3 VALUE              CL*55
00067                                                  +999999999.         CL*55
00068  01  R125-OUT-REC.                                                   CL*20
00069      05  FILLER                      PIC X(07) VALUE SPACES.         CL*59
00070      05  R125-OUT-EMP-NO             PIC 999B999.                    CL*73
00071      05  FILLER                      PIC X(04) VALUE SPACES.         CL*33
00072      05  R125-OUT-PRIMARY-NAME       PIC X(40).                      CL*13
00073      05  FILLER                      PIC X(05) VALUE SPACES.         CL*60
00074      05  R125-OUT-EMPLOYER-CLASS     PIC X(13).                      CL*59
00075      05  FILLER                      PIC X(11) VALUE SPACES.         CL*62
00076      05  R125-OUT-LIAB-DATE          PIC X(10).                      CL*28
00077      05  FILLER                      PIC X(04) VALUE SPACES.         CL*37
00078      05  R125-OUT-INACT-DATE         PIC X(10).                      CL*28
00079      05  FILLER                      PIC X(08) VALUE SPACES.         CL*37
00080      05  R125-OUT-FIELD-REP-CD       PIC X(02).                      CL*13
00081  01  WRK-COUNTERS.                                                   CL*13
00082      05  PAGE-COUNT             PIC 9(05).                           CL**9
00083      05  EMPLOYER-COUNT         PIC 9(05).                           CL**9
00084      05  RECORD-COUNT           PIC 9(02) VALUE 46.                  CL*68
00085  01  WRK-DATE-01                PIC  9(09) VALUE ZEROES.             CL*38
00086  01  WRK-DATE-01-REDEFINE REDEFINES WRK-DATE-01.                     CL*34
00087      05  FILLER                 PIC 9.                               CL*36
00088      05  WRK-DATE-YEAR          PIC 9(04).                           CL*35
00089      05  WRK-DATE-MONTH         PIC 9(02).                           CL*29
00090      05  WRK-DATE-DAY           PIC 9(02).                           CL*29
00091  01  WRK-CONV-DATE.                                                  CL*30
00092      05  WRK-DATE-MM            PIC X(02).                           CL*34
00093      05  FILLER                 PIC X VALUE '/'.                     CL*31
00094      05  WRK-DATE-DD            PIC X(02).                           CL*34
00095      05  FILLER                 PIC X VALUE '/'.                     CL*31
00096      05  WRK-DATE-YY            PIC X(04).                           CL*34
00097  01  WRK-HEADER-1-TEXT.                                              CL**8
00098      05  FILLER                  PIC  X VALUE SPACE.                 CL*39
00099      05  FILLER                  PIC  X(05) VALUE                    CL*39
00100          '125R1'.                                                    CL**8
00101      05  FILLER                  PIC  X(36) VALUE SPACES.            CL*71
00102      05  WRK-AGY-NAME-LINE1      PIC  X(50) VALUE SPACES.            CL*69
00103      05  FILLER                  PIC  X(26) VALUE SPACES.            CL*71
00104      05  FILLER                  PIC  X(06) VALUE                    CL**8
00105          'DATE: '.                                                   CL**8
00106      05  HEADER-1-DATE           PIC  X(08).                         CL**8
00107  01  WRK-HEADER-2-TEXT.                                              CL**9
00108      05  FILLER                  PIC  X VALUE SPACE.                 CL*41
00109      05  FILLER                  PIC  X(41) VALUE SPACES.            CL*71
00110      05  WRK-AGY-NAME-LINE2      PIC  X(50) VALUE SPACES.            CL*69
00111      05  FILLER                  PIC  X(26) VALUE SPACES.            CL*72
00112      05  FILLER                  PIC  X(06) VALUE                    CL**9
00113          'TIME: '.                                                   CL**9
00114      05  HEADER-2-TIME           PIC  X(08).                         CL**9
00115  01  WRK-HEADER-3-TEXT.                                              CL**9
00116      05  FILLER                  PIC  X(01) VALUE SPACES.            CL*39
00117      05  FILLER                  PIC  X(33) VALUE                    CL*39
00118          'ROUTE TO: REGISTRATION AND RATES'.                         CL*15
00119      05  FILLER                  PIC  X(84) VALUE SPACES.            CL*43
00120      05  FILLER                  PIC  X(08) VALUE                    CL*42
00121          'PAGE:   '.                                                 CL*35
00122      05  HEADER-3-PAGE           PIC  ZZ,ZZ9.                        CL*15
00123  01  WRK-REPORT-TITLE.                                               CL*10
00124      05  FILLER                  PIC  X(57) VALUE SPACES.            CL*73
00125      05  FILLER                  PIC  X(21) VALUE                    CL*10
00126          'EMPLOYER ACCOUNT LIST'.                                    CL*34
00127  01  WRK-COLUMN-HEAD-1.                                              CL*10
00128      05  FILLER                  PIC  X(66)  VALUE SPACES.           CL*35
00129      05  FILLER                  PIC  X(08)  VALUE 'EMPLOYER'.       CL*10
00130      05  FILLER                  PIC  X(13)  VALUE SPACES.           CL*35
00131      05  FILLER                  PIC  X(09)  VALUE 'LIABILITY'.      CL*10
00132      05  FILLER                  PIC  X(06)  VALUE SPACES.           CL*10
00133      05  FILLER                  PIC  X(08)  VALUE 'INACTIVE'.       CL*10
00134      05  FILLER                  PIC  X(06)  VALUE SPACES.           CL*10
00135      05  FILLER                  PIC  X(09)  VALUE 'FIELD REP'.      CL*10
00136  01  WRK-COLUMN-HEAD-2.                                              CL*11
00137      05  FILLER                  PIC  X(07)  VALUE SPACES.           CL*59
00138      05  FILLER                  PIC  X(07)  VALUE 'EMP NO '.        CL*57
00139      05  FILLER                  PIC  X(04)  VALUE SPACES.           CL*30
00140      05  FILLER                  PIC  X(12)  VALUE 'PRIMARY NAME'.   CL*11
00141      05  FILLER                  PIC  X(37)  VALUE SPACES.           CL*15
00142      05  FILLER                  PIC  X(05)  VALUE 'CLASS'.          CL*15
00143      05  FILLER                  PIC  X(17)  VALUE SPACES.           CL*35
00144      05  FILLER                  PIC  X(04)  VALUE 'DATE'.           CL*15
00145      05  FILLER                  PIC  X(10)  VALUE SPACES.           CL*30
00146      05  FILLER                  PIC  X(11)  VALUE 'DATE'.           CL*15
00147      05  FILLER                  PIC  X(03)  VALUE SPACES.           CL*35
00148      05  FILLER                  PIC  X(04)  VALUE 'CODE'.           CL*15
00149  01  WRK-FOOTER.                                                     CL*15
00150      05  FILLER                  PIC  X(46)  VALUE SPACES.           CL*15
00151      05  R125-OUT-EMPLOYER-COUNT PIC  ZZ,ZZ9.                        CL*15
00152      05  FILLER                  PIC  X(24)  VALUE                   CL*15
00153      ' EMPLOYERS ON LIST'.                                           CL*14
00154      EJECT                                                           CL*14
00155                                                                      CL**8
00156  01  L001-LINK-AREA.                                                 CL**8
00157  ++INCLUDE DTSIL001                                                  CL**8
00158                                                                      CL**5
00159  LINKAGE SECTION.                                                    CL**4
00160                                                                      CL**5
00161  01  LRCM-LINK-AREA.                                                 CL**4
00162  ++INCLUDE DTSILRCM                                                  CL**5
00163      EJECT                                                           CL**4
00164  01  R125-REC.                                                       CL**8
00165  ++INCLUDE DTSIR125                                                  CL**8
00166      EJECT                                                           CL**4
00167                                                                      CL**8
00168  PROCEDURE DIVISION USING LRCM-LINK-AREA                             CL**4
00169                           R125-REC.                                  CL**8
00170                                                                      CL**5
00171      IF FIRST-TIME-IND = 'Y'                                         CL**4
00172          PERFORM I1000-INITIATE                                      CL**5
00173             THRU I1000-EXIT                                          CL**5
00174          MOVE 'N' TO FIRST-TIME-IND.                                 CL**4
00175                                                                      CL**4
00176      IF LRCM-EOR-88                                                  CL**4
00177          PERFORM T1000-TERMINATE                                     CL**5
00178             THRU T1000-EXIT                                          CL**5
00179      ELSE                                                            CL**4
00180          PERFORM P1000-PROCESS                                       CL**5
00181             THRU P1000-EXIT.                                         CL**5
00182                                                                      CL**5
00183      GOBACK.                                                         CL**4
00184      EJECT                                                           CL**4
00185  I1000-INITIATE.                                                     CL**4
00186      OPEN OUTPUT PRINT-FILE.                                         CL*13
00187      MOVE ZEROS TO WRK-COUNTERS.                                     CL*13
00188      MOVE LRCM-AGY-NAME-LINE1 TO WRK-AGY-NAME-LINE1.                 CL*69
00189      MOVE LRCM-AGY-NAME-LINE2 TO WRK-AGY-NAME-LINE2.                 CL*69
00190      MOVE LRCM-SYS-DATE TO HEADER-1-DATE.                            CL**8
00191      MOVE LRCM-SYS-TIME TO HEADER-2-TIME.                            CL**8
00192      PERFORM I1100-WRITE-HEADERS THRU I1100-WRITE-EXIT.              CL*24
00193  I1000-EXIT.                                                         CL**4
00194      EXIT.                                                           CL**4
00195      EJECT                                                           CL**4
00196  I1100-WRITE-HEADERS.                                                CL*24
00197      INITIALIZE PRINT-RCD.                                           CL*13
00198      ADD 1 TO PAGE-COUNT.                                            CL*13
00199      MOVE ZERO TO RECORD-COUNT.                                      CL*22
00200      MOVE PAGE-COUNT TO HEADER-3-PAGE.                               CL*15
00201      WRITE PRINT-RCD FROM WRK-HEADER-1-TEXT                          CL*13
00202            AFTER ADVANCING TOP-OF-PAGE.                              CL*13
00203      WRITE PRINT-RCD FROM WRK-HEADER-2-TEXT                          CL*13
00204            AFTER ADVANCING 1 LINE.                                   CL*13
00205      WRITE PRINT-RCD FROM WRK-HEADER-3-TEXT                          CL*13
00206            AFTER ADVANCING 1 LINE.                                   CL*13
00207      WRITE PRINT-RCD FROM WRK-REPORT-TITLE                           CL*13
00208            AFTER ADVANCING 2 LINES.                                  CL*13
00209      WRITE PRINT-RCD FROM WRK-COLUMN-HEAD-1                          CL*13
00210            AFTER ADVANCING 3 LINES.                                  CL*13
00211      WRITE PRINT-RCD FROM WRK-COLUMN-HEAD-2                          CL*13
00212            AFTER ADVANCING 1 LINE.                                   CL*13
00213      INITIALIZE PRINT-RCD.                                           CL*58
00214      WRITE PRINT-RCD                                                 CL*58
00215            AFTER ADVANCING 1 LINE.                                   CL*58
00216      ADD 8 TO RECORD-COUNT.                                          CL*58
00217  I1100-WRITE-EXIT.                                                   CL*24
00218      EXIT.                                                           CL*13
00219                                                                      CL*13
00220  P1000-PROCESS.                                                      CL**4
00221      IF RECORD-COUNT > 56                                            CL*74
00222          PERFORM I1100-WRITE-HEADERS THRU I1100-WRITE-EXIT.          CL*24
00223      MOVE R125-EMP-NO         TO R125-OUT-EMP-NO.                    CL*14
00224      MOVE R125-PRIMARY-NAME   TO R125-OUT-PRIMARY-NAME.              CL*14
00225 *BO  MOVE R125-EMPLOYER-CLASS TO R125-OUT-EMPLOYER-CLASS.            CL*59
00226      IF R125-EMPLOYER-CLASS = 'R'                                    CL*59
00227         MOVE '    RATED    ' TO R125-OUT-EMPLOYER-CLASS              CL*59
00228      ELSE IF R125-EMPLOYER-CLASS = 'S'                               CL*59
00229         MOVE ' SELF INSURED' TO R125-OUT-EMPLOYER-CLASS              CL*61
00230      ELSE IF R125-EMPLOYER-CLASS = 'U'                               CL*59
00231         MOVE '   UNKNOWN   ' TO R125-OUT-EMPLOYER-CLASS.             CL*59
00232      MOVE R125-LIAB-DATE      TO WRK-DATE-01.                        CL*45
00233      PERFORM P1100-DATE-RTN   THRU P1100-DATE-RTN-EXIT.              CL*45
00234      MOVE WRK-CONV-DATE       TO R125-OUT-LIAB-DATE.                 CL*45
00235      IF R125-INACT-DATE EQUAL WRK-INVALID-DATE                       CL*56
00236           MOVE SPACES         TO R125-OUT-INACT-DATE                 CL*45
00237      ELSE                                                            CL*45
00238           MOVE R125-INACT-DATE      TO WRK-DATE-01                   CL*45
00239           PERFORM P1100-DATE-RTN   THRU P1100-DATE-RTN-EXIT          CL*45
00240           MOVE WRK-CONV-DATE       TO R125-OUT-INACT-DATE            CL*49
00241      END-IF.                                                         CL*45
00242      MOVE R125-FIELD-REP-CD   TO R125-OUT-FIELD-REP-CD.              CL*44
00243                                                                      CL*44
00244      PERFORM P1200-WRITE-RECORDS THRU P1200-WRITE-EXIT.              CL*20
00245                                                                      CL*44
00246      ADD 1 TO RECORD-COUNT EMPLOYER-COUNT.                           CL*30
00247  P1000-EXIT.                                                         CL**4
00248      EXIT.                                                           CL**4
00249      EJECT                                                           CL**4
00250                                                                      CL**5
00251  P1100-DATE-RTN.                                                     CL*32
00252      MOVE WRK-DATE-YEAR       TO WRK-DATE-YY.                        CL*31
00253      MOVE WRK-DATE-MONTH      TO WRK-DATE-MM.                        CL*31
00254      MOVE WRK-DATE-DAY        TO WRK-DATE-DD.                        CL*31
00255  P1100-DATE-RTN-EXIT.                                                CL*32
00256      EXIT.                                                           CL*14
00257  P1200-WRITE-RECORDS.                                                CL*31
00258      WRITE PRINT-RCD FROM R125-OUT-REC                               CL*31
00259          AFTER ADVANCING 1 LINE.                                     CL*31
00260      INITIALIZE PRINT-RCD.                                           CL*31
00261                                                                      CL*31
00262  P1200-WRITE-EXIT.                                                   CL*31
00263      EXIT.                                                           CL*31
00264      EJECT                                                           CL*14
00265                                                                      CL**5
00266  T1000-TERMINATE.                                                    CL**4
00267      MOVE EMPLOYER-COUNT TO R125-OUT-EMPLOYER-COUNT.                 CL*15
00268      MOVE WRK-FOOTER     TO PRINT-RCD.                               CL*15
00269      WRITE PRINT-RCD AFTER 3.                                        CL*40
00270      CLOSE PRINT-FILE.                                               CL*20
00271                                                                      CL*20
00272  T1000-EXIT.                                                         CL**4
00273      EXIT.                                                           CL**4
00274      EJECT                                                           CL**4
00275                                                                      CL**5
00276  S999-ABEND.                                                         CL**4
00277                                                                      CL**4
00278      CALL 'DTSBU999' USING WRK-ABEND-CD.                             CL**5
00279                                                                      CL**4
00280  S999-EXIT.                                                          CL**4
00281      EXIT.                                                           CL**4
