000010 IDENTIFICATION DIVISION. 00001000 000020 PROGRAM-ID. SWPARCH2 00002000 000030 AUTHOR. OCCZYD 00003000 000040 INSTALLATION. OCC. 00004000 000050 DATE-WRITTEN. JAN 27, 2012. 00005000 000060 DATE-COMPILED. 00006000 000070 00007000 000080*REMARKS. 00008000 000090**************************************************************** 00009000 000091* TO SWEEP THE IDB AND STORE THE FOLLOWING RECORD ON A CD FOR 00009100 000092* ARCHIVE: INST, CONS, DOBK, IHFN, IHLC, IHMA, IHSN, IOWN, ITRN. 00009200 000093* THIS PROCESS IS BASED ON THE PAST ARCHIVE DONE FOR THE 5 YEAR 00009300 000094* PERIOD ARCHIVE. 00009400 000095**************************************************************** 00009500 000096 00009600 000097 ENVIRONMENT DIVISION. 00009700 000098 CONFIGURATION SECTION. 00009800 000099 INPUT-OUTPUT SECTION. 00009900 000100 FILE-CONTROL. 00010000 000101 SELECT INST-FILE ASSIGN TO UT-S-INST. 00010100 000102 SELECT CONS-FILE ASSIGN TO UT-S-CONS. 00010200 000103 SELECT DOBK-FILE ASSIGN TO UT-S-DOBK. 00010300 000104 SELECT IHFN-FILE ASSIGN TO UT-S-IHFN. 00010400 000105 SELECT IHLC-FILE ASSIGN TO UT-S-IHLC. 00010500 000106 SELECT IHMA-FILE ASSIGN TO UT-S-IHMA. 00010600 000107 SELECT IHSN-FILE ASSIGN TO UT-S-IHSN. 00010700 000108 SELECT IOWN-FILE ASSIGN TO UT-S-IOWN. 00010800 000109 SELECT ITRN-FILE ASSIGN TO UT-S-ITRN. 00010900 000110*--------------------------------------------------------* 00011000 000111 00011100 000112 IDMS-CONTROL SECTION. 00011200 000113 PROTOCOL. MODE IS BATCH DEBUG 00011300 000114 IDMS-RECORDS MANUAL. 00011400 000115 00011500 000116 DATA DIVISION. 00011600 000117*----------------------------------------------------------* 00011700 000118 SCHEMA SECTION. 00011800 000119 DB COCOGLBL WITHIN TESTMAST. 00011900 000120*----------------------------------------------------------* 00012000 000121 FILE SECTION. 00012100 000122 FD INST-FILE 00012200 000123 LABEL RECORDS ARE STANDARD 00012300 000124 RECORD CONTAINS 624 CHARACTERS 00012400 000125 BLOCK CONTAINS 0 RECORDS 00012500 000126 DATA RECORD IS INST-REC. 00012600 000127 01 INST-REC PIC X(624). 00012700 000128 00012800 000129 FD CONS-FILE 00012900 000130 LABEL RECORDS ARE STANDARD 00013000 000131 RECORD CONTAINS 056 CHARACTERS 00013100 000132 BLOCK CONTAINS 0 RECORDS 00013200 000133 DATA RECORD IS CONS-REC. 00013300 000134 01 CONS-REC PIC X(056). 00013400 000135 00013500 000136 FD DOBK-FILE 00013600 000137 LABEL RECORDS ARE STANDARD 00013700 000138 RECORD CONTAINS 018 CHARACTERS 00013800 000139 BLOCK CONTAINS 0 RECORDS 00013900 000140 DATA RECORD IS DOBK-REC. 00014000 000141 01 DOBK-REC PIC X(018). 00014100 000142 00014200 000143 FD IHFN-FILE 00014300 000144 LABEL RECORDS ARE STANDARD 00014400 000145 RECORD CONTAINS 090 CHARACTERS 00014500 000146 BLOCK CONTAINS 0 RECORDS 00014600 000147 DATA RECORD IS IHFN-REC. 00014700 000148 01 IHFN-REC PIC X(090). 00014800 000149 00014900 000150 FD IHLC-FILE 00015000 000151 LABEL RECORDS ARE STANDARD 00015100 000152 RECORD CONTAINS 125 CHARACTERS 00015200 000153 BLOCK CONTAINS 0 RECORDS 00015300 000154 DATA RECORD IS IHLC-REC. 00015400 000155 01 IHLC-REC PIC X(125). 00015500 000156 00015600 000157 FD IHMA-FILE 00015700 000158 LABEL RECORDS ARE STANDARD 00015800 000159 RECORD CONTAINS 117 CHARACTERS 00015900 000160 BLOCK CONTAINS 0 RECORDS 00016000 000161 DATA RECORD IS IHMA-REC. 00016100 000162 01 IHMA-REC PIC X(117). 00016200 000163 00016300 000164 FD IHSN-FILE 00016400 000165 LABEL RECORDS ARE STANDARD 00016500 000166 RECORD CONTAINS 058 CHARACTERS 00016600 000167 BLOCK CONTAINS 0 RECORDS 00016700 000168 DATA RECORD IS IHSN-REC. 00016800 000169 01 IHSN-REC PIC X(058). 00016900 000170 00017000 000171 FD IOWN-FILE 00017100 000172 LABEL RECORDS ARE STANDARD 00017200 000173 RECORD CONTAINS 056 CHARACTERS 00017300 000174 BLOCK CONTAINS 0 RECORDS 00017400 000175 DATA RECORD IS IOWN-REC. 00017500 000176 01 IOWN-REC PIC X(056). 00017600 000177 00017700 000178 FD ITRN-FILE 00017800 000179 LABEL RECORDS ARE STANDARD 00017900 000180 RECORD CONTAINS 029 CHARACTERS 00018000 000181 BLOCK CONTAINS 0 RECORDS 00018100 000182 DATA RECORD IS ITRN-REC. 00018200 000183 01 ITRN-REC PIC X(029). 00018300 000184 00018400 000185*----------------------------------------------------------* 00018500 000186 WORKING-STORAGE SECTION. 00018600 000187 00018700 000188 01 WS-HOLD-INST-ID PIC X(009) VALUE SPACE. 00018802 000189 00018908 000190 01 WS-BRAN-MASK-CERT-ID. 00019008 000191 05 WS-BRAN-MASK-NUMBER PIC X(006) VALUE SPACE. 00019108 000192 05 WS-BRAN-MASK-SUFFIX PIC X(001) VALUE SPACE. 00019208 000193 00019308 000194 01 WS-CONS-REC. 00019408 000195 05 WCONS-INST-ID PIC X(009) VALUE SPACE. 00019508 000196 05 WCONS-CONS-TYPE-CODE PIC X(002) VALUE SPACE. 00019608 000197 05 WCONS-CONS-ESTBD-DT PIC X(008) VALUE SPACE. 00019708 000198 05 WCONS-CONS-END-DT PIC X(008) VALUE SPACE. 00019808 000199 05 WCONS-CONS-ESTBD-REC-DT PIC X(008) VALUE SPACE. 00019908 000200 05 WCONS-CONS-END-REC-DT PIC X(008) VALUE SPACE. 00020008 000201 05 WCONS-CONS-R-INST-OCC-ASGND-ID PIC X(006) VALUE SPACE. 00020108 000202 05 WCONS-CONS-P-INST-OCC-ASGND-ID PIC X(006) VALUE SPACE. 00020208 000203 05 FILLER PIC X(001) VALUE SPACE. 00020308 000204* REC-LENGTH 056 00020408 000205 01 WS-DOBK-REC. 00020508 000206 05 WDOBK-INST-ID PIC X(009) VALUE SPACE. 00020608 000207 05 WDOBK-INST-DOBK-TYPE-CODE PIC X(002) VALUE SPACE. 00020708 000208 05 WDOBK-INST-PBUSN-ACT-CODE PIC X(002) VALUE SPACE. 00020808 000209 05 WDOBK-INST-DOBK-PEER-GRP-NBR PIC X(002) VALUE SPACE. 00020908 000210 05 WDOBK-INST-DOBK-STAT-CODE PIC X(002) VALUE SPACE. 00021008 000211 05 FILLER PIC X(001) VALUE SPACE. 00021108 000212* REC-LENGTH 018 00021208 000213 01 WS-IHFN-REC. 00021308 000214 05 WIHFN-INST-ID PIC X(009) VALUE SPACE. 00021408 000215 05 WIHFN-IHFN-EFF-DT PIC X(008) VALUE SPACE. 00021508 000216 05 WIHFN-IHFN-FULL-NAME PIC X(072) VALUE SPACE. 00021608 000217 05 FILLER PIC X(001) VALUE SPACE. 00021708 000218* REC-LENGTH 090 00021808 000219 01 WS-IHLC-REC. 00021908 000220 05 WIHLC-INST-ID PIC X(009) VALUE SPACE. 00022008 000221 05 WIHLC-IHLC-EFF-DT PIC X(008) VALUE SPACE. 00022108 000222 05 WIHLC-IHLC-ADDR1 PIC X(060) VALUE SPACE. 00022208 000223 05 WIHLC-IHLC-CITY-NAME PIC X(028) VALUE SPACE. 00022308 000224 05 WIHLC-IHLC-CNTRY-CODE PIC X(005) VALUE SPACE. 00022408 000225 05 WIHLC-IHLC-CNTY-CODE PIC X(003) VALUE SPACE. 00022508 000226 05 WIHLC-IHLC-ST-ABBRV PIC X(002) VALUE SPACE. 00022608 000227 05 WIHLC-IHLC-ZIP-CODE PIC X(009) VALUE SPACE. 00022708 000228 05 FILLER PIC X(001) VALUE SPACE. 00022808 000229* REC-LENGTH 125 00022908 000230 01 WS-IHMA-REC. 00023008 000231 05 WIHMA-INST-ID PIC X(009) VALUE SPACE. 00023108 000232 05 WIHMA-IHMA-EFF-DT PIC X(008) VALUE SPACE. 00023208 000233 05 WIHMA-IHMA-ADDR1 PIC X(060) VALUE SPACE. 00023308 000234 05 WIHMA-IHMA-CITY-NAME PIC X(028) VALUE SPACE. 00023408 000235 05 WIHMA-IHMA-ST-ABBRV PIC X(002) VALUE SPACE. 00023508 000236 05 WIHMA-IHMA-ZIP-CODE PIC X(009) VALUE SPACE. 00023608 000237 05 FILLER PIC X(001) VALUE SPACE. 00023708 000238* REC-LENGTH 117 00023808 000239 01 WS-IHSN-REC. 00023908 000240 05 WIHSN-INST-ID PIC X(009) VALUE SPACE. 00024008 000241 05 WIHSN-IHSN-EFF-DT PIC X(008) VALUE SPACE. 00024108 000242 05 WIHSN-IHSN-SHORT-NAME PIC X(040) VALUE SPACE. 00024208 000243 05 FILLER PIC X(001) VALUE SPACE. 00024308 000244* REC-LENGTH 058 00024408 000245 01 WS-INST-REC. 00024508 000246 05 WINST-INST-ID PIC X(009) VALUE SPACE. 00024608 000247 05 WINST-INST-TYPE-CODE PIC X(002) VALUE SPACE. 00024708 000248 05 WINST-INST-OCC-ASGND-ID PIC X(006) VALUE SPACE. 00024808 000249 05 WINST-INST-FDIC-CERT-ID PIC X(006) VALUE SPACE. 00024908 000250 05 WINST-INST-FRB-DHC-ID PIC X(006) VALUE SPACE. 00025008 000251 05 WINST-INST-FRB-BANK-ID PIC X(006) VALUE SPACE. 00025108 000252 05 WINST-INST-FULL-NAME PIC X(072) VALUE SPACE. 00025208 000253 05 WINST-INST-FULNAME-EFF-DT PIC X(008) VALUE SPACE. 00025308 000254 05 WINST-INST-SHORT-NAME PIC X(040) VALUE SPACE. 00025408 000255 05 WINST-INST-LOC-ADDR1 PIC X(060) VALUE SPACE. 00025508 000256 05 WINST-INST-LOC-ADDR2 PIC X(060) VALUE SPACE. 00025608 000257 05 WINST-INST-LOC-CITY-NAME PIC X(028) VALUE SPACE. 00025708 000258 05 WINST-INST-LOC-ST-ABBRV PIC X(002) VALUE SPACE. 00025808 000259 05 WINST-INST-LOC-ZIP-CODE PIC X(009) VALUE SPACE. 00025908 000260 05 WINST-INST-LOC-CNTY-CODE PIC X(003) VALUE SPACE. 00026008 000261 05 WINST-INST-LOC-CNTRY-CODE PIC X(005) VALUE SPACE. 00026108 000262 05 WINST-INST-MAIL-ADDR1 PIC X(060) VALUE SPACE. 00026208 000263 05 WINST-INST-MAIL-ADDR2 PIC X(060) VALUE SPACE. 00026308 000264 05 WINST-INST-MAIL-CITY-NAME PIC X(028) VALUE SPACE. 00026408 000265 05 WINST-INST-MAIL-ST-ABBRV PIC X(002) VALUE SPACE. 00026508 000266 05 WINST-INST-MAIL-ZIP-CODE PIC X(009) VALUE SPACE. 00026608 000267 05 WINST-INST-MAIL-CNTRY-CODE PIC X(005) VALUE SPACE. 00026708 000268 05 WINST-INST-FRB-DIST-CODE PIC X(002) VALUE SPACE. 00026808 000269 05 WINST-INST-OCC-DIST-CODE PIC X(002) VALUE SPACE. 00026908 000270 05 WINST-INST-MSA-NBR PIC X(004) VALUE SPACE. 00027008 000271 05 WINST-INST-PRIM-REG-CODE PIC X(002) VALUE SPACE. 00027108 000272 05 WINST-INST-ESTBD-DT PIC X(008) VALUE SPACE. 00027208 000273 05 WINST-INST-OPEN-DT PIC X(008) VALUE SPACE. 00027308 000274 05 WINST-INST-ACTVE-CODE PIC X(001) VALUE SPACE. 00027408 000275 05 WINST-INST-INACTVE-DT PIC X(008) VALUE SPACE. 00027508 000276 05 WINST-INST-TR-ACTV-IND PIC X(001) VALUE SPACE. 00027608 000277 05 WINST-INST-TR-POWERS-CODE PIC X(001) VALUE SPACE. 00027708 000278 05 WINST-INST-TFAG-SEC-ID PIC X(008) VALUE SPACE. 00027808 000279 05 WINST-INST-TFAG-EFF-DT PIC X(008) VALUE SPACE. 00027908 000280 05 WINST-INST-TFAG-DEL-DT PIC X(008) VALUE SPACE. 00028008 000281 05 WINST-INST-EDP-PRVR-TO-CODE PIC X(001) VALUE SPACE. 00028108 000282 05 WINST-INST-EDP-PRVR-STAT-CODE PIC X(001) VALUE SPACE. 00028208 000283 05 WINST-INST-EDP-PRVR-INACTVE-DT PIC X(008) VALUE SPACE. 00028308 000284 05 WINST-INST-BSUB-TYPE-CODE PIC X(002) VALUE SPACE. 00028408 000285 05 WINST-INST-BRAN-SPCL-TYPE-CODE PIC X(002) VALUE SPACE. 00028508 000286 05 WINST-INST-BRAN-PRE-APRL-IND PIC X(001) VALUE SPACE. 00028608 000287 05 WINST-INST-BRAG-TYPE-CODE PIC X(001) VALUE SPACE. 00028708 000288 05 WINST-INST-BRAG-STAT-CODE PIC X(001) VALUE SPACE. 00028808 000289 05 WINST-INST-ESTBD-REC-DT PIC X(008) VALUE SPACE. 00028908 000290 05 WINST-INST-INACTVE-REC-DT PIC X(008) VALUE SPACE. 00029008 000291 05 WINST-INST-LOC-EFF-DT PIC X(008) VALUE SPACE. 00029108 000292 05 WINST-INST-MAIL-EFF-DT PIC X(008) VALUE SPACE. 00029208 000293 05 WINST-INST-SHORT-NAME-EFF-DT PIC X(008) VALUE SPACE. 00029308 000294 05 WINST-INST-OCC-BRANCH-CERT-ID PIC X(007) VALUE SPACE. 00029408 000295 05 WINST-INST-FRB-RSSD-NR PIC X(010) VALUE SPACE. 00029508 000296 05 WINST-INST-FDIC-INS-CD PIC X(001) VALUE SPACE. 00029608 000297 05 WINST-INST-SAVE-OCC-DIST-CODE PIC X(001) VALUE SPACE. 00029708 000298 05 FILLER PIC X(001) VALUE SPACE. 00029808 000299* REC-LENGTH 624 00029908 000300 01 WS-IOWN-REC. 00030008 000301 05 WIOWN-INST-ID PIC X(009) VALUE SPACE. 00030108 000302 05 WIOWN-IOWN-OWNER-INST-ID PIC X(009) VALUE SPACE. 00030208 000303 05 WIOWN-IOWN-ESTBD-DT PIC X(008) VALUE SPACE. 00030308 000304 05 WIOWN-IOWN-END-DT PIC X(008) VALUE SPACE. 00030408 000305 05 WIOWN-IOWN-PCT PIC X(003) VALUE SPACE. 00030508 000306 05 WIOWN-IOWN-ESTBD-REC-DT PIC X(008) VALUE SPACE. 00030608 000307 05 WIOWN-IOWN-END-REC-DT PIC X(008) VALUE SPACE. 00030708 000308 05 WIOWN-IOWN-EDP-ESTBD-IND PIC X(001) VALUE SPACE. 00030808 000309 05 WIOWN-IOWN-STAT-CODE PIC X(001) VALUE SPACE. 00030908 000310 05 FILLER PIC X(001) VALUE SPACE. 00031008 000311* REC-LENGTH 056 00031108 000312 01 WS-ITRN-REC. 00031208 000313 05 WITRN-INST-ID PIC X(009) VALUE SPACE. 00031308 000314 05 WITRN-ITRN-TYPE-CODE PIC X(002) VALUE SPACE. 00031408 000315 05 WITRN-ITRN-DT PIC X(008) VALUE SPACE. 00031508 000316 05 WITRN-ITRN-INTO-INST-ID PIC X(009) VALUE SPACE. 00031608 000317 05 FILLER PIC X(001) VALUE SPACE. 00031708 000318* REC-LENGTH 029 00031808 000320 00032002 000321 01 WS-IDB-EOS PIC X(01) VALUE 'N'. 00032106 000322 01 WS-FIND-ALL-CONS PIC X(01) VALUE 'N'. 00032202 000323 01 WS-FIND-ALL-HIST PIC X(01) VALUE 'N'. 00032302 000324 01 WS-FIND-ALL-ITRN PIC X(01) VALUE 'N'. 00032402 000325 01 WS-FIND-ALL-IOWN PIC X(01) VALUE 'N'. 00032502 000326 01 WS-COUNT COMP PIC 9(05) VALUE 0. 00032602 000380 00038002 000381 01 RINST-DBKEY PIC S9(08) COMP VALUE +0. 00038102 000382 01 RIOWN-DBKEY PIC S9(08) COMP VALUE +0. 00038202 000383 01 RITRN-DBKEY PIC S9(08) COMP VALUE +0. 00038305 000384 00038405 000385******************************************************************00038505 000386 COPY IDMS RECORD R-CONS-CON-SERV. 00038605 000387 COPY IDMS RECORD R-DOBK-DOM-BANK. 00038705 000388 COPY IDMS RECORD R-IHFN-HIST-FNAM. 00038805 000389 COPY IDMS RECORD R-IHLC-HIST-LOCN. 00038905 000390 COPY IDMS RECORD R-IHMA-HIST-MAIL. 00039005 000391 COPY IDMS RECORD R-IHSN-HIST-SNAM. 00039105 000392 COPY IDMS RECORD R-INST-INSTITUTN. 00039205 000393 COPY IDMS RECORD R-IOWN-INST-OWN. 00039305 000394 COPY IDMS RECORD R-ITRN-INST-TRN. 00039405 000396******************************************************************00039600 000397 00039700 000398 01 SUBSCHEMA-CONTROL. 00039800 000399 05 COPY IDMS SUBSCHEMA-CONTROL. 00039900 000400 00040000 000401 COPY IDMS DB-STATISTICS. 00040100 000402 00040200 000403******************************************************************00040300 000404* PROCEDURE DIVISION STARTS HERE 00040400 000405******************************************************************00040500 000406 PROCEDURE DIVISION. 00040600 000407 00040700 000408 0000-MAIN. 00040800 000409 PERFORM 1000-SETUP THRU 1000-EXIT. 00040900 000410 00041000 000411 PERFORM 2000-OBT-INST THRU 2000-EXIT 00041108 000412 UNTIL WS-IDB-EOS = 'Y'. 00041206 000413 00041300 000414 CLOSE INST-FILE 00041400 000415 CONS-FILE 00041500 000416 DOBK-FILE 00041600 000417 IHFN-FILE 00041700 000418 IHLC-FILE 00041800 000419 IHMA-FILE 00041900 000420 IHSN-FILE 00042000 000421 IOWN-FILE 00042100 000422 ITRN-FILE. 00042200 000423 00042300 000424 ROLLBACK. 00042400 000425 DISPLAY '*******ROLLBACK-NO UPDATE********'. 00042500 000426 00042600 000427 FINISH. 00042700 000428 00042800 000429 STOP RUN. 00042900 000430 0000-EXIT. 00043000 000431 EXIT. 00043100 000432 00043200 000433***************************************************************** 00043300 000434* 1000-SETUP STARTS HERE * 00043400 000435***************************************************************** 00043500 000436 1000-SETUP. 00043600 000437 BIND RUN-UNIT. 00043700 000438 IF DB-STATUS-OK 00043800 000439 NEXT SENTENCE 00043900 000440 ELSE 00044000 000441 PERFORM IDMS-STATUS THRU ISABEX. 00044100 000442 00044200 000443 BIND R-INST-INSTITUTN. 00044300 000444 IF DB-STATUS-OK 00044400 000445 NEXT SENTENCE 00044500 000446 ELSE 00044600 000447 PERFORM IDMS-STATUS THRU ISABEX. 00044700 000448 00044800 000449 BIND R-CONS-CON-SERV. 00044900 000450 IF DB-STATUS-OK 00045000 000451 NEXT SENTENCE 00045100 000452 ELSE 00045200 000453 PERFORM IDMS-STATUS THRU ISABEX. 00045300 000454 00045400 000461 BIND R-IHFN-HIST-FNAM. 00046100 000462 IF DB-STATUS-OK 00046200 000463 NEXT SENTENCE 00046300 000464 ELSE 00046400 000465 PERFORM IDMS-STATUS THRU ISABEX. 00046500 000466 00046600 000467 BIND R-IHSN-HIST-SNAM. 00046700 000468 IF DB-STATUS-OK 00046800 000469 NEXT SENTENCE 00046900 000470 ELSE 00047000 000471 PERFORM IDMS-STATUS THRU ISABEX. 00047100 000472 00047200 000473 BIND R-IHLC-HIST-LOCN. 00047300 000474 IF DB-STATUS-OK 00047400 000475 NEXT SENTENCE 00047500 000476 ELSE 00047600 000477 PERFORM IDMS-STATUS THRU ISABEX. 00047700 000478 00047800 000479 BIND R-IHMA-HIST-MAIL. 00047900 000480 IF DB-STATUS-OK 00048000 000481 NEXT SENTENCE 00048100 000482 ELSE 00048200 000483 PERFORM IDMS-STATUS THRU ISABEX. 00048300 000484 00048400 000485 BIND R-DOBK-DOM-BANK. 00048500 000486 IF DB-STATUS-OK 00048600 000487 NEXT SENTENCE 00048700 000488 ELSE 00048800 000489 PERFORM IDMS-STATUS THRU ISABEX. 00048900 000490 00049000 000491 BIND R-ITRN-INST-TRN. 00049100 000492 IF DB-STATUS-OK 00049200 000493 NEXT SENTENCE 00049300 000494 ELSE 00049400 000495 PERFORM IDMS-STATUS THRU ISABEX. 00049500 000496 00049600 000497 BIND R-IOWN-INST-OWN. 00049700 000498 IF DB-STATUS-OK 00049800 000499 NEXT SENTENCE 00049900 000500 ELSE 00050000 000501 PERFORM IDMS-STATUS THRU ISABEX. 00050100 000502 00050200 000503 READY A-CO-INST-HIST USAGE-MODE IS RETRIEVAL. 00050300 000504 IF DB-STATUS-OK 00050400 000505 NEXT SENTENCE 00050500 000506 ELSE 00050600 000507 PERFORM IDMS-STATUS THRU ISABEX. 00050700 000508 00050800 000509 READY A-INST-AREA USAGE-MODE IS RETRIEVAL. 00050900 000510 IF DB-STATUS-OK 00051000 000511 NEXT SENTENCE 00051100 000512 ELSE 00051200 000513 PERFORM IDMS-STATUS THRU ISABEX. 00051300 000514 00051400 000515 READY A-INST-X-OCCID USAGE-MODE IS RETRIEVAL. 00051500 000516 IF DB-STATUS-OK 00051600 000517 NEXT SENTENCE 00051700 000518 ELSE 00051800 000519 PERFORM IDMS-STATUS THRU ISABEX. 00051900 000520 00052000 000521 READY A-INST-X-FDIC USAGE-MODE IS RETRIEVAL. 00052100 000522 IF DB-STATUS-OK 00052200 000523 NEXT SENTENCE 00052300 000524 ELSE 00052400 000525 PERFORM IDMS-STATUS THRU ISABEX. 00052500 000526 00052600 000527 READY A-CO-FIL-INST USAGE-MODE IS RETRIEVAL. 00052700 000528 IF DB-STATUS-OK 00052800 000529 NEXT SENTENCE 00052900 000530 ELSE 00053000 000531 PERFORM IDMS-STATUS THRU ISABEX. 00053100 000532 00053200 000533 READY READY A-CO-X-BRCERT USAGE-MODE IS RETRIEVAL. 00053300 000534 IF DB-STATUS-OK 00053400 000535 NEXT SENTENCE 00053500 000536 ELSE 00053600 000537 PERFORM IDMS-STATUS THRU ISABEX. 00053700 000538 00053800 000539 OPEN OUTPUT INST-FILE 00053900 000540 CONS-FILE 00054000 000541 DOBK-FILE 00054100 000542 IHFN-FILE 00054200 000543 IHLC-FILE 00054300 000544 IHMA-FILE 00054400 000545 IHSN-FILE 00054500 000546 IOWN-FILE 00054600 000547 ITRN-FILE. 00054700 000548 00054800 000549 OBTAIN FIRST R-INST-INSTITUTN WITHIN A-INST-AREA. 00054903 000550 IF ANY-ERROR-STATUS 00055000 000551 PERFORM IDMS-STATUS. 00055100 000552 1000-EXIT. 00055200 000553 EXIT. 00055300 000554 00055400 000555 2000-OBT-INST. 00055508 000565*** DISREGARD THE ATM, SINCE OCC IS NOT MONITORING IT *** 00056508 000566*** PUT IT BACK AS TRACEY'S REQUEST - 02/09/12 *** 00056616 000567* IF RINST-INST-TYPE-CODE = 3 00056716 000568* MOVE RINST-INST-OCC-BRANCH-CERT-ID 00056816 000569* TO WS-BRAN-MASK-CERT-ID 00056916 000570* IF WS-BRAN-MASK-SUFFIX = 'C' 00057016 000571* GO TO 2000-OBT-NEXT-INST 00057116 000572* ELSE 00057216 000573* NEXT SENTENCE 00057316 000574* ELSE 00057416 000575* NEXT SENTENCE. 00057516 000576* 00057616 000577* TEST(START) 00057716 000578* ADD 1 TO WS-COUNT. 00057816 000579* IF WS-COUNT = 200 00057916 000580* MOVE 'Y' TO WS-IDB-EOS 00058016 000581* GO TO 2000-EXIT. 00058116 000582* TEST(END) 00058216 000583 00058316 000584 ACCEPT RINST-DBKEY FROM R-INST-INSTITUTN CURRENCY. 00058416 000585 IF ANY-ERROR-STATUS 00058516 000586 PERFORM IDMS-STATUS. 00058616 000587 00058716 000588 PERFORM 2100-WRITE-INST THRU 2100-EXIT. 00058816 000589 00058916 000590 PERFORM 2300-OBT-DOBK THRU 2300-EXIT. 00059016 000591 00059116 000592 FIND CURRENT R-INST-INSTITUTN. 00059216 000593 IF ANY-ERROR-STATUS 00059316 000594 PERFORM IDMS-STATUS. 00059416 000595 00059516 000596 OBTAIN FIRST R-IHFN-HIST-FNAM WITHIN S-INST-HISTORY. 00059616 000597 IF DB-STATUS-OK 00059716 000598 MOVE 'N' TO WS-FIND-ALL-HIST 00059816 000599 PERFORM 2400-OBT-HIST-FNAM THRU 2400-EXIT 00059916 000600 UNTIL WS-FIND-ALL-HIST = 'Y' 00060016 000601 ELSE 00060116 000602 IF DB-END-OF-SET 00060216 000603 NEXT SENTENCE 00060316 000604 ELSE 00060416 000605 PERFORM IDMS-STATUS. 00060516 000606 00060616 000607 FIND CURRENT R-INST-INSTITUTN. 00060716 000608 IF ANY-ERROR-STATUS 00060816 000609 PERFORM IDMS-STATUS. 00060916 000610 00061016 000611 OBTAIN FIRST R-IHSN-HIST-SNAM WITHIN S-INST-HISTORY. 00061116 000612 IF DB-STATUS-OK 00061216 000613 MOVE 'N' TO WS-FIND-ALL-HIST 00061316 000614 PERFORM 2500-OBT-HIST-SNAM THRU 2500-EXIT 00061416 000615 UNTIL WS-FIND-ALL-HIST = 'Y' 00061516 000616 ELSE 00061616 000617 IF DB-END-OF-SET 00061716 000618 NEXT SENTENCE 00061816 000619 ELSE 00061916 000620 PERFORM IDMS-STATUS. 00062016 000621 00062116 000622 FIND CURRENT R-INST-INSTITUTN. 00062216 000623 IF ANY-ERROR-STATUS 00062316 000624 PERFORM IDMS-STATUS. 00062416 000625 00062516 000626 OBTAIN FIRST R-IHLC-HIST-LOCN WITHIN S-INST-HISTORY. 00062616 000627 IF DB-STATUS-OK 00062716 000628 MOVE 'N' TO WS-FIND-ALL-HIST 00062816 000629 PERFORM 2600-OBT-HIST-LOCN THRU 2600-EXIT 00062916 000630 UNTIL WS-FIND-ALL-HIST = 'Y' 00063016 000631 ELSE 00063116 000632 IF DB-END-OF-SET 00063216 000633 NEXT SENTENCE 00063316 000634 ELSE 00063416 000635 PERFORM IDMS-STATUS. 00063516 000636 00063616 000637 FIND CURRENT R-INST-INSTITUTN. 00063716 000638 IF ANY-ERROR-STATUS 00063816 000639 PERFORM IDMS-STATUS. 00063916 000640 00064016 000641 OBTAIN FIRST R-IHMA-HIST-MAIL WITHIN S-INST-HISTORY. 00064116 000642 IF DB-STATUS-OK 00064216 000643 MOVE 'N' TO WS-FIND-ALL-HIST 00064316 000644 PERFORM 2700-OBT-HIST-MAIL THRU 2700-EXIT 00064416 000645 UNTIL WS-FIND-ALL-HIST = 'Y' 00064516 000646 ELSE 00064616 000647 IF DB-END-OF-SET 00064716 000648 NEXT SENTENCE 00064816 000649 ELSE 00064916 000650 PERFORM IDMS-STATUS. 00065016 000651 00065116 000652 FIND CURRENT R-INST-INSTITUTN. 00065216 000653 IF ANY-ERROR-STATUS 00065316 000654 PERFORM IDMS-STATUS. 00065416 000655 00065516 000658*** RETRIEVE CONS RECORD FOR OTHER THAN BRANCH OR FED-BRANCH ***00065809 000659*** BECAUSE BRANCH AND FED-BRANCH DO NOT HAVE IT ***00065909 000660* IF NOT ( RINST-INST-TYPE-CODE = 3 00066012 000661* OR RINST-INST-TYPE-CODE = 5) 00066112 000662 OBTAIN FIRST R-CONS-CON-SERV WITHIN S-INST-CONS-RCVS. 00066212 000663 IF DB-STATUS-OK 00066309 000664 MOVE 'N' TO WS-FIND-ALL-CONS 00066409 000665 PERFORM 3000-OBT-R-CONS THRU 3000-EXIT 00066509 000666 UNTIL WS-FIND-ALL-CONS = 'Y' 00066609 000667 ELSE 00066709 000668 IF DB-END-OF-SET 00066809 000669 NEXT SENTENCE 00066909 000670 ELSE 00067009 000671 PERFORM IDMS-STATUS. 00067109 000672 00067209 000673 FIND CURRENT R-INST-INSTITUTN. 00067309 000674 IF ANY-ERROR-STATUS 00067409 000675 PERFORM IDMS-STATUS. 00067509 000676 00067609 000677*** RETRIEVE ITRN RECORD FOR OTHER THAN BRANCH AND FED-BRANCH ***00067709 000678*** BECAUSE BRANCH AND FED-BRFANCH DO NOT HAVE IT ***00067809 000679* IF NOT (RINST-INST-TYPE-CODE = 3 00067912 000680* OR RINST-INST-TYPE-CODE = 5) 00068012 000681 OBTAIN FIRST R-ITRN-INST-TRN WITHIN S-INST-TRNF-TO. 00068112 000682 IF DB-STATUS-OK 00068209 000683 MOVE 'N' TO WS-FIND-ALL-ITRN 00068309 000684 PERFORM 4000-OBT-ITRN THRU 4000-EXIT 00068409 000685 UNTIL WS-FIND-ALL-ITRN = 'Y' 00068509 000686 ELSE 00068609 000687 IF DB-END-OF-SET 00068709 000688 NEXT SENTENCE 00068809 000689 ELSE 00068909 000690 PERFORM IDMS-STATUS. 00069009 000691 00069109 000692 FIND CURRENT R-INST-INSTITUTN. 00069209 000693 IF ANY-ERROR-STATUS 00069309 000694 PERFORM IDMS-STATUS. 00069409 000695 00069509 000696*** ONLY BRANCH OR FED-BRAN HAS IOWN RECORD *** 00069609 000697* IF RINST-INST-TYPE-CODE = 3 00069712 000698* OR RINST-INST-TYPE-CODE = 5 00069812 000699 OBTAIN FIRST R-IOWN-INST-OWN WITHIN S-INST-IOWN-BY. 00069912 000700 IF DB-STATUS-OK 00070009 000701 MOVE 'N' TO WS-FIND-ALL-IOWN 00070109 000702 PERFORM 5000-OBT-IOWN THRU 5000-EXIT 00070209 000703 UNTIL WS-FIND-ALL-IOWN = 'Y' 00070309 000704 ELSE 00070409 000705 IF DB-END-OF-SET 00070509 000706 NEXT SENTENCE 00070609 000707 ELSE 00070709 000708 PERFORM IDMS-STATUS. 00070809 000709 00070909 000711 OBTAIN R-INST-INSTITUTN DB-KEY IS RINST-DBKEY. 00071109 000712 IF ANY-ERROR-STATUS 00071209 000713 PERFORM IDMS-STATUS. 00071309 000714 00071409 000715 2000-OBT-NEXT-INST. 00071511 000716 OBTAIN NEXT R-INST-INSTITUTN WITHIN A-INST-AREA. 00071609 000717 IF DB-END-OF-SET 00071709 000718 MOVE 'Y' TO WS-IDB-EOS 00071809 000719 ELSE 00071909 000720 IF ANY-ERROR-STATUS 00072009 000721 PERFORM IDMS-STATUS. 00072109 000722 2000-EXIT. 00072209 000723 EXIT. 00072309 000724 00072409 000725 2100-WRITE-INST. 00072509 000726 MOVE RINST-INST-ID 00072609 000727 TO WINST-INST-ID 00072709 000728 WS-HOLD-INST-ID. 00072809 000729 MOVE RINST-INST-TYPE-CODE 00072909 000730 TO WINST-INST-TYPE-CODE. 00073009 000731 MOVE RINST-INST-OCC-ASGND-ID 00073109 000732 TO WINST-INST-OCC-ASGND-ID. 00073209 000733 MOVE RINST-INST-FDIC-CERT-ID 00073309 000734 TO WINST-INST-FDIC-CERT-ID. 00073409 000735 MOVE RINST-INST-FRB-DHC-ID 00073509 000736 TO WINST-INST-FRB-DHC-ID. 00073609 000737 MOVE RINST-INST-FRB-BANK-ID 00073709 000738 TO WINST-INST-FRB-BANK-ID. 00073809 000739 MOVE RINST-INST-FULL-NAME 00073909 000740 TO WINST-INST-FULL-NAME. 00074009 000741 MOVE RINST-INST-FULNAME-EFF-DT 00074109 000742 TO WINST-INST-FULNAME-EFF-DT. 00074209 000743 MOVE RINST-INST-SHORT-NAME 00074309 000744 TO WINST-INST-SHORT-NAME. 00074409 000745 MOVE RINST-INST-LOC-ADDR1 00074509 000746 TO WINST-INST-LOC-ADDR1. 00074609 000747 MOVE RINST-INST-LOC-ADDR2 00074709 000748 TO WINST-INST-LOC-ADDR2. 00074809 000749 MOVE RINST-INST-LOC-CITY-NAME 00074909 000750 TO WINST-INST-LOC-CITY-NAME. 00075009 000751 MOVE RINST-INST-LOC-ST-ABBRV 00075109 000752 TO WINST-INST-LOC-ST-ABBRV. 00075209 000753 MOVE RINST-INST-LOC-ZIP-CODE 00075309 000754 TO WINST-INST-LOC-ZIP-CODE. 00075409 000755 MOVE RINST-INST-LOC-CNTY-CODE 00075509 000756 TO WINST-INST-LOC-CNTY-CODE. 00075609 000757 MOVE RINST-INST-LOC-CNTRY-CODE 00075709 000758 TO WINST-INST-LOC-CNTRY-CODE. 00075809 000759 MOVE RINST-INST-MAIL-ADDR1 00075909 000760 TO WINST-INST-MAIL-ADDR1. 00076009 000761 MOVE RINST-INST-MAIL-ADDR2 00076109 000762 TO WINST-INST-MAIL-ADDR2. 00076209 000763 MOVE RINST-INST-MAIL-CITY-NAME 00076309 000764 TO WINST-INST-MAIL-CITY-NAME. 00076409 000765 MOVE RINST-INST-MAIL-ST-ABBRV 00076509 000766 TO WINST-INST-MAIL-ST-ABBRV. 00076609 000767 MOVE RINST-INST-MAIL-ZIP-CODE 00076709 000768 TO WINST-INST-MAIL-ZIP-CODE. 00076809 000769 MOVE RINST-INST-MAIL-CNTRY-CODE 00076909 000770 TO WINST-INST-MAIL-CNTRY-CODE. 00077009 000771 MOVE RINST-INST-FRB-DIST-CODE 00077109 000772 TO WINST-INST-FRB-DIST-CODE. 00077209 000773 MOVE RINST-INST-OCC-DIST-CODE 00077309 000774 TO WINST-INST-OCC-DIST-CODE. 00077409 000775 MOVE RINST-INST-MSA-NBR 00077509 000776 TO WINST-INST-MSA-NBR. 00077609 000777 MOVE RINST-INST-PRIM-REG-CODE 00077709 000778 TO WINST-INST-PRIM-REG-CODE. 00077809 000779 MOVE RINST-INST-ESTBD-DT 00077909 000780 TO WINST-INST-ESTBD-DT. 00078009 000781 MOVE RINST-INST-OPEN-DT 00078109 000782 TO WINST-INST-OPEN-DT. 00078209 000783 MOVE RINST-INST-ACTVE-CODE 00078309 000784 TO WINST-INST-ACTVE-CODE. 00078409 000785 MOVE RINST-INST-INACTVE-DT 00078509 000786 TO WINST-INST-INACTVE-DT. 00078609 000787 MOVE RINST-INST-TR-ACTV-IND 00078709 000788 TO WINST-INST-TR-ACTV-IND. 00078809 000789 MOVE RINST-INST-TR-POWERS-CODE 00078909 000790 TO WINST-INST-TR-POWERS-CODE. 00079009 000791 MOVE RINST-INST-TFAG-SEC-ID 00079109 000792 TO WINST-INST-TFAG-SEC-ID. 00079209 000793 MOVE RINST-INST-TFAG-EFF-DT 00079309 000794 TO WINST-INST-TFAG-EFF-DT. 00079409 000795 MOVE RINST-INST-TFAG-DEL-DT 00079509 000796 TO WINST-INST-TFAG-DEL-DT. 00079609 000797 MOVE RINST-INST-EDP-PRVR-TO-CODE 00079709 000798 TO WINST-INST-EDP-PRVR-TO-CODE. 00079809 000799 MOVE RINST-INST-EDP-PRVR-STAT-CODE 00079909 000800 TO WINST-INST-EDP-PRVR-STAT-CODE. 00080009 000801 MOVE RINST-INST-EDP-PRVR-INACTVE-DT 00080109 000802 TO WINST-INST-EDP-PRVR-INACTVE-DT. 00080209 000803 MOVE RINST-INST-BSUB-TYPE-CODE 00080309 000804 TO WINST-INST-BSUB-TYPE-CODE. 00080409 000805 MOVE RINST-INST-BRAN-SPCL-TYPE-CODE 00080509 000806 TO WINST-INST-BRAN-SPCL-TYPE-CODE. 00080609 000807 MOVE RINST-INST-BRAN-PRE-APRL-IND 00080709 000808 TO WINST-INST-BRAN-PRE-APRL-IND. 00080809 000809 MOVE RINST-INST-BRAG-TYPE-CODE 00080909 000810 TO WINST-INST-BRAG-TYPE-CODE. 00081009 000811 MOVE RINST-INST-BRAG-STAT-CODE 00081109 000812 TO WINST-INST-BRAG-STAT-CODE. 00081209 000813 MOVE RINST-INST-ESTBD-REC-DT 00081309 000814 TO WINST-INST-ESTBD-REC-DT. 00081409 000815 MOVE RINST-INST-INACTVE-REC-DT 00081509 000816 TO WINST-INST-INACTVE-REC-DT. 00081609 000817 MOVE RINST-INST-LOC-EFF-DT 00081709 000818 TO WINST-INST-LOC-EFF-DT. 00081809 000819 MOVE RINST-INST-MAIL-EFF-DT 00081909 000820 TO WINST-INST-MAIL-EFF-DT. 00082009 000821 MOVE RINST-INST-SHORT-NAME-EFF-DT 00082109 000822 TO WINST-INST-SHORT-NAME-EFF-DT. 00082209 000823 MOVE RINST-INST-OCC-BRANCH-CERT-ID 00082309 000824 TO WINST-INST-OCC-BRANCH-CERT-ID. 00082409 000825 MOVE RINST-INST-FRB-RSSD-NR 00082509 000826 TO WINST-INST-FRB-RSSD-NR. 00082609 000827 MOVE RINST-INST-FDIC-INS-CD 00082709 000828 TO WINST-INST-FDIC-INS-CD. 00082809 000829 MOVE RINST-INST-SAVE-OCC-DIST-CODE 00082909 000830 TO WINST-INST-SAVE-OCC-DIST-CODE. 00083009 000831 00083109 000832 WRITE INST-REC FROM WS-INST-REC. 00083209 000833 2100-EXIT. 00083309 000834 EXIT. 00083409 000835 00083509 000836 2300-OBT-DOBK. 00083609 000837 OBTAIN FIRST R-DOBK-DOM-BANK WITHIN S-INST-DOM. 00083714 000838 IF DB-END-OF-SET 00083809 000839 GO TO 2300-EXIT 00083909 000840 ELSE 00084009 000841 IF ANY-ERROR-STATUS 00084109 000842 PERFORM IDMS-STATUS. 00084209 000843 00084309 000844 MOVE RINST-INST-ID 00084409 000845 TO WDOBK-INST-ID. 00084509 000846 MOVE RDOBK-INST-DOBK-TYPE-CODE 00084609 000847 TO WDOBK-INST-DOBK-TYPE-CODE. 00084709 000848 MOVE RDOBK-INST-PBUSN-ACT-CODE 00084809 000849 TO WDOBK-INST-PBUSN-ACT-CODE. 00084909 000850 MOVE RDOBK-INST-DOBK-PEER-GRP-NBR 00085009 000851 TO WDOBK-INST-DOBK-PEER-GRP-NBR. 00085109 000852 MOVE RDOBK-INST-DOBK-STAT-CODE 00085209 000853 TO WDOBK-INST-DOBK-STAT-CODE. 00085309 000854 00085409 000855 WRITE DOBK-REC FROM WS-DOBK-REC. 00085515 000860 2300-EXIT. 00086000 000900 EXIT. 00090000 000985 00098500 000986 2400-OBT-HIST-FNAM. 00098602 000989 MOVE RIHFN-INST-ID 00098902 000990 TO WIHFN-INST-ID. 00099002 000991 00099100 000992 MOVE RIHFN-IHFN-EFF-DT 00099202 000993 TO WIHFN-IHFN-EFF-DT. 00099302 000994 00099402 000995 MOVE RIHFN-IHFN-FULL-NAME 00099502 000996 TO WIHFN-IHFN-FULL-NAME. 00099602 001013 00101300 001014 WRITE IHFN-REC FROM WS-IHFN-REC. 00101402 001015 00101502 001016 OBTAIN NEXT R-IHFN-HIST-FNAM WITHIN S-INST-HISTORY. 00101602 001017 IF DB-END-OF-SET 00101700 001018 MOVE 'Y' TO WS-FIND-ALL-HIST 00101802 001019 ELSE 00101900 001020 PERFORM IDMS-STATUS. 00102000 001021 2400-EXIT. 00102102 001022 EXIT. 00102200 001023 00102300 001024 2500-OBT-HIST-SNAM. 00102402 001025 MOVE RIHSN-INST-ID 00102502 001026 TO WIHSN-INST-ID. 00102602 001027 00102702 001028 MOVE RIHSN-IHSN-EFF-DT 00102802 001029 TO WIHSN-IHSN-EFF-DT. 00102902 001030 00103002 001031 MOVE RIHSN-IHSN-SHORT-NAME 00103102 001040 TO WIHSN-IHSN-SHORT-NAME. 00104002 001049 00104900 001050 WRITE IHSN-REC FROM WS-IHSN-REC. 00105002 001051 00105102 001052 OBTAIN NEXT R-IHSN-HIST-SNAM WITHIN S-INST-HISTORY. 00105202 001053 IF DB-END-OF-SET 00105300 001054 MOVE 'Y' TO WS-FIND-ALL-HIST 00105400 001055 ELSE 00105500 001056 PERFORM IDMS-STATUS. 00105600 001057 2500-EXIT. 00105702 001058 EXIT. 00105800 001059 00105900 001060 2600-OBT-HIST-LOCN. 00106002 001061 MOVE RIHLC-INST-ID 00106102 001062 TO WIHLC-INST-ID. 00106202 001066 MOVE RIHLC-IHLC-EFF-DT 00106602 001067 TO WIHLC-IHLC-EFF-DT. 00106702 001081 MOVE RIHLC-IHLC-ADDR1 00108102 001082 TO WIHLC-IHLC-ADDR1. 00108202 001086 MOVE RIHLC-IHLC-CITY-NAME 00108602 001087 TO WIHLC-IHLC-CITY-NAME. 00108702 001091 MOVE RIHLC-IHLC-CNTRY-CODE 00109102 001092 TO WIHLC-IHLC-CNTRY-CODE. 00109202 001096 MOVE RIHLC-IHLC-CNTY-CODE 00109602 001097 TO WIHLC-IHLC-CNTY-CODE. 00109702 001101 MOVE RIHLC-IHLC-ST-ABBRV 00110102 001102 TO WIHLC-IHLC-ST-ABBRV. 00110202 001106 MOVE RIHLC-IHLC-ZIP-CODE 00110602 001107 TO WIHLC-IHLC-ZIP-CODE. 00110702 001110 00111000 001111 WRITE IHLC-REC FROM WS-IHLC-REC. 00111102 001112 00111202 001113 OBTAIN NEXT R-IHLC-HIST-LOCN WITHIN S-INST-HISTORY. 00111302 001114 IF DB-END-OF-SET 00111402 001115 MOVE 'Y' TO WS-FIND-ALL-HIST 00111502 001116 ELSE 00111602 001117 PERFORM IDMS-STATUS. 00111702 001118 2600-EXIT. 00111802 001119 EXIT. 00111902 001120 00112002 001121 2700-OBT-HIST-MAIL. 00112102 001122 MOVE RIHMA-INST-ID 00112202 001123 TO WIHMA-INST-ID. 00112302 001127 MOVE RIHMA-IHMA-EFF-DT 00112702 001128 TO WIHMA-IHMA-EFF-DT. 00112802 001142 MOVE RIHMA-IHMA-ADDR1 00114202 001143 TO WIHMA-IHMA-ADDR1. 00114302 001147 MOVE RIHMA-IHMA-CITY-NAME 00114702 001148 TO WIHMA-IHMA-CITY-NAME. 00114802 001152 MOVE RIHMA-IHMA-ST-ABBRV 00115202 001153 TO WIHMA-IHMA-ST-ABBRV. 00115302 001157 MOVE RIHMA-IHMA-ZIP-CODE 00115702 001158 TO WIHMA-IHMA-ZIP-CODE. 00115802 001161 00116100 001162 WRITE IHMA-REC FROM WS-IHMA-REC. 00116202 001163 00116302 001164 OBTAIN NEXT R-IHMA-HIST-MAIL WITHIN S-INST-HISTORY. 00116400 001165 IF DB-END-OF-SET 00116500 001166 MOVE 'Y' TO WS-FIND-ALL-HIST 00116600 001167 ELSE 00116700 001168 PERFORM IDMS-STATUS. 00116800 001169 2700-EXIT. 00116902 001170 EXIT. 00117000 001180 00118000 001190 3000-OBT-R-CONS. 00119002 001191 MOVE RINST-INST-ID 00119102 001192 TO WCONS-INST-ID. 00119202 001193 MOVE RCONS-CONS-TYPE-CODE 00119302 001194 TO WCONS-CONS-TYPE-CODE. 00119402 001195 MOVE RCONS-CONS-ESTBD-DT 00119502 001196 TO WCONS-CONS-ESTBD-DT. 00119602 001197 MOVE RCONS-CONS-END-DT 00119702 001198 TO WCONS-CONS-END-DT. 00119802 001199 MOVE RCONS-CONS-ESTBD-REC-DT 00119902 001200 TO WCONS-CONS-ESTBD-REC-DT. 00120002 001201 MOVE RCONS-CONS-END-REC-DT 00120102 001202 TO WCONS-CONS-END-REC-DT. 00120202 001203 MOVE RCONS-CONS-R-INST-OCC-ASGND-ID 00120302 001204 TO WCONS-CONS-R-INST-OCC-ASGND-ID. 00120402 001205 MOVE RCONS-CONS-P-INST-OCC-ASGND-ID 00120502 001206 TO WCONS-CONS-P-INST-OCC-ASGND-ID. 00120602 001207 00120702 001208 WRITE CONS-REC FROM WS-CONS-REC. 00120802 001209 00120902 001210 OBTAIN NEXT R-CONS-CON-SERV WITHIN S-INST-CONS-RCVS. 00121002 001211 IF DB-END-OF-SET 00121102 001212 MOVE 'Y' TO WS-FIND-ALL-CONS 00121202 001213 ELSE 00121302 001214 PERFORM IDMS-STATUS. 00121402 001215 3000-EXIT. 00121502 001220 EXIT. 00122002 001231 00123100 001232 4000-OBT-ITRN. 00123202 001233 ACCEPT RITRN-DBKEY FROM R-ITRN-INST-TRN CURRENCY. 00123305 001234 IF ANY-ERROR-STATUS 00123405 001235 PERFORM IDMS-STATUS. 00123505 001236 00123605 001237 MOVE RINST-INST-ID 00123702 001238 TO WITRN-INST-ID. 00123802 001239 00123902 001240 MOVE RITRN-ITRN-TYPE-CODE 00124003 001241 TO WITRN-ITRN-TYPE-CODE. 00124103 001242 00124202 001243 MOVE RITRN-ITRN-DT 00124302 001244 TO WITRN-ITRN-DT. 00124402 001245 00124502 001246 OBTAIN OWNER WITHIN S-INST-TRNF-FROM. 00124604 001247 IF DB-STATUS-OK 00124704 001248 MOVE RINST-INST-ID 00124804 001249 TO WITRN-ITRN-INTO-INST-ID 00124904 001250 ELSE 00125004 001251 MOVE '000000000' 00125104 001252 TO WITRN-ITRN-INTO-INST-ID. 00125204 001253 00125304 001254 WRITE ITRN-REC FROM WS-ITRN-REC. 00125404 001255 00125504 001256 4000-OBT-NEXT-ITRN. 00125604 001257 OBTAIN R-ITRN-INST-TRN DB-KEY IS RITRN-DBKEY. 00125705 001258 IF ANY-ERROR-STATUS 00125805 001259 PERFORM IDMS-STATUS. 00125905 001260 00126005 001261 OBTAIN NEXT R-ITRN-INST-TRN WITHIN S-INST-TRNF-TO. 00126104 001262 IF DB-END-OF-SET 00126204 001263 MOVE 'Y' TO WS-FIND-ALL-ITRN 00126304 001264 ELSE 00126404 001265 PERFORM IDMS-STATUS. 00126504 001266 4000-EXIT. 00126604 001267 EXIT. 00126704 001268 00126804 001270 5000-OBT-IOWN. 00127004 001271 ACCEPT RIOWN-DBKEY FROM R-IOWN-INST-OWN CURRENCY. 00127105 001272 IF ANY-ERROR-STATUS 00127205 001273 PERFORM IDMS-STATUS. 00127305 001274 00127405 001275 MOVE WS-HOLD-INST-ID 00127502 001276 TO WIOWN-INST-ID. 00127602 001277 MOVE RIOWN-IOWN-ESTBD-DT 00127702 001278 TO WIOWN-IOWN-ESTBD-DT. 00127802 001280 MOVE RIOWN-IOWN-END-DT 00128002 001281 TO WIOWN-IOWN-END-DT. 00128102 001286 MOVE RIOWN-IOWN-PCT 00128602 001287 TO WIOWN-IOWN-PCT. 00128702 001288 MOVE RIOWN-IOWN-ESTBD-REC-DT 00128802 001289 TO WIOWN-IOWN-ESTBD-REC-DT. 00128902 001295 MOVE RIOWN-IOWN-END-REC-DT 00129502 001296 TO WIOWN-IOWN-END-REC-DT. 00129602 001300 MOVE RIOWN-IOWN-EDP-ESTBD-IND 00130002 001301 TO WIOWN-IOWN-EDP-ESTBD-IND. 00130102 001305 MOVE RIOWN-IOWN-STAT-CODE 00130502 001307 TO WIOWN-IOWN-STAT-CODE. 00130702 001308 00130800 001309 OBTAIN OWNER WITHIN S-INST-IOWN-OWN. 00130900 001310 IF ANY-ERROR-STATUS 00131000 001311 PERFORM IDMS-STATUS. 00131100 001314 00131400 001317 MOVE RINST-INST-ID 00131702 001318 TO WIOWN-IOWN-OWNER-INST-ID. 00131802 001329 00132900 001330 WRITE IOWN-REC FROM WS-IOWN-REC. 00133002 001331 00133102 001333 5000-OBT-NEXT-IOWN. 00133302 001334 OBTAIN R-IOWN-INST-OWN DB-KEY IS RIOWN-DBKEY. 00133400 001335 IF ANY-ERROR-STATUS 00133500 001336 PERFORM IDMS-STATUS. 00133600 001337 00133700 001338 OBTAIN NEXT R-IOWN-INST-OWN WITHIN S-INST-IOWN-BY. 00133802 001342 IF DB-END-OF-SET 00134205 001343 MOVE 'Y' TO WS-FIND-ALL-IOWN 00134305 001344 ELSE 00134405 001345 IF ANY-ERROR-STATUS 00134505 001346 PERFORM IDMS-STATUS. 00134605 001347 5000-EXIT. 00134702 001348 EXIT. 00134802 001349 00134902 001350*----------------------------------------------------------------*00135002 001351 COPY IDMS IDMS-STATUS. 00135102 001352*----------------------------------------------------------------*00135202 001353 IDMS-ABORT SECTION. 00135302 001354 ACCEPT DB-STATISTICS FROM IDMS-STATISTICS. 00135402 001355 DISPLAY '***********************************************'. 00135502 001356 DISPLAY '* EXECUTION ENDED ABNORMALLY '. 00135602 001357 DISPLAY '***********************************************'. 00135702 001358 DISPLAY 'INST-ID ' RINST-INST-ID. 00135810 001359 DISPLAY 'CHARTER ' RINST-INST-OCC-ASGND-ID. 00135910 001360 DISPLAY 'BRANCH ' RINST-INST-OCC-BRANCH-CERT-ID. 00136010 001361 COPY IDMS DISPLAY-STATISTICS. 00136110 001362 IDMS-ABORT-EXIT. 00136210 001370*END**************************************END 00137010