MODELPGM

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