Compaq COBOL
DBMS Database Programming Manual
Previous Contents Index

8.3 Accessing and Displaying Database Information

The PARTBOM program in Example 8-3 produces a report of subcomponents (bill of materials) for a part in the PARTS database. Refer to Figure 5_23 for an explanation of the report and Section 8.6 for a sample listing.

Example 8-3 Accessing and Displaying Database Information 

IDENTIFICATION DIVISION. 
PROGRAM-ID.  PARTBOM. 
 
ENVIRONMENT DIVISION. 
CONFIGURATION SECTION. 
 
 
DATA DIVISION. 
SUB-SCHEMA SECTION. 
 
DB    PARTSS1 WITHIN PARTS FOR NEW. 
LD    KEEP-COMPONENT. 
 
WORKING-STORAGE SECTION. 
 
01      INPUT-REC               PIC X(80). 
 
01      INDENT-LEVEL            PIC 9(02)  VALUE 40. 
01      END-OF-COLLECTION       PIC 9(01)  VALUE 0. 
        88  END-COLLECTION                 VALUE 1. 
 
01      INDENT-TREE. 
        02  INDENT-TREE-ARRAY   PIC X(03)  OCCURS 1 TO 40 TIMES 
                                DEPENDING ON INDENT-LEVEL. 
PROCEDURE DIVISION. 
 
INITIALIZATION. 
    READY   MAKE, BUY EXCLUSIVE RETRIEVAL. 
    MOVE    ALL "|  " TO INDENT-TREE. 
 
SOLICIT-INPUT. 
    MOVE ZERO TO END-OF-COLLECTION. 
    DISPLAY    " ". 
    DISPLAY    "Enter PART_ID> " WITH NO ADVANCING. 
    MOVE    SPACES TO INPUT-REC. 
    ACCEPT PART_ID 
        AT END GO TO PARTBOM-DONE. 
    FETCH    FIRST PART WITHIN ALL_PARTS USING PART_ID 
        AT END DISPLAY "***  Part number ", 
 
                                PART_ID, " not found.  ***" 
               GO TO SOLICIT-INPUT. 
    DISPLAY    " ". 
    DISPLAY    " ". 
    DISPLAY "+-----------------------------------+". 
    DISPLAY "| Parts Bill of Materials Explosion |". 
    DISPLAY "|          (COBOL Version)          |". 
    DISPLAY "|         Part-id: " PART_ID "      |". 
    DISPLAY "+-----------------------------------+". 
    DISPLAY " ". 
    DISPLAY " ". 
    DISPLAY " ". 
    DISPLAY    PART_ID, " - ", PART_DESC 
    MOVE ZERO TO INDENT-LEVEL. 
    FREE ALL FROM KEEP-COMPONENT. 
    PERFORM PARTBOM-LOOP THRU PARTBOM-LOOP-EXIT 
        UNTIL END-COLLECTION. 
    GO TO SOLICIT-INPUT. 
 
PARTBOM-DONE. 
    COMMIT. 
    DISPLAY " ". 
    DISPLAY "END COBOL PARTBOM.". 
    STOP RUN. 
 
PARTBOM-LOOP. 
    FIND NEXT COMPONENT WITHIN PART_USES 
        AT END PERFORM POP-COMPONENT THRU POP-COMPONENT-EXIT 
               GO TO PARTBOM-LOOP-EXIT. 
    KEEP CURRENT USING KEEP-COMPONENT. 
    ADD 1 TO INDENT-LEVEL. 
    FIND OWNER PART_USED_ON. 
    GET PART_ID, PART_DESC. 
    DISPLAY INDENT-TREE, PART_ID, " - ", PART_DESC. 
 
PARTBOM-LOOP-EXIT. 
    EXIT. 
 
POP-COMPONENT. 
    FIND LAST WITHIN KEEP-COMPONENT 
        AT END MOVE 1 TO END-OF-COLLECTION 
               GO TO POP-COMPONENT-EXIT. 
    FREE LAST WITHIN KEEP-COMPONENT. 
    SUBTRACT 1 FROM INDENT-LEVEL. 
 
POP-COMPONENT-EXIT. 
    EXIT.

8.4 PARTBOM Sample Run

Example 8-4 displays a sample run of the PARTBOM program in Example 8-3.

Example 8-4 Sample Run of the PARTBOM Program 

Enter PARTID> BT163456 
 
                 +-----------------------------------+ 
                 | Parts Bill of Materials Explosion | 
                 |          (COBOL Version)          | 
                 |         Part-id: BT163456         | 
                 +-----------------------------------+ 
 
BT163456 - VT100 
|  BU355678 - VT100 NON REFLECTIVE SCREEN 
|  BU345670 - TERMINAL TABLE VT100 
|  |  AZ345678 - 3/4 INCH SCREWS 
|  |  AZ167890 - 1/2 INCH SCREWS 
|  |  AZ517890 - 1/4 INCH BOLTS 
|  |  AZ012345 - 3 INCH NAILS 
|  |  AS234567 - 1/4 INCH TACKS 
|  |  AS901234 - 3/8 INCH SCREWS 
|  |  AS456789 - 4/5 INCH CLAMP 
|  |  AS560890 - 1 INCH CLAMP 
|  BU456789 - PLASTIC KEY ALPHA. 
|  BU345438 - PLASTIC KEY NUM. 
|  BU234567 - VIDEO TUBE 
|  |  AZ345678 - 3/4 INCH SCREWS 
|  |  AZ789012 - 3/8 INCH BOLTS 
|  |  AS234567 - 1/4 INCH TACKS 
|  |  AS560890 - 1 INCH CLAMP 
|  BU890123 - VT100 HOUSING 
|  BU876778 - VT100 SCREEN 
|  AZ345678 - 3/4 INCH SCREWS 
|  AZ567890 - 1/4 INCH SCREWS 
|  AZ789012 - 3/8 INCH BOLTS 
|  AS901234 - 3/8 INCH SCREWS 
|  AS890123 - 3/4 INCH ELECTRICAL TAPE 
 
Enter PARTID> [ctrl/z]
 
END COBOL PARTBOM.

8.5 Creating Relationships Between Records of the Same Type

The STOOL program in Example 8-5 illustrates how to create a relationship between records of the same type. It loads and connects the parts example discussed in Section 5.9.2.2 and produces a parts breakdown report illustrating the relationships. Section 8.6 contains the sample report.

Example 8-5 Creating Relationships Between Records of the Same Type 

IDENTIFICATION DIVISION. 
PROGRAM-ID. STOOL. 
DATA DIVISION. 
SUB-SCHEMA SECTION. 
DB  PARTSS1 WITHIN  PARTS FOR "NEW.ROO". 
LD  KEEP-COMPONENT. 
WORKING-STORAGE SECTION. 
01  DB-ERROR-CHECK       PIC 9. 
    88  DB-ERROR         VALUE 1. 
    88  DB-OK            VALUE 0. 
01  DB-COND              PIC 9(9). 
01  DB-ID                PIC 9(4). 
 
PROCEDURE DIVISION. 
A000-BEGIN. 
    READY USAGE-MODE IS CONCURRENT UPDATE. 
    MOVE 0 TO DB-ERROR-CHECK. 
    PERFORM B000-STORE-PARTS THROUGH 
            B300-BUILD-AND-STORE-STOOL-LEG. 
    IF DB-OK PERFORM C000-STORE-COMPONENTS 
                     THRU 800-VERIFY-ROUTINE. 
 
A100-EOJ. 
*   IF DB-ERROR 
    ROLLBACK ON ERROR DISPLAY "Error on ROLLBACK" 
             PERFORM 900-DISPLAY-DB-CONDITION 
             END-ROLLBACK 
    DISPLAY "End of Job". 
    STOP RUN. 
 
B000-STORE-PARTS. 
    FIND FIRST PART ON ERROR 
         DISPLAY "Positioning to first part is unsuccessful" 
         PERFORM 900-DISPLAY-DB-CONDITION 
         MOVE 1 TO DB-ERROR-CHECK. 
 
B100-BUILD-AND-STORE-STOOL. 
    MOVE "SAMP1" TO PART_ID. 
    MOVE "STOOL" TO PART_DESC. 
    MOVE "G"     TO PART_STATUS. 
    MOVE 11      TO PART_PRICE. 
    MOVE 6       TO PART_COST. 
    MOVE SPACES  TO PART_SUPPORT. 
    IF DB-OK STORE PART ON ERROR 
          DISPLAY "B100 Error in storing STOOL" 
          PERFORM 900-DISPLAY-DB-CONDITION 
          MOVE 1 TO DB-ERROR-CHECK. 
 
B200-BUILD-AND-STORE-STOOL-SEAT. 
    MOVE "SAMP2"      TO PART_ID. 
    MOVE "STOOL SEAT" TO PART_DESC. 
    MOVE "G"          TO PART_STATUS. 
    MOVE 3            TO PART_PRICE. 
    MOVE 2            TO PART_COST. 
    MOVE SPACES       TO PART_SUPPORT. 
    IF DB-OK STORE PART ON ERROR 
          DISPLAY "B200 Error in storing STOOL SEAT" 
          PERFORM 900-DISPLAY-DB-CONDITION 
          MOVE 1 TO DB-ERROR-CHECK. 
 
B300-BUILD-AND-STORE-STOOL-LEG. 
    MOVE "SAMP3"      TO PART_ID. 
    MOVE "STOOL LEGS" TO PART_DESC. 
    MOVE "G"          TO PART_STATUS. 
    MOVE 2            TO PART_PRICE. 
    MOVE 1            TO PART_COST. 
    MOVE SPACES       TO PART_SUPPORT. 
    IF DB-OK STORE PART ON ERROR 
          DISPLAY "B300 Error in storing STOOL LEGS" 
          PERFORM 900-DISPLAY-DB-CONDITION 
          MOVE 1 TO DB-ERROR-CHECK. 
 
C000-STORE-COMPONENTS. 
    MOVE "STOOL" TO PART_DESC. 
 
C100-FIND-STOOL. 
    FIND FIRST PART USING PART_DESC ON ERROR 
         DISPLAY "C000 Error in finding STOOL" 
         PERFORM 900-DISPLAY-DB-CONDITION 
         MOVE 1 TO DB-ERROR-CHECK. 
    MOVE "STOOL SEAT" TO PART_DESC. 
 
C200-FIND-STOOL-SEAT. 
    IF DB-OK 
       FIND FIRST PART USING PART_DESC RETAINING PART_USES 
         ON ERROR 
             DISPLAY "C000 Error in finding STOOL SEAT" 
             PERFORM 900-DISPLAY-DB-CONDITION 
             MOVE 1 TO DB-ERROR-CHECK. 
 
C300-CONNECT-COMPONENT-1. 
    MOVE "SAMP2" TO COMP_SUB_PART. 
    MOVE "SAMP1" TO COMP_OWNER_PART. 
    MOVE "U"     TO COMP_MEASURE. 
    MOVE 1       TO COMP_QUANTITY. 
    IF DB-OK 
       STORE COMPONENT RETAINING PART_USES 
         ON ERROR 
             DISPLAY "C000 Error in storing first component" 
             PERFORM 900-DISPLAY-DB-CONDITION 
             MOVE 1 TO DB-ERROR-CHECK. 
 
C400-FIND-STOOL-LEGS. 
    MOVE "STOOL LEGS" TO PART_DESC. 
    IF DB-OK 
       FIND FIRST PART USING PART_DESC RETAINING PART_USES 
         ON ERROR 
             DISPLAY "C000 Error in finding STOOL LEGS" 
             PERFORM 900-DISPLAY-DB-CONDITION 
             MOVE 1 TO DB-ERROR-CHECK. 
 
C500-CONNECT-COMPONENT-4. 
    MOVE "SAMP3" TO COMP_SUB_PART. 
    MOVE "SAMP1" TO COMP_OWNER_PART. 
    MOVE "U"     TO COMP_MEASURE. 
    MOVE 4       TO COMP_QUANTITY. 
    IF DB-OK 
       STORE COMPONENT 
         ON ERROR 
             DISPLAY "C000 Error in storing second component" 
             PERFORM 900-DISPLAY-DB-CONDITION 
             MOVE 1 TO DB-ERROR-CHECK. 
 
800-VERIFY-ROUTINE. 
    CALL "PARTBOM". 
 
900-DISPLAY-DB-CONDITION. 
    MOVE DB-CONDITION                  TO DB-COND. 
    MOVE DB-CURRENT-RECORD-ID          TO DB-ID. 
    DISPLAY "DB-CONDITION            - ", DB-COND. 
    DISPLAY "DB-CURRENT-RECORD-NAME  - ", 
                             DB-CURRENT-RECORD-NAME. 
    DISPLAY "DB-CURRENT-RECORD-ID    - ", DB-ID. 
    CALL "DBM$SIGNAL". 
 
IDENTIFICATION DIVISION. 
PROGRAM-ID.  PARTBOM. 
ENVIRONMENT DIVISION. 
INPUT-OUTPUT SECTION. 
FILE-CONTROL. 
     SELECT  INPUT-FILE ASSIGN TO "SYS$COMMAND". 
 
DATA DIVISION. 
SUB-SCHEMA SECTION. 
*  DB PARTSS1 WITHIN  PARTS FOR "NEW.ROO". 
 
FILE SECTION. 
FD      INPUT-FILE 
        LABEL RECORDS ARE STANDARD 
        DATA  RECORD  IS  INPUT-REC. 
01      INPUT-REC               PIC X(80). 
 
WORKING-STORAGE SECTION. 
01      INDENT-LEVEL            PIC 9(02)  VALUE 40. 
01      DBM$_END                PIC 9(09)  COMP 
                                VALUE EXTERNAL DBM$_END. 
01      END-OF-COLLECTION       PIC 9(01)  VALUE 0. 
        88  END-COLLECTION                 VALUE 1. 
01      INDENT-TREE. 
        02  INDENT-TREE-ARRAY   PIC X(03) 
                                OCCURS 1 TO 40 TIMES 
                                DEPENDING  ON INDENT-LEVEL. 
 
PROCEDURE DIVISION. 
 
INITIALIZATION. 
    OPEN INPUT  INPUT-FILE. 
    MOVE ALL "|  " TO INDENT-TREE. 
 
SOLICIT-INPUT. 
    MOVE ZERO TO END-OF-COLLECTION. 
    DISPLAY " ". 
    DISPLAY "Enter PART_ID> " WITH NO ADVANCING. 
    MOVE SPACES TO INPUT-REC. 
    READ INPUT-FILE INTO PART_ID 
        AT END GO TO PARTBOM-DONE. 
    FETCH FIRST PART WITHIN ALL_PARTS USING PART_ID 
        AT END DISPLAY "*** Part number ", 
                                PART_ID, " not found.  ***" 
               GO TO SOLICIT-INPUT. 
    DISPLAY    " ". 
    DISPLAY    " ". 
    DISPLAY 
    DISPLAY "+-----------------------------------+". 
    DISPLAY "| Parts Bill of Materials Explosion |". 
    DISPLAY "|          (COBOL Version)          |". 
    DISPLAY "|         Part-id: " PART_ID "      |". 
    DISPLAY "+-----------------------------------+". 
    DISPLAY " ". 
    DISPLAY " ". 
    DISPLAY " ". 
    DISPLAY    PART_ID, " - ", PART_DESC 
    MOVE ZERO TO INDENT-LEVEL. 
    FREE ALL FROM KEEP-COMPONENT. 
    PERFORM PARTBOM-LOOP THRU PARTBOM-LOOP-EXIT 
        UNTIL END-COLLECTION. 
    GO TO SOLICIT-INPUT. 
 
PARTBOM-DONE. 
    CLOSE INPUT-FILE. 
    EXIT PROGRAM. 
 
PARTBOM-LOOP. 
    FIND NEXT COMPONENT WITHIN PART_USES 
         AT END PERFORM POP-COMPONENT 
                       THRU POP-COMPONENT-EXIT 
         GO TO PARTBOM-LOOP-EXIT. 
    KEEP CURRENT USING KEEP-COMPONENT. 
    ADD 1 TO INDENT-LEVEL. 
    FIND OWNER PART_USED_ON. 
    GET PART_ID, PART_DESC. 
    DISPLAY INDENT-TREE, PART_ID, " - ", PART_DESC. 
 
PARTBOM-LOOP-EXIT. 
    EXIT. 
 
POP-COMPONENT. 
    FIND    LAST WITHIN KEEP-COMPONENT 
        AT END MOVE 1 TO END-OF-COLLECTION 
               GO TO POP-COMPONENT-EXIT. 
    FREE    LAST WITHIN KEEP-COMPONENT. 
    SUBTRACT 1 FROM INDENT-LEVEL. 
 
POP-COMPONENT-EXIT. 
    EXIT. 
END PROGRAM PARTBOM. 
END PROGRAM STOOL.

8.6 STOOL Program Parts Breakdown Report---Sample Run

This is the report output by the STOOL program in Example 8-5. 


      Enter PARTID>  (SAMP1 [RET] 
          +-----------------------------------+ 
          | Parts Bill of Materials Explosion | 
          |         (COBOL Version)           | 
          |          Part-id: SAMP1           | 
          +-----------------------------------+ 
 
          SAMP1    - STOOL 
          SAMP3    - STOOL LEGS 
          SAMP2    - STOOL SEAT 
 
          Enter PARTID> [ctrl/z]
          End of Job

8.7 Creating New Record Relationships

The PERSONNEL-UPDATE program in Example 8-6 creates the records and implements the relationships described in Section 5.9.2.3. It directly contains two other programs: PROMOTION-UPDATE and PERSONNEL-REPORT. PROMOTION-UPDATE is directly contained by PERSONNEL-UPDATE. It changes the record relationships created by PERSONNEL-UPDATE. PERSONNEL-REPORT is also directly contained by PERSONNEL-UPDATE. It generates one report showing the record relationships just after creation by PERSONNEL-UPDATE and another report showing the new record relationships. PERSONNEL-REPORT is a Report Writer program. Section 8.7.1 and Section 8.7.2 each contain a report generated by the PERSONNEL-UPDATE program.

Example 8-6 Creating New Record Relationships 

IDENTIFICATION DIVISION. 
PROGRAM-ID. PERSONNEL-UPDATE. 
 
DATA DIVISION. 
SUB-SCHEMA SECTION. 
DB PARTSS1 WITHIN PARTS FOR "NEW.ROO". 
LD KEEPSUPER. 
LD KEEP-EMPLOYEE. 
 
WORKING-STORAGE SECTION. 
01  ANSWER      PIC X. 
 
PROCEDURE DIVISION. 
A000-BEGIN. 
    READY USAGE-MODE IS UPDATE. 
    PERFORM A100-EMPLOYEE-LOAD. 
    PERFORM A200-CONNECTING-TO-CONSISTS-OF. 
    DISPLAY "Employees and groups are loaded". 
    DISPLAY "Personnel Report before update ..." 
    CALL "PERSONNEL-REPORT". 
    DISPLAY "Press your carriage return key to continue". 
    ACCEPT ANSWER. 
    CALL "PROMOTION-UPDATE". 
    DISPLAY "Promotions completed". 
    DISPLAY "Press your carriage return key to continue". 
    ACCEPT ANSWER. 
    DISPLAY "Personnel Report after update ...". 
    CALL "PERSONNEL-REPORT". 
 
A010-EOJ. 
    ROLLBACK. 
    DISPLAY "End of PERSONNEL-UPDATE". 
    STOP RUN. 
 
A100-EMPLOYEE-LOAD. 
    MOVE 10500     TO EMP_ID. 
    MOVE "HOWELL"  TO EMP_LAST_NAME. 
    MOVE "JOHN"    TO EMP_FIRST_NAME. 
    MOVE 1111111   TO EMP_PHONE. 
    MOVE "N.H."    TO EMP_LOC. 
    STORE EMPLOYEE. 
 
    MOVE 08400     TO EMP_ID. 
    MOVE "NOYCE"   TO EMP_LAST_NAME. 
    MOVE "BILL"    TO EMP_FIRST_NAME. 
    MOVE 2222222   TO EMP_PHONE. 
    MOVE "N.H."    TO EMP_LOC. 
    STORE EMPLOYEE. 
 
    MOVE 06600     TO EMP_ID. 
    MOVE "MOORE"   TO EMP_LAST_NAME. 
    MOVE "BRUCE"   TO EMP_FIRST_NAME. 
    MOVE 3333333   TO EMP_PHONE. 
    MOVE "N.H."    TO EMP_LOC. 
    STORE EMPLOYEE. 
 
    MOVE 01000     TO EMP_ID. 
    MOVE "RAVAN"   TO EMP_LAST_NAME. 
    MOVE "JERRY"   TO EMP_FIRST_NAME. 
    MOVE 5555555   TO EMP_PHONE. 
    MOVE "N.H."    TO EMP_LOC. 
    STORE EMPLOYEE. 
 
    MOVE 04000     TO EMP_ID. 
    MOVE "BURLEW"  TO EMP_LAST_NAME. 
    MOVE "THOMAS"  TO EMP_FIRST_NAME. 
    MOVE 6666666   TO EMP_PHONE. 
    MOVE "N.H."    TO EMP_LOC. 
    STORE EMPLOYEE. 
 
    MOVE 07000     TO EMP_ID. 
    MOVE "NEILS"   TO EMP_LAST_NAME. 
    MOVE "ALBERT"  TO EMP_FIRST_NAME. 
    MOVE 7777777   TO EMP_PHONE. 
    MOVE "N.H."    TO EMP_LOC. 
    STORE EMPLOYEE. 
 
    MOVE 05000     TO EMP_ID. 
    MOVE "KLEIN"   TO EMP_LAST_NAME. 
    MOVE "DON"     TO EMP_FIRST_NAME. 
    MOVE 8888888   TO EMP_PHONE. 
    MOVE "N.H."    TO EMP_LOC. 
    STORE EMPLOYEE. 
 
    MOVE 02000     TO EMP_ID. 
    MOVE "DEANE"   TO EMP_LAST_NAME. 
    MOVE "FRANK"   TO EMP_FIRST_NAME. 
    MOVE 9999999   TO EMP_PHONE. 
    MOVE "N.H."    TO EMP_LOC. 
    STORE EMPLOYEE. 
 
    MOVE 01400     TO EMP_ID. 
    MOVE "RILEY"   TO EMP_LAST_NAME. 
    MOVE "GEORGE"  TO EMP_FIRST_NAME. 
    MOVE 1234567   TO EMP_PHONE. 
    MOVE "N.H."    TO EMP_LOC. 
    STORE EMPLOYEE. 
 
    MOVE 05500     TO EMP_ID. 
    MOVE "BAKER"   TO EMP_LAST_NAME. 
    MOVE "DOUGH"   TO EMP_FIRST_NAME. 
    MOVE 7654321   TO EMP_PHONE. 
    MOVE "N.H."    TO EMP_LOC. 
    STORE EMPLOYEE. 
 
    MOVE 07400     TO EMP_ID. 
    MOVE "FIFER"   TO EMP_LAST-NAME. 
    MOVE "MIKE"    TO EMP_FIRST_NAME. 
    MOVE 1212121   TO EMP_PHONE. 
    MOVE "N.H."    TO EMP_LOC. 
    STORE EMPLOYEE. 
 
A200-CONNECTING-TO-CONSISTS-OF. 
    MOVE 10500 TO EMP_ID. 
    FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING EMP_ID. 
    MOVE "A" TO GROUP_NAME. 
    STORE WK_GROUP. 
 
    MOVE 08400 TO EMP_ID. 
    FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING EMP_ID. 
    CONNECT EMPLOYEE TO CONSISTS_OF. 
 
    MOVE 06600 TO EMP_ID. 
    FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING EMP_ID. 
    CONNECT EMPLOYEE TO CONSISTS_OF. 
 
    MOVE 08400 TO EMP_ID. 
    FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING EMP_ID. 
    MOVE "B1" TO GROUP_NAME. 
    STORE WK_GROUP. 
 
    MOVE 01000 TO EMP_ID. 
    FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING EMP_ID. 
    CONNECT EMPLOYEE TO CONSISTS_OF. 
 
    MOVE 04000 TO EMP_ID. 
    FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING EMP_ID. 
    CONNECT EMPLOYEE TO CONSISTS_OF. 
 
    MOVE 07000 TO EMP_ID. 
    FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING EMP_ID. 
    CONNECT EMPLOYEE TO CONSISTS_OF. 
 
    MOVE 06600 TO EMP_ID. 
    FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING EMP_ID. 
    MOVE "B2" TO GROUP_NAME. 
    STORE WK_GROUP. 
 
    MOVE 01400 TO EMP_ID. 
    FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING EMP_ID. 
    CONNECT EMPLOYEE TO CONSISTS_OF. 
 
    MOVE 02000 TO EMP_ID. 
    FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING EMP_ID. 
    CONNECT EMPLOYEE TO CONSISTS_OF. 
 
    MOVE 05000 TO EMP_ID. 
    FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING EMP_ID. 
    CONNECT EMPLOYEE TO CONSISTS_OF. 
 
    MOVE 05500 TO EMP_ID. 
    FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING EMP_ID. 
    CONNECT EMPLOYEE TO CONSISTS_OF. 
 
    MOVE 07400 TO EMP_ID. 
    FIND FIRST EMPLOYEE WITHIN ALL_EMPLOYEES USING EMP_ID. 
    CONNECT EMPLOYEE TO CONSISTS_OF. 
 
IDENTIFICATION DIVISION. 
PROGRAM-ID. PROMOTION-UPDATE. 
 
PROCEDURE DIVISION. 
A000-BEGIN. 
    MOVE "A" TO GROUP_NAME. 
* 
* The next statement makes HOWELL's GROUP "A" record current 
* 
    FIND FIRST WK_GROUP USING GROUP_NAME. 
* 
* The next two statements fetch KLEIN using EMP_ID. 
* The RETAINING clause keeps the WK_GROUP record "A" 
* as current of the CONSISTS_OF set. This allows the program 
* to connect KLEIN to the correct occurrence of WK_GROUP. 
* A fetch to KLEIN without the RETAINING clause makes KLEIN 
* current of CONSISTS_OF thus destroying the pointer to the 
* WK_GROUP record "A". 
* 
    MOVE 05000 TO EMP_ID. 
    FETCH FIRST EMPLOYEE USING EMP_ID RETAINING CONSISTS_OF. 
* 
* The next statement disconnects KLEIN from the WK_GROUP "B1" 
* record and connects him to the current WK_GROUP "A" record. 
* 
    RECONNECT EMPLOYEE WITHIN CONSISTS_OF. 
* 
* The next two sentences create and store a WK_GROUP record. 
* Because KLEIN is current of EMPLOYEE, a STORE WK_GROUP 
* automatically connects WK_GROUP as a member of the MANAGES 
* set owned by KLEIN, and makes "B3" current of the MANAGES 
* and CONSISTS_OF sets. 
* 
    MOVE "B3" TO WK_GROUP. 
    STORE WK_GROUP. 
* 
* The next two statements fetch NEILS and retain WK_GROUP 
* "B3" as current of CONSISTS_OF. 
* 
    MOVE 7000 TO EMP_ID. 
    FETCH FIRST EMPLOYEE USING EMP_ID RETAINING CONSISTS_OF. 
* 
* The next statement disconnects NEILS from WK_GROUP "B1" 
* record and reconnects him to the WK_GROUP "B3" record. 
* It also retains "B3" as current of CONSISTS_OF. This 
* maintains the pointer at "B3" allowing the program to 
* reassign RILEY to KLEIN. 
* 
    RECONNECT EMPLOYEE WITHIN CONSISTS_OF RETAINING CONSISTS_OF. 
* 
* The next three statements fetch RILEY, disconnect him from 
* "B2" and reconnect him to "B3". 
* 
    MOVE 01400 TO EMP_ID. 
    FETCH FIRST EMPLOYEE USING EMP_ID RETAINING CONSISTS_OF. 
    RECONNECT EMPLOYEE WITHIN CONSISTS_OF. 
 
END PROGRAM PROMOTION-UPDATE. 
 
IDENTIFICATION DIVISION. 
PROGRAM-ID. PERSONNEL-REPORT. 
 
ENVIRONMENT DIVISION. 
INPUT-OUTPUT SECTION. 
FILE-CONTROL. 
    SELECT PERSONNEL-REPORT-FILE ASSIGN TO "TT:". 
 
DATA DIVISION. 
FILE SECTION. 
FD  PERSONNEL-REPORT-FILE 
    VALUE OF ID IS "PERSONNEL.LIS" 
    REPORT IS PERSONNEL-LISTING. 
 
WORKING-STORAGE SECTION. 
01  CONTROL-FIELDS. 
    02  MANAGER-NAME      PIC X(20). 
    02  MANAGES-GROUP     PIC XX. 
    02  SUPERVISOR-NAME   PIC X(20). 
    02  SUPERVISES-GROUP  PIC XX. 
    02  EMPLOYEE-NUMBER   PIC XXXXX. 
    02  EMPLOYEE-NAME     PIC X(20). 
REPORT SECTION. 
RD  PERSONNEL-LISTING 
    PAGE LIMIT IS 66 
    HEADING       1 
    FIRST DETAIL  3 
    LAST DETAIL   60 
    CONTROLS ARE  MANAGES-GROUP 
                  SUPERVISES-GROUP. 
01  TYPE IS PAGE HEADING. 
    02  LINE 1 COLUMN 22 
               PIC X(16) VALUE "EMPLOYEE LISTING". 
01  MANAGER-CONTROL TYPE IS CONTROL HEADING MANAGES-GROUP. 
    02  LINE IS PLUS 1. 
        03  COLUMN 16 PIC X(17) 
                      VALUE "MANAGER OF GROUP ". 
        03  COLUMN 33 PIC XX 
                      SOURCE MANAGES-GROUP. 
        03  COLUMN 35 PIC XXXX 
                      VALUE "IS: ". 
        03  COLUMN 39 PIC X(20) 
                      SOURCE MANAGER-NAME. 
01  GROUP-CONTROL TYPE IS CONTROL HEADING SUPERVISES-GROUP. 
    02  LINE IS PLUS 1. 
        03  COLUMN 3  PIC XXXXXXX 
                      VALUE "GROUP: ". 
        03  COLUMN 10 PIC XX 
                      SOURCE SUPERVISES-GROUP. 
    02  LINE IS PLUS 1. 
        03  COLUMN 3  PIC X(15) 
                      VALUE IS "SUPERVISOR IS: ". 
        03  COLUMN 18 PIC X(20) 
                      SOURCE IS SUPERVISOR-NAME. 
    02  LINE IS PLUS 2. 
        03  COLUMN 3  PIC X(6) 
                      VALUE "GROUP ". 
        03  COLUMN 9  PIC XX 
                      SOURCE IS SUPERVISES-GROUP. 
        03  COLUMN 12 PIC X(9) 
                      VALUE "EMPLOYEES". 
        03  COLUMN 24 PIC X(15) 
                      VALUE "EMPLOYEE NUMBER". 
        03  COLUMN 43 PIC X(13) 
                      VALUE "EMPLOYEE NAME". 
01  EMPLOYEE-LINE TYPE IS DETAIL. 
    02  LINE IS PLUS 1. 
        03  COLUMN 28 PIC XXXXX SOURCE IS EMPLOYEE-NUMBER. 
        03  COLUMN 44 PIC X(20) SOURCE IS EMPLOYEE-NAME. 
 
PROCEDURE DIVISION. 
A000-BEGIN. 
    OPEN OUTPUT PERSONNEL-REPORT-FILE. 
    INITIATE PERSONNEL-LISTING. 
    PERFORM A100-GET-THE-BOSS THROUGH A700-DONE-THE-BOSS. 
    TERMINATE PERSONNEL-LISTING. 
    CLOSE PERSONNEL-REPORT-FILE. 
    EXIT PROGRAM. 
 
A100-GET-THE-BOSS. 
    MOVE 10500 TO EMP_ID. 
    FETCH FIRST EMPLOYEE USING EMP_ID. 
    MOVE EMP_LAST_NAME TO MANAGER-NAME. 
    FETCH FIRST WK_GROUP WITHIN MANAGES. 
    MOVE GROUP_NAME TO MANAGES-GROUP. 
 
A200-GET-SUPERVISORS. 
    FETCH NEXT EMPLOYEE WITHIN CONSISTS_OF 
               AT END GO TO A700-DONE-THE-BOSS. 
    MOVE EMP_LAST_NAME TO SUPERVISOR-NAME. 
    KEEP CURRENT USING KEEPSUPER. 
    FETCH NEXT WK_GROUP WITHIN MANAGES. 
    MOVE GROUP_NAME TO SUPERVISES-GROUP. 
    PERFORM A500-GET-EMPLOYEES THROUGH A600-DONE-EMPLOYEES. 
    GO TO A200-GET-SUPERVISORS. 
 
A500-GET-EMPLOYEES. 
    FETCH NEXT EMPLOYEE WITHIN CONSISTS_OF 
               AT END GO TO A510-FIND-CURRENT-SUPER. 
    MOVE EMP_LAST_NAME TO EMPLOYEE-NAME. 
    MOVE EMP_ID        TO EMPLOYEE-NUMBER. 
    GENERATE EMPLOYEE-LINE. 
    GO TO A500-GET-EMPLOYEES. 
 
A510-FIND-CURRENT-SUPER. 
    FIND FIRST WITHIN KEEPSUPER. 
    FREE ALL FROM KEEPSUPER. 
 
A600-DONE-EMPLOYEES. 
    EXIT. 
 
A700-DONE-THE-BOSS. 
    EXIT. 
 
END PROGRAM PERSONNEL-REPORT. 
 
END PROGRAM PERSONNEL-UPDATE.

8.7.1 PERSONNEL-UPDATE Sample Run---Listing Before Promotion

This sample report (Example 8-7), created by the preceding PERSONNEL-UPDATE program, corresponds to the data in Figure 5-25.

Example 8-7 Sample Run of PERSONNEL-UPDATE Before Promotion 

                  EMPLOYEE LISTING 
 
            MANAGER OF GROUP A IS: HOWELL 
GROUP B2 
SUPERVISOR IS: MOORE 
 
GROUP B2 EMPLOYEES   EMPLOYEE NUMBER    EMPLOYEE NAME 
                         05500           BAKER 
                         02000           DEANE 
                         07400           FIFER 
                         05000           KLEIN 
                         01400           RILEY 
GROUP B1 
SUPERVISOR IS: NOYCE 
 
GROUP B1 EMPLOYEES   EMPLOYEE NUMBER    EMPLOYEE NAME 
                         04000           BURLEW 
                         07000           NEILS 
                         01000           RAVAN

Previous Next Contents Index