# 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:

- Populate a database
- Back up a database
- Access and display database information
- Create new record relationships

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