The MODELPGM program demonstrates tableBASE best practices. It calls the sample subprogram TBTMPLAT. MODELPGM opens two tableBASE tables into the local TSR. It fetches rows sequentially from one table and accesses another table directly by key based on data in the first table. A count is kept of how many rows were fetched from the first table and how many were matched in the second table. At the end, the counts are displayed.
The following shows the MODELPGM program details.
IDENTIFICATION DIVISION.
PROGRAM-ID. MODELPGM.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
***********************************************************
*
***********************************************************
DATA DIVISION.
FILE SECTION.
WORKING-STORAGE SECTION.
01 WS-LIL-DATE PIC S9(9) BINARY.
01 WS-LIL-SECS COMP-2.
01 DATE-TIME-AREAS.
05 WS-DATE-TIME.
06 RUN-DATE.
10 WS-YYYY PIC XXXX VALUE SPACES.
10 WS-MM PIC XX VALUE SPACES.
10 WS-DD PIC XX VALUE SPACES.
06 RUN-TIME.
10 WS-HH PIC XX VALUE SPACES.
10 WS-MI PIC XX VALUE SPACES.
10 WS-SS PIC XX VALUE SPACES.
10 WS-MS PIC XXX VALUE SPACES.
05 W-DISPLAY-DATE-TIME.
10 W-DISPLAY-YEAR PIC XXXX VALUE SPACES.
10 FILLER PIC X VALUE '/'.
10 W-DISPLAY-MONTH PIC XX VALUE SPACES.
10 FILLER PIC X VALUE '/'.
10 W-DISPLAY-DAY PIC XX VALUE SPACES.
10 FILLER PIC X VALUE ' '.
10 W-DISPLAY-HOUR PIC XX VALUE SPACES.
10 FILLER PIC X VALUE ':'.
10 W-DISPLAY-MIN PIC XX VALUE SPACES.
10 FILLER PIC X VALUE ':'.
10 W-DISPLAY-SEC PIC XX VALUE SPACES.
10 FILLER PIC X VALUE '.'.
10 W-DISPLAY-1000THS PIC XXX VALUE SPACES.
01 TB-TRANS-CMD-AREA.
05 TB-TRANS-CMD PIC X(2) VALUE SPACES.
05 TB-TRANS-TABLE PIC X(8) VALUE SPACES.
05 FILLER PIC X(62) VALUE LOW-VALUES.
01 TB-REF-CMD-AREA.
05 TB-REF-CMD PIC X(2) VALUE SPACES.
05 TB-REF-TABLE PIC X(8) VALUE SPACES.
05 FILLER PIC X(62) VALUE LOW-VALUES.
01 REFERENCE-TABLE-ROW.
05 REF-CUST-NO PIC 9(6).
05 REF-CUST-NAME PIC X(30).
05 REF-CUST-TERRITORY PIC 9(3).
01 TRANSACTION-TABLE-ROW.
05 TRANS-NUMBER PIC 9(8).
05 TRANS-CUST-NO PIC 9(6).
05 TRANS-ORDER-NO PIC 9(9).
05 TRANS-ORDER-AMT PIC S9(7)V99.
77 W-TRANS-COUNT PIC S9(9) BINARY.
77 W-MATCH-COUNT PIC S9(9) BINARY.
77 TBTMPLAT PIC X(8) VALUE 'TBTMPLAT'.
*****************************************************************
PROCEDURE DIVISION.
Perform INIT
Perform PROCESS-TABLES
Perform TERM
Goback.
PROCESS-TABLES.
* Open Reference Table
Perform OPEN-REF-TABLE
* Open Transaction Table
If Return-Code = 0
Perform OPEN-TRANS-TABLE
End-if
* Process transaction table
If Return-Code = 0
Move 0 to W-Trans-Count W-Match-Count
Perform Process-Trans
Until Return-Code > 0
End-if
If Return-Code = 2
Move 0 to Return-Code
End-if
If Return-Code = 0
Display 'Transactions Processed ' W-Trans-Count
Display 'Transactions Matched ' W-Match-Count
End-if
Exit.
* -----------------------------------------------------------
Process-Trans.
*
Call TBTMPLAT Using TB-TRANS-CMD-AREA
TRANSACTION-TABLE-ROW
If Return-Code = 0
Add +1 to W-TRANS-COUNT
Move TRANS-CUST-NO to REF-CUST-NO
Call TBTMPLAT Using TB-REF-CMD-AREA
REFERENCE-TABLE-ROW
Evaluate TRUE
When Return-Code = 0
Add +1 to W-MATCH-COUNT
When Return-Code = 2
Move 0 to Return-Code
When Other
Continue
End-if.
* -----------------------------------------------------------
OPEN-TRANS-TABLE.
Move 'OR' to TB-TRANS-CMD
Move 'TRANSTBL' to TB-TRANS-TABLE
Call TBTMPLAT Using TB-TRANS-CMD-AREA OMITTED OMITTED
If Return-Code = 0
Move 'GN' to TB-TRANS-CMD
Else
Display 'MODELPGM Program failed to Open Table '
TB-TRANS-TABLE
End-If
Exit.
OPEN-REF-TABLE.
Move 'OR' to TB-REF-CMD
Move 'CUSTREF' to TB-REF-TABLE
Call TBTMPLAT Using TB-REF-CMD-AREA OMITTED OMITTED
If Return-Code = 0
Move 'FK' to TB-REF-CMD
Else
Display 'MODELPGM Program failed to Open Table '
TB-REF-TABLE
End-If
Exit.
*****************************************************************
INIT.
Call 'CEELOCT' Using WS-LIL-DATE WS-LIL-SECS WS-DATE-TIME
MOVE WS-YYYY TO W-DISPLAY-YEAR
MOVE WS-MM TO W-DISPLAY-MONTH
MOVE WS-DD TO W-DISPLAY-DAY
MOVE WS-HH TO W-DISPLAY-HOUR
MOVE WS-MI TO W-DISPLAY-MIN
MOVE WS-SS TO W-DISPLAY-SEC
MOVE WS-MS TO W-DISPLAY-1000THS
DISPLAY ' '
DISPLAY 'TSTTMPLT STARTED ' W-DISPLAY-DATE-TIME
EXIT.
TERM.
Move spaces to WS-MS
ACCEPT RUN-DATE FROM DATE YYYYMMDD
ACCEPT RUN-TIME FROM TIME
* Call 'CEELOCT' Using WS-LIL-DATE WS-LIL-SECS WS-DATE-TIME
* CEELOCT has a bug at our level
MOVE WS-YYYY TO W-DISPLAY-YEAR
MOVE WS-MM TO W-DISPLAY-MONTH
MOVE WS-DD TO W-DISPLAY-DAY
MOVE WS-HH TO W-DISPLAY-HOUR
MOVE WS-MI TO W-DISPLAY-MIN
MOVE WS-SS TO W-DISPLAY-SEC
MOVE WS-MS TO W-DISPLAY-1000THS
DISPLAY ' '
DISPLAY 'TSTTMPLT ENDED ' W-DISPLAY-DATE-TIME
' RETURN-CODE = ' RETURN-CODE
EXIT.
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx