Case Study 2: IMS Batch Update for Account Maintenance
Background
First National Federal Bank runs a nightly batch cycle that applies pending account maintenance requests to the IMS customer database (CUSTDB). During business hours, branch staff and online banking users submit maintenance requests -- new account openings, address changes, account closures, balance adjustments, and new transaction postings. These requests are collected in a sequential transaction file throughout the day. At night, a Batch Message Processing (BMP) program reads this file and applies the changes to the IMS database.
Senior developer Angela Moretti designed the batch update program, CUSTUPD1, to handle three categories of operations:
- ISRT (Insert): Add new account segments for newly opened accounts, or add new transaction segments for posted activity.
- REPL (Replace): Update existing segments -- for example, changing an account status from ACTIVE to FROZEN, or updating a customer's address.
- DLET (Delete): Remove segments for closed accounts that have passed the retention period.
The program must also implement checkpoint/restart logic. The nightly transaction file can contain over 500,000 records. If the program abends at record 400,000, it must be able to restart from the last checkpoint rather than reprocessing the entire file. This is a critical requirement for meeting the bank's overnight processing window.
The Transaction File Layout
Each record in the nightly maintenance file contains an action code and the segment data to be applied:
01 WS-MAINT-RECORD.
05 WS-MAINT-ACTION PIC X(1).
88 MAINT-INSERT VALUE 'I'.
88 MAINT-REPLACE VALUE 'R'.
88 MAINT-DELETE VALUE 'D'.
05 WS-MAINT-SEG-TYPE PIC X(1).
88 SEG-CUSTOMER VALUE 'C'.
88 SEG-ACCOUNT VALUE 'A'.
88 SEG-TRANSACTION VALUE 'T'.
05 WS-MAINT-CUST-KEY PIC X(10).
05 WS-MAINT-ACCT-KEY PIC X(12).
05 WS-MAINT-TXN-KEY PIC X(15).
05 WS-MAINT-DATA PIC X(200).
05 WS-MAINT-TIMESTAMP PIC X(26).
05 WS-MAINT-USER-ID PIC X(8).
05 WS-MAINT-SOURCE PIC X(3).
88 SOURCE-BRANCH VALUE 'BRN'.
88 SOURCE-ONLINE VALUE 'OLB'.
88 SOURCE-ATM VALUE 'ATM'.
88 SOURCE-SYSTEM VALUE 'SYS'.
The file is sorted by customer key, then by account key within customer, then by transaction key within account. This sort order aligns with the IMS hierarchy and minimizes physical I/O by processing all changes for one customer before moving to the next.
Complete COBOL Program
IDENTIFICATION DIVISION.
PROGRAM-ID. CUSTUPD1.
*================================================================*
* CUSTUPD1 - IMS Batch Update for Account Maintenance *
* BMP program that reads a sequential maintenance file and *
* applies inserts, replaces, and deletes to the CUSTDB IMS *
* database. Implements checkpoint/restart for recovery. *
*================================================================*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT MAINT-FILE ASSIGN TO MAINTFL
FILE STATUS IS WS-MAINT-FS.
SELECT AUDIT-FILE ASSIGN TO AUDITFL
FILE STATUS IS WS-AUDIT-FS.
DATA DIVISION.
FILE SECTION.
FD MAINT-FILE
RECORDING MODE IS F
RECORD CONTAINS 275 CHARACTERS.
01 MAINT-FILE-RECORD PIC X(275).
FD AUDIT-FILE
RECORDING MODE IS F
RECORD CONTAINS 300 CHARACTERS.
01 AUDIT-FILE-RECORD PIC X(300).
WORKING-STORAGE SECTION.
*================================================================*
* DL/I function codes *
*================================================================*
01 WS-DLI-GU PIC X(4) VALUE 'GU '.
01 WS-DLI-GHU PIC X(4) VALUE 'GHU '.
01 WS-DLI-GN PIC X(4) VALUE 'GN '.
01 WS-DLI-GNP PIC X(4) VALUE 'GNP '.
01 WS-DLI-GHN PIC X(4) VALUE 'GHN '.
01 WS-DLI-ISRT PIC X(4) VALUE 'ISRT'.
01 WS-DLI-REPL PIC X(4) VALUE 'REPL'.
01 WS-DLI-DLET PIC X(4) VALUE 'DLET'.
01 WS-DLI-CHKP PIC X(4) VALUE 'CHKP'.
*================================================================*
* File status fields *
*================================================================*
01 WS-MAINT-FS PIC XX VALUE '00'.
01 WS-AUDIT-FS PIC XX VALUE '00'.
*================================================================*
* Maintenance record (read from file) *
*================================================================*
01 WS-MAINT-RECORD.
05 WS-MAINT-ACTION PIC X(1).
88 MAINT-INSERT VALUE 'I'.
88 MAINT-REPLACE VALUE 'R'.
88 MAINT-DELETE VALUE 'D'.
05 WS-MAINT-SEG-TYPE PIC X(1).
88 SEG-CUSTOMER VALUE 'C'.
88 SEG-ACCOUNT VALUE 'A'.
88 SEG-TRANSACTION VALUE 'T'.
05 WS-MAINT-CUST-KEY PIC X(10).
05 WS-MAINT-ACCT-KEY PIC X(12).
05 WS-MAINT-TXN-KEY PIC X(15).
05 WS-MAINT-DATA PIC X(200).
05 WS-MAINT-TIMESTAMP PIC X(26).
05 WS-MAINT-USER-ID PIC X(8).
05 WS-MAINT-SOURCE PIC X(3).
88 SOURCE-BRANCH VALUE 'BRN'.
88 SOURCE-ONLINE VALUE 'OLB'.
88 SOURCE-ATM VALUE 'ATM'.
88 SOURCE-SYSTEM VALUE 'SYS'.
*================================================================*
* Segment I/O areas *
*================================================================*
01 WS-CUSTOMER-SEG.
05 WS-CUST-ID PIC X(10).
05 WS-CUST-LAST-NAME PIC X(25).
05 WS-CUST-FIRST-NAME PIC X(20).
05 WS-CUST-MIDDLE-INIT PIC X(1).
05 WS-CUST-ADDR-LINE1 PIC X(30).
05 WS-CUST-ADDR-LINE2 PIC X(30).
05 WS-CUST-CITY PIC X(20).
05 WS-CUST-STATE PIC X(2).
05 WS-CUST-ZIP PIC X(10).
05 WS-CUST-PHONE PIC X(15).
05 WS-CUST-REL-DATE PIC X(10).
05 WS-CUST-TIER PIC X(2).
05 FILLER PIC X(25).
01 WS-ACCOUNT-SEG.
05 WS-ACCT-NUMBER PIC X(12).
05 WS-ACCT-TYPE PIC X(3).
05 WS-ACCT-STATUS PIC X(8).
05 WS-ACCT-BALANCE PIC S9(11)V99 COMP-3.
05 WS-ACCT-OPEN-DATE PIC X(10).
05 WS-ACCT-LAST-ACTIVITY PIC X(10).
05 WS-ACCT-BRANCH PIC X(4).
05 FILLER PIC X(20).
01 WS-TRANSACT-SEG.
05 WS-TXN-ID PIC X(15).
05 WS-TXN-DATE PIC X(10).
05 WS-TXN-TYPE PIC X(3).
05 WS-TXN-AMOUNT PIC S9(9)V99 COMP-3.
05 WS-TXN-RUN-BALANCE PIC S9(11)V99 COMP-3.
05 WS-TXN-DESC PIC X(30).
05 FILLER PIC X(10).
*================================================================*
* Qualified SSAs for direct segment access *
*================================================================*
01 WS-CUST-QUAL-SSA.
05 FILLER PIC X(9) VALUE 'CUSTOMER('.
05 FILLER PIC X(10) VALUE 'CUST_ID ='.
05 WS-SSA-CUST-ID PIC X(10).
05 FILLER PIC X(1) VALUE ')'.
01 WS-ACCT-QUAL-SSA.
05 FILLER PIC X(9) VALUE 'ACCOUNT ('.
05 FILLER PIC X(10) VALUE 'ACCT_NO ='.
05 WS-SSA-ACCT-NO PIC X(12).
05 FILLER PIC X(1) VALUE ')'.
01 WS-TXN-QUAL-SSA.
05 FILLER PIC X(9) VALUE 'TRANSACT('.
05 FILLER PIC X(10) VALUE 'TXN_ID ='.
05 WS-SSA-TXN-ID PIC X(15).
05 FILLER PIC X(1) VALUE ')'.
*================================================================*
* Unqualified SSAs (for ISRT) *
*================================================================*
01 WS-CUST-UNQUAL-SSA PIC X(9) VALUE 'CUSTOMER '.
01 WS-ACCT-UNQUAL-SSA PIC X(9) VALUE 'ACCOUNT '.
01 WS-TXN-UNQUAL-SSA PIC X(9) VALUE 'TRANSACT '.
*================================================================*
* Checkpoint/restart fields *
*================================================================*
01 WS-CHECKPOINT-ID PIC X(8) VALUE 'CUSTUPD1'.
01 WS-CHECKPOINT-INTERVAL PIC 9(5) VALUE 5000.
01 WS-RECORDS-SINCE-CHKP PIC 9(5) VALUE ZEROS.
* Restart data area saved in checkpoint
01 WS-RESTART-DATA.
05 WS-RST-RECORD-COUNT PIC 9(9) VALUE ZEROS.
05 WS-RST-LAST-CUST-KEY PIC X(10) VALUE SPACES.
05 WS-RST-LAST-ACCT-KEY PIC X(12) VALUE SPACES.
05 WS-RST-INSERT-COUNT PIC 9(7) VALUE ZEROS.
05 WS-RST-REPLACE-COUNT PIC 9(7) VALUE ZEROS.
05 WS-RST-DELETE-COUNT PIC 9(7) VALUE ZEROS.
05 WS-RST-ERROR-COUNT PIC 9(7) VALUE ZEROS.
*================================================================*
* Processing counters and flags *
*================================================================*
01 WS-RECORD-COUNT PIC 9(9) VALUE ZEROS.
01 WS-INSERT-COUNT PIC 9(7) VALUE ZEROS.
01 WS-REPLACE-COUNT PIC 9(7) VALUE ZEROS.
01 WS-DELETE-COUNT PIC 9(7) VALUE ZEROS.
01 WS-ERROR-COUNT PIC 9(7) VALUE ZEROS.
01 WS-SKIP-COUNT PIC 9(7) VALUE ZEROS.
01 WS-EOF-FLAG PIC X VALUE 'N'.
88 END-OF-FILE VALUE 'Y'.
01 WS-RESTART-FLAG PIC X VALUE 'N'.
88 IS-RESTART VALUE 'Y'.
*================================================================*
* Audit trail record *
*================================================================*
01 WS-AUDIT-RECORD.
05 WS-AUD-TIMESTAMP PIC X(26).
05 WS-AUD-ACTION PIC X(6).
05 WS-AUD-SEG-TYPE PIC X(10).
05 WS-AUD-CUST-KEY PIC X(10).
05 WS-AUD-ACCT-KEY PIC X(12).
05 WS-AUD-TXN-KEY PIC X(15).
05 WS-AUD-STATUS PIC X(2).
05 WS-AUD-RESULT PIC X(10).
05 WS-AUD-USER-ID PIC X(8).
05 WS-AUD-SOURCE PIC X(3).
05 FILLER PIC X(198) VALUE SPACES.
*================================================================*
* Work fields *
*================================================================*
01 WS-CURRENT-TIMESTAMP PIC X(26).
01 WS-SYS-DATE PIC 9(8).
01 WS-SYS-TIME PIC 9(8).
01 WS-STATUS-CODE-SAVE PIC XX VALUE SPACES.
01 WS-DIAG-MSG PIC X(80) VALUE SPACES.
*================================================================*
* PCB Masks - LINKAGE SECTION *
*================================================================*
LINKAGE SECTION.
01 LS-IO-PCB.
05 LS-IO-LTERM PIC X(8).
05 FILLER PIC XX.
05 LS-IO-STATUS PIC XX.
01 LS-DB-PCB.
05 LS-DBD-NAME PIC X(8).
05 LS-SEG-LEVEL PIC XX.
05 LS-STATUS-CODE PIC XX.
05 LS-PROC-OPTIONS PIC X(4).
05 LS-RESERVED PIC S9(5) COMP.
05 LS-SEG-NAME PIC X(8).
05 LS-KEY-LENGTH PIC S9(5) COMP.
05 LS-NUM-SENS-SEGS PIC S9(5) COMP.
05 LS-KEY-FEEDBACK PIC X(37).
*================================================================*
* PROCEDURE DIVISION: BMP entry with I/O PCB and DB PCB *
*================================================================*
PROCEDURE DIVISION USING LS-IO-PCB LS-DB-PCB.
0000-MAIN-CONTROL.
PERFORM 1000-INITIALIZE
PERFORM 2000-PROCESS-MAINTENANCE
PERFORM 3000-FINAL-CHECKPOINT
PERFORM 9000-WRAP-UP
GOBACK.
*================================================================*
* 1000-INITIALIZE: Open files, check for restart, initialize *
* counters. If restarting, skip already-processed records. *
*================================================================*
1000-INITIALIZE.
OPEN INPUT MAINT-FILE
OPEN OUTPUT AUDIT-FILE
IF WS-MAINT-FS NOT = '00'
DISPLAY 'ERROR: Cannot open maintenance file. '
'Status: ' WS-MAINT-FS
MOVE 16 TO RETURN-CODE
GOBACK
END-IF
ACCEPT WS-SYS-DATE FROM DATE YYYYMMDD
ACCEPT WS-SYS-TIME FROM TIME
DISPLAY '============================================='
DISPLAY ' CUSTUPD1 - IMS Batch Account Maintenance'
DISPLAY ' Run Date: ' WS-SYS-DATE
DISPLAY ' Run Time: ' WS-SYS-TIME
DISPLAY '============================================='
* Check if this is a restart by examining the I/O PCB
* In a real BMP, the XRST call would restore the restart
* data from the previous checkpoint.
PERFORM 1100-CHECK-RESTART
IF IS-RESTART
DISPLAY ' *** RESTART DETECTED ***'
DISPLAY ' Skipping to record: '
WS-RST-RECORD-COUNT
PERFORM 1200-SKIP-TO-RESTART-POINT
MOVE WS-RST-INSERT-COUNT TO WS-INSERT-COUNT
MOVE WS-RST-REPLACE-COUNT TO WS-REPLACE-COUNT
MOVE WS-RST-DELETE-COUNT TO WS-DELETE-COUNT
MOVE WS-RST-ERROR-COUNT TO WS-ERROR-COUNT
MOVE WS-RST-RECORD-COUNT TO WS-RECORD-COUNT
ELSE
DISPLAY ' Normal start (no restart data found).'
END-IF
.
*================================================================*
* 1100-CHECK-RESTART: Issue XRST call to determine if this is *
* a restart. If restart data exists, IMS restores it. *
*================================================================*
1100-CHECK-RESTART.
* In a production BMP, the XRST (Extended Restart) call
* restores the checkpoint data. If no restart data exists,
* status code is spaces (normal start).
CALL 'CBLTDLI' USING WS-DLI-GU
LS-IO-PCB
WS-RESTART-DATA
IF LS-IO-STATUS = SPACES
AND WS-RST-RECORD-COUNT > ZEROS
MOVE 'Y' TO WS-RESTART-FLAG
ELSE
MOVE 'N' TO WS-RESTART-FLAG
END-IF
.
*================================================================*
* 1200-SKIP-TO-RESTART-POINT: Read and discard records that *
* were already processed before the last checkpoint. *
*================================================================*
1200-SKIP-TO-RESTART-POINT.
MOVE ZEROS TO WS-SKIP-COUNT
PERFORM UNTIL WS-SKIP-COUNT >= WS-RST-RECORD-COUNT
OR END-OF-FILE
READ MAINT-FILE INTO WS-MAINT-RECORD
AT END
MOVE 'Y' TO WS-EOF-FLAG
NOT AT END
ADD 1 TO WS-SKIP-COUNT
END-READ
END-PERFORM
DISPLAY ' Skipped ' WS-SKIP-COUNT ' records.'
.
*================================================================*
* 2000-PROCESS-MAINTENANCE: Main loop reading maintenance *
* records and applying them to the IMS database. *
*================================================================*
2000-PROCESS-MAINTENANCE.
PERFORM 2050-READ-MAINT-RECORD
PERFORM UNTIL END-OF-FILE
ADD 1 TO WS-RECORD-COUNT
PERFORM 2100-APPLY-MAINTENANCE
PERFORM 2900-CHECK-CHECKPOINT
PERFORM 2050-READ-MAINT-RECORD
END-PERFORM
.
*================================================================*
* 2050-READ-MAINT-RECORD: Priming and subsequent reads. *
*================================================================*
2050-READ-MAINT-RECORD.
READ MAINT-FILE INTO WS-MAINT-RECORD
AT END
MOVE 'Y' TO WS-EOF-FLAG
NOT AT END
CONTINUE
END-READ
.
*================================================================*
* 2100-APPLY-MAINTENANCE: Route to appropriate handler based *
* on the action code in the maintenance record. *
*================================================================*
2100-APPLY-MAINTENANCE.
EVALUATE TRUE
WHEN MAINT-INSERT
PERFORM 3000-PROCESS-INSERT
WHEN MAINT-REPLACE
PERFORM 4000-PROCESS-REPLACE
WHEN MAINT-DELETE
PERFORM 5000-PROCESS-DELETE
WHEN OTHER
ADD 1 TO WS-ERROR-COUNT
MOVE 'UNKNOWN' TO WS-AUD-ACTION
MOVE 'INVALID ' TO WS-AUD-RESULT
PERFORM 7000-WRITE-AUDIT
DISPLAY 'WARNING: Invalid action code "'
WS-MAINT-ACTION
'" at record ' WS-RECORD-COUNT
END-EVALUATE
.
*================================================================*
* 3000-PROCESS-INSERT: Insert a new segment into the database. *
* For ACCOUNT inserts, first position on the parent CUSTOMER. *
* For TRANSACTION inserts, position on CUSTOMER then ACCOUNT. *
*================================================================*
3000-PROCESS-INSERT.
EVALUATE TRUE
WHEN SEG-ACCOUNT
PERFORM 3100-INSERT-ACCOUNT
WHEN SEG-TRANSACTION
PERFORM 3200-INSERT-TRANSACTION
WHEN SEG-CUSTOMER
PERFORM 3300-INSERT-CUSTOMER
WHEN OTHER
ADD 1 TO WS-ERROR-COUNT
DISPLAY 'ERROR: Invalid segment type for INSERT'
END-EVALUATE
.
*================================================================*
* 3100-INSERT-ACCOUNT: Position on parent customer, then ISRT *
* the new account segment. *
*================================================================*
3100-INSERT-ACCOUNT.
* First, establish position on the parent customer
MOVE WS-MAINT-CUST-KEY TO WS-SSA-CUST-ID
* Move maintenance data into account I/O area
MOVE WS-MAINT-DATA(1:LENGTH OF WS-ACCOUNT-SEG)
TO WS-ACCOUNT-SEG
MOVE WS-MAINT-ACCT-KEY TO WS-ACCT-NUMBER
* Issue ISRT with qualified parent SSA and unqualified
* child SSA. The parent SSA establishes position; the
* child SSA identifies the segment type to insert.
CALL 'CBLTDLI' USING WS-DLI-ISRT
LS-DB-PCB
WS-ACCOUNT-SEG
WS-CUST-QUAL-SSA
WS-ACCT-UNQUAL-SSA
MOVE LS-STATUS-CODE TO WS-STATUS-CODE-SAVE
EVALUATE LS-STATUS-CODE
WHEN SPACES
ADD 1 TO WS-INSERT-COUNT
MOVE 'INSERT' TO WS-AUD-ACTION
MOVE 'ACCOUNT ' TO WS-AUD-SEG-TYPE
MOVE 'SUCCESS ' TO WS-AUD-RESULT
WHEN 'II'
ADD 1 TO WS-ERROR-COUNT
MOVE 'INSERT' TO WS-AUD-ACTION
MOVE 'ACCOUNT ' TO WS-AUD-SEG-TYPE
MOVE 'DUPLICATE' TO WS-AUD-RESULT
DISPLAY 'WARNING: Duplicate account '
WS-MAINT-ACCT-KEY
' for customer ' WS-MAINT-CUST-KEY
WHEN 'GE'
ADD 1 TO WS-ERROR-COUNT
MOVE 'INSERT' TO WS-AUD-ACTION
MOVE 'ACCOUNT ' TO WS-AUD-SEG-TYPE
MOVE 'NO PARENT' TO WS-AUD-RESULT
DISPLAY 'ERROR: Parent customer '
WS-MAINT-CUST-KEY
' not found for account insert.'
WHEN OTHER
ADD 1 TO WS-ERROR-COUNT
MOVE 'INSERT' TO WS-AUD-ACTION
MOVE 'ACCOUNT ' TO WS-AUD-SEG-TYPE
MOVE 'DLI ERROR' TO WS-AUD-RESULT
PERFORM 8000-DLI-ERROR-HANDLER
END-EVALUATE
PERFORM 7000-WRITE-AUDIT
.
*================================================================*
* 3200-INSERT-TRANSACTION: Position on customer and account, *
* then ISRT the new transaction segment. *
*================================================================*
3200-INSERT-TRANSACTION.
MOVE WS-MAINT-CUST-KEY TO WS-SSA-CUST-ID
MOVE WS-MAINT-ACCT-KEY TO WS-SSA-ACCT-NO
* Move maintenance data into transaction I/O area
MOVE WS-MAINT-DATA(1:LENGTH OF WS-TRANSACT-SEG)
TO WS-TRANSACT-SEG
MOVE WS-MAINT-TXN-KEY TO WS-TXN-ID
* ISRT with two qualified parent SSAs to position on
* the correct customer and account, plus the unqualified
* SSA for the segment being inserted.
CALL 'CBLTDLI' USING WS-DLI-ISRT
LS-DB-PCB
WS-TRANSACT-SEG
WS-CUST-QUAL-SSA
WS-ACCT-QUAL-SSA
WS-TXN-UNQUAL-SSA
EVALUATE LS-STATUS-CODE
WHEN SPACES
ADD 1 TO WS-INSERT-COUNT
MOVE 'INSERT' TO WS-AUD-ACTION
MOVE 'TRANSACT' TO WS-AUD-SEG-TYPE
MOVE 'SUCCESS ' TO WS-AUD-RESULT
WHEN 'II'
ADD 1 TO WS-ERROR-COUNT
MOVE 'INSERT' TO WS-AUD-ACTION
MOVE 'TRANSACT' TO WS-AUD-SEG-TYPE
MOVE 'DUPLICATE' TO WS-AUD-RESULT
WHEN 'GE'
ADD 1 TO WS-ERROR-COUNT
MOVE 'INSERT' TO WS-AUD-ACTION
MOVE 'TRANSACT' TO WS-AUD-SEG-TYPE
MOVE 'NO PARENT' TO WS-AUD-RESULT
WHEN OTHER
ADD 1 TO WS-ERROR-COUNT
MOVE 'INSERT' TO WS-AUD-ACTION
MOVE 'TRANSACT' TO WS-AUD-SEG-TYPE
MOVE 'DLI ERROR' TO WS-AUD-RESULT
PERFORM 8000-DLI-ERROR-HANDLER
END-EVALUATE
PERFORM 7000-WRITE-AUDIT
.
*================================================================*
* 3300-INSERT-CUSTOMER: ISRT a new root customer segment. *
* No parent positioning needed for root segments. *
*================================================================*
3300-INSERT-CUSTOMER.
MOVE WS-MAINT-DATA(1:LENGTH OF WS-CUSTOMER-SEG)
TO WS-CUSTOMER-SEG
MOVE WS-MAINT-CUST-KEY TO WS-CUST-ID
CALL 'CBLTDLI' USING WS-DLI-ISRT
LS-DB-PCB
WS-CUSTOMER-SEG
WS-CUST-UNQUAL-SSA
EVALUATE LS-STATUS-CODE
WHEN SPACES
ADD 1 TO WS-INSERT-COUNT
MOVE 'INSERT' TO WS-AUD-ACTION
MOVE 'CUSTOMER' TO WS-AUD-SEG-TYPE
MOVE 'SUCCESS ' TO WS-AUD-RESULT
WHEN 'II'
ADD 1 TO WS-ERROR-COUNT
MOVE 'INSERT' TO WS-AUD-ACTION
MOVE 'CUSTOMER' TO WS-AUD-SEG-TYPE
MOVE 'DUPLICATE' TO WS-AUD-RESULT
WHEN OTHER
ADD 1 TO WS-ERROR-COUNT
PERFORM 8000-DLI-ERROR-HANDLER
END-EVALUATE
PERFORM 7000-WRITE-AUDIT
.
*================================================================*
* 4000-PROCESS-REPLACE: Retrieve the target segment with a *
* Get Hold call, modify the I/O area, then issue REPL. *
* The "Hold" variant (GHU) locks the segment for update. *
*================================================================*
4000-PROCESS-REPLACE.
EVALUATE TRUE
WHEN SEG-CUSTOMER
PERFORM 4100-REPLACE-CUSTOMER
WHEN SEG-ACCOUNT
PERFORM 4200-REPLACE-ACCOUNT
WHEN OTHER
ADD 1 TO WS-ERROR-COUNT
DISPLAY 'ERROR: Invalid segment type for REPLACE'
END-EVALUATE
.
*================================================================*
* 4100-REPLACE-CUSTOMER: GHU to retrieve with hold, modify, *
* then REPL. *
*================================================================*
4100-REPLACE-CUSTOMER.
MOVE WS-MAINT-CUST-KEY TO WS-SSA-CUST-ID
* Get Hold Unique - retrieves and locks the segment
CALL 'CBLTDLI' USING WS-DLI-GHU
LS-DB-PCB
WS-CUSTOMER-SEG
WS-CUST-QUAL-SSA
IF LS-STATUS-CODE = SPACES
* Apply changes from maintenance record to the
* retrieved segment. IMPORTANT: Do NOT change the
* sequence field (CUST-ID) -- this is prohibited.
MOVE WS-MAINT-DATA(1:LENGTH OF WS-CUSTOMER-SEG)
TO WS-CUSTOMER-SEG
* Preserve the original key
MOVE WS-MAINT-CUST-KEY TO WS-CUST-ID
* Issue REPL to write modified segment back
CALL 'CBLTDLI' USING WS-DLI-REPL
LS-DB-PCB
WS-CUSTOMER-SEG
IF LS-STATUS-CODE = SPACES
ADD 1 TO WS-REPLACE-COUNT
MOVE 'REPLCE' TO WS-AUD-ACTION
MOVE 'CUSTOMER' TO WS-AUD-SEG-TYPE
MOVE 'SUCCESS ' TO WS-AUD-RESULT
ELSE
ADD 1 TO WS-ERROR-COUNT
MOVE 'REPLCE' TO WS-AUD-ACTION
MOVE 'CUSTOMER' TO WS-AUD-SEG-TYPE
MOVE 'REPL ERR' TO WS-AUD-RESULT
PERFORM 8000-DLI-ERROR-HANDLER
END-IF
ELSE
ADD 1 TO WS-ERROR-COUNT
MOVE 'REPLCE' TO WS-AUD-ACTION
MOVE 'CUSTOMER' TO WS-AUD-SEG-TYPE
MOVE 'NOT FOUND' TO WS-AUD-RESULT
DISPLAY 'ERROR: Customer ' WS-MAINT-CUST-KEY
' not found for replace.'
END-IF
PERFORM 7000-WRITE-AUDIT
.
*================================================================*
* 4200-REPLACE-ACCOUNT: GHU with path SSAs, modify, REPL. *
*================================================================*
4200-REPLACE-ACCOUNT.
MOVE WS-MAINT-CUST-KEY TO WS-SSA-CUST-ID
MOVE WS-MAINT-ACCT-KEY TO WS-SSA-ACCT-NO
* GHU with qualified SSAs at both levels for direct path
CALL 'CBLTDLI' USING WS-DLI-GHU
LS-DB-PCB
WS-ACCOUNT-SEG
WS-CUST-QUAL-SSA
WS-ACCT-QUAL-SSA
IF LS-STATUS-CODE = SPACES
MOVE WS-MAINT-DATA(1:LENGTH OF WS-ACCOUNT-SEG)
TO WS-ACCOUNT-SEG
MOVE WS-MAINT-ACCT-KEY TO WS-ACCT-NUMBER
CALL 'CBLTDLI' USING WS-DLI-REPL
LS-DB-PCB
WS-ACCOUNT-SEG
IF LS-STATUS-CODE = SPACES
ADD 1 TO WS-REPLACE-COUNT
MOVE 'REPLCE' TO WS-AUD-ACTION
MOVE 'ACCOUNT ' TO WS-AUD-SEG-TYPE
MOVE 'SUCCESS ' TO WS-AUD-RESULT
ELSE
ADD 1 TO WS-ERROR-COUNT
MOVE 'REPLCE' TO WS-AUD-ACTION
MOVE 'ACCOUNT ' TO WS-AUD-SEG-TYPE
MOVE 'REPL ERR' TO WS-AUD-RESULT
PERFORM 8000-DLI-ERROR-HANDLER
END-IF
ELSE
ADD 1 TO WS-ERROR-COUNT
MOVE 'REPLCE' TO WS-AUD-ACTION
MOVE 'ACCOUNT ' TO WS-AUD-SEG-TYPE
MOVE 'NOT FOUND' TO WS-AUD-RESULT
END-IF
PERFORM 7000-WRITE-AUDIT
.
*================================================================*
* 5000-PROCESS-DELETE: Retrieve segment with GHU, then DLET. *
* Only account segments can be deleted in this program. *
* Deleting an account also deletes all its transactions *
* (IMS cascading delete behavior). *
*================================================================*
5000-PROCESS-DELETE.
IF NOT SEG-ACCOUNT
ADD 1 TO WS-ERROR-COUNT
DISPLAY 'ERROR: Only ACCOUNT deletes are permitted.'
MOVE 'DELETE' TO WS-AUD-ACTION
MOVE 'INVALID ' TO WS-AUD-RESULT
PERFORM 7000-WRITE-AUDIT
ELSE
PERFORM 5100-DELETE-ACCOUNT
END-IF
.
*================================================================*
* 5100-DELETE-ACCOUNT: GHU the account, then DLET it. *
*================================================================*
5100-DELETE-ACCOUNT.
MOVE WS-MAINT-CUST-KEY TO WS-SSA-CUST-ID
MOVE WS-MAINT-ACCT-KEY TO WS-SSA-ACCT-NO
CALL 'CBLTDLI' USING WS-DLI-GHU
LS-DB-PCB
WS-ACCOUNT-SEG
WS-CUST-QUAL-SSA
WS-ACCT-QUAL-SSA
IF LS-STATUS-CODE = SPACES
* Verify account is marked CLOSED before deleting
IF WS-ACCT-STATUS = 'CLOSED '
CALL 'CBLTDLI' USING WS-DLI-DLET
LS-DB-PCB
WS-ACCOUNT-SEG
IF LS-STATUS-CODE = SPACES
ADD 1 TO WS-DELETE-COUNT
MOVE 'DELETE' TO WS-AUD-ACTION
MOVE 'ACCOUNT ' TO WS-AUD-SEG-TYPE
MOVE 'SUCCESS ' TO WS-AUD-RESULT
ELSE
ADD 1 TO WS-ERROR-COUNT
MOVE 'DELETE' TO WS-AUD-ACTION
MOVE 'ACCOUNT ' TO WS-AUD-SEG-TYPE
MOVE 'DLET ERR' TO WS-AUD-RESULT
PERFORM 8000-DLI-ERROR-HANDLER
END-IF
ELSE
ADD 1 TO WS-ERROR-COUNT
MOVE 'DELETE' TO WS-AUD-ACTION
MOVE 'ACCOUNT ' TO WS-AUD-SEG-TYPE
MOVE 'NOT CLSD' TO WS-AUD-RESULT
DISPLAY 'ERROR: Account ' WS-MAINT-ACCT-KEY
' status is ' WS-ACCT-STATUS
' - must be CLOSED to delete.'
END-IF
ELSE
ADD 1 TO WS-ERROR-COUNT
MOVE 'DELETE' TO WS-AUD-ACTION
MOVE 'ACCOUNT ' TO WS-AUD-SEG-TYPE
MOVE 'NOT FOUND' TO WS-AUD-RESULT
END-IF
PERFORM 7000-WRITE-AUDIT
.
*================================================================*
* 2900-CHECK-CHECKPOINT: Issue checkpoint every N records to *
* enable restart recovery. The CHKP call saves the restart *
* data and commits all database changes since the last *
* checkpoint. *
*================================================================*
2900-CHECK-CHECKPOINT.
ADD 1 TO WS-RECORDS-SINCE-CHKP
IF WS-RECORDS-SINCE-CHKP >= WS-CHECKPOINT-INTERVAL
* Save current counters to restart area
MOVE WS-RECORD-COUNT TO WS-RST-RECORD-COUNT
MOVE WS-MAINT-CUST-KEY TO WS-RST-LAST-CUST-KEY
MOVE WS-MAINT-ACCT-KEY TO WS-RST-LAST-ACCT-KEY
MOVE WS-INSERT-COUNT TO WS-RST-INSERT-COUNT
MOVE WS-REPLACE-COUNT TO WS-RST-REPLACE-COUNT
MOVE WS-DELETE-COUNT TO WS-RST-DELETE-COUNT
MOVE WS-ERROR-COUNT TO WS-RST-ERROR-COUNT
* Issue checkpoint call
CALL 'CBLTDLI' USING WS-DLI-CHKP
LS-IO-PCB
WS-RESTART-DATA
IF LS-IO-STATUS = SPACES
DISPLAY 'CHECKPOINT at record '
WS-RECORD-COUNT
MOVE ZEROS TO WS-RECORDS-SINCE-CHKP
ELSE
DISPLAY 'WARNING: Checkpoint failed. '
'Status: ' LS-IO-STATUS
END-IF
END-IF
.
*================================================================*
* 3000-FINAL-CHECKPOINT: Issue a final checkpoint after all *
* records have been processed. *
*================================================================*
3000-FINAL-CHECKPOINT.
MOVE WS-RECORD-COUNT TO WS-RST-RECORD-COUNT
MOVE WS-INSERT-COUNT TO WS-RST-INSERT-COUNT
MOVE WS-REPLACE-COUNT TO WS-RST-REPLACE-COUNT
MOVE WS-DELETE-COUNT TO WS-RST-DELETE-COUNT
MOVE WS-ERROR-COUNT TO WS-RST-ERROR-COUNT
CALL 'CBLTDLI' USING WS-DLI-CHKP
LS-IO-PCB
WS-RESTART-DATA
DISPLAY 'FINAL CHECKPOINT at record ' WS-RECORD-COUNT
.
*================================================================*
* 7000-WRITE-AUDIT: Write an audit trail record for every *
* database operation attempted. *
*================================================================*
7000-WRITE-AUDIT.
ACCEPT WS-SYS-DATE FROM DATE YYYYMMDD
ACCEPT WS-SYS-TIME FROM TIME
STRING WS-SYS-DATE '-' WS-SYS-TIME
DELIMITED SIZE INTO WS-AUD-TIMESTAMP
MOVE WS-MAINT-CUST-KEY TO WS-AUD-CUST-KEY
MOVE WS-MAINT-ACCT-KEY TO WS-AUD-ACCT-KEY
MOVE WS-MAINT-TXN-KEY TO WS-AUD-TXN-KEY
MOVE LS-STATUS-CODE TO WS-AUD-STATUS
MOVE WS-MAINT-USER-ID TO WS-AUD-USER-ID
MOVE WS-MAINT-SOURCE TO WS-AUD-SOURCE
WRITE AUDIT-FILE-RECORD FROM WS-AUDIT-RECORD
.
*================================================================*
* 8000-DLI-ERROR-HANDLER: Log diagnostic information for *
* unexpected DL/I errors. *
*================================================================*
8000-DLI-ERROR-HANDLER.
DISPLAY '*** DL/I ERROR ***'
DISPLAY ' Record #: ' WS-RECORD-COUNT
DISPLAY ' Action: ' WS-MAINT-ACTION
DISPLAY ' Segment Type: ' WS-MAINT-SEG-TYPE
DISPLAY ' Customer Key: ' WS-MAINT-CUST-KEY
DISPLAY ' Account Key: ' WS-MAINT-ACCT-KEY
DISPLAY ' Status Code: ' LS-STATUS-CODE
DISPLAY ' DBD Name: ' LS-DBD-NAME
DISPLAY ' Segment Name: ' LS-SEG-NAME
DISPLAY ' Key Feedback: ' LS-KEY-FEEDBACK
DISPLAY '*** END ERROR ***'
.
*================================================================*
* 9000-WRAP-UP: Close files and display processing summary. *
*================================================================*
9000-WRAP-UP.
CLOSE MAINT-FILE
CLOSE AUDIT-FILE
DISPLAY ' '
DISPLAY '============================================='
DISPLAY ' CUSTUPD1 - PROCESSING SUMMARY'
DISPLAY '============================================='
DISPLAY ' Total Records Read: ' WS-RECORD-COUNT
DISPLAY ' Successful Inserts: ' WS-INSERT-COUNT
DISPLAY ' Successful Replaces: ' WS-REPLACE-COUNT
DISPLAY ' Successful Deletes: ' WS-DELETE-COUNT
DISPLAY ' Errors Encountered: ' WS-ERROR-COUNT
IF IS-RESTART
DISPLAY ' Records Skipped (RST): ' WS-SKIP-COUNT
END-IF
DISPLAY '============================================='
IF WS-ERROR-COUNT > ZEROS
DISPLAY '*** COMPLETED WITH ERRORS - REVIEW AUDIT ***'
MOVE 4 TO RETURN-CODE
ELSE
DISPLAY '*** COMPLETED SUCCESSFULLY ***'
MOVE 0 TO RETURN-CODE
END-IF
.
Solution Walkthrough
The ISRT Call Pattern
Inserting a new segment requires that the parent path be established first. For an ACCOUNT segment (level 2 in the hierarchy), the parent CUSTOMER (level 1) must be identified. The ISRT call uses a qualified SSA for the parent and an unqualified SSA for the segment being inserted:
CALL 'CBLTDLI' USING WS-DLI-ISRT
LS-DB-PCB
WS-ACCOUNT-SEG
WS-CUST-QUAL-SSA
WS-ACCT-UNQUAL-SSA
IMS reads the SSAs from left to right. It uses the qualified CUSTOMER SSA to locate the parent, then uses the unqualified ACCOUNT SSA to determine the segment type to insert. IMS places the new segment in sequence-field order within the parent's children.
For a TRANSACTION insert (level 3), two parent SSAs are needed -- one for customer and one for account -- followed by the unqualified TRANSACT SSA.
Status code II after an ISRT indicates that a segment with the same sequence field value already exists. The program logs this as a duplicate rather than treating it as a fatal error.
The GHU/REPL Pattern
Updating an existing segment is a two-step process. First, the program must retrieve the segment with a "hold" call (GHU -- Get Hold Unique). The hold tells IMS that the program intends to modify the segment, and IMS locks it against concurrent access. Then the program modifies the I/O area and issues REPL.
A critical rule: the sequence field must not be changed during a REPL. If a customer's ID needs to change, the old segment must be deleted and a new one inserted. Attempting to change a sequence field results in status code DJ.
The GHU/DLET Pattern
Deletion follows the same hold-then-operate pattern. The program issues GHU to retrieve and lock the segment, then DLET to remove it. In IMS, deleting a parent segment automatically deletes all its dependents. Deleting an account removes all associated transactions. This cascading behavior is inherent to the hierarchical model and must be understood by the programmer.
Angela added a safety check: only accounts with status CLOSED can be deleted. This business rule prevents accidental deletion of active accounts, even if an erroneous maintenance record requests it.
Checkpoint/Restart Logic
The checkpoint mechanism is essential for long-running batch programs. Every 5,000 records, the program issues a CHKP (Checkpoint) call through the I/O PCB:
CALL 'CBLTDLI' USING WS-DLI-CHKP
LS-IO-PCB
WS-RESTART-DATA
The CHKP call does three things: 1. Commits all database changes made since the last checkpoint. 2. Saves the restart data area (WS-RESTART-DATA) so it can be restored on restart. 3. Provides a sync point for database recovery.
On restart, the XRST (Extended Restart) call restores the saved data. The program then skips forward in the input file to the record after the last checkpoint and resumes processing with the saved counters.
The checkpoint interval (5,000 records) is a tuning parameter. A smaller interval means less reprocessing after a failure but more overhead. A larger interval means less overhead but more reprocessing. Angela chose 5,000 based on the bank's typical nightly volume and the acceptable restart time.
Qualified SSA Structure
The qualified SSA is the mechanism for direct access in IMS. Its format is rigid:
SEGNAME(fieldname op value)
Where:
- SEGNAME: Exactly 8 bytes, padded with spaces.
- (: Opening parenthesis.
- fieldname: The field name as defined in the DBD, exactly 8 bytes.
- op: A 2-byte relational operator (=, >, >=, <, <=, NE).
- value: The search value, exactly as long as the field in the DBD.
- ): Closing parenthesis.
Getting any of these lengths wrong produces status code AK (invalid SSA). This is one of the most common errors in IMS programming.
Discussion Questions
-
The program restricts deletions to ACCOUNT segments only and requires the account status to be CLOSED. What additional business rules would you implement to make the deletion process safer? Consider scenarios such as accounts with pending transactions or accounts linked to active loans.
-
The checkpoint interval is hardcoded at 5,000 records. How would you make this configurable without recompiling the program? Consider approaches such as a control card, a SYSIN parameter, or an IMS-managed configuration segment.
-
When an ISRT returns status code II (duplicate), the program logs it as an error and continues. Is this the correct behavior? Consider scenarios where the duplicate might indicate a legitimate retry after a restart versus a genuine data error. How would you differentiate between these cases?
-
The audit trail is written to a sequential file. What happens to audit records for operations that occurred between the last checkpoint and an abend? Are they recoverable? How would you design the audit mechanism to ensure no audit records are lost?
-
Compare the GHU/REPL pattern with a relational database UPDATE statement. What are the advantages of the two-step retrieve-then-update approach? What are the risks (such as the time window between GHU and REPL during which another program might need the same segment)?
-
The maintenance file is sorted to match the IMS hierarchy order. What would happen to performance if the file were sorted randomly (for example, by timestamp instead of by customer key)? How does the IMS access method handle non-sequential navigation of the database?