Compaq COBOL
DBMS Database Programming Manual
Previous Contents Index

Chapter 8
Database Programming Examples

The next few pages show programming examples of how to do the following:

This chapter also provides an example of how to create a bill of materials and sample runs of some of the programming examples.

8.1 Populating a Database

The DBMPARTLD program in Example 8-1 loads a series of sequential data files into the PARTS database. The PARTS database consists of a NEW root file with a default extension of .ROO describing the database instance and a series of .DBS storage files containing the actual data records. PARTS is the schema relative to the current position in CDD/Repository when the program is compiled. As the DBCS inserts the records, it creates set relationships based on the PARTSS1 subschema definitions. In the DB statement PARTS and NEW can be logical names. If PARTS is not a logical name, Compaq COBOL appends PARTS to CDD$DEFAULT; for example, CDD$DEFAULT.PARTS. If NEW is not a logical name, the DBCS appends .ROO as the default file type; for example, NEW.ROO.

Example 8-1 Populating a Database 

IDENTIFICATION DIVISION. 
PROGRAM-ID.   DBMPARTLD. 
********************************************************** 
*                                                        * 
* This program loads the PARTS database                  * 
*                                                        * 
********************************************************** 
ENVIRONMENT DIVISION. 
CONFIGURATION SECTION. 
INPUT-OUTPUT SECTION. 
FILE-CONTROL. 
        SELECT MAKE-FILE 
                ASSIGN TO "DBM$PARTS:DBMMAKE.DAT". 
        SELECT BUY-FILE 
                ASSIGN TO "DBM$PARTS:DBMBUY.DAT". 
        SELECT VENDOR-FILE 
                ASSIGN TO "DBM$PARTS:DBMVENDOR.DAT". 
        SELECT EMPLOYEE-FILE 
                ASSIGN TO "DBM$PARTS:DBMEMPLOY.DAT". 
        SELECT COMPONENT-FILE 
                ASSIGN TO "DBM$PARTS:DBMCOMPON.DAT". 
        SELECT SUPPLY-FILE 
                ASSIGN TO "DBM$PARTS:DBMSUPPLY.DAT". 
                SELECT DIVISION-FILE 
                ASSIGN TO "DBM$PARTS:DBMSUPER.DAT". 
        SELECT RESP-FOR-FILE 
                ASSIGN TO "DBM$PARTS:DBMRESPON.DAT". 
DATA DIVISION. 
SUB-SCHEMA SECTION. 
        DB PARTSS1 WITHIN PARTS FOR NEW. 
FILE SECTION. 
FD      MAKE-FILE 
        RECORD VARYING FROM 24 TO 80 CHARACTERS. 
01      MAKE-PART-RECORD. 
            02 CONTROL-FIELD        PIC X. 
            02 PART_ID              PIC X(8). 
            02 PART_DESC            PIC X(50). 
            02 PART_STATUS          PIC X(1). 
            02 PART_PRICE           PIC 9(6)V9(3). 
            02 PART_COST            PIC 9(6)V9(3). 
            02 PART_SUPPORT         PIC X(2). 
01     MAKE-CLASS-RECORD. 
            02  CONTROL-FIELD       PIC X. 
            02  CLASS_CODE          PIC XX. 
            02  CLASS_DESC          PIC X(20). 
            02  CLASS_STATUS        PIC X. 
FD      BUY-FILE 
        RECORD VARYING FROM 24 TO 80 CHARACTERS. 
01      BUY-PART-RECORD. 
            02 CONTROL-FIELD        PIC X. 
            02 PART_ID              PIC X(8). 
            02 PART_DESC            PIC X(50). 
            02 PART_STATUS          PIC X(1). 
            02 PART_PRICE           PIC 9(6)V9(3). 
            02 PART_COST            PIC 9(6)V9(3). 
            02 PART_SUPPORT         PIC X(2). 
01      BUY-CLASS-RECORD. 
            02 CONTROL-FIELD        PIC X. 
            02  CLASS_CODE          PIC XX. 
            02  CLASS_DESC          PIC X(20). 
            02  CLASS_STATUS        PIC X. 
FD      COMPONENT-FILE 
        LABEL RECORDS ARE STANDARD. 
01      COMPONENT-RECORD. 
            02  COMP_SUB_PART      PIC X(8). 
            02  COMP_OWNER_PART    PIC X(8). 
            02  COMP_MEASURE       PIC X. 
            02  COMP_QUANTITY      PIC 9(5). 
FD      VENDOR-FILE 
        LABEL RECORDS ARE STANDARD. 
01      VENDOR-RECORD. 
            02 VEND_ID              PIC X(8). 
            02 VEND_NAME            PIC X(40). 
            02 VEND_CONTACT         PIC X(30). 
            02 VEND_ADD OCCURS 3 TIMES 
                                    PIC X(15). 
            02 VEND_PHONE           PIC 9(10). 
FD      SUPPLY-FILE 
        RECORD VARYING FROM 37 TO 64 CHARACTERS. 
01      SUPPLY-RECORD. 
            02  CONTROL-FIELD     PIC X. 
            02  PART-ID           PIC X(8). 
            02  VEND-NAME         PIC X(40). 
            02  SUP_RATING        PIC X. 
            02  SUP_TYPE          PIC X(4). 
            02  SUP_LAG_TIME      PIC X(10). 
01      QUOTE-RECORD. 
            02  CONTROL-FIELD      PIC X. 
            02  QUOTE_ID           PIC X(7). 
            02  QUOTE_DATE         PIC 9(6). 
            02  QUOTE_MIN_ORDER    PIC X(5). 
            02  QUOTE_UNIT_PRIC    PIC 9(6)V9(3). 
            02  QUOTE_QTY_PRICE    PIC 9(6)V9(3). 
FD      EMPLOYEE-FILE 
        LABEL RECORDS ARE STANDARD. 
01      EMPLOYEE-RECORD. 
            02 EMP_ID              PIC 9(5). 
            02 EMP_NAME. 
                03 EMP_LAST_NAME   PIC X(20). 
                03 EMP_FIRST_NAME  PIC X(10). 
            02 EMP_PHONE           PIC X(7). 
            02 EMP_LOC             PIC X(5). 
FD      DIVISION-FILE 
        RECORD VARYING FROM 6 TO 26 CHARACTERS. 
01      MANAGES-RECORD. 
            02  CONTROL-FIELD               PIC X. 
            02  GROUP_NAME                  PIC X(20). 
            02  EMP_ID                      PIC 9(5). 
01      CONSISTS-RECORD. 
            02  CONTROL-FIELD               PIC X. 
            02  EMP_ID                      PIC 9(5). 
FD      RESP-FOR-FILE 
        LABEL RECORDS ARE STANDARD. 
01      RESP-FOR-RECORD. 
            02  EMP_ID                      PIC 9(5). 
            02  PART_ID                     PIC X(8). 
 
WORKING-STORAGE SECTION. 
 
77      ITEM-USED                PIC X(70). 
77      STAT                     PIC 9(9) USAGE COMP. 
77      DB-TEMP                  PIC 9(9) USAGE IS COMP. 
77      CLASS-COUNT              PIC 999 VALUE IS 0. 
77      PART-COUNT               PIC 999 VALUE IS 0. 
77      COMPONENT-COUNT          PIC 999 VALUE IS 0. 
77      VENDOR-COUNT             PIC 999 VALUE IS 0. 
77      SUPPLY-COUNT             PIC 999 VALUE IS 0. 
77      QUOTE-COUNT              PIC 999 VALUE IS 0. 
77      EMPLOYEE-COUNT           PIC 999 VALUE IS 0. 
77      DIVISION-COUNT           PIC 999 VALUE IS 0. 
 
PROCEDURE DIVISION. 
 
DECLARATIVES. 
100-DATABASE-EXCEPTIONS SECTION. 
    USE FOR DB-EXCEPTION ON OTHER. 
100-PROCEDURE. 
    DISPLAY "DATABASE EXCEPTION CONDITION". 
    PERFORM 150-DISPLAY-MESSAGE. 
 
150-DISPLAY-MESSAGE. 
* 
*  DBM$SIGNAL displays diagnostic messages based on the 
*  status code in DB-CONDITION. 
* 
    CALL "DBM$SIGNAL". 
    ROLLBACK. 
    STOP RUN. 
END DECLARATIVES. 
 
DB-PROCESSING SECTION. 
 
INITIALIZATION-ROUT. 
    READY EXCLUSIVE UPDATE. 
 
CONTROL-ROUT. 
    OPEN INPUT MAKE-FILE. 
    PERFORM MAKE-LOAD THRU MAKE-LOAD-END. 
    CLOSE MAKE-FILE. 
*    DISPLAY " ". 
*    DISPLAY CLASS-COUNT, " CLASS records loaded from MAKE". 
*    DISPLAY PART-COUNT, " PART records loaded from MAKE". 
 
    OPEN INPUT BUY-FILE. 
    MOVE 0 TO CLASS-COUNT. 
    MOVE 0 TO PART-COUNT. 
    PERFORM BUY-LOAD THRU BUY-LOAD-END. 
    CLOSE BUY-FILE. 
*    DISPLAY " ". 
*    DISPLAY CLASS-COUNT, " CLASS records loaded from BUY". 
*    DISPLAY PART-COUNT, " PART records loaded from BUY". 
 
    OPEN INPUT VENDOR-FILE. 
    PERFORM VENDOR-LOAD THRU VENDOR-LOAD-END. 
    CLOSE VENDOR-FILE. 
*    DISPLAY " ". 
*    DISPLAY VENDOR-COUNT, " VENDOR records loaded". 
 
    OPEN INPUT COMPONENT-FILE. 
    PERFORM COMPONENT-LOAD THRU COMPONENT-LOAD-END. 
    CLOSE COMPONENT-FILE. 
*    DISPLAY " ". 
*    DISPLAY COMPONENT-COUNT, " COMPONENT records loaded". 
 
    OPEN INPUT EMPLOYEE-FILE. 
    PERFORM EMPLOYEE-LOAD THRU EMPLOYEE-LOAD-END. 
    CLOSE EMPLOYEE-FILE. 
*    DISPLAY " ". 
*    DISPLAY EMPLOYEE-COUNT, " EMPLOYEE records loaded". 
 
    OPEN INPUT SUPPLY-FILE. 
    PERFORM SUPPLY-LOAD THRU SUPPLY-LOAD-END. 
    CLOSE SUPPLY-FILE. 
*    DISPLAY " ". 
*    DISPLAY SUPPLY-COUNT, " SUPPLY records loaded". 
*    DISPLAY QUOTE-COUNT, " QUOTE records loaded". 
 
    OPEN INPUT DIVISION-FILE. 
    PERFORM DIVISION-LOAD THRU DIVISION-LOAD-END. 
    CLOSE DIVISION-FILE. 
*    DISPLAY " ". 
*    DISPLAY DIVISION-COUNT, " DIVISION records loaded". 
 
    OPEN INPUT RESP-FOR-FILE. 
    PERFORM RESP-FOR-LOAD THRU RESP-FOR-LOAD-END. 
    CLOSE RESP-FOR-FILE. 
 
    COMMIT. 
    STOP RUN. 
 
MAKE-LOAD. 
    READ MAKE-FILE AT END GO TO MAKE-LOAD-END. 
    IF CONTROL-FIELD OF MAKE-PART-RECORD = "C" 
        MOVE CORR MAKE-CLASS-RECORD TO CATEGORY 
        STORE CATEGORY WITHIN MAKE 
        ADD 1 TO CLASS-COUNT 
            ELSE 
            MOVE CORR MAKE-PART-RECORD TO PART 
            STORE PART WITHIN MAKE 
            ADD 1 TO PART-COUNT. 
    GO TO MAKE-LOAD. 
 
MAKE-LOAD-END. 
    EXIT. 
 
BUY-LOAD. 
    READ BUY-FILE AT END GO TO BUY-LOAD-END. 
    IF CONTROL-FIELD OF BUY-PART-RECORD = "C" 
        MOVE CORR BUY-CLASS-RECORD TO CATEGORY 
        STORE CATEGORY WITHIN BUY 
        ADD 1 TO CLASS-COUNT 
            ELSE 
            MOVE CORR BUY-PART-RECORD TO PART 
            STORE PART WITHIN BUY 
            ADD 1 TO PART-COUNT. 
    GO TO BUY-LOAD. 
 
BUY-LOAD-END. 
    EXIT. 
 
VENDOR-LOAD. 
    READ VENDOR-FILE AT END GO TO VENDOR-LOAD-END. 
    MOVE VEND_ID OF VENDOR-RECORD TO VEND_ID OF VENDOR. 
    MOVE VEND_NAME OF VENDOR-RECORD TO VEND_NAME OF VENDOR. 
    MOVE VEND_CONTACT OF VENDOR-RECORD TO VEND_CONTACT OF VENDOR. 
    MOVE VEND_ADD (1) TO VEND_ADDRESS (1). 
    MOVE VEND_ADD (2) TO VEND_ADDRESS (2). 
    MOVE VEND_ADD (3) TO VEND_ADDRESS (3). 
    MOVE VEND_PHONE OF VENDOR-RECORD TO VEND_PHONE OF VENDOR. 
    STORE VENDOR. 
    ADD 1 TO VENDOR-COUNT. 
    GO TO VENDOR-LOAD. 
 
VENDOR-LOAD-END. 
    EXIT. 
 
COMPONENT-LOAD. 
    READ COMPONENT-FILE AT END GO TO COMPONENT-LOAD-END. 
    IF COMP_OWNER_PART OF COMPONENT-RECORD = 
       COMP_OWNER_PART OF COMPONENT 
           GO TO COMPONENT-SUB-LOAD. 
    MOVE COMP_OWNER_PART OF COMPONENT-RECORD TO PART_ID OF PART. 
    FIND FIRST PART WITHIN ALL_PARTS USING PART_ID OF PART 
        AT END DISPLAY PART_ID OF PART, 
           "COMP_OWNER_PART does not exist for COMPONENT" 
           GO TO COMPONENT-LOAD. 
 
COMPONENT-SUB-LOAD. 
    MOVE COMP_SUB_PART OF COMPONENT-RECORD TO PART_ID OF PART. 
    FIND FIRST PART WITHIN ALL_PARTS USING PART_ID OF PART 
        RETAINING PART_USES 
        AT END DISPLAY PART_ID OF PART, 
            "COMP_SUB_PART does not exist for COMPONENT" 
           GO TO COMPONENT-LOAD. 
    MOVE CORR COMPONENT-RECORD TO COMPONENT. 
    STORE COMPONENT. 
    ADD 1 TO COMPONENT-COUNT. 
    GO TO COMPONENT-LOAD. 
 
COMPONENT-LOAD-END. 
    EXIT. 
 
EMPLOYEE-LOAD. 
    READ EMPLOYEE-FILE AT END GO TO EMPLOYEE-LOAD-END. 
    MOVE CORR EMPLOYEE-RECORD TO EMPLOYEE. 
    STORE EMPLOYEE. 
    ADD 1 TO EMPLOYEE-COUNT. 
    GO TO EMPLOYEE-LOAD. 
 
EMPLOYEE-LOAD-EXIT 
    EXIT. 
 
SUPPLY-LOAD. 
    READ SUPPLY-FILE AT END GO TO SUPPLY-LOAD-END. 
 
SUPPLY-LOAD-LOOP. 
    IF CONTROL-FIELD OF SUPPLY-RECORD = "S" 
        MOVE PART-ID OF SUPPLY-RECORD TO PART_ID OF PART 
        FIND FIRST PART WITHIN ALL_PARTS USING PART_ID OF PART 
          AT END 
            DISPLAY PART_ID OF PART, 
                    " PART-ID for SUPPLY does not exist" 
            MOVE " " TO CONTROL-FIELD OF SUPPLY-RECORD 
            PERFORM BAD-SUPPLY THRU BAD-SUPPLY-END 
                    UNTIL CONTROL-FIELD OF SUPPLY-RECORD = "S" 
            GO TO SUPPLY-LOAD-LOOP 
          END-FIND 
        MOVE VEND-NAME OF SUPPLY-RECORD TO VEND_NAME OF VENDOR 
        FIND FIRST VENDOR WITHIN ALL_VENDORS USING VEND_NAME OF VENDOR 
          AT END 
            DISPLAY VEND_NAME OF VENDOR 
                    "VEND-NAME for SUPPLY does not exist" 
            MOVE " " TO CONTROL-FIELD OF SUPPLY-RECORD 
            PERFORM BAD-SUPPLY THRU BAD-SUPPLY-END 
                    UNTIL CONTROL-FIELD OF SUPPLY-RECORD = "S" 
            GO TO SUPPLY-LOAD-LOOP 
          END-FIND 
        MOVE CORR SUPPLY-RECORD TO SUPPLY 
        STORE SUPPLY 
        ADD 1 TO SUPPLY-COUNT 
        GO TO SUPPLY-LOAD 
    ELSE 
        MOVE CORR QUOTE-RECORD TO PR_QUOTE 
        STORE PR_QUOTE 
        ADD 1 TO QUOTE-COUNT 
        GO TO SUPPLY-LOAD. 
 
BAD-SUPPLY. 
    READ SUPPLY-FILE AT END GO TO SUPPLY-LOAD-END. 
    IF CONTROL-FIELD OF SUPPLY-RECORD = "Q" 
        DISPLAY QUOTE_ID OF QUOTE-RECORD, " QUOTE_ID not stored". 
 
BAD-SUPPLY-END. 
    EXIT. 
 
SUPPLY-LOAD-END. 
    EXIT. 
 
DIVISION-LOAD. 
    READ DIVISION-FILE AT END GO TO DIVISION-LOAD-END. 
 
DIVISION-LOAD-LOOP. 
    IF CONTROL-FIELD OF MANAGES-RECORD = "M" 
        MOVE EMP_ID OF MANAGES-RECORD TO EMP_ID OF EMPLOYEE 
        FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES 
                   USING EMP_ID OF EMPLOYEE 
          AT END DISPLAY EMP_ID OF EMPLOYEE, 
                " EMP_ID for MANAGES does not exist" 
                MOVE " " TO CONTROL-FIELD OF MANAGES-RECORD 
                PERFORM BAD-DIVISION THRU BAD-DIVISION-END UNTIL 
                CONTROL-FIELD OF MANAGES-RECORD = "M" 
                GO TO DIVISION-LOAD-LOOP 
          END-FIND 
        MOVE CORR MANAGES-RECORD TO WK_GROUP 
        STORE WK_GROUP 
        ADD 1 TO DIVISION-COUNT 
        GO TO DIVISION-LOAD 
    ELSE 
        MOVE EMP_ID OF CONSISTS-RECORD TO EMP_ID OF EMPLOYEE 
        FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING 
         EMP_ID OF EMPLOYEE 
          AT END DISPLAY EMP_ID OF CONSISTS-RECORD, 
            " EMP_ID for CONSISTS_OF does not exist" 
            GO TO DIVISION-LOAD 
          END-FIND 
        CONNECT EMPLOYEE TO CONSISTS_OF 
        GO TO DIVISION-LOAD. 
 
BAD-DIVISION. 
    READ DIVISION-FILE AT END GO TO DIVISION-LOAD-END. 
    IF CONTROL-FIELD OF MANAGES-RECORD = "C" 
        DISPLAY EMP_ID OF CONSISTS-RECORD, " EMP_ID not connected". 
 
BAD-DIVISION-END. 
    EXIT. 
 
DIVISION-LOAD-END. 
    EXIT. 
 
RESP-FOR-LOAD. 
    READ RESP-FOR-FILE AT END GO TO RESP-FOR-LOAD-END. 
 
RESP-FOR-LOAD-LOOP. 
    MOVE EMP_ID OF RESP-FOR-RECORD TO EMP_ID OF EMPLOYEE. 
    FETCH FIRST EMPLOYEE WITHIN ALL_EMPLOYEES 
                USING EMP_ID OF EMPLOYEE 
      AT END 
        DISPLAY EMP_ID OF RESP-FOR-RECORD, 
        " EMP_ID for RESPONSIBLE_FOR does not exist" 
        GO TO RESP-FOR-LOAD. 
 
RESP-PART-LOOP. 
    MOVE PART_ID OF RESP-FOR-RECORD TO PART_ID OF PART. 
    FIND FIRST PART WITHIN ALL_PARTS USING PART_ID OF PART 
      AT END 
        DISPLAY PART_ID OF RESP-FOR-RECORD, 
        " PART_ID for RESPONSIBLE_FOR does not exist" 
        GO TO RESP-FOR-LOAD. 
    CONNECT PART TO RESPONSIBLE_FOR. 
    READ RESP-FOR-FILE AT END GO TO RESP-FOR-LOAD-END. 
    IF EMP_ID OF RESP-FOR-RECORD = EMP_ID OF EMPLOYEE 
        GO TO RESP-PART-LOOP 
    ELSE 
        GO TO RESP-FOR-LOAD-LOOP. 
RESP-FOR-LOAD-END. 
    EXIT.

8.2 Backing Up a Database

The PARTSBACK program in Example 8-2 unloads all PARTS database records, independently of their pointers, into a series of sequential data files. It is the first step in restructuring and reorganizing a database. For example, after backing up the database, you can change its contents. You can also create a new version of the database including different keys or new set relationships.

The PARTS database consists of a NEW root file with a default extension of .ROO describing the database instance and a series of .DBS storage files containing the actual data records. PARTS is the schema relative to the current position in CDD/Repository when the program is compiled. In the DB statement, PARTS and NEW can be logical names. If PARTS is not a logical name, Compaq COBOL appends PARTS to CDD$DEFAULT; for example, CDD$DEFAULT.PARTS. If NEW is not a logical name, the DBCS appends .ROO as the default file type; for example, NEW.ROO.

Example 8-2 Backing Up a Database 

IDENTIFICATION DIVISION. 
PROGRAM-ID.     PARTSBACK. 
************************************************************* 
* 
*  This program unloads the PARTS database 
* 
************************************************************* 
 
ENVIRONMENT DIVISION. 
CONFIGURATION SECTION. 
 
INPUT-OUTPUT SECTION. 
 
FILE-CONTROL. 
        SELECT MAKE-FILE 
                ASSIGN TO "DBM$PARTS:DBMMAKE.DAT". 
        SELECT BUY-FILE 
               ASSIGN TO "DBM$PARTS:DBMBUY.DAT". 
        SELECT VENDOR-FILE 
               ASSIGN TO "DBM$PARTS:DBMVENDOR.DAT". 
        SELECT EMPLOYEE-FILE 
               ASSIGN TO "DBM$PARTS:DBMEMPLOY.DAT". 
        SELECT COMPONENT-FILE 
               ASSIGN TO "DBM$PARTS:DBMCOMPON.DAT". 
        SELECT SUPPLY-FILE 
               ASSIGN TO "DBM$PARTS:DBMSUPPLY.DAT". 
        SELECT DIVISION-FILE 
               ASSIGN TO "DBM$PARTS:DBMSUPER.DAT". 
        SELECT RESP-FOR-FILE 
               ASSIGN TO "DBM$PARTS:DBMRESPON.DAT". 
 
DATA DIVISION. 
 
SUB-SCHEMA SECTION. 
DB PARTSS1 WITHIN PARTS FOR NEW. 
 
FILE SECTION. 
 
FD      MAKE-FILE 
        RECORD VARYING FROM 24 TO 80 CHARACTERS. 
01      MAKE-PART-RECORD. 
        02 CONTROL-FIELD        PIC X. 
        02 PART_ID              PIC X(8). 
        02 PART_DESC            PIC X(50). 
        02 PART_STATUS          PIC X(1). 
        02 PART_PRICE           PIC 9(6)V9(3). 
        02 PART_COST            PIC 9(6)V9(3). 
        02 PART_SUPPORT         PIC X(2). 
01      MAKE-CLASS-RECORD. 
        02  CONTROL-FIELD       PIC X. 
        02  CLASS_CODE          PIC XX. 
        02  CLASS_DESC          PIC X(20). 
        02  CLASS_STATUS        PIC X. 
 
FD      BUY-FILE 
        RECORD VARYING FROM 24 TO 80 CHARACTERS. 
01      BUY-PART-RECORD. 
        02 CONTROL-FIELD        PIC X. 
        02 PART_ID              PIC X(8). 
        02 PART_DESC            PIC X(50). 
        02 PART_STATUS          PIC X(1). 
        02 PART_PRICE           PIC 9(6)V9(3). 
        02 PART_COST            PIC 9(6)V9(3). 
        02 PART_SUPPORT         PIC X(2). 
01      BUY-CLASS-RECORD. 
        02 CONTROL-FIELD        PIC X. 
        02 CLASS_CODE           PIC XX. 
        02 CLASS_DESC           PIC X(20). 
        02 CLASS_STATUS         PIC X. 
 
FD      COMPONENT-FILE 
        LABEL RECORDS ARE STANDARD. 
01      COMPONENT-RECORD. 
        02  COMP_SUB_PART      PIC X(8). 
        02  COMP_OWNER_PART    PIC X(8). 
        02  COMP_MEASURE       PIC X. 
        02  COMP_QUANTITY      PIC 9(5). 
 
FD      VENDOR-FILE 
        LABEL RECORDS ARE STANDARD. 
01      VENDOR-RECORD. 
        02 VEND_ID                     PIC X(8). 
        02 VEND_NAME                   PIC X(40). 
        02 VEND_CONTACT                PIC X(30). 
        02 VEND_ADDRESS OCCURS 3 TIMES PIC X(15). 
        02 VEND_PHONE                  PIC 9(10). 
 
FD      SUPPLY-FILE 
        RECORD VARYING FROM 37 TO 64 CHARACTERS. 
01      SUPPLY-RECORD. 
        02  CONTROL-FIELD      PIC X. 
        02  PART-ID            PIC X(8). 
        02  VEND-NAME          PIC X(40). 
        02  SUP_RATING         PIC X. 
        02  SUP_TYPE           PIC X(4). 
        02  SUP_LAG_TIME       PIC X(10). 
01      QUOTE-RECORD. 
        02  CONTROL-FIELD      PIC X. 
        02  QUOTE_ID           PIC X(7). 
        02  QUOTE_DATE         PIC 9(6). 
        02  QUOTE_MIN_ORDER    PIC X(5). 
        02  QUOTE_UNIT_PRIC    PIC 9(6)V9(3). 
        02  QUOTE_QTY_PRICE    PIC 9(6)V9(3). 
 
FD      EMPLOYEE-FILE 
        LABEL RECORDS ARE STANDARD. 
01      EMPLOYEE-RECORD. 
        02 EMP_ID                      PIC 9(5). 
        02 EMP_NAME. 
                03 EMP_LAST_NAME       PIC X(20). 
                03 EMP_FIRST_NAME      PIC X(10). 
        02 EMP_PHONE                   PIC X(7). 
        02 EMP_LOC                     PIC X(5). 
 
FD      DIVISION-FILE 
        RECORD VARYING FROM 6 TO 26 CHARACTERS. 
01      MANAGES-RECORD. 
        02  CONTROL-FIELD       PIC X. 
        02  GROUP_NAME          PIC X(20). 
        02  EMP_ID              PIC 9(5). 
01      CONSISTS-RECORD. 
        02  CONTROL-FIELD       PIC X. 
        02  EMP_ID              PIC 9(5). 
 
FD      RESP-FOR-FILE 
        LABEL RECORDS ARE STANDARD. 
01      RESP-FOR-RECORD. 
        02  EMP_ID             PIC 9(5). 
        02  PART_ID            PIC X(8). 
 
WORKING-STORAGE SECTION. 
 
77      CLASS-COUNT             PIC 999 VALUE IS 0. 
77      PART-COUNT              PIC 999 VALUE IS 0. 
77      COMPONENT-COUNT         PIC 999 VALUE IS 0. 
77      VENDOR-COUNT            PIC 999 VALUE IS 0. 
77      SUPPLY-COUNT            PIC 999 VALUE IS 0. 
77      QUOTE-COUNT             PIC 999 VALUE IS 0. 
77      EMPLOYEE-COUNT          PIC 999 VALUE IS 0. 
 
PROCEDURE DIVISION. 
 
DECLARATIVES. 
100-DATABASE-EXCEPTIONS SECTION. 
    USE FOR DB-EXCEPTION ON OTHER. 
100-PROCEDURE. 
    DISPLAY "DATABASE EXCEPTION CONDITION". 
    PERFORM 150-DISPLAY-MESSAGE. 
 
150-DISPLAY-MESSAGE. 
* 
* DBM$SIGNAL displays diagnostic messages based on the 
* status code in DB-CONDITION. 
* 
    CALL "DBM$SIGNAL". 
    ROLLBACK. 
    STOP RUN. 
END DECLARATIVES. 
 
DB-PROCESSING SECTION. 
 
INITIALIZATION-ROUT. 
    READY PROTECTED. 
 
CONTROL-ROUT. 
    OPEN OUTPUT COMPONENT-FILE, SUPPLY-FILE. 
    OPEN OUTPUT MAKE-FILE. 
    PERFORM MAKE-UNLOAD THRU MAKE-UNLOAD-END. 
    CLOSE MAKE-FILE. 
    DISPLAY " ". 
    DISPLAY CLASS-COUNT, " CLASS records unloaded from MAKE". 
    DISPLAY PART-COUNT, " PART records unloaded from MAKE". 
 
    OPEN OUTPUT BUY-FILE. 
    MOVE 0 TO CLASS-COUNT. 
    MOVE 0 TO PART-COUNT. 
    PERFORM BUY-UNLOAD THRU BUY-UNLOAD-END. 
    CLOSE BUY-FILE, COMPONENT-FILE, SUPPLY-FILE. 
    DISPLAY " ". 
    DISPLAY CLASS-COUNT, " CLASS records unloaded from BUY". 
    DISPLAY PART-COUNT, " PART records unloaded from BUY". 
    DISPLAY " ". 
    DISPLAY SUPPLY-COUNT, " SUPPLY records unloaded". 
    DISPLAY QUOTE-COUNT, " QUOTE records unloaded". 
    DISPLAY COMPONENT-COUNT " COMPONENT records unloaded". 
 
    OPEN OUTPUT VENDOR-FILE. 
    PERFORM VENDOR-UNLOAD THRU VENDOR-UNLOAD-END. 
    CLOSE VENDOR-FILE. 
    DISPLAY " ". 
    DISPLAY VENDOR-COUNT, " VENDOR records unloaded". 
 
    OPEN OUTPUT EMPLOYEE-FILE, RESP-FOR-FILE, DIVISION-FILE. 
    PERFORM EMPLOYEE-UNLOAD THRU EMPLOYEE-UNLOAD-END. 
    CLOSE EMPLOYEE-FILE, RESP-FOR-FILE, DIVISION-FILE. 
    DISPLAY " ". 
    DISPLAY EMPLOYEE-COUNT, " EMPLOYEE records unloaded". 
 
    COMMIT. 
    STOP RUN. 
 
MAKE-UNLOAD. 
    FETCH NEXT CATEGORY WITHIN MAKE 
        AT END GO TO MAKE-UNLOAD-END. 
    MOVE "C" TO CONTROL-FIELD OF MAKE-CLASS-RECORD. 
    MOVE CORR CATEGORY TO MAKE-CLASS-RECORD. 
    ADD 1 TO CLASS-COUNT. 
    WRITE MAKE-CLASS-RECORD. 
 
MAKE-PART-LOOP. 
    FETCH NEXT PART WITHIN CLASS_PART RETAINING REALM 
        AT END GO TO MAKE-UNLOAD. 
    MOVE "P" TO CONTROL-FIELD OF MAKE-PART-RECORD. 
    MOVE CORR PART TO MAKE-PART-RECORD. 
    ADD 1 TO PART-COUNT. 
    WRITE MAKE-PART-RECORD. 
    PERFORM COMPONENT-SUPPLY-UNLOAD THRU 
            COMPONENT-SUPPLY-UNLOAD-END. 
    GO TO MAKE-PART-LOOP. 
 
MAKE-UNLOAD-END. 
    EXIT. 
 
BUY-UNLOAD. 
    FETCH NEXT CATEGORY WITHIN BUY 
        AT END GO TO BUY-UNLOAD-END. 
    MOVE "C" TO CONTROL-FIELD OF BUY-CLASS-RECORD. 
    MOVE CORR CATEGORY TO BUY-CLASS-RECORD. 
    ADD 1 TO CLASS-COUNT. 
    WRITE BUY-CLASS-RECORD. 
 
BUY-PART-LOOP. 
    FETCH NEXT PART WITHIN CLASS_PART RETAINING REALM 
        AT END GO TO BUY-UNLOAD. 
    MOVE "P" TO CONTROL-FIELD OF BUY-PART-RECORD. 
    MOVE CORR PART TO BUY-PART-RECORD. 
    ADD 1 TO PART-COUNT. 
    WRITE BUY-PART-RECORD. 
    PERFORM COMPONENT-SUPPLY-UNLOAD THRU 
            COMPONENT-SUPPLY-UNLOAD-END. 
    GO TO BUY-PART-LOOP. 
 
BUY-UNLOAD-END. 
    EXIT. 
 
COMPONENT-SUPPLY-UNLOAD. 
 
COMPONENT-UNLOAD. 
    FETCH NEXT COMPONENT WITHIN PART_USES RETAINING REALM 
        AT END GO TO SUPPLY-QUOTE-LOOP. 
    MOVE CORR COMPONENT TO COMPONENT-RECORD. 
    ADD 1 TO COMPONENT-COUNT. 
    WRITE COMPONENT-RECORD. 
    GO TO COMPONENT-UNLOAD. 
 
SUPPLY-QUOTE-LOOP. 
    FETCH NEXT WITHIN PART_INFO RETAINING REALM 
        AT END GO TO COMPONENT-SUPPLY-UNLOAD-END. 
    IF DB-CURRENT-RECORD-NAME = "PR_QUOTE" THEN 
        MOVE CORR PR_QUOTE TO QUOTE-RECORD 
        MOVE "Q" TO CONTROL-FIELD OF QUOTE-RECORD 
        ADD 1 TO QUOTE-COUNT 
        WRITE QUOTE-RECORD 
        GO TO SUPPLY-QUOTE-LOOP 
    ELSE 
        MOVE CORR SUPPLY TO SUPPLY-RECORD 
        FETCH OWNER WITHIN VENDOR_SUPPLY 
        MOVE "S" TO CONTROL-FIELD OF SUPPLY-RECORD 
        MOVE VEND_NAME OF VENDOR TO VEND-NAME OF SUPPLY-RECORD 
        MOVE PART_ID OF PART TO PART-ID OF SUPPLY-RECORD 
        ADD 1 TO SUPPLY-COUNT 
        WRITE SUPPLY-RECORD 
        GO TO SUPPLY-QUOTE-LOOP. 
 
COMPONENT-SUPPLY-UNLOAD-END. 
    EXIT. 
 
VENDOR-UNLOAD. 
    FREE CURRENT WITHIN MARKET. 
 
VENDOR-UNLOAD-LOOP. 
    FETCH NEXT VENDOR WITHIN MARKET 
        AT END GO TO VENDOR-UNLOAD-END. 
    ADD 1 TO VENDOR-COUNT. 
    MOVE VEND_ID OF VENDOR TO VEND_ID OF VENDOR-RECORD. 
    MOVE VEND_NAME OF VENDOR TO VEND_NAME OF VENDOR-RECORD. 
    MOVE VEND_CONTACT OF VENDOR TO VEND_CONTACT OF VENDOR-RECORD. 
    MOVE VEND_ADDRESS OF VENDOR (1) TO 
         VEND_ADDRESS OF VENDOR-RECORD (1). 
    MOVE VEND_ADDRESS OF VENDOR (2) TO 
         VEND_ADDRESS OF VENDOR-RECORD (2). 
    MOVE VEND_ADDRESS OF VENDOR (3) TO 
         VEND_ADDRESS OF VENDOR-RECORD (3). 
    MOVE VEND_PHONE OF VENDOR TO VEND_PHONE OF VENDOR-RECORD. 
    WRITE VENDOR-RECORD. 
    GO TO VENDOR-UNLOAD-LOOP. 
 
VENDOR-UNLOAD-END. 
    EXIT. 
 
EMPLOYEE-UNLOAD. 
    FETCH NEXT EMPLOYEE WITHIN ALL_EMPLOYEES 
        AT END GO TO EMPLOYEE-UNLOAD-END. 
    MOVE CORR EMPLOYEE TO EMPLOYEE-RECORD. 
    ADD 1 TO EMPLOYEE-COUNT. 
    WRITE EMPLOYEE-RECORD. 
 
DIVISION-UNLOAD. 
    FETCH NEXT WITHIN MANAGES 
        AT END GO TO RESP-UNLOAD. 
    MOVE EMP_ID OF EMPLOYEE TO EMP_ID OF MANAGES-RECORD. 
    MOVE GROUP_NAME OF WK_GROUP TO GROUP_NAME OF MANAGES-RECORD. 
    MOVE "M" TO CONTROL-FIELD OF MANAGES-RECORD. 
    WRITE MANAGES-RECORD. 
 
CONSISTS-UNLOAD. 
    FETCH NEXT WITHIN CONSISTS_OF RETAINING MANAGES ALL_EMPLOYEES 
        AT END GO TO DIVISION-UNLOAD. 
    MOVE "C" TO CONTROL-FIELD OF CONSISTS-RECORD. 
    MOVE EMP_ID OF EMPLOYEE TO  EMP_ID OF CONSISTS-RECORD. 
    WRITE CONSISTS-RECORD. 
    GO TO CONSISTS-UNLOAD. 
 
RESP-UNLOAD. 
    FETCH CURRENT WITHIN ALL_EMPLOYEES. 
RESP-UNLOAD-LOOP. 
    FETCH NEXT WITHIN RESPONSIBLE_FOR 
        AT END GO TO EMPLOYEE-UNLOAD. 
    MOVE PART_ID OF PART TO PART_ID OF RESP-FOR-RECORD. 
    MOVE EMP_ID OF EMPLOYEE TO EMP_ID OF RESP-FOR-RECORD. 
    WRITE RESP-FOR-RECORD. 
    GO TO RESP-UNLOAD-LOOP. 
EMPLOYEE-UNLOAD-END. 
    EXIT.

Previous Next Contents Index