283 lines
22 KiB
COBOL
283 lines
22 KiB
COBOL
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
|