IMS sample program (DFSISC00)
The following IMS sample program, written in COBOL, accepts an input message from an ISC session with CICS® and returns the same message to CICS.
The program has two transaction codes: SAMPLA1 and SAMPLA2. When invoked using SAMPLA1, the output message is not formatted by MFS. When invoked using SAMPLA2, the output message is formatted by MFS using distributed presentation management (DPM).
CBL APOST
IDENTIFICATION DIVISION.
PROGRAM-ID. SAMPLA.
AUTHOR:
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-370.
OBJECT-COMPUTER. IBM-370.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
DATA DIVISION.
FILE SECTION.
EJECT
WORKING-STORAGE SECTION.
77 BEGIN-LIT PIC X(16) VALUE 'BEGIN 77 ENTRIES'.
77 FILLER PIC X(45) VALUE
'****DATE LAST COMPILED: xxx xx, 19xx****'.
77 CALL-FUNCTION PIC XXXX.
77 MOD-NAME PIC X(08).
EJECT
01 INPUT-AREA.
02 IN-LL PIC S9999 COMP.
02 IN-ZZ PIC S999 COMP.
02 TRAN-CODE PIC X(08).
02 INPUT-DATA PIC X(79).
02 INPUT-DATA-D REDEFINES INPUT-DATA.
05 INPUT-DATA-1 OCCURS 3 TIMES
PIC X(20).
05 INPUT-DATA-2 PIC X(19).
01 OUTPUT-AREA.
02 OUT-LL PIC S9999 COMP.
02 OUT-ZZ PIC S999 COMP.
02 OUTPUT-DATA PIC X(79).
01 OUTPUT-AREA-1.
02 OUT-LL-1 PIC S9999 COMP.
02 OUT-ZZ-1 PIC S999 COMP.
02 OUTPUT-DATA-1 PIC X(20).
EJECT
01 DLI-FUNCTIONS.
02 GET-UNIQ PIC XXXX VALUE 'GU '.
02 GET-NEXT PIC XXXX VALUE 'GN '.
02 ISRT PIC XXXX VALUE 'ISRT'.
EJECT
01 STATUS-ERROR-SEG.
02 FILLER PIC S999 COMP VALUE +83.
02 FILLER PIC S999 COMP VALUE +0.
02 FILLER PIC X(28) VALUE
'******* STATUS ERROR *******'.
02 FILLER PIC X(10) VALUE ' TRANCODE:'.
02 ERROR-TRAN PIC X(8).
02 FILLER PIC X(17) VALUE
' STATUS RECEIVED:'.
02 ERROR-STATUS PIC XX.
02 FILLER PIC X(10) VALUE ' FUNCTION:'.
02 ERROR-FUNCTION PIC XXXX.
EJECT
LINKAGE SECTION.
01 IOTP-PCB.
02 IOTP-LTERM PIC X(8).
02 FILLER PIC XX.
02 IOTP-STATUS PIC XX.
02 IOTP-PREFIX.
03 IOTP-DATE PIC S9(7) COMP-3.
03 IOTP-TIME PIC S9(7) COMP-3.
03 IOTP-MSG-NUMBER PIC S999 COMP.
03 FILLER PIC XX.
02 IOTP-MOD-NAME PIC X(8).
EJECT
PROCEDURE DIVISION.
ENTRY 'DLITCBL' USING IOTP-PCB.
100-RETRIEVE-MESSAGE-SEGMENT.
MOVE GET-UNIQ TO CALL-FUNCTION.
CALL 'CBLTDLI' USING CALL-FUNCTION IOTP-PCB INPUT-AREA.
IF IOTP-STATUS = 'QC'
GO TO 800-GOBACK-ROUTINE.
IF IOTP-STATUS NOT = SPACES
GO TO 700-INVALID-STATUS-CODE.
200-CHECK-TRAN-CODE.
***************************************************************
* THE ONLY DIFFERENCE BETWEEN THESE TWO TRANSACTIONS *
* IS THE ABSENCE OR PRESENCE OF MFS. SAMPLA1 DOES NOT *
* CONTAIN MFS. SAMPLA2 CONTAINS MFS. *
***************************************************************
IF TRAN-CODE = 'SAMPLA2'
PERFORM 400-SAMPLA2-ROUTINE
THRU 450-SAMPLA2-ROUTINE-EXIT,
ELSE
PERFORM 300-SAMPLA1-ROUTINE
THRU 350-SAMPLA1-ROUTINE-EXIT.
GO TO 100-RETRIEVE-MESSAGE-SEGMENT.
EJECT
300-SAMPLA1-ROUTINE.
MOVE ISRT TO CALL-FUNCTION.
SUBTRACT 8 FROM IN-LL GIVING OUT-LL.
MOVE IN-ZZ TO OUT-ZZ.
MOVE INPUT-DATA TO OUTPUT-DATA.
CALL 'CBLTDLI' USING CALL-FUNCTION IOTP-PCB OUTPUT-AREA.
IF IOTP-STATUS NOT = SPACES
GO TO 700-INVALID-STATUS-CODE.
350-SAMPLA1-ROUTINE-EXIT.
EXIT.
400-SAMPLA2-ROUTINE.
MOVE 'MODA' TO MOD-NAME,
MOVE +0 TO OUT-ZZ-1.
MOVE 24 TO OUT-LL-1.
MOVE INPUT-DATA-1 (1) TO OUTPUT-DATA-1.
PERFORM 500-INSERT-ROUTINE
THRU 550-INSERT-ROUTINE-EXIT.
SUBTRACT 20 FROM IN-LL.
IF IN-LL IS LESS THAN 13 GO TO 450-SAMPLA2-ROUTINE-EXIT.
MOVE INPUT-DATA-1 (2) TO OUTPUT-DATA-1.
PERFORM 600-INSERT-ROUTINE
THRU 650-INSERT-ROUTINE-EXIT.
SUBTRACT 20 FROM IN-LL.
IF IN-LL IS LESS THAN 13 GO TO 450-SAMPLA2-ROUTINE-EXIT.
MOVE INPUT-DATA-1 (3) TO OUTPUT-DATA-1.
PERFORM 600-INSERT-ROUTINE
THRU 650-INSERT-ROUTINE-EXIT.
SUBTRACT 20 FROM IN-LL.
IF IN-LL IS LESS THAN 13 GO TO 450-SAMPLA2-ROUTINE-EXIT.
MOVE INPUT-DATA-2 TO OUTPUT-DATA-1.
PERFORM 600-INSERT-ROUTINE
450-SAMPLA2-ROUTINE-EXIT.
THRU 650-INSERT-ROUTINE-EXIT.
EXIT.
EJECT
500-INSERT-ROUTINE.
MOVE ISRT TO CALL-FUNCTION.
CALL 'CBLTDLI' USING CALL-FUNCTION IOTP-PCB OUTPUT-AREA-1
MOD-NAME.
IF IOTP-STATUS NOT = SPACES
GO TO 700-INVALID-STATUS-CODE.
550-INSERT-ROUTINE-EXIT.
EXIT.
600-INSERT-ROUTINE.
MOVE ISRT TO CALL-FUNCTION.
CALL 'CBLTDLI' USING CALL-FUNCTION IOTP-PCB OUTPUT-AREA-1.
IF IOTP-STATUS NOT = SPACES
GO TO 700-INVALID-STATUS-CODE.
650-INSERT-ROUTINE-EXIT.
EXIT.
700-INVALID-STATUS-CODE.
MOVE CALL-FUNCTION TO ERROR-FUNCTION.
MOVE IOTP-STATUS TO ERROR-STATUS.
MOVE TRAN-CODE TO ERROR-TRAN.
MOVE ISRT TO CALL-FUNCTION.
CALL 'CBLTDLI' USING CALL-FUNCTION IOTP-PCB STATUS-ERROR-SEG.
800-GOBACK-ROUTINE.
GOBACK.