Utility Procs

these tiny procs may be installed into your common user proclib to provide for commonly used tasks in JCL.

EXIST - how to test if dataset exists

this requires the program PARMGEN (see below) to be installed in a user loadlib. 

//EXIST PROC DS=                                       
//* //TEST EXEC EXIST,DS=YOUR.FILE.NAME                
//* // IF TEST.EXIST.RC=0 THEN /* IF FILE EXISTS ... */
//GENLISTC EXEC PGM=PARMGEN,PARM=' LISTC ENT(&DS)'    
//STEPLIB DD DISP=SHR,DSN=USER.LOADLIB                
//PARMOUT DD DSN=&&EXISTQ,UNIT=SYSDA,SPACE=(TRK,1),    
// RECFM=FB,LRECL=80,BLKSIZE=0,DISP=(,PASS,DELETE)     
//SYSOUT DD SYSOUT=*                                   
//EXIST EXEC PGM=IDCAMS                                
//SYSPRINT DD SYSOUT=Z    /* PRINT TO BIT BUCKET */
//SYSIN DD DISP=(OLD,DELETE,DELETE),DSN=&&EXISTQ

HASDATA - how to test if dataset has data

//HASDATA PROC DS=                                      
//* //TEST EXEC HASDATA,DS=YOUR.FILE.NAME               
//* // IF TEST.HASDATA.RC=0 THEN /* IF NOT EMPTY ... */ 
//* // IF TEST.HASDATA.RC=4 THEN /* IF EMPTY ... */     
//HASDATA EXEC PGM=IDCAMS                               
//SYSPRINT DD SYSOUT=Z    /* PRINT TO BIT BUCKET */
//SYSIN  DD DISP=SHR,DSN=ZET.UI.CTLCARDS(PRINT1)        
//SYSUT1 DD DISP=SHR,DSN=&DS

SUBNEXT - how to chain to a new job

//SUBNEXT PROC DSN=NULLFILE                          
//* //SUBNEXT EXEC SUBNEXT,DSN=NEXT.JOB.DSN(NEXTJOB) 
//SUBMIT  EXEC PGM=IEBGENER                          
//SYSPRINT DD SYSOUT=*                               
//SYSUT1   DD DISP=SHR,DSN=&DSN                      
//SYSUT2   DD SYSOUT=(B,INTRDR)                      
//SYSIN    DD DUMMY

DDNEW - how to create a new file

//DDNEW PROC DSN=,RECFM=FB,LRECL=80,UNIT=SYSDA                      
//* //NEWFILE1 EXEC DDNEW,DSN=MY.NEW.FILE,FB=FB,LRECL=256,UNIT=SYSDA
//DELT EXEC PGM=IEFBR14         /* DELETE OLD FILE, IF ANY */                                             //SYSUT1 DD DSN=&DSN,                                               
// UNIT=&UNIT,SPACE=(TRK,(1,1),RLSE),                               
// RECFM=&RECFM,LRECL=&LRECL,BLKSIZE=0,                             
// DISP=(MOD,DELETE,DELETE)                                         
//ALLO EXEC PGM=IEFBR14         /* ALLOCATE NEW FILE */                                    
//SYSUT1 DD DSN=&DSN,                                               
// UNIT=&UNIT,SPACE=(TRK,(1,1),RLSE),                               
// RECFM=&RECFM,LRECL=&LRECL,BLKSIZE=0,                             
// DISP=(,CATLG,DELETE)

Utility Programs

READPDS - program to read a PDS and display its members

000100 IDENTIFICATION DIVISION.                      
000200 PROGRAM-ID.                                   
000300         READPDS.                              
000400 AUTHOR.                                       
000500*         MANNY JUAN.                          
000600 DATE-WRITTEN.  JANUARY 23, 1997.              
000700 DATE-COMPILED.                                
000800*REMARKS.                                      
000801* USAGE: //GO EXEC PGM=READPDS                       
000802*        //STEPLIB DD DISP=SHR,DSN=&LOADLIB            
000803*        //SYSOUT DD SYSOUT=*                        
000804*        //PDS DD DISP=SHR,DSN=ZET.TEST.PDS,RECFM=U, 
000805*        // LRECL=256                                
000900 ENVIRONMENT DIVISION.                         
001000 CONFIGURATION SECTION.                        
001100 SOURCE-COMPUTER.  IBM-370.                    
001200 OBJECT-COMPUTER.  IBM-370.                    
001300 INPUT-OUTPUT SECTION.                         
001400 FILE-CONTROL.                                 
001500      SELECT DIRECTORY-FILE ASSIGN TO UT-S-PDS.
001600 DATA DIVISION.                                
001700 FILE SECTION.                                 
001800  FD  DIRECTORY-FILE.                          
001900  01  FD-DIRECTORY-RECORD  PIC X(256).      
002000  WORKING-STORAGE SECTION.                  
002100  77  IX-1       PIC S9(4) COMP.            
002200  77  TRASH      PIC S9(4) COMP.            
002300  77  HALF-WORDS PIC S9(4) COMP.            
002400  01  DIRECTORY-RECORD.                     
002500      02  USED-BYTES   PIC S9(3) COMP.      
002600      02  REST-OF-RECORD  PIC X(254).       
002700  01  DIRECTORY-ENTRY.                      
002800      02  MEMBER-NAME  PIC X(8).            
002900      02  FILLER     PIC X(3).              
003000      02  WS-INDC    PIC X.                 
003100  01  WORK-FIELD.                           
003200      05 WORK-FIELD-NUMERIC PIC S9(4) COMP. 
003300  01  FILLER.                               
003400    03  FILLER         PIC 9.               
003500      88 DONE        VALUE 1.               
003600      88 NOT-DONE    VALUE 0.               
003700  PROCEDURE DIVISION.                       
003800      OPEN INPUT DIRECTORY-FILE                             
003900      READ DIRECTORY-FILE                                   
004000      SET NOT-DONE TO TRUE                                  
004100      PERFORM PROCESS-RECORD                                
004200          UNTIL DONE                                        
004300      CLOSE DIRECTORY-FILE                                  
004400      GOBACK.                                               
004500  PROCESS-RECORD.                                           
004600      MOVE FD-DIRECTORY-RECORD TO DIRECTORY-RECORD          
004700      MOVE 1 TO IX-1.                                       
004800      PERFORM  UNTIL                                        
004900                   USED-BYTES - IX-1 < 11     OR            
005000                   REST-OF-RECORD (IX-1:1) = HIGH-VALUES    
005100           MOVE  REST-OF-RECORD (IX-1:12) TO DIRECTORY-ENTRY
005200           PERFORM  PROCESS-MEMBER-NAME                     
005300           MOVE LOW-VALUES TO WORK-FIELD                    
005400           MOVE WS-INDC TO WORK-FIELD (2:1)                 
005500           DIVIDE WORK-FIELD-NUMERIC BY 32 GIVING TRASH     
005600               REMAINDER HALF-WORDS                         
005700           COMPUTE IX-1 = IX-1 + 12 + HALF-WORDS * 2
005800      END-PERFORM                                   
005900      IF  REST-OF-RECORD (IX-1:1) = HIGH-VALUES     
006000          SET DONE TO TRUE                          
006100      ELSE                                          
006200          READ DIRECTORY-FILE                       
006300      END-IF                                        
006400      .                                             
006500 PROCESS-MEMBER-NAME.                               
006600      DISPLAY 'MEMBER=' MEMBER-NAME                 
006700      .

PARMGEN - program to generate a deck from PARM of EXEC statement

000010 IDENTIFICATION DIVISION.                                        
000020 PROGRAM-ID.    PARMGEN.                                        
000030*                                                                
000040*   THIS PROGRAM CONVERTS THE PARM STRING INTO A FILE.           
000050*   VERTICAL BARS ON THE STRING TRANSLATE TO NEWLINE.            
000060*   EXAMPLES:                                                    
000070*----------------------------------------------------------------
000080*   INPUT JCL                         OUTPUT FILE                
000090*                                     123456789012345678901234567
000100*----------------------------------------------------------------
000110*                                                                 
000120*// PARM=('CANTON 911231')            CANTON 911231               
000130*                                                                 
000140*// PARM=('A01|B02|C03|D04')          A01                         
000150*                                     B02                         
000160*                                     C03                         
000170*                                     D04                         
000180*                                                                 
000190*// PARM=('A01','B02','C03','D04')    A01,B02,C03,D04 (NOTE COMMAS
000200*                                                                 
000210*// PARM=('A01','|B02','|C03','|D04') A01,  (NOTE COMMAS)         
000220*                                     B02,                        
000230*                                     C03,                        
000240*                                     D04                         
000250*                                                                 
000260*// PARM=('SORT FIELDS=(1,24,A),FORMAT=CH')                       
000270*                                     SORT FIELDS=(1,24,A),FORM.. 
000280*                                                                 
000290*// PARM=('SORT FIELDS=(1,24,A)',                                 
000300*//       'FORMAT=CH')                                            
000310*                                     SORT FIELDS=(1,24,A),FORM..
000320*                                     (SAME AS PREVIOUS)         
000330*// PARM=('SORT FIELDS=(1,24,A)',                                
000340*//       '| FORMAT=CH')                                         
000350*                                     SORT FIELDS=(1,24,A),      
000360*                                      FORMAT=CH                 
000370*                                                                
000380*                                                                
000390 AUTHOR.        MANNY JUAN.                                      
000400 INSTALLATION.                                                   
000410 DATE-WRITTEN.  MARCH 27, 1991.                                  
000420 DATE-COMPILED.                                                  
000430                                                                 
000440 ENVIRONMENT DIVISION.                                           
000450 CONFIGURATION SECTION.                                          
000460 SOURCE-COMPUTER.   IBM-3033.                                    
000470 OBJECT-COMPUTER.   IBM-3033.                                    
000480 INPUT-OUTPUT SECTION.                                           
000490 FILE-CONTROL.                                                   
000500     SELECT  CARDSOUT-FILE ASSIGN TO UT-S-PARMOUT.               
000510                                                        
000520 DATA DIVISION.                                         
000530 FILE SECTION.                                          
000540 FD  CARDSOUT-FILE                                      
000550     RECORD CONTAINS 080 CHARACTERS                     
000560     BLOCK  CONTAINS 00  RECORDS                        
000570     RECORDING MODE IS F                                
000580     LABEL RECORDS ARE STANDARD.                        
000590   01  CARDSOUT-REC   PIC X(80).                        
000600                                                        
000610 WORKING-STORAGE SECTION.                               
000620 01  VBAR                    PIC X(01) VALUE '|'.       
000630 01  PRM-STRING              PIC X(100).                
000640 01  FILLER REDEFINES PRM-STRING.                       
000650   03  PRM-CH                PIC X(01) OCCURS 100 TIMES 
000660                                       INDEXED BY PCX.  
000670                                                        
000680 01  CRD-STRING              PIC X(072).                
000690 01  FILLER REDEFINES CRD-STRING.                       
000700   03  CRD-CH                PIC X(01) OCCURS 072 TIMES 
000710                                       INDEXED BY CCX.
000720 LINKAGE SECTION.                                     
000730 01  PARM-WKAREA.                                     
000740   03  PARM-LENGTH           PIC 9(04) COMP.          
000750   03  PARM-STRING           PIC X(100).              
000760                                                      
000770 PROCEDURE DIVISION USING PARM-WKAREA.                
000780     OPEN OUTPUT CARDSOUT-FILE                        
000790     MOVE PARM-STRING TO PRM-STRING                   
000800     SET PCX TO 1                                     
000810     PERFORM                                          
000820         TEST BEFORE                                  
000830     UNTIL PCX > PARM-LENGTH                          
000840         SET CCX TO 1                                 
000850         MOVE SPACES TO CRD-STRING                    
000860         PERFORM                                      
000870             TEST BEFORE                              
000880         UNTIL PCX > PARM-LENGTH                      
000890         OR CCX > 72                                  
000900         OR PRM-CH (PCX) = VBAR                       
000910             MOVE PRM-CH (PCX) TO CRD-CH (CCX)
000920             SET PCX UP BY 1                  
000930             SET CCX UP BY 1                  
000940         END-PERFORM                          
000950         IF (PRM-CH (PCX) = VBAR)             
000960             SET PCX UP BY 1                  
000970         END-IF                               
000980         WRITE CARDSOUT-REC FROM CRD-STRING   
000990     END-PERFORM                              
001000     CLOSE CARDSOUT-FILE                      
001010     GOBACK                                   
001020     .

HEXPRINT - program to print a field to hexadecimal string

000100 IDENTIFICATION DIVISION.                    
000200 PROGRAM-ID. HEXPRINT.                       
000300 AUTHOR. MANNY JUAN .         
000400 ENVIRONMENT DIVISION.                       
000500 DATA DIVISION.                              
000600 WORKING-STORAGE SECTION.                    
000700 01  ATOX-WKAREA.                            
000800   03  ATOX-INPT-AREA.                       
000900     05  ATOX-INPT-STRING   PIC X(04).       
001000     05  ATOX-INPT-LENGTH   PIC S9(04) COMP. 
001100                                             
001200   03  ATOX-OUPT-AREA.                       
001300     05  ATOX-OUPT-STRING   PIC X(08).       
001400                                             
001500   03  ATOX-WORK-AREA.                       
001600     05  ATOX-WORK-STRING   PIC X(32).       
001700     05  ATOX-ICCX          PIC S9(04) COMP. 
001800     05  ATOX-OCCX          PIC S9(04) COMP. 
001900     05  ATOX-REM           PIC S9(04) COMP.                   
002000     05  ATOX-CHARS         PIC X(16) VALUE '0123456789ABCDEF'.
002100     05  ATOX-HW            PIC S9(04) COMP.                   
002200     05  FILLER REDEFINES ATOX-HW.                             
002300       07  ATOX-HW-1        PIC X(01).                         
002400       07  ATOX-HW-2        PIC X(01).                         
002500                                                               
002600 PROCEDURE DIVISION.                                           
002700     MOVE X'B3E4FD0C'        TO ATOX-INPT-STRING               
002800     MOVE 4                  TO ATOX-INPT-LENGTH               
002900     MOVE SPACES TO ATOX-OUPT-STRING                           
003000     PERFORM VARYING ATOX-ICCX FROM ATOX-INPT-LENGTH BY -1     
003100     UNTIL ATOX-ICCX < 1                                       
003200         MOVE LOW-VALUES                    TO ATOX-HW-1       
003300         MOVE ATOX-INPT-STRING(ATOX-ICCX:1) TO ATOX-HW-2       
003400         DIVIDE ATOX-HW BY 16 GIVING ATOX-HW                   
003500             REMAINDER ATOX-REM                                
003600         MOVE SPACES TO ATOX-WORK-STRING                       
003700         STRING                                                
003800                ATOX-CHARS (ATOX-HW  + 1 : 1)       
003900                                 DELIMITED BY SIZE  
004000                ATOX-CHARS (ATOX-REM + 1 : 1)       
004100                                 DELIMITED BY SIZE  
004200                ATOX-OUPT-STRING DELIMITED BY SPACE 
004300         INTO ATOX-WORK-STRING                      
004400         END-STRING                                 
004500     MOVE ATOX-WORK-STRING   TO ATOX-OUPT-STRING    
004600*    DISPLAY 'CC=' ATOX-CHARS (ATOX-REM + 1 : 1)    
004700*            ' OUPT=' ATOX-OUPT-STRING              
004800     END-PERFORM                                    
004900     DISPLAY                                        
005000             'OUPT=' ATOX-OUPT-STRING               
005100     GOBACK                                         
005200     .

COBOL DEBUGGING MODE - example of a cobol program using debugging mode

if you use "IBM-370 WITH DEBUGGING MODE", all lines with a "D" in column 7 become active code, while the simple form "IBM-370" will disable all such lines (they are treated as comments), thus allowing you to insert debugging code that can be turned on and off by simply recompiling with a small change.

the technique used below is to start with debugging mode enabled but the program contains logic to detect the presence/absence of a special debug file and execute or skip debugging code accordingly. of course, once debugging mode is removed, all that logic becomes non-existent.

during execution, if the KUDEBUG file is not coded, the program will fail and the error procedure defined in the declaratives area will be invoked thus turning off a debug flag in working storage. however, if the KUDEBUG file is coded, the program starts with the debug flag on. 

 - - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - 45 Line(s) not Displayed
 000440 000440*SOURCE-COMPUTER.  IBM-370.
 000450 000450 SOURCE-COMPUTER.  IBM-370 WITH DEBUGGING MODE.
 - - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - 14 Line(s) not Displayed
 000600 000600D    SELECT KUDEBUG-FILE  ASSIGN TO UT-S-KUDEBUG.
 - - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - 34 Line(s) not Displayed
 000950 000950DFD KUDEBUG-FILE
 000960 000960D    RECORDING MODE F
 000970 000970D    LABEL RECORD STANDARD
 000980 000980D    BLOCK CONTAINS 0 RECORDS.
 000990 000990D01 KUDEBUG-RECORD                  PIC X(080).
 - - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  3 Line(s) not Displayed
 001030 001030D01 KUDEBUG-ON-FIELD PIC 9(01) VALUE 0.
 001040 001040D 88 KUDEBUG-ON   VALUE 1.
 001050 001050D 88 KUDEBUG-OFF  VALUE 0.
 - - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -   928 Line(s) not Displayed
 010340 010340 PROCEDURE DIVISION.
 010350 010350DDECLARATIVES.
 010360 010360DKUDEBUG-DECLARATIVES SECTION.
 010370 010370D    USE AFTER STANDARD ERROR PROCEDURE ON KUDEBUG-FILE.
 010380 010380DKUDEBUG-CHECK.
 010390 010390D    DISPLAY 'NO KUDEBUG-FILE SUPPLIED  DEBUG DISABLED'
 010400 010400D    SET KUDEBUG-OFF TO TRUE
 010410 010410D    .
 010420 010420DEND DECLARATIVES.
 - - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  2 Line(s) not Displayed
 010450 010450D    SET KUDEBUG-ON TO TRUE
 010460 010460D    OPEN INPUT KUDEBUG-FILE
 010470 010470D    CLOSE KUDEBUG-FILE
 - - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  1454 Line(s) not Displayed
 025020 025020D    IF KUDEBUG-ON
 - - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - 63 Line(s) not Displayed
 025660 025660D    ELSE
 - - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - 62 Line(s) not Displayed
 026290 026290D    END-IF
 - - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - 22 Line(s) not Displayed

GENERALIZED TABLE HANDLER

these copy members have been used to implement a generalized handler for loading and searching look up tables. it's based on these simple assumptions
  1. the lookup table is an 80-column file with two fixed-length fields: key and value.
  2. column 1 is reserved for comment indicator (asterisk)
  3. the key field must start at column 2 and may be any length but fixed for the whole table
  4. there must be one space between the key field and the value field
  5. the table must be sorted by the key field (comment records may be interspersed among the records)

SAMPLE DATA

SAMPLE DATA (column 1 is reserved for asterisk - comment indicator)
*  DIBLSCTX (SOURCE CODE --> DESC)  
 01 SAN FRANCISCO                   
 02 EL MONTE                        
 03 FREMONT                         
 04 TEMPE                           
 05 ARIZONA                         
 08 OREGON                          
 10 DALLAS TEXAS                    
 13 COLORADO                        
 14 HOUSTON TEXAS                   
 15 TELLER VISION                   
 16 DARWIN                          
 17 EAST-TO-WEST                    
 18 TELLER VISION NM

DITBFICO - select statement, include inside file-control section

           SELECT DI-TABLE-FILE-:TBL: ASSIGN TO :DDN:.

DITBFDEF - file definition, include in file section

       FD  DI-TABLE-FILE-:TBL:                       
           RECORDING MODE IS F                       
           LABEL RECORDS ARE STANDARD                
           BLOCK CONTAINS 0 RECORDS.                 
                                                     
         01  DI-TABLE-RECORD-:TBL:.                  
           03  FILLER                  PIC X(01).    
             88  DI-TABLE-CMTREC-:TBL:     VALUE '*'.
                                                     
           03  FILLER                  PIC X(79).

DITBWDEF - work area definition, include in working-storage section

       01  WS-TBL-:TBL:-TABLE-AREA.                                   
           05  FILLER                    PIC X(01) VALUE 'N'.         
             88  NO-MORE-DI-TABLE-:TBL:            VALUE 'Y'.         
             88  MORE-DI-TABLE-:TBL:               VALUE 'N'.         
                                                                      
           05  FILLER                    PIC X(01) VALUE 'N'.         
             88  FOUND-:TBL:                   VALUE 'Y'.             
             88  NOT-FOUND-:TBL:               VALUE 'N'.             
                                                                      
           05  WS-TBL-:TBL:-LAST-KEY     PIC X(:TBKL:)                
                                               VALUE LOW-VALUES.      
           05  WS-TBL-:TBL:-LAST-VALUE   PIC X(:TBVL:)                
                                               VALUE SPACES.          
           05  WS-TBL-:TBL:-SIZE-MAX     PIC S9(03) COMP-3 VALUE +500.
           05  WS-TBL-:TBL:-SIZE         PIC S9(03) COMP-3 VALUE +0.  
           05  WS-TBL-:TBL:-TABLE-DEF.                                
                                                                      
               10  WS-TBL-:TBL:-TABLE-ENTRY   OCCURS 0 TO 500 TIMES   
                                DEPENDING ON  WS-TBL-:TBL:-SIZE 
                                ASCENDING KEY WS-TBL-:TBL:-KEY  
                                INDEXED   BY  :TBL:X.           
                                                                
                   15  FILLER       PIC X(01).                  
                   15  WS-TBL-:TBL:-KEY          PIC X(:TBKL:). 
                   15  FILLER       PIC X(01).                  
                   15  WS-TBL-:TBL:-VALUE        PIC X(:TBVL:).

DITBPLOD - table load, include in initialization section of procedure division


      *  -- LOAD THE TABLE                            
           OPEN INPUT DI-TABLE-FILE-:TBL:             
                                                      
           PERFORM TEST AFTER                         
           UNTIL NO-MORE-DI-TABLE-:TBL:               
           OR NOT (DI-TABLE-CMTREC-:TBL:)             
               READ DI-TABLE-FILE-:TBL:               
               AT END                                 
                   SET NO-MORE-DI-TABLE-:TBL: TO TRUE 
               END-READ                               
           END-PERFORM                                
                                                      
           MOVE +0 TO WS-TBL-:TBL:-SIZE               
           MOVE LOW-VALUES TO WS-TBL-:TBL:-LAST-KEY   
                                                      
           PERFORM TEST BEFORE                        
           UNTIL NO-MORE-DI-TABLE-:TBL:               
               ADD  1 TO WS-TBL-:TBL:-SIZE            
               IF WS-TBL-:TBL:-SIZE > WS-TBL-:TBL:-SIZE-MAX        
                   DISPLAY 'TABLE MAX ' WS-TBL-:TBL:-SIZE-MAX      
                           ' HAS BEEN EXCEEDED'                    
                   CALL ABENDPGM                                   
               END-IF                                              
               SET  :TBL:X     TO WS-TBL-:TBL:-SIZE                
               MOVE DI-TABLE-RECORD-:TBL:                          
                               TO WS-TBL-:TBL:-TABLE-ENTRY (:TBL:X)
               IF WS-TBL-:TBL:-KEY (:TBL:X) < WS-TBL-:TBL:-LAST-KEY
                   DISPLAY 'LOAD ABORTED, TABLE OUT OF SEQUENCE'   
                   DISPLAY 'LAST-KEY=' WS-TBL-:TBL:-LAST-KEY       
                   ' CURR-KEY=' WS-TBL-:TBL:-KEY (:TBL:X)          
                   CALL ABENDPGM                                   
               END-IF                                              
               MOVE WS-TBL-:TBL:-KEY (:TBL:X)                      
                 TO WS-TBL-:TBL:-LAST-KEY                          
                                                                   
               DISPLAY WS-TBL-:TBL:-TABLE-ENTRY (:TBL:X)           
                                                                   
               PERFORM TEST AFTER                                 
               UNTIL NO-MORE-DI-TABLE-:TBL:                       
               OR NOT (DI-TABLE-CMTREC-:TBL:)                     
                   READ DI-TABLE-FILE-:TBL:                       
                   AT END                                         
                       SET NO-MORE-DI-TABLE-:TBL: TO TRUE         
                   END-READ                                       
               END-PERFORM                                        
           END-PERFORM                                            
                                                                  
           CLOSE DI-TABLE-FILE-:TBL:                              
           DISPLAY '--- TABLE ENTRIES LOADED:' WS-TBL-:TBL:-SIZE  
           MOVE LOW-VALUES TO WS-TBL-:TBL:-LAST-KEY

DITBPSCH - search routine, include in procedure division at the point of search

                                                                  
           IF :ARG: = WS-TBL-:TBL:-LAST-KEY             
               MOVE WS-TBL-:TBL:-LAST-VALUE             
                 TO :DEST:                              
           ELSE                                         
               SEARCH ALL WS-TBL-:TBL:-TABLE-ENTRY      
                   AT END                               
                       SET NOT-FOUND-:TBL: TO TRUE      
                       MOVE :ARG:                       
                         TO WS-TBL-:TBL:-LAST-KEY       
                       MOVE SPACES                      
                         TO WS-TBL-:TBL:-LAST-VALUE     
                       INITIALIZE                       
                            :DEST:                      
                   WHEN WS-TBL-:TBL:-KEY (:TBL:X)       
                   =    :ARG:                           
                       SET FOUND-:TBL: TO TRUE          
                       MOVE WS-TBL-:TBL:-KEY   (:TBL:X) 
                         TO WS-TBL-:TBL:-LAST-KEY       
                       MOVE WS-TBL-:TBL:-VALUE (:TBL:X) 
                         TO WS-TBL-:TBL:-LAST-VALUE     
                       MOVE WS-TBL-:TBL:-VALUE (:TBL:X) 
                         TO :DEST:                      
               END-SEARCH                               
           END-IF

SAMPLE USAGE

this sample program will use an external table to translate a 2-digit source id into a 16-byte source description. say the table has a nickname of BSCX. this shows how the copy members are used to define, load and search the table. 
000100  IDENTIFICATION DIVISION.                                              
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - 16 Line(s) not Displayed
001800  ENVIRONMENT DIVISION.                                                 
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  3 Line(s) not Displayed
002200  FILE-CONTROL.                                                         
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  3 Line(s) not Displayed
create the SELECT statement
002600      COPY DITBFICO REPLACING ==:TBL:== BY ==BSCX==                     
002700                              ==:DDN:== BY ==TABLDEF1==.                
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  1 Line(s) not Displayed
002900  DATA DIVISION.                                                        
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  1 Line(s) not Displayed
003100  FILE SECTION.                                                         
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - 24 Line(s) not Displayed
create the FD (file definition) for the table
005600  COPY DITBFDEF REPLACING ==:TBL:== BY ==BSCX==.                        
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  1 Line(s) not Displayed
005800  WORKING-STORAGE SECTION.                                              
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - 31 Line(s) not Displayed
define the work area for the table (note Key Length and Value Length)
009000  01  FILLER PIC X(08) VALUE 'BSCX'.                                    
009100  COPY DITBWDEF REPLACING ==:TBL:== BY ==BSCX==                         
009200                          ==:TBKL:== BY ==2==                           
009300                          ==:TBVL:== BY ==16==.                         
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  1 Line(s) not Displayed
009500    03  WS-BSCX-SEARCH-RETURN.                                          
009600      05  WS-BSCX-TITLE     PIC X(16).                                  
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - 22 Line(s) not Displayed
011900  PROCEDURE DIVISION USING LK-LINK-AREA.                                
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - 20 Line(s) not Displayed
include the table-load in the initialization section
014000      DISPLAY 'LOADING BSCX...'                                         
014100      COPY DITBPLOD REPLACING ==:TBL:== BY ==BSCX==.                    
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - 51 Line(s) not Displayed
perform a lookup (ie. translate di-rj-source-id to ws-bscx-search-return)
019300      COPY DITBPSCH REPLACING                                           
019400                   ==:TBL:==  BY ==BSCX==                               
019500                   ==:ARG:==  BY ==DI-RJ-SOURCE-ID==                    
019600                   ==:DEST:== BY ==WS-BSCX-SEARCH-RETURN==.             
test if not found
019700      IF NOT FOUND-BSCX                                                 
019800          CONTINUE                                                      
019900      ELSE                                                              
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  - 25 Line(s) not Displayed
022500      END-IF                                                            
- - -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -   157 Line(s) not Displayed
brought to you by exist,hasdata,subnext,ddnew,readpds,parmgen,hexprint,disymrep.