| 1 | ****************************************************************** |
| 2 | * Copyright Amazon.com, Inc. or its affiliates. |
| 3 | * All Rights Reserved. |
| 4 | * |
| 5 | * Licensed under the Apache License, Version 2.0 (the "License"). |
| 6 | * You may not use this file except in compliance with the License. |
| 7 | * You may obtain a copy of the License at |
| 8 | * |
| 9 | * http://www.apache.org/licenses/LICENSE-2.0 |
| 10 | * |
| 11 | * Unless required by applicable law or agreed to in writing, |
| 12 | * software distributed under the License is distributed on an |
| 13 | * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, |
| 14 | * either express or implied. See the License for the specific |
| 15 | * language governing permissions and limitations under the License |
| 16 | ****************************************************************** |
| 17 | IDENTIFICATION DIVISION. 00010026 |
| 18 | PROGRAM-ID. PAUDBUNL. 00020037 |
| 19 | AUTHOR. AWS. 00030026 |
| 20 | 00040026 |
| 21 | ENVIRONMENT DIVISION. 00050026 |
| 22 | CONFIGURATION SECTION. 00060026 |
| 23 | 00070026 |
| 24 | INPUT-OUTPUT SECTION. 00080026 |
| 25 | FILE-CONTROL. 00090026 |
| 26 | SELECT OPFILE1 ASSIGN TO OUTFIL1 00100035 |
| 27 | ORGANIZATION IS SEQUENTIAL 00110026 |
| 28 | ACCESS MODE IS SEQUENTIAL 00120026 |
| 29 | FILE STATUS IS WS-OUTFL1-STATUS. 00130026 |
| 30 | 00140026 |
| 31 | * 00150026 |
| 32 | SELECT OPFILE2 ASSIGN TO OUTFIL2 00151035 |
| 33 | ORGANIZATION IS SEQUENTIAL 00152026 |
| 34 | ACCESS MODE IS SEQUENTIAL 00153026 |
| 35 | FILE STATUS IS WS-OUTFL2-STATUS. 00154026 |
| 36 | 00155026 |
| 37 | * 00156026 |
| 38 | *----------------------------------------------------------------*00160026 |
| 39 | DATA DIVISION. 00170026 |
| 40 | *----------------------------------------------------------------*00180026 |
| 41 | * 00190026 |
| 42 | FILE SECTION. 00200026 |
| 43 | FD OPFILE1. 00210026 |
| 44 | 01 OPFIL1-REC PIC X(100). 00220026 |
| 45 | FD OPFILE2. 00221026 |
| 46 | 01 OPFIL2-REC. 00222036 |
| 47 | 05 ROOT-SEG-KEY PIC S9(11) COMP-3. 00223036 |
| 48 | 05 CHILD-SEG-REC PIC X(200). 00224036 |
| 49 | * 00230026 |
| 50 | *----------------------------------------------------------------*00240026 |
| 51 | WORKING-STORAGE SECTION. 00250026 |
| 52 | *----------------------------------------------------------------*00260026 |
| 53 | 01 WS-VARIABLES. 00270026 |
| 54 | 05 WS-PGMNAME PIC X(08) VALUE 'IMSUNLOD'. 00280026 |
| 55 | 05 CURRENT-DATE PIC 9(06). 00290026 |
| 56 | 05 CURRENT-YYDDD PIC 9(05). 00300026 |
| 57 | 05 WS-AUTH-DATE PIC 9(05). 00310026 |
| 58 | 05 WS-EXPIRY-DAYS PIC S9(4) COMP. 00320026 |
| 59 | 05 WS-DAY-DIFF PIC S9(4) COMP. 00330026 |
| 60 | 05 IDX PIC S9(4) COMP. 00340026 |
| 61 | 05 WS-CURR-APP-ID PIC 9(11). 00350026 |
| 62 | * 00360026 |
| 63 | 05 WS-NO-CHKP PIC 9(8) VALUE 0. 00370026 |
| 64 | 05 WS-AUTH-SMRY-PROC-CNT PIC 9(8) VALUE 0. 00380026 |
| 65 | 05 WS-TOT-REC-WRITTEN PIC S9(8) COMP VALUE 0. 00390026 |
| 66 | 05 WS-NO-SUMRY-READ PIC S9(8) COMP VALUE 0. 00400026 |
| 67 | 05 WS-NO-SUMRY-DELETED PIC S9(8) COMP VALUE 0. 00410026 |
| 68 | 05 WS-NO-DTL-READ PIC S9(8) COMP VALUE 0. 00420026 |
| 69 | 05 WS-NO-DTL-DELETED PIC S9(8) COMP VALUE 0. 00430026 |
| 70 | * 00440026 |
| 71 | 05 WS-ERR-FLG PIC X(01) VALUE 'N'. 00450026 |
| 72 | 88 ERR-FLG-ON VALUE 'Y'. 00460026 |
| 73 | 88 ERR-FLG-OFF VALUE 'N'. 00470026 |
| 74 | 05 WS-END-OF-AUTHDB-FLAG PIC X(01) VALUE 'N'. 00480026 |
| 75 | 88 END-OF-AUTHDB VALUE 'Y'. 00490026 |
| 76 | 88 NOT-END-OF-AUTHDB VALUE 'N'. 00500026 |
| 77 | 05 WS-MORE-AUTHS-FLAG PIC X(01) VALUE 'N'. 00510026 |
| 78 | 88 MORE-AUTHS VALUE 'Y'. 00520026 |
| 79 | 88 NO-MORE-AUTHS VALUE 'N'. 00530026 |
| 80 | 05 WS-END-OF-ROOT-SEG PIC X(01) VALUE SPACES. 00540050 |
| 81 | 05 WS-END-OF-CHILD-SEG PIC X(01) VALUE SPACES. 00550050 |
| 82 | 05 WS-INFILE-STATUS PIC X(02) VALUE SPACES. 00570026 |
| 83 | 05 WS-OUTFL1-STATUS PIC X(02) VALUE SPACES. 00571026 |
| 84 | 05 WS-OUTFL2-STATUS PIC X(02) VALUE SPACES. 00572026 |
| 85 | 05 WS-CUSTID-STATUS PIC X(02) VALUE SPACES. 00580026 |
| 86 | 88 END-OF-FILE VALUE '10'. 00590026 |
| 87 | * 00600026 |
| 88 | 05 WK-CHKPT-ID. 00610026 |
| 89 | 10 FILLER PIC X(04) VALUE 'RMAD'. 00620026 |
| 90 | 10 WK-CHKPT-ID-CTR PIC 9(04) VALUE ZEROES. 00630026 |
| 91 | * 00640026 |
| 92 | 01 WS-IMS-VARIABLES. 00650026 |
| 93 | * 05 PSB-NAME PIC X(8) VALUE 'IMSUNLOD'. 00660042 |
| 94 | * 05 PCB-OFFSET. 00670042 |
| 95 | * 10 PAUT-PCB-NUM PIC S9(4) COMP VALUE +2. 00680042 |
| 96 | 05 IMS-RETURN-CODE PIC X(02). 00690026 |
| 97 | 88 STATUS-OK VALUE ' ', 'FW'. 00700026 |
| 98 | 88 SEGMENT-NOT-FOUND VALUE 'GE'. 00710026 |
| 99 | 88 DUPLICATE-SEGMENT-FOUND VALUE 'II'. 00720026 |
| 100 | 88 WRONG-PARENTAGE VALUE 'GP'. 00730026 |
| 101 | 88 END-OF-DB VALUE 'GB'. 00740026 |
| 102 | 88 DATABASE-UNAVAILABLE VALUE 'BA'. 00750026 |
| 103 | 88 PSB-SCHEDULED-MORE-THAN-ONCE VALUE 'TC'. 00760026 |
| 104 | 88 COULD-NOT-SCHEDULE-PSB VALUE 'TE'. 00770026 |
| 105 | 88 RETRY-CONDITION VALUE 'BA', 'FH', 'TE'. 00780026 |
| 106 | 05 WS-IMS-PSB-SCHD-FLG PIC X(1). 00790026 |
| 107 | 88 IMS-PSB-SCHD VALUE 'Y'. 00800026 |
| 108 | 88 IMS-PSB-NOT-SCHD VALUE 'N'. 00810026 |
| 109 | 00820026 |
| 110 | * 00830026 |
| 111 | 01 ROOT-UNQUAL-SSA. 00831029 |
| 112 | 05 FILLER PIC X(08) VALUE 'PAUTSUM0'. 00831129 |
| 113 | 05 FILLER PIC X(01) VALUE ' '. 00831229 |
| 114 | * 00831329 |
| 115 | 01 CHILD-UNQUAL-SSA. 00831429 |
| 116 | 05 FILLER PIC X(08) VALUE 'PAUTDTL1'. 00831529 |
| 117 | 05 FILLER PIC X(01) VALUE ' '. 00831629 |
| 118 | * 00833029 |
| 119 | 01 PRM-INFO. 00840026 |
| 120 | 05 P-EXPIRY-DAYS PIC 9(02). 00850026 |
| 121 | 05 FILLER PIC X(01). 00860026 |
| 122 | 05 P-CHKP-FREQ PIC X(05). 00870026 |
| 123 | 05 FILLER PIC X(01). 00880026 |
| 124 | 05 P-CHKP-DIS-FREQ PIC X(05). 00890026 |
| 125 | 05 FILLER PIC X(01). 00900026 |
| 126 | 05 P-DEBUG-FLAG PIC X(01). 00910026 |
| 127 | 88 DEBUG-ON VALUE 'Y'. 00920026 |
| 128 | 88 DEBUG-OFF VALUE 'N'. 00930026 |
| 129 | 05 FILLER PIC X(01). 00940026 |
| 130 | * 00950026 |
| 131 | * 00960026 |
| 132 | COPY IMSFUNCS. 00961032 |
| 133 | *----------------------------------------------------------------*00970026 |
| 134 | * IMS SEGMENT LAYOUT 00980026 |
| 135 | *----------------------------------------------------------------*00990026 |
| 136 | 01000026 |
| 137 | *- PENDING AUTHORIZATION SUMMARY SEGMENT - ROOT 01010026 |
| 138 | 01 PENDING-AUTH-SUMMARY. 01020026 |
| 139 | COPY CIPAUSMY. 01030026 |
| 140 | 01040026 |
| 141 | *- PENDING AUTHORIZATION DETAILS SEGMENT - CHILD 01050026 |
| 142 | 01 PENDING-AUTH-DETAILS. 01060026 |
| 143 | COPY CIPAUDTY. 01070026 |
| 144 | 01080026 |
| 145 | * 01090026 |
| 146 | *----------------------------------------------------------------*01100026 |
| 147 | LINKAGE SECTION. 01110026 |
| 148 | *----------------------------------------------------------------*01120026 |
| 149 | * PCB MASKS FOLLOW 01130026 |
| 150 | COPY PAUTBPCB. 01140027 |
| 151 | * 01160026 |
| 152 | *----------------------------------------------------------------*01170026 |
| 153 | PROCEDURE DIVISION USING PAUTBPCB. 01180028 |
| 154 | * PGM-PCB-MASK. 01190028 |
| 155 | *----------------------------------------------------------------*01200026 |
| 156 | * 01210026 |
| 157 | MAIN-PARA. 01220026 |
| 158 | ENTRY 'DLITCBL' USING PAUTBPCB. 01225033 |
| 159 | 01226029 |
| 160 | * 01230026 |
| 161 | PERFORM 1000-INITIALIZE THRU 1000-EXIT 01240026 |
| 162 | * 01250026 |
| 163 | PERFORM 2000-FIND-NEXT-AUTH-SUMMARY THRU 2000-EXIT 01260026 |
| 164 | UNTIL WS-END-OF-ROOT-SEG = 'Y' 01280050 |
| 165 | 01531150 |
| 166 | PERFORM 4000-FILE-CLOSE THRU 4000-EXIT 01532030 |
| 167 | * 01540026 |
| 168 | * 01560026 |
| 169 | * 01650026 |
| 170 | GOBACK. 01660026 |
| 171 | * 01670026 |
| 172 | *----------------------------------------------------------------*01680026 |
| 173 | 1000-INITIALIZE. 01690026 |
| 174 | *----------------------------------------------------------------*01700026 |
| 175 | * 01710026 |
| 176 | ACCEPT CURRENT-DATE FROM DATE 01720026 |
| 177 | ACCEPT CURRENT-YYDDD FROM DAY 01730026 |
| 178 | 01740026 |
| 179 | * ACCEPT PRM-INFO FROM SYSIN 01750038 |
| 180 | DISPLAY 'STARTING PROGRAM PAUDBUNL::' 01760054 |
| 181 | DISPLAY '*-------------------------------------*' 01770026 |
| 182 | DISPLAY 'TODAYS DATE :' CURRENT-DATE 01790043 |
| 183 | DISPLAY ' ' 01800026 |
| 184 | 01810026 |
| 185 | . 01960026 |
| 186 | OPEN OUTPUT OPFILE1 01961028 |
| 187 | IF WS-OUTFL1-STATUS = SPACES OR '00' 01962028 |
| 188 | CONTINUE 01963028 |
| 189 | ELSE 01964028 |
| 190 | DISPLAY 'ERROR IN OPENING OPFILE1:' WS-OUTFL1-STATUS 01965028 |
| 191 | PERFORM 9999-ABEND 01966028 |
| 192 | END-IF 01967028 |
| 193 | * 01968028 |
| 194 | OPEN OUTPUT OPFILE2 01969028 |
| 195 | IF WS-OUTFL2-STATUS = SPACES OR '00' 01969128 |
| 196 | CONTINUE 01969228 |
| 197 | ELSE 01969328 |
| 198 | DISPLAY 'ERROR IN OPENING OPFILE2:' WS-OUTFL2-STATUS 01969428 |
| 199 | PERFORM 9999-ABEND 01969528 |
| 200 | END-IF. 01969634 |
| 201 | * 01969728 |
| 202 | * 01970026 |
| 203 | 1000-EXIT. 01980026 |
| 204 | EXIT. 01990026 |
| 205 | * 02000026 |
| 206 | *----------------------------------------------------------------*02010026 |
| 207 | 2000-FIND-NEXT-AUTH-SUMMARY. 02020026 |
| 208 | *----------------------------------------------------------------*02030026 |
| 209 | * 02040026 |
| 210 | * DISPLAY 'IN 2000 READ ROOT SEGMENT PARA' 02041057 |
| 211 | * PAUT-PCB-STATUS 02065050 |
| 212 | INITIALIZE PAUT-PCB-STATUS 02066047 |
| 213 | CALL 'CBLTDLI' USING FUNC-GN 02070034 |
| 214 | PAUTBPCB 02080029 |
| 215 | PENDING-AUTH-SUMMARY 02090029 |
| 216 | ROOT-UNQUAL-SSA. 02100029 |
| 217 | * DISPLAY ' *******************************' 02130057 |
| 218 | * DISPLAY ' AFTER THE ROOT SEG IMS CALL ' 02130157 |
| 219 | * DISPLAY 'SEG LEVEL: ' PAUT-SEG-LEVEL 02132057 |
| 220 | * DISPLAY 'PCB STATU: ' PAUT-PCB-STATUS 02133057 |
| 221 | * DISPLAY 'SEG NAME : ' PAUT-SEG-NAME 02135057 |
| 222 | * DISPLAY ' *******************************' 02138043 |
| 223 | IF PAUT-PCB-STATUS = SPACES 02140029 |
| 224 | * SET NOT-END-OF-AUTHDB TO TRUE 02160050 |
| 225 | ADD 1 TO WS-NO-SUMRY-READ 02170026 |
| 226 | ADD 1 TO WS-AUTH-SMRY-PROC-CNT 02180026 |
| 227 | MOVE PENDING-AUTH-SUMMARY TO OPFIL1-REC 02190030 |
| 228 | INITIALIZE ROOT-SEG-KEY 02190156 |
| 229 | INITIALIZE CHILD-SEG-REC 02190256 |
| 230 | MOVE PA-ACCT-ID TO ROOT-SEG-KEY 02190356 |
| 231 | * DISPLAY 'WRITING FIRST FILE' 02190456 |
| 232 | IF PA-ACCT-ID IS NUMERIC 02190556 |
| 233 | WRITE OPFIL1-REC 02190656 |
| 234 | INITIALIZE WS-END-OF-CHILD-SEG 02190756 |
| 235 | PERFORM 3000-FIND-NEXT-AUTH-DTL THRU 3000-EXIT 02190856 |
| 236 | UNTIL WS-END-OF-CHILD-SEG='Y' 02190956 |
| 237 | END-IF 02191056 |
| 238 | END-IF 02191156 |
| 239 | IF PAUT-PCB-STATUS = 'GB' 02192029 |
| 240 | SET END-OF-AUTHDB TO TRUE 02194029 |
| 241 | MOVE 'Y' TO WS-END-OF-ROOT-SEG 02195050 |
| 242 | END-IF 02197029 |
| 243 | IF PAUT-PCB-STATUS NOT EQUAL TO SPACES AND 'GB' 02200029 |
| 244 | DISPLAY 'AUTH SUM GN FAILED :' PAUT-PCB-STATUS 02230029 |
| 245 | DISPLAY 'KEY FEEDBACK AREA :' PAUT-KEYFB 02240048 |
| 246 | PERFORM 9999-ABEND 02260026 |
| 247 | . 02280026 |
| 248 | 2000-EXIT. 02290026 |
| 249 | EXIT. 02300026 |
| 250 | * 02310026 |
| 251 | * 02320026 |
| 252 | *----------------------------------------------------------------*02330026 |
| 253 | 3000-FIND-NEXT-AUTH-DTL. 02340026 |
| 254 | *----------------------------------------------------------------*02350026 |
| 255 | * 02360026 |
| 256 | * DISPLAY 'IN 3000 READ CHILD SEGMENT PARA' 02361057 |
| 257 | CALL 'CBLTDLI' USING FUNC-GNP 02370034 |
| 258 | PAUTBPCB 02380030 |
| 259 | PENDING-AUTH-DETAILS 02390030 |
| 260 | CHILD-UNQUAL-SSA. 02400030 |
| 261 | * DISPLAY '***************************' 02401057 |
| 262 | * DISPLAY ' AFTER CHILD SEG IMS CALL ' 02402057 |
| 263 | * DISPLAY 'PCB STATU: ' PAUT-PCB-STATUS 02410057 |
| 264 | * DISPLAY 'SEG NAME : ' PAUT-SEG-NAME 02411057 |
| 265 | * DISPLAY '***************************' 02412057 |
| 266 | IF PAUT-PCB-STATUS = SPACES 02420030 |
| 267 | SET MORE-AUTHS TO TRUE 02430030 |
| 268 | ADD 1 TO WS-NO-SUMRY-READ 02440030 |
| 269 | ADD 1 TO WS-AUTH-SMRY-PROC-CNT 02450030 |
| 270 | MOVE PENDING-AUTH-DETAILS TO CHILD-SEG-REC 02460036 |
| 271 | WRITE OPFIL2-REC 02470030 |
| 272 | END-IF 02480030 |
| 273 | IF PAUT-PCB-STATUS = 'GE' 02490030 |
| 274 | * SET NO-MORE-AUTHS TO TRUE 02500050 |
| 275 | MOVE 'Y' TO WS-END-OF-CHILD-SEG 02500150 |
| 276 | DISPLAY 'CHILD SEG FLAG GE : ' 02501044 |
| 277 | WS-END-OF-CHILD-SEG 02502050 |
| 278 | END-IF 02510030 |
| 279 | IF PAUT-PCB-STATUS NOT EQUAL TO SPACES AND 'GE' 02520030 |
| 280 | DISPLAY 'GNP CALL FAILED :' PAUT-PCB-STATUS 02530030 |
| 281 | DISPLAY 'KFB AREA IN CHILD:' PAUT-KEYFB 02531048 |
| 282 | PERFORM 9999-ABEND 02540049 |
| 283 | END-IF. 02550051 |
| 284 | INITIALIZE PAUT-PCB-STATUS. 02580052 |
| 285 | 3000-EXIT. 02590026 |
| 286 | EXIT. 02600026 |
| 287 | * 02610026 |
| 288 | *----------------------------------------------------------------*02620026 |
| 289 | 4000-FILE-CLOSE. 02630030 |
| 290 | DISPLAY 'CLOSING THE FILE' 02631043 |
| 291 | CLOSE OPFILE1. 02640034 |
| 292 | 02650030 |
| 293 | IF WS-OUTFL1-STATUS = SPACES OR '00' 02660034 |
| 294 | CONTINUE 02670030 |
| 295 | ELSE 02680034 |
| 296 | DISPLAY 'ERROR IN CLOSING 1ST FILE:'WS-OUTFL1-STATUS 02690030 |
| 297 | END-IF. 02700034 |
| 298 | CLOSE OPFILE2. 02710034 |
| 299 | 02720030 |
| 300 | IF WS-OUTFL2-STATUS = SPACES OR '00' 02730034 |
| 301 | CONTINUE 02740030 |
| 302 | ELSE 02750034 |
| 303 | DISPLAY 'ERROR IN CLOSING 2ND FILE:'WS-OUTFL2-STATUS 02760030 |
| 304 | END-IF. 02770034 |
| 305 | 4000-EXIT. 02780030 |
| 306 | EXIT. 02790030 |
| 307 | *----------------------------------------------------------------*03620026 |
| 308 | 9999-ABEND. 03630026 |
| 309 | *----------------------------------------------------------------*03640026 |
| 310 | * 03650026 |
| 311 | DISPLAY 'IMSUNLOD ABENDING ...' 03660030 |
| 312 | 03670026 |
| 313 | MOVE 16 TO RETURN-CODE 03680026 |
| 314 | GOBACK. 03690026 |
| 315 | * 03700026 |
| 316 | 9999-EXIT. 03710026 |
| 317 | EXIT. 03720026 |