MGT Computer Solutions >>
Services >>
Custom Programming >>
COBOL >> Example ASCII COBOL
This is a listing of program BMCALL, an ASCII COBOL subroutine which is a functional replacement for a subroutine by the same name in IBM's Database Bill of Materials Program (abbr. DBOMP). It was developed as part of a conversion from DBOMP to DMS-1100.
This is a listing of program BMCALL, an ASCII COBOL subroutine which is a functional replacement for a subroutine by the same name in IBM's Database Bill of Materials Program (abbr. DBOMP). It was developed as part of a conversion from DBOMP to DMS-1100.
This was a one-off project, so it took advantage of techniques that would have been out of place in a longer-life application. Because the database being converted was in static structures, meta-information about the database schema was embedded into application-level logic. This approach made programming straightforward, and shortened the project time, but obviously coupled schema-type metadata with application code. A more robust solution would also model DBOMP's data definition capabilities, something that wasn't required here.
This conversion stiil presented several technical issues. One such was that subroutines written in IBM Cobol accept any number of parameters; the number does not have to be specified at compile time. At run time, the calling program can call the same COBOL subroutine several times with a different number of parameters at each call. ASCII COBOL followed the ANS 1974 COBOL standard, which specified that the number of top-level declarations in the Linkage Section fixed the number of parameters required by a subroutine.
To resolve this issue cleanly, a MASM wrapper which adjusted the parameter count on-the-fly for each subroutine call was created and included in the MAP for each executable. The MASM wrapper also wrote the original count of parameters into the subroutine's working storage section, so correct logical information was still available to the subroutine at run time.
The embedded copybooks were authored by the UNISYS client's IT staff, and some code was inserted by the UNISYS ADMLP preprocessor. Other than those, all the code presented here, and the MASM wrapper described above, were authored by staff now with MGT Computer Solutions.
Some modifications have been made to this listing for purposes of confidentiality. These changes have been noted.
1 1 **************************************************************** 0001 2 2 **************************************************************** 0002 3 3 IDENTIFICATION DIVISION. 0003 4 4 **************************************************************** 0004 5 5 **************************************************************** 0005 6 6 * 0006 7 7 PROGRAM-ID. BMCALL. 0007 8 8 * 0008 9 9 AUTHOR. SPERRY. 0009 10 10 * 0010 *** ****** * remainder of this section not shown **** 17 17 * 0017 18 18 * 0018 19 19 ***************************************************************** 0019 20 20 ***************************************************************** 0020 21 21 ENVIRONMENT DIVISION. 0021 22 22 ***************************************************************** 0022 23 23 ***************************************************************** 0023 24 24 * * 0024 25 25 CONFIGURATION SECTION. 0025 26 26 * * 0026 27 27 SOURCE-COMPUTER. UNIVAC-1100. 0027 28 28 *SOURCE-COMPUTER. UNIVAC-1100 WITH DEBUGGING MODE. * 0028 29 29 * * 0029 30 30 OBJECT-COMPUTER. UNIVAC-1100 MEMORY SIZE 4 MODULES. 0030 31 31 * * 0031 32 32 /**************************************************************** 0032 33 33 ***************************************************************** 0033 34 34 DATA DIVISION. 0034 35 35 ***************************************************************** 0035 36 36 ***************************************************************** 0036 37 37 * * 0037 38 38 *SUBSCHEMA SECTION. 0038 39 39 ***************************************************************** 0039 40 40 * * 0040 41 41 *INVOKE SUBSCHEMA DBOMPSUBSCH 0041 42 42 * IN FILE DBOMPSCH OF SCHEMA DBOMPSCHEMA 0042 43 43 * COPYING RECORDS INTO COMMON 0043 44 44 * COPYING DATA-NAMES INTO COMMON 0044 45 45 * DMCA AND RUN-UNIT-STATISTICS ARE COMMON. 0045 46 46 * * 0046 47 47 ***************************************************************** 0047 48 48 /**************************************************************** 0048 49 49 * * 0049 50 50 * W O R K I N G - S T O R A G E S E C T I O N * 0050 51 51 * * 0051 52 52 ***************************************************************** 0052 53 53 WORKING-STORAGE SECTION. 0053 54 54 * * 0054 55 55 01 WS-CHAINADR. 0055 56 56 05 WS-CHAINADR-DBK PIC H9(05). 0056 57 57 05 WS-CHAINADR-XDBK 0057 58 58 REDEFINES WS-CHAINADR-DBK PIC X(02). 0058 59 59 05 WS-CHAINADR-SET PIC X(02). 0059 60 60 05 WS-CHAINADR-DIRECTION PIC X(01). 0060 61 61 05 FILLER PIC X(01). 0061 62 62 01 WS-MISC. 0062 63 63 05 WS-X2 PIC X(02). 0063 64 64 05 WS-H95 REDEFINES WS-X2 PIC H9(05). 0064 65 65 ***************************************************************** 0065 66 66 * * 0066 67 67 * C O M M O N - S T O R A G E S E C T I O N * 0067 68 68 * * 0068 69 69 ***************************************************************** 0069 70 70 COMMON-STORAGE SECTION. 0070 71 71 01 DMS-PS-HDR-AN PIC X(12) USAGE IS DISPLAY. 72 72 01 DMS-SR-HDR-AN PIC X(12) USAGE IS DISPLAY. 73 73 01 DMS-TS-HDR-AN PIC X(12) USAGE IS DISPLAY. 74 74 01 DMSPSKEY1 PIC X(15) USAGE IS DISPLAY. 75 75 01 DMSTSKEY1 PIC X(18) USAGE IS DISPLAY. 76 76 77 CS-DB-AN USAGE IS DISPLAY PIC X(12). 0071 77 77 77 CS-DB-KEY USAGE IS COMP PIC 9(10). 0072 78 78 77 CS-SET-NAME USAGE IS DISPLAY PIC X(30). 0073 79 79 77 CS-REC-NAME USAGE IS DISPLAY PIC X(30). 0074 80 80 01 CS-ENTRY-NAME PIC X(08). 0075 81 81 01 CS-CALLED-FROM PIC X(08). 0076 82 82 01 DMS-PROC-NAME PIC X(30). 0077 83 83 01 CS-FREE-DBOMPSCH-IMG PIC X(24) VALUE 0078 84 84 ' FREE DBOMP*DBOMPSCH. .'. 0079 85 85 01 CS-ACSF-ERSTAT PIC H9(10). 0080 86 86 01 CS-DMS-GEN-ERR-LIT PIC X(20) VALUE 0081 87 87 'DMS GENERAL ERROR'. 0082 88 88 01 CS-ENDP-LIT PIC X(04) VALUE 'END.' . 0083 89 89 01 FILLER PIC X(40). 0084 90 90 01 CS-SWITCHES. 0085 91 91 05 CS-FDPARMC-OPEN PIC SH9(01) VALUE 0. 0086 92 92 05 CS-FDPSRTC-OPEN PIC SH9(01) VALUE 0. 0087 93 93 05 CS-FDWKCTM-OPEN PIC SH9(01) VALUE 0. 0088 94 94 05 CS-FDSRTCG-OPEN PIC SH9(01) VALUE 0. 0089 95 95 05 CS-FDSBMST-OPEN PIC SH9(01) VALUE 0. 0090 96 96 05 CS-FDTLMST-OPEN PIC SH9(01) VALUE 0. 0091 97 97 05 CS-FDTLSTR-OPEN PIC SH9(01) VALUE 0. 0092 98 98 01 WDIMRUN. COPY WDIMRUN. 0093 99 WDIMRU **************************************************************** 100 WDIMRU * COMPANY ITEM MASTER OVERHEAD & DISK RECORD DATA DESCRIPTION * 101 WDIMRU * * * * * * * * * * * * * * * * * * * * * * 102 WDIMRU *MODIFICATIONS 103 WDIMRU * 2-25-86 SPERRY CONVERT WDIMRUN RECORD TO DMS/DBOMP FORMAT 104 WDIMRU * CHANGED: WD-DISK-ADDR FROM X(9) TO H9(10) 105 WDIMRU * CHANGED: WD-FACA, WD-FWUA, WD-FROA, WD-LROA 106 WDIMRU * FROM X(4) TO X(8) SYNC 107 WDIMRU * COMMENTED OUT: WD-OCAA, WD-NMRA, WD-FCOO, WD-RCCO,WD-MSMRA 108 WDIMRU **************************************************************** 109 WDIMRU *01 WDPARTM. 110 WDIMRU 03 WD-STD-PREFIX-IM. 111 WDIMRU 05 WD-FILE-NAME PICTURE X(7) VALUE 'FDPARTM'. 112 WDIMRU 05 WD-PROCESS-IND PICTURE X(4). 113 WDIMRU 05 WD-ERR-BYTE. 114 WDIMRU 07 WD-ERR-B1 PICTURE X. 115 WDIMRU 07 WD-ERR-B2 PICTURE X. 116 WDIMRU 05 WD-DISK-ADDR PICTURE H9(10). 117 WDIMRU 05 WD-KEY-ARG PICTURE X(15). 118 WDIMRU *THIS DATA-NAME FOR COMPATIBILITY ONLY. DO NOT USE IN NEW PGM'G. 119 WDIMRU 03 WD-STD-PREFIX REDEFINES WS-STD-PREFIX-IM 120 WDIMRU PIC X(32). 121 WDIMRU 03 WD-DISK-RECORD-IM. 122 WDIMRU 05 WD-BM-OVRHD-IM. 123 WDIMRU * 07 WD-OCAA PICTURE X(4). 124 WDIMRU 07 WD-PART-NO. 125 WDIMRU 09 FIL-IM-00500 PICTURE X(6). 126 WDIMRU 09 WD-CPPN-IM PICTURE XXX. 127 WDIMRU *THIS DATA-NAME FOR COMPATIBILITY ONLY. DO NOT USE IN NEW PGM'G. 128 WDIMRU 09 WD-CPPN REDEFINES WD-CPPN-IM 129 WDIMRU PIC XXX. 130 WDIMRU 09 FIL-IM-00700 PICTURE X(6). 131 WDIMRU 07 WD-FACA PICTURE X(8) SYNC. 132 WDIMRU 07 WD-FWUA PICTURE X(8) SYNC. 133 WDIMRU 07 WD-FROA PICTURE X(8) SYNC. 134 WDIMRU 07 WD-LROA PICTURE X(8) SYNC. 135 WDIMRU 07 WD-RCAC PICTURE XX. 136 WDIMRU 07 WD-RCWU PICTURE XX. 137 WDIMRU 07 WD-DEL-TAG-IM. 138 WDIMRU 09 WD-LLC PICTURE S999 COMP. 139 WDIMRU *THIS DATA-NAME FOR COMPATIBILITY ONLY. DO NOT USE IN NEW PGM'G. 140 WDIMRU 07 WD-DEL-TAG REDEFINES WD-DEL-TAG-IM 141 WDIMRU PIC XX. 142 WDIMRU * 07 WD-MNRA PICTURE X(4). 143 WDIMRU 07 WD-CPMR PICTURE XXX. 144 WDIMRU 07 WD-RACN PICTURE XX. 145 WDIMRU 07 WD-RCRO PICTURE XX. 146 WDIMRU * 07 WD-FCOO PICTURE X(4). 147 WDIMRU * 07 WD-RCC0 PICTURE XX. 148 WDIMRU * 07 WD-MSMRA PICTURE X(4). 149 WDIMRU *WD-BM-OVRHD FOR COMPATIBILITY ONLY. DO NOT USE IN NEW PGM'G. 150 WDIMRU 05 WD-BM-OVRHD REDEFINES WD-BMOVRHD-IM 151 WDIMRU PIC X(61). 152 WDIMRU 05 WD-BM-USERS. *** ****** * remainder of this record not shown **** 505 WDIMRU *THIS DATA-NAME FOR COMPATIBILITY ONLY. DO NOT USE IN NEW PGM'G. 506 WDIMRU 03 WD-DISK-RECORD REDEFINES WD-DISK-RECORD-IM 507 WDIMRU PIC X(745). 508 99 01 WDIMRUN-LEN-FLG PIC H9(10). 0094 509 100 01 WDPSRUN. COPY WDPSRUN. 0095 510 WDPSRU **************************************************************** 511 WDPSRU *PRODUCT STRUCTURE PREFIX & DISK RECORD DATA DESCRIPTION 512 WDPSRU * * * * * * * * * * * * * * * * * * * * * * 513 WDPSRU *MODIFICATION 514 WDPSRU * 2-25-86 SPERRY CONVERT WDPSRUN RECORD TO DMS/DBOMP FORMAT 515 WDPSRU * CHANGED: WD-DISK-ADDR FROM X(9) TO H9(10) 516 WDPSRU * CHANGED: WDPS-CMRA, WDPS-NACA, WDPS-PMRA, WDPS-NWUA, 517 WDPSRU * WDPS-PWUA FROM X(4) TO X(8) SYNC 518 WDPSRU **************************************************************** 519 WDPSRU *01 WDPSRUN. 520 WDPSRU 03 WDPS-STD-PREFIX. 521 WDPSRU 05 WDPS-FILE-NAME PICTURE X(7) VALUE 'FDPARTM'. 522 WDPSRU 05 WDPS-PROCESS-IND PICTURE X(4). 523 WDPSRU 05 WDPS-ERR-BYTE. 524 WDPSRU 07 WDPS-ERR-B1 PICTURE X. 525 WDPSRU 07 WDPS-ERR-B2 PICTURE X. 526 WDPSRU 05 WDPS-DISK-ADDR PICTURE H9(10). 527 WDPSRU 05 WDPS-KEY-ARG PICTURE X(15). 528 WDPSRU 03 WDPS-DISK-RECORD. 529 WDPSRU 05 WDPS-OVRHD. 530 WDPSRU 07 WDPS-CMRA PICTURE X(8) SYNC. 531 WDPSRU 07 WDPS-NACA PICTURE X(8) SYNC. 532 WDPSRU 07 WDPS-PMRA PICTURE X(8) SYNC. 533 WDPSRU 07 WDPS-NWUA PICTURE X(8) SYNC. 534 WDPSRU 07 WDPS-PWUA PICTURE X(8) SYNC. 535 WDPSRU 07 WDPS-CPC PICTURE XXX. 536 WDPSRU 07 WDPS-CPP PICTURE XXX. 537 WDPSRU 05 WDPS-USER-AREA. 538 WDPSRU 07 FILLER PICTURE X. 539 WDPSRU 07 QTY PICTURE S999V9(5) COMP. 540 WDPSRU 07 SRSC0 PICTURE X. 541 WDPSRU 07 SPSSF PICTURE S9V99 COMP. 542 WDPSRU 07 SPSOA PICTURE S999 COMP. 543 WDPSRU 07 WDPS-REV-AUTH PIC X(14). 544 WDPSRU 07 WDPS-REACT-CD PIC X. 545 WDPSRU 07 WDPS-EC PIC X. 546 WDPSRU 07 WDPS-LT-ADJ PIC 99. 547 WDPSRU 07 FILLER PIC X. 548 WDPSRU 07 WDPS-EFF-FROM-DATE PIC S9(7) COMP. 549 WDPSRU 07 FILLER PIC X. 550 WDPSRU 07 WDPS-EFF-TO-DATE PIC S9(7) COMP. 551 WDPSRU 07 FILLER PIC X. 552 WDPSRU 07 WDPS-REACT-DATE PIC S9(7) COMP. 553 WDPSRU 07 WD-TRAN-SEQ-PS PICTURE S999 COMP. 554 101 01 WDPSRUN-LEN-FLG PIC H9(10). 0096 555 102 01 WDWKCTM. COPY WDWKCTM. 0097 556 WDWKCT **************************************************************** 557 WDWKCT *WORK CENTER PREFIX & DISK RECORD DATA DESCRIPTION 558 WDWKCT * * * * * * * * * * * * * * * * * * * * * * 559 WDWKCT *MODIFICATION 560 WDWKCT * 2-25-86 SPERRY CONVERT WDWKCTM RECORD TO DMS/DBOMP FORMAT 561 WDWKCT * CHANGED: WD-DISK-ADDR FROM X(9) TO H9(10) 562 WDWKCT * CHANGED: WD-FOWA FROM X(4) TO X(8) SYNC 563 WDWKCT * COMMENTED OUT: WD-OSCA 564 WDWKCT **************************************************************** 565 WDWKCT *01 WDWKCTM. 566 WDWKCT 03 WD-STD-PREFIX-WC. 567 WDWKCT 05 WD-FILE-NAME PICTURE X(7) VALUE 'FDWKCTM'. 568 WDWKCT 05 WD-PROCESS-IND PICTURE X(4). 569 WDWKCT 05 WD-ERR-BYTE. 570 WDWKCT 07 WD-ERR-B1 PICTURE X. 571 WDWKCT 07 WD-ERR-B2 PICTURE X. 572 WDWKCT 05 WD-DISK-ADDR PICTURE H9(10). 573 WDWKCT 05 WD-KEY-ARG PICTURE X(15). 574 WDWKCT *WD-STD-PREFIX FOR COMPATIBILITY ONLY. DO NOT USE FOR NEW PGM'G. 575 WDWKCT 03 WD-STD-PREFIX REDEFINES WD-STD-PREFIX-WC 576 WDWKCT PIC X(21). 577 WDWKCT 03 WD-DISK-RECORD-WC. 578 WDWKCT 05 WD-BM-OVRHD-WC. 579 WDWKCT * 07 WD-OSCA PICTURE X(4). 580 WDWKCT 07 WD-WCID. 581 WDWKCT 09 WD-KEY. 582 WDWKCT 11 FIL-WC-00700 PIC XXX. 583 WDWKCT 11 W0-CPWC-WC PIC X. 584 WDWKCT *WD-CPWC FOR COMPATIBILITY ONLY. DO NOT USE FOR NEW PGM'G. 585 WDWKCT 11 W0-CPWC-WC REDEFINES W0-CPWC-WC 586 WDWKCT PIC X. 587 WDWKCT 07 WD-FOWA PICTURE X(8) SYNC. 588 WDWKCT 07 WD-FOWR PICTURE XX. 589 WDWKCT *WD-BM-OVRHD FOR COMPATIBILITY ONLY. DO NOT USE FOR NEW PGM'G. 590 WDWKCT 05 WD-BM-OVRHD REDEFINES WD-BM-OVRHD-WC 591 WDWKCT PIC X(17). 592 WDWKCT 05 WD-USERS-WC. *** ****** * remainder of this record not shown **** 613 WDWKCT *WD-USERS FOR COMPATIBILITY ONLY. DO NOT USE FOR NEW PGM'G. 614 WDWKCT 05 WD-USERS REDEFINES WD-USERS-WC 615 WDWKCT PIC X(303). 616 103 01 WDWKCTM-LEN-FLG PIC H9(10). 0098 617 104 01 WDSRTGC. COPY WDSRTGC. 0099 618 WDSRTG **************************************************************** 619 WDSRTG *STANDARD ROUTING PREFIX & DISK RECORD DATA DESCRIPTION 620 WDSRTG * * * * * * * * * * * * * * * * * * * * * * 621 WDSRTG *MODIFICATION 622 WDSRTG * 2-25-86 SPERRY CONVERT WDSRTGC RECORD TO DMS/DBOMP FORMAT 623 WDSRTG * CHANGED: WD-DISK-ADDR FROM X(9) TO H9(10) 624 WDSRTG * CHANGED: WD-PTMA, WD-NOPA, WD-POPA, WD-WOMA, WD-WCNE 625 WDSRTG * WD-WCPR FROM X(4) TO X(8) SYNC 626 WDSRTG **************************************************************** 627 WDSRTG *01 WDSRTGC. 628 WDSRTG 03 WD-STD-PREFIX-SR. 629 WDSRTG 05 WD-FILE-NAME PICTURE X(7) VALUE 'FDSRTGC'. 630 WDSRTG 05 WD-PROCESS-IND PICTURE X(4). 631 WDSRTG 05 WD-ERR-BYTE. 632 WDSRTG 07 WD-ERR-B1 PICTURE X. 633 WDSRTG 07 WD-ERR-B2 PICTURE X. 634 WDSRTG 05 WD-DISK-ADDR PICTURE H9(10). 635 WDSRTG *WD-STD-PREFIX FOR COMPATIBILITY ONLY. DO NOT USE FOR NEW PGM'G. 636 WDSRTG 03 WD-STD-PREFIX REDEFINES WD-STD-PREFIX-SR 637 WDSRTG PIC X(17). 638 WDSRTG 03 WD-DISK-RECORD-SR. 639 WDSRTG 05 WD-BM-OVRHD-SR. 640 WDSRTG 07 WD-CPPN-SR PICTURE XXX. 641 WDSRTG *WD-CPPN FOR COMPATIBILITY ONLY. DO NOT USE IN NEW PGM'G. 642 WDSRTG 07 WD-CPPN REDEFINES WD-CPPN-SR PICTURE XXX. 643 WDSRTG 07 WD-OPNO. 644 WDSRTG 09 WD-PRC-MD PICTURE X. 645 WDSRTG 09 WD-OP-SEQ PICTURE 999. 646 WDSRTG 09 WD-RC-SEQ PICTURE X. 647 WDSRTG 07 WD-PTMA PICTURE X(8) SYNC. 648 WDSRTG 07 WD-NOPA PICTURE X(8) SYNC. 649 WDSRTG 07 WD-POPA PICTURE X(8) SYNC. 650 WDSRTG 07 WD-WCMA PICTURE X(8) SYNC. 651 WDSRTG 07 WD-WCNE PICTURE X(8) SYNC. 652 WDSRTG 07 WD-WCPR PICTURE X(8) SYNC. 653 WDSRTG 07 WD-CPWC-SR PICTURE X. 654 WDSRTG *WD-CPWC FOR COMPATIBILITY ONLY. DO NOT USE IN NEW PGM'G. 655 WDSRTG 07 WD-CPWC REDEFINES WD-CPWC-SR PIC X. 656 WDSRTG *WD-BM-OVRHD FOR COMPATIBILITY ONLY. DO NOT USE IN NEW PGM'G. 657 WDSRTG 05 WD-BM-OVRHD REDEFINES WD-BM-OVRHD-SR 658 WDSRTG PIC X(60). 659 WDSRTG 05 WD-USERS-SR. *** ****** * remainder of this record not shown **** 697 105 01 WDSRTGC-LEN-FLG PIC H9(10). 0100 698 106 01 WDSBMST. COPY WDSBMST. 0101 699 WDSBMS **************************************************************** 700 WDSBMS *SUBORDINATE MASTER PREFIX & DISK RECORD DATA DESCRIPTION 701 WDSBMS * * * * * * * * * * * * * * * * * * * * * * 702 WDSBMS *MODIFICATION 703 WDSBMS * 2-25-86 SPERRY CONVERT WDSRTGC RECORD TO DMS/DBOMP FORMAT 704 WDSBMS * CHANGED: WD-DISK-ADDR FROM X(9) TO H9(10) 705 WDSBMS * COMMENTED OUT: WD-OSCA 706 WDSBMS **************************************************************** 707 WDSBMS *01 WDSBMST. 708 WDSBMS 02 WD-STD-PREFIX-SM. 709 WDSBMS 05 WD-FILE-NAME PICTURE X(7) VALUE 'FDSBMST'. 710 WDSBMS 05 WD-PROCESS-IND PICTURE X(4). 711 WDSBMS 05 WD-ERR-BYTE. 712 WDSBMS 07 WD-ERR-B1 PICTURE X. 713 WDSBMS 07 WD-ERR-B2 PICTURE X. 714 WDSBMS 05 WD-DISK-ADDR PICTURE H9(10). 715 WDSBMS 05 WD-KEY-ADRG PIC X(15). 716 WDSBMS *WD-STD-PREFIX FOR COMPATIBILITY ONLY. DO NOT USE IN NEW PGM'G. 717 WDSBMS 02 WD-STD-PREFIX REDEFINES WD-STD-PREFIX-SM PIC X(32). 718 WDSBMS 02 SB-MAST. 719 WDSBMS 03 SB-OSCA PIC X(4). 720 WDSBMS 03 SB-ITNO PIC X(15). 721 WDSBMS 03 SB-DLTG PIC 99. 722 WDSBMS 03 SB-GRRQ OCCURS 2 TIMES. 723 WDSBMS 05 FILLER PIC 9(02) COMP. 724 WDSBMS 05 SB-GRDT PIC S9(7) COMP. 725 WDSBMS 05 FILLER PIC 9(02) COMP. 726 WDSBMS 05 SB-GRON PIC S9(7) COMP. 727 WDSBMS 03 SB-OPOR-R. 728 WDSBMS 04 SB-OPOR OCCURS 12 TIMES. 729 WDSBMS 05 SB-OONO PIC X(6). 730 WDSBMS 05 SB-OOPL PIC X(6). 731 WDSBMS 05 FILLER PIC 9(02) COMP. 732 WDSBMS 05 SB-00DE PIC S9(7) COMP. 733 WDSBMS 05 FILLER PIC 9(02) COMP. 734 WDSBMS 05 SB-00DA PIC S9(7) COMP. 735 WDSBMS 05 FILLER PIC 9(02) COMP. 736 WDSBMS 05 SB-00QN PIC S9(7) COMP. 737 WDSBMS 03 SB-PLOR. 738 WDSBMS 05 FILLER PIC 9(02) COMP. 739 WDSBMS 05 SB-PODT PIC S9(7) COMP. 740 WDSBMS 05 SB-PODT-R REDEFINES SB-PODT PIC XXX. 741 WDSBMS 05 FILLER PIC 9(02) COMP. 742 WDSBMS 05 SB-POQN PIC S9(7) COMP. 743 WDSBMS 03 MRACF PIC X. 744 WDSBMS 03 FIL-SM-02100 PIC X(6). 745 107 01 WDSBMST-LEN-FLG PIC H9(10). 0102 746 108 01 WDTLMST. COPY WDTLMST. 0103 747 WDTLMS **************************************************************** 748 WDTLMS *TOOL MASTER PREFIX & DISK RECORD DATA DESCRIPTION 749 WDTLMS * * * * * * * * * * * * * * * * * * * * * * 750 WDTLMS *MODIFICATION 751 WDTLMS * 2-25-86 SPERRY CONVERT WDSRTGC RECORD TO DMS/DBOMP FORMAT 752 WDTLMS * CHANGED: WD-DISK-ADDR FROM X(9) TO H9(10) 753 WDTLMS * CHANGED: TM-FACA, TMM-FWUA FROM X(4) TO X(8) SYNC 754 WDTLMS * COMMENTED OUT: TM-OCAA, TM-NMRA 755 WDTLMS **************************************************************** 756 WDTLMS *01 WDTLMST. 757 WDTLMS 05 TS-STD-PREFIX-IM. 758 WDTLMS 10 TM-FILE-NAME PICTURE X(7) VALUE 'FDTLMST'. 759 WDTLMS 10 TM-PROCESS-IND PICTURE X(4). 760 WDTLMS 10 TM-ERR-BYTE. 761 WDTLMS 15 TM-ERR-B1 PICTURE X. 762 WDTLMS 15 TM-ERR-B2 PICTURE X. 763 WDTLMS 10 TM-DISK-ADDR PICTURE H9(10). 764 WDTLMS 10 TM-KEY-ADRG PIC X(18). 765 WDTLMS 05 TM-DISK-RECORD. 766 WDTLMS 10 TM-BM-OVRHD. 767 WDTLMS 15 TM-KEY. 768 WDTLMS 20 TM-TOOL-NO. 769 WDTLMS 25 FIL-TM-00800 PIC X(6). 770 WDTLMS 25 TM-CPPN PIC XXX. 771 WDTLMS 25 FIL-TM-00500 PIC X(6). 772 WDTLMS 20 TM-OPER-SEQ PIC XXX. 773 WDTLMS 15 TM-FACA PIC X(8) SYNC. 774 WDTLMS 15 TM-RCAC PIC XX. 775 WDTLMS 15 TM-RCAC-BINARY REDEFINES TM-RCAC 776 WDTLMS PIC S9(4) COMP. 777 WDTLMS 15 TM-FWUA PIC X(8) SYNC. 778 WDTLMS 15 TM-RCWU PIC XX. 779 WDTLMS 15 TM-RCWU-BINARY REDEFINES TM-RCWU 780 WDTLMS PIC S9(4) COMP. 781 WDTLMS 15 TM-DEL-TAG PIC X(8) SYNC. 782 WDTLMS 20 TM-NMRA PIC X(4). 783 WDTLMS 15 TM-NMRA PIC X(4). 784 WDTLMS 15 TM-CPMR PIC XXX. 785 WDTLMS 15 TM-RACN PIC XX. 786 WDTLMS 10 TM-BM-USERS. *** ****** * remainder of this record not shown **** 826 109 01 WDTLMST-LEN-FLG PIC H9(10). 0104 827 110 01 WDTLSTR. COPY WDTLSTR. 0105 828 WDTLST **************************************************************** 829 WDTLST *TOOL STRUCTURE PREFIX & DISK RECORD DATA DESCRIPTION 830 WDTLST * * * * * * * * * * * * * * * * * * * * * * 831 WDTLST *MODIFICATION 832 WDTLST * 2-25-86 SPERRY CONVERT WDSRTGC RECORD TO DMS/DBOMP FORMAT 833 WDTLST * CHANGED: WD-DISK-ADDR FROM X(9) TO H9(10) 834 WDTLST * CHANGED: TS-CMRA, TS-NACA, TS-PMRA, TS-NWUA, TS-PWUA 835 WDTLST * FROM X(4) TO X(8) SYNC 836 WDTLST **************************************************************** 837 WDTLST *01 WDTLSTR. 838 WDTLST 05 TS-STD-PREFIX-IM. 839 WDTLST 10 TS-FILE-NAME PICTURE X(7) VALUE 'FDTLSTR'. 840 WDTLST 10 TS-PROCESS-IND PICTURE X(4). 841 WDTLST 10 TS-ERR-BYTE. 842 WDTLST 15 TS-ERR-B1 PICTURE X. 843 WDTLST 15 TS-ERR-B2 PICTURE X. 844 WDTLST 10 TS-DISK-ADDR PICTURE H9(10). 845 WDTLST 10 TS-KEY-ADRG PIC X(18). 846 WDTLST 05 TS-DISK-RECORD. 847 WDTLST 10 TS-OVRHD. 848 WDTLST 15 TS-CMRA PICTURE X(8) SYNC. 849 WDTLST 15 TS-NACA PICTURE X(8) SYNC. 850 WDTLST 15 TS-PMRA PICTURE X(8) SYNC. 851 WDTLST 15 TS-NWUA PICTURE X(8) SYNC. 852 WDTLST 15 TS-PWUA PICTURE X(8) SYNC. 853 WDTLST 15 TS-CPC PICTURE XXX. 854 WDTLST 15 TS-CPP PICTURE XXX. 855 WDTLST 10 TS-USER-AREA. 856 WDTLST 15 TS-QTY PICTURE S999 COMPUTATIONAL. 857 WDTLST 15 FIL-TS-01200 PICTURE X(22). 858 111 01 WDTLSTR-LEN-FLG PIC H9(10). 0106 859 112 /*************************************************************** 0107 860 113 * * 0108 861 114 * D M C A A N D D A T A B A S E R E C O R D S * 0109 862 115 * * 0110 863 116 /*************************************************************** 0111 864 117 * 0112 865 118 01 DMCA. 866 119 02 FILLER PIC 1(36) VALUE IS 09786434904. 867 120 02 FILLER PIC 1(36) VALUE IS 08810733957. 868 121 02 FILLER PIC 1(36) VALUE IS 09786434904. 869 122 02 FILLER PIC 1(36) VALUE IS 28041752997. 870 123 02 FILLER PIC 1(36) VALUE IS 09786434904. 871 124 02 FILLER PIC 1(36) VALUE IS 08809369925. 872 125 02 FILLER PIC 1(36) VALUE IS 05453926725. 873 126 02 FILLER PIC 1(36) VALUE IS 05521522165. 874 127 02 FILLER USAGE COMP PIC 9(10) 875 128 VALUE IS 0. 876 129 02 COMMAND-SEQ-NUM USAGE IS COMP PIC 9(5) 877 130 VALUE IS 0. 878 131 02 QUICK-BEF-LOOKS PIC 1(6) VALUE IS 0. 879 132 02 FILLER PIC 1(3) VALUE IS 0. 880 133 02 IMPART-DEPART USAGE IS DISP PIC X(1) 881 134 VALUE IS 0. 882 135 02 RESERVED-WORD-AREA. 883 136 03 AREA-NAME USAGE IS DISP PIC X(12). 884 137 03 AREA-KEY USAGE IS COMP. 885 138 04 PAGE-NUM PIC 9(5). 886 139 04 RECORD-NUM PIC 9(5). 887 140 03 RECORD-NAME USAGE IS DISP PIC X(30). 888 141 03 FILLER USAGE IS DISP PIC X(2) 889 142 VALUE IS LOW-VALUE. 890 143 03 SET-NAME USAGE IS DISP PIC X(30). 891 144 03 FILLER USAGE IS DISP PIC X(2) 892 145 VALUE IS LOW-VALUE. 893 146 03 PRIORITY USAGE IS COMP PIC 9(10) 894 147 VALUE IS 0000000000. 895 148 03 DATABASE-KEY USAGE IS COMP PIC 9(10). 896 149 03 CURRENT-AREA-NAME USAGE IS DISP PIC X(12). 897 150 03 CURRENT-AREA-KEY USAGE IS COMP. 898 151 04 PAGE-NUM PIC 9(5). 899 152 04 RECORD-NUM PIC 9(5). 900 153 03 ERROR-AREA USAGE IS DISP PIC X(12). 901 154 03 ERROR-RECORD USAGE IS DISP PIC X(30). 902 155 03 FILLER USAGE IS DISP PIC X(2) 903 156 VALUE IS LOW-VALUE. 904 157 03 ERROR-SET USAGE IS DISP PIC X(30). 905 158 03 FILLER USAGE IS DISP PIC X(2) 906 159 VALUE IS LOW-VALUE. 907 160 03 ERROR-STATUS USAGE IS DISP. 908 161 04 RB-ERROR-CODE PIC X(2). 909 162 04 ERROR-FUNCTION PIC X(2). 910 163 04 ERROR-STATUS PIC X(2) 911 164 VALUE IS '21'. 912 165 03 FILLER USAGE IS DISP PIC X(2) 913 166 VALUE IS LOW-VALUE. 914 167 03 ERROR-NUM USAGE IS DISP PIC X(4) 915 168 VALUE IS '0021'. 916 169 02 IO-ERROR-STATUS USAGE IS COMP PIC 9(5). 917 170 02 QUEUE-ERR-STATUS USAGE IS COMP PIC 9(5). 918 171 02 FILLER PIC 1(36). 919 172 02 FILLER PIC 1(36) VALUE IS 5453926725. 920 173 02 RUN-UNIT-ID PIC 1(36) VALUE IS 05453926725. 921 174 02 FILLER PIC 1(36) VALUE IS 29115918173. 922 175 02 FAC-REQ-ERROR-STATUS 923 176 PIC 1 OCCURS 36 TIMES. 924 177 02 DMR-LEV-NUM USAGE IS DISP PIC X(8), 925 178 02 DMR-MODE PIC 1(36) 926 179 VALUE IS 0. 927 180 02 FILLER USAGE IS DISP PIC X(8) 928 181 VALUE IS LOW-VALUE. 929 182 02 FILLER USAGE IS COMP PIC 9(5) 930 183 VALUE IS 71 . 931 184 02 FILLER USAGE IS COMP PIC 9(5) 932 185 VALUE IS 84 . 933 186 02 NUM-ERROR-ITEMS USAGE IS COMP PIC 9(5) 934 187 VALUE IS 0. 935 188 02 ERR-ITEM-SIZE USAGE IS COMP PIC 9(5) 936 189 VALUE IS 8. 937 190 02 RUN-UNIT-STATISTICS. 938 191 03 COMMAND-STATISTICS USAGE IS COMP. 939 192 04 CLOSE-COUNT PIC 9(5). 940 193 04 DELETE-COUNT PIC 9(5). 941 194 04 FIND-COUNT PIC 9(5). 942 195 04 FREE-COUNT PIC 9(5). 943 196 04 GET-COUNT PIC 9(5). 944 197 04 KEEP-COUNT PIC 9(5). 945 198 04 INSERT-COUNT PIC 9(5). 946 199 04 MODIFY-COUNT PIC 9(5). 947 200 04 OPEN-COUNT PIC 9(5). 948 201 04 FILLER PIC 9(5) 949 202 VALUE IS ZERO. 950 203 04 REMOVE-COUNT PIC 9(5). 951 204 04 STORE-COUNT PIC 9(5). 952 205 04 DEPART-COUNT PIC 9(5). 953 206 04 IF-COUNT PIC 9(5). 954 207 04 IMPART-COUNT PIC 9(5). 955 208 04 MOVE-COUNT PIC 9(5). 956 209 04 LOG-COUNT PIC 9(5). 957 210 04 FILLER PIC 9(5) 958 211 VALUE IS ZERO. 959 212 04 ACQUIRE-COUNT PIC 9(5). 960 213 04 FILLER PIC 9(5) 961 214 VALUE IS ZERO. 962 215 04 FILLER PIC 9(10) 963 216 VALUE IS ZERO. 964 217 04 FILLER PIC 9(10) 965 218 VALUE IS ZERO. 966 219 04 FILLER PIC 9(5) 967 220 VALUE IS ZERO. 968 221 04 FILLER PIC 9(5) 969 222 VALUE IS ZERO. 970 223 03 QUEUE-STATISTICS USAGE IS COMP. 971 224 04 TABLE-COUNT PIC 9(5). 972 225 04 PAGE-COUNT PIC 9(5). 973 226 04 AREA-COUNT PIC 9(5). 974 227 04 LRI-COUNT PIC 9(5). 975 228 04 TRL-COUNT PIC 9(5). 976 229 04 USAGE-LOCK-COUNT PIC 9(5). 977 230 04 I-0-COUNT PIC 9(5). 978 231 04 CORE-LOCK-COUNT PIC 9(5). 979 232 04 CURRETN-LOCK-COUNT PIC 9(5). 980 233 04 CORE-ALLOCATION-COUNT PIC 9(5). 981 234 04 ROLLBACK-BUFFER-COUNT PIC 9(5). 982 235 04 TIP-PAGE-COUNT PIC 9(5). 983 236 04 OVERLAY-COUNT PIC 9(5). 984 237 04 SEGMENT-COUNT PIC 9(5). 985 238 04 CURRENT-LOCK-COUNT2 PIC 9(5). 986 239 04 USAGE-LOCK-COUNT2 PIC 9(5). 987 240 04 CKECKPOINT-COUNT PIC 9(5). 988 241 04 QUEUE-CNT-DOWN PIC 9(5). 989 242 04 FILLER PIC 9(5) 990 243 VALUE IS ZERO. 991 244 03 FILLER PIC X(30) 992 245 VALUE IS ZERO. 993 246 01 DMSIMRUN. 994 247 05 DMS-IM-KEY PICTURE X(15). 995 248 05 DMS-BM-OVRHD. 996 249 07 DMS-RCAC PICTURE XX. 997 250 07 DMS-RCWU PICTURE XX. 998 251 07 DMS-DEL-TAG-IM PICTURE XX. 999 252 07 DMS-CPMR PICTURE XXX. 1000 253 07 DMS-RACN PICTURE XX. 1001 254 07 DMS-RCRO PICTURE XX. 1002 255 05 DMS-BM-USERS PICTURE X(684). 1003 256 01 DMSPSRUN. 1004 257 05 DMSPS-KEY-ARG PICTURE X(15). 1005 258 05 DMSPS-OVRHD. 1006 259 07 DMSPS-CPC PICTURE XXX. 1007 260 07 DMSPS-CPP PICTURE XXX. 1008 261 05 DMSPS-USER-AREA PICTURE X(44). 1009 262 01 DMSWKCTM. 1010 263 05 DMS-WCTR-NO PICTURE X(04). 1011 264 05 DMS-BM-OVRHD-WC. 1012 265 07 DMS-KEY-WC. 1013 266 09 FIL-WC-00700 PICTURE XXX. 1014 267 09 DMS-CPWC-WC PICTURE X. 1015 268 07 DMS-FOWR PICTURE XX. 1016 269 05 DMS-USERS-WC PICTURE X(286). 1017 270 01 DMSSRTGC. 1018 271 05 DMS-BM-OVRHD-SR. 1019 272 07 DMS-CPPN-SR PICTURE XXX. 1020 273 07 DMS-OPNO. 1021 274 09 DMS-PRC-MD PICTURE X. 1022 275 09 DMS-OP-SEQ PICTURE 999. 1023 276 09 DMS-RC-SEQ PICTURE X. 1024 277 07 DMS-CPWC-SR PICTURE X. 1025 278 05 DMS-USERS-SR PICTURE X(156). 1026 279 01 DMSSBMST. 1027 280 05 DMS-SUBM-KEY PICTURE X(15). 1028 281 05 DMS-SB-MAST PICTURE X(612). 1029 282 01 DMS-PS-HDR. 1030 283 05 DMS-PS-KEY PICTURE X(15). 1031 284 01 DMS-SR-HDR-IM. 1032 285 05 DMS-SR-KEY-IM PICTURE X(15). 1033 286 01 DMS-SR-HDR-WC. 1034 287 05 DMS-SR-KEY-WC PICTURE X(04). 1035 288 01 DMSTLMST. 1036 289 05 DMS-TM-KEY PICTURE X(18). 1037 290 05 DMS-BM-OVRHD-TM. 1038 291 07 DMS-RCAC-TM PICTURE XX. 1039 292 07 DMS-RCWU-TM PICTURE XX. 1040 293 07 DMS-DEL-TAG-TM PICTURE XX. 1041 294 07 DMS-CPMR-TM PICTURE XXX. 1042 295 07 DMS-RACN-TM PICTURE XX. 1043 296 05 DMS-TM-USERS PICTURE X(255). 1044 297 01 DMSTLSTR. 1045 298 05 DMS-KEY-ARG-TS PICTURE X(18). 1046 299 05 DMS-OVRHD-TS. 1047 300 07 DMS-CPC-TS PICTURE XXX. 1048 301 07 DMS-CPP-TS PICTURE XXX. 1049 302 05 DMS-USER-AREA-TS PICTURE X(24). 1050 303 01 DMS-TS-HDR. 1051 304 05 DMS-TS-KEY PICTURE X(18). 1052 305 LINKAGE SECTION. 0113 1053 306 01 PARM1. COPY PARM1. 0114 1054 PARM1 *01 PARM1. 1055 PARM1 03 PARM1-HDR. 1056 PARM1 05 PARM1-FILE-NAME PIC X(07). 1057 PARM1 05 PARM1-PROCESS-IND PIC X(04). 1058 PARM1 05 PARM1-ERR-BYTE PIC X(02). 1059 PARM1 05 PARM1-DISK-ADDR PIC H9(10). 1060 PARM1 03 PARM1-DATA PIC X(1500). 1061 307 01 PARM2 PIC X(08). 0115 1062 308 /*************************************************************** 0116 1063 309 **************************************************************** 0117 1064 310 PROCEDURE DIVISION 0118 1065 311 USING PARM1 PARM2. 0119 1066 312 * 0120 1067 313 DMONITOR-PARA. 0121 1068 314 D MONITOR ALL. 0122 1069 315 * 0123 1070 316 BMCALL. 0124 1071 317 * 0125 1072 318 * 0126 1073 319 MOVE 'BMCALL' TO CS-ENTRY-NAME. 0127 1074 320 IF PARM1-PROCESS-IND = 'EXPN' 0128 1075 321 PERFORM 2000-EXPN 0129 1076 322 THRU 2000-EXPN-EXIT 0130 1077 323 ELSE IF PARM1-PROCESS-IND = 'MDIR' OR 'MUPD' OR 0131 1078 324 'CUPD' OR 'FREE' OR 'KEEP' 0132 1079 325 PERFORM 6700-DBOMP-CALL-SETUP 0133 1080 326 CALL 'BMPFO' USING PARM1 0134 1081 327 PERFORM 6800-DBOMP-CALL-RETURN 0135 1082 328 ELSE 0136 1083 329 DISPLAY 'BMPCALL USING INVALID PROCESS INDICATOR' 0137 1084 330 UPON PRINTER 0138 1085 331 CALL 'BZCANCEL'. 0139 1086 332 * 0140 1087 333 GO TO 6999-EXIT. 0141 1088 334 / 0142 1089 335 2000-EXPN. 0143 1090 336 * 0144 1091 337 MOVE PARM2 TO WS-CHAINADR. 0145 1092 338 IF WS-CHAINADR = 'END.' 0146 1093 339 MOVE ZEROS TO PARM1-DISK-ADDR 0147 1094 340 GO TO 2000-EXPN-EXIT. 0148 1095 341 MOVE WS-CHAINADR-DBK TO CS-DB-KEY. 0149 1096 342 PERFORM 7492-FIND-DBKEY 0150 1097 343 THRU 7492-FIND-DBKEY-EXIT. 0151 1098 344 IF WS-CHAINADR-SET = 'WU' 0152 1099 345 MOVE 'IM-WU-SET' TO CS-SET-NAME 0153 1100 346 * MOVE 'IM-COMP-SET' TO CS-OTHER-SET 0154 1101 347 MOVE 'DMSPSRUN' TO CS-REC-NAME 0155 1102 348 ELSE IF WS-CHAINADR-SET = 'CA' 0156 1103 349 MOVE 'IM-COMP-SET' TO CS-SET-NAME 0157 1104 350 * MOVE 'IM-WU-SET' TO CS-OTHER-SET 0158 1105 351 MOVE 'DMSPSRUN' TO CS-REC-NAME 0159 1106 352 ELSE IF WS-CHAINADR-SET = 'IO' 0160 1107 353 MOVE 'IM-OPER-SET' TO CS-SET-NAME 0161 1108 354 * MOVE 'WC-OPER-SET' TO CS-OTHER-SET 0162 1109 355 MOVE 'DMSSRTCG' TO CS-REC-NAME 0163 1110 356 ELSE IF WS-CHAINADR-SET = 'WO' 0164 1111 357 MOVE 'WC-OPER-SET' TO CS-SET-NAME 0165 1112 358 * MOVE 'IM-OPER-SET' TO CS-OTHER-SET 0166 1113 359 MOVE 'DMSSRTGC' TO CS-REC-NAME 0167 1114 360 ELSE IF WS-CHAINADR-SET = 'TA' 0168 1115 361 MOVE 'TM-COMP-SET' TO CS-SET-NAME 0169 1116 362 * MOVE 'TM-WU-SET' TO CS-OTHER-SET 0170 1117 363 MOVE 'DMSTLSTR' TO CS-REC-NAME 0171 1118 364 ELSE IF WS-CHAINADR-SET = 'TU' 0172 1119 365 MOVE 'TM-WU-SET' TO CS-SET-NAME 0173 1120 366 * MOVE 'TM-COMP-SET' TO CS-OTHER-SET 0174 1121 367 MOVE 'DMSTLSTR' TO CS-REC-NAME. 0175 1122 368 IF WS-CHAINADR-DIRECTION = 'P' 0176 1123 369 PERFORM 7472-FIND-PRIOR-REC 0177 1124 370 THRU 7472-FIND-PRIOR-REC-EXIT 0178 1125 371 IF RECORD-NAME OF DMCA NOT CS-REC-NAME 0179 1126 372 MOVE ZEROS TO PARM1-DISK-ADDR 0180 1127 373 GO TO 2000-EXPN-EXIT 0181 1128 374 ELSE 0182 1129 375 NEXT SENTENCE 0183 1130 376 ELSE IF WS-CHAINADR-DIRECTION = 'N' 0184 1131 377 PERFORM 7442-FIND-NEXT-REC 0185 1132 378 THRU 7442-FIND-NEXT-REC-EXIT 0186 1133 379 IF RECORD-NAME OF DMCA NOT CS-REC-NAME 0187 1134 380 MOVE ZEROS TO PARM1-DISK-ADDR 0188 1135 381 GO TO 2000-EXPN-EXIT 0189 1136 382 ELSE 0190 1137 383 NEXT SENTENCE 0191 1138 384 ELSE IF WS-CHAINADR-DIRECTION = 'O' 0192 1139 385 PERFORM 7472-FIND-PRIOR-REC 0193 1140 386 THRU 7472-FIND-PRIOR-REC-EXIT 0194 1141 387 IF RECORD-NAME OF DMCA = 'DMS-PS-HDR' 0195 1142 388 MOVE 'DMSIMRUN' TO CS-REC-NAME 0196 1143 389 MOVE DMS-PS-KEY TO DMS-IM-KEY 0197 1144 390 PERFORM 7480-REC-NAME 0198 1145 391 THRU 7480-REC-NAME-EXIT 0199 1146 392 ELSE IF RECORD-NAME OF DMCA = 'DMS-SR-HDR-IM' 0200 1147 393 MOVE 'DMSIMRUN' TO CS-REC-NAME 0201 1148 394 MOVE DMS-SR-KEY-IM TO DMS-IM-KEY 0202 1149 395 PERFORM 7480-REC-NAME 0203 1150 396 THRU 7480-REC-NAME-EXIT 0204 1151 397 ELSE IF RECORD-NAME OF DMCA = 'DMS-SR-HDR-WC' 0205 1152 398 MOVE 'DMSWKCTM' TO CS-REC-NAME 0206 1153 399 MOVE DMS-SR-KEY-WC TO DMS-WCTR-NO 0207 1154 400 PERFORM 7480-REC-NAME 0208 1155 401 THRU 7480-REC-NAME-EXIT 0209 1156 402 ELSE IF RECORD-NAME OF DMCA = 'DMS-TS-HDR' 0210 1157 403 MOVE 'DMSTLMST' TO CS-REC-NAME 0211 1158 404 MOVE DMS-TS-KEY TO DMS-TM-KEY 0212 1159 405 PERFORM 7480-REC-NAME 0213 1160 406 THRU 7480-REC-NAME-EXIT. 0214 1161 407 PERFORM 7090-MOVE 0215 1162 408 THRU 7090-MOVE-EXIT. 0216 1163 409 MOVE CS-DB-KEY TO PARM1-DISK-ADDR. 0217 1164 410 * 0218 1165 411 2000-EXPN-EXIT. 0219 1166 412 EXIT. 0220 1167 413 * 0221 1168 414 * 0222 1169 415 6700-DBOMP-CALL-SETUP. 0223 1170 416 * 0224 1171 417 MOVE CS-ENTRY-NAME TO CS-CALLED-FROM. 0225 1172 418 * 0226 1173 419 6800-DBOMP-CALL-RETURN. 0227 1174 420 * 0228 1175 421 MOVE CS-CALLED-FROM TO CS-ENTRY-NAME. 0229 1176 422 MOVE SPACES TO CS-CALLED-FROM. 0230 1177 423 * 0231 1178 424 * 0232 1179 425 * 0233 1180 426 6999-EXIT. 0234 1181 427 EXIT PROGRAM. 0235 1182 428 / 0236 1183 429 7090-MOVE. 0237 1184 430 ****************************************************************** 0238 1185 431 * MOVE STATUS (DATABASE KEY) OF RUN UNIT * 0239 1186 432 ****************************************************************** 0240 1187 433 MOVE '7090-MOVE' TO DMS-PROC-NAME. 0241 1188 434 * MOVE CURRENT STATUS FOR RUN-UNIT TO CS-DB-KEY. 0242 1189 435 CALL 'DBMS' USING 1190 436 176179877378 01073741824 1191 437 MOVE DATABASE-KEY TO CS-DB-KEY. 1192 438 * 0243 1193 439 7090-MOVE-EXIT. 0244 1194 440 EXIT. 0245 1195 441 * 0246 1196 442 7260-OWNER. 0247 1197 443 ****************************************************************** 0248 1198 444 * FETCH OWNER RECORD WITHIN CS-SET-NAME (FMT 4) * 0249 1199 445 * NOTE: CURRENCY MUST BE ESTABLISHED FOR CS-SET-NAME SET * 0250 1200 446 ****************************************************************** 0251 1201 447 MOVE '7260-OWNER' TO DMS-PROC-NAME. 0252 1202 448 * FETCH OWNER RECORED WITHIN CS-SET-NAME SET 0253 1203 449 * ON ERROR GO TO 9000-GEN-DMS-ERR. 0254 1204 450 CALL 'DBMS' USING 1205 451 03807448580 00000000000 00000000000 00000000005 9000-GEN- 1206 452 - DMS-ERR. 1207 453 7260-OWNER-EXIT. 0255 1208 454 EXIT. 0256 1209 455 * 0257 1210 456 7442-FIND-NEXT-REC. 0258 1211 457 ****************************************************************** 0259 1212 458 * FIND NEXT CS-REC-NAME WITHIN CS-SET-NAME SET (FMT 4) * 0260 1213 459 * NOTE: CURRENCY MUST BE ESTABLISHED FOR CS-SET-NAME SET * 0261 1214 460 ****************************************************************** 0262 1215 461 MOVE '7442-FIND-NEXT-REC' TO DMS-PROC-NAME. 0263 1216 462 * FIND NEXT CS-REC-NAME WITHIN CS-SET-NAME SET 0264 1217 463 * ON ERROR GO TO DMS-9000-ERROR. 0265 1218 464 CALL 'DBMS' USING 1219 465 03288355012 00000524288 00000000000 00001572869 9000-GEN- 1220 466 - DMS-ERR. 1221 467 7442-FIND-NEXT-REC-EXIT. 0266 1222 468 EXIT. 0267 1223 469 * 0268 1224 470 7472-FIND-PRIOR-REC. 0269 1225 471 ****************************************************************** 0270 1226 472 * FIND PRIOR CS-REC-NAME WITHIN CS-SET-NAME SET (FMT 4) * 0271 1227 473 * NOTE: CURRENCY MUST BE ESTABLISHED FOR CS-SET-NAME SET * 0272 1228 474 ****************************************************************** 0273 1229 475 MOVE '7472-FIND-PRIOR-REC' TO DMS-PROC-NAME. 0274 1230 476 * FIND PRIOR CS-REC-NAME WITHIN CS-SET-NAME SET 0275 1231 477 * ON ERROR GO TO DMS-9000-ERROR. 0276 1232 478 CALL 'DBMS' USING 1233 479 03288355012 00000786432 00000000000 00001572869 9000-GEN- 1234 480 - DMS-ERR. 1235 481 7472-FIND-PRIOR-REC-EXIT. 0277 1236 482 EXIT. 0278 1237 483 * 0279 1238 484 7480-REC-NAME. 0280 1239 485 ****************************************************************** 0281 1240 486 * FIND CS-REC-NAME RECORD (FORMAT 5) * 0282 1241 487 * NOTE: CS-REC-NAME RECORD WILL BE SELECTED ACCORDING TO * 0283 1242 488 * THE LOCATION MODE CLAUSE WITHIN THE SCHEMA. * 0284 1243 489 ****************************************************************** 0285 1244 490 MOVE '7480-REC-NAME' TO DMS-PROC-NAME. 0286 1245 491 * FIND CS-REC-NAME RECORD 0287 1246 492 * ON ERROR GO TO 9000-GEN-DMS-ERR. 0288 1247 493 CALL 'DBMS' USING 1248 494 03305132100 00000000000 00000000000 00000000006 9000-GEN- 1249 495 - DMS-ERR. 1250 496 7480-REC-NAME-EXIT. 0289 1251 497 EXIT. 0290 1252 498 * 0291 1253 499 7492-FIND-DBKEY. 0292 1254 500 ****************************************************************** 0293 1255 501 * FIND CD-DB-KEY (FORMAT 1) * 0294 1256 502 * NOTE: CS-DB-KEY MUST BE DEFINE WITH USAGE OF 0295 1257 503 * DATA BASE KEY AND INITIALIZED 0296 1258 504 ****************************************************************** 0297 1259 505 MOVE '7492-FIND-DBKEY' TO DMS-PROC-NAME. 0298 1260 506 * FIND CS-DB-KEY 0299 1261 507 * ON ERROR GO TO 9000-GEN-DMS-ERR. 0300 1262 508 MOVE CS-DB-KEY TO DATABASE-KEY 1263 509 CALL 'DBMS' USING 1264 510 03807448580 00000000000 00000000000 9000-GEN-DMS-ERR. 1265 511 7492-FIND-DBKEY-EXIT. 0301 1266 512 EXIT. 0302 1267 513 / 0303 1268 514 9000-GEN-DMS-ERR. 0304 1269 515 DISPLAY CS-DMS-GEN-ERR-LIT UPON PRINTER. 1270 516 CALL 'BZDMCADUMP' 1271 517 IF IMPART-DEPART NOT = 1 1272 518 GO TO 9000-END-PROGRAM. 1273 519 * DEPART WITH ROLLBACK ON ERROR 1274 520 * GO TO 9000-DMS-DEPART-ERROR. 1275 521 CALL 'DBMS' USING 1276 522 13975420121 9000-DMS-DEPART-ERROR. 1277 523 GO TO 9000-END-PROGRAM. 1278 524 9000-DMS-DEPART-ERR. 1279 525 DISPLAY 'GEN DMS DEPART ERROR' UPON PRINTER. 1280 526 MOVE '9000-DMS-DEPART-ERR' TO DMS-PROC-NAME. 1281 527 CALL 'BZDMCADUMP'. 1282 528 9000-END-PROGRAM. 1283 529 CALL 'ER$ABORT'. 0306