DSN8IC0
THIS MODULE RECEIVES AN INPUT MESSAGE AND DEFORMATS IT, CALLS DSN8IC1, FORMATS OUTPUT MESSAGE AND SENDS IT.
IDENTIFICATION DIVISION. 00010000
*------------------------ 00012000
PROGRAM-ID. DSN8IC0. 00014000
00016000
******* DSN8IC0 - IMS SUBSYSTEM INTERFACE MODULE - COBOL ******** 00018000
* * 00020000
* MODULE NAME = DSN8IC0 * 00030000
* * 00040000
* DESCRIPTIVE NAME = DB2 SAMPLE APPLICATION * 00050000
* SUBSYSTEM INTERFACE MODULE * 00060000
* IMS * 00070000
* COBOL * 00080000
* ORGANIZATION APPLICATION * 00090000
* * 00100000
*LICENSED MATERIALS - PROPERTY OF IBM * 00110000
*5615-DB2 * 00116000
*(C) COPYRIGHT 1996, 2013 IBM CORP. ALL RIGHTS RESERVED. * 00125000
* * 00126000
*STATUS = VERSION 11 * 00128001
* * 00130000
* FUNCTION = THIS MODULE RECEIVES AN INPUT MESSAGE AND * 00160000
* DEFORMATS IT, CALLS DSN8IC1, * 00170000
* FORMATS OUTPUT MESSAGE AND SENDS IT. * 00180000
* * 00190000
* NOTES = NONE * 00200000
* * 00210000
* MODULE TYPE = * 00220000
* PROCESSOR = DB2 PREPROCESSOR, COBOL COMPILER * 00230000
* MODULE SIZE = SEE LINKEDIT * 00240000
* ATTRIBUTES = REUSABLE * 00250000
* * 00260000
* ENTRY POINT = DSN8IC0 * 00270000
* PURPOSE = SEE FUNCTION * 00280000
* LINKAGE = FROM IMS * 00290000
* * 00300000
* INPUT = PARAMETERS EXPLICITLY PASSED TO THIS FUNCTION: * 00310000
* * 00320000
* SYMBOLIC LABEL/NAME = DSN8ICGI * 00330000
* DESCRIPTION = IMS/VS MFS GENERAL MENU * 00340000
* * 00350000
* SYMBOLIC LABEL/NAME = DSN8ICDI * 00360000
* DESCRIPTION = IMS/VS MFS DETAIL MENU * 00370000
* * 00380000
* OUTPUT = PARAMETERS EXPLICITLY RETURNED: * 00390000
* * 00400000
* SYMBOLIC LABEL/NAME = DSN8ICGO * 00410000
* DESCRIPTION = IMS/VS MFS GENERAL MENU * 00420000
* * 00430000
* SYMBOLIC LABEL/NAME = DSN8ICDO * 00440000
* DESCRIPTION = IMS/VS MFS DETAIL MENU * 00450000
* * 00460000
* EXIT-NORMAL = RETURN CODE 0 NORMAL COMPLETION * 00470000
* * 00480000
* EXIT-ERROR = * 00490000
* * 00500000
* RETURN CODE = NONE * 00510000
* * 00520000
* ABEND CODES = NONE * 00530000
* * 00540000
* ERROR-MESSAGES = * 00550000
* DSN8064E - INVALID DL/I STC-CODE ON GU MSG * 00560000
* DSN8065E - INVALID DL/I STC-CODE ON ISRT MSG * 00570000
* * 00580000
* EXTERNAL REFERENCES = * 00590000
* ROUTINES/SERVICES = MODULE DSN8IC1 * 00600000
* MODULE CBLTDLI * 00610000
* MODULE DSN8MCG * 00620000
* DATA-AREAS = * 00630000
* DSN8MCCA - PARAMETER TO BE PASSED TO DSN8IC1* 00640000
* CONTAINS TERMINAL INPUT AND * 00650000
* OUTPUT AREAS. * 00660000
* * 00670000
* CONTROL-BLOCKS = * 00680000
* IN-MESSAGE - MFS INPUT * 00690000
* OUT-MESSAGE - MFS OUTPUT * 00700000
* * 00710000
* TABLES = NONE * 00720000
* * 00730000
* CHANGE-ACTIVITY = * 00740000
* 05/18/2012: SWITCH ARITHMETICS FROM COMP TO COMP-5 PM66408* 00750002
* * 00751000
* * 00760000
* *PSEUDOCODE* * 00770000
* * 00780000
* PROCEDURE * 00790000
* DECLARATIONS. * 00800000
* ALLOCATE COBOL WORK AREA FOR COMMAREA. * 00810000
* INITIALIZATION. * 00820000
* PUT MODNAME 'DSN8ICGO' IN MODNAME FIELD. * 00830000
* PUT MODULE NAME 'DSN8IC0' IN AREA USED BY * 00840000
* ERROR-HANDLER. * 00850000
* * 00860000
* STEP1. * 00870000
* CALL DLI GU INPUT MESSAGE. * 00880000
* IF STATUS CODE NOT OK THEN SEND ERROR MESSAGE AND * 00890000
* STOP PROGRAM. * 00900000
* * 00910000
* IF SCREEN CLEARED/UNFORMATTED , MOVE '00' TO PFKIN. * 00920000
* MOVE INPUT MESSAGE FIELDS TO CORRESPONDING * 00930000
* INAREA FIELDS IN COMPARM. * 00940000
* CALL DSN8IC1 (COMMAREA) * 00950000
* MOVE OUTAREA FIELDS IN PCONVSTA TO CORRESPONDING * 00960000
* OUTPUT MESSAGE FIELDS. * 00970000
* IF LASTSCR 'DSN8001' MOVE 'DSN8ICGO' TO MODNAME FIELD * 00980000
* ELSE MOVE 'DSN8ICDO' TO MODNAME FIELD. * 00990000
* * 01000000
* CALL DLI ISRT OUTPUT MESSAGE. * 01010000
* IF STATUS CODE NOT OK THEN SEND ERROR MESSAGE AND * 01020000
* STOP PROGRAM. * 01030000
* * 01040000
* END. * 01050000
* * 01060000
***************************************************************** 01070000
* 01080000
ENVIRONMENT DIVISION. 01130000
*------------------------ 01140000
01150000
DATA DIVISION. 01160000
*------------------------ 01170000
WORKING-STORAGE SECTION. 01180000
**************************************************************** 01190000
* DECLARATION FOR PASSING INPUT/OUTPUT DATA BETWEEN THE * 01200000
* SUBSYSTEM DEPENDENT MODULE IMS/DLI AND SQL1 AND SQL2 * 01210000
**************************************************************** 01220000
* 01230000
01 COMMAREA. 01240000
EXEC SQL INCLUDE DSN8MCCA END-EXEC. 01250000
**************************************************************** 01260000
* DECLARATION FOR INPUT: MIDNAME DSN8ICGI/DSN8ICDI * 01270000
**************************************************************** 01280000
* 01290000
01 IN-MESSAGE. 01300000
02 LL PIC S9(3) COMP-5. 01310000
02 Z1 PIC X. 01320000
02 Z2 PIC X. 01330000
02 TC-CODE PIC X(7). 01340000
02 IN-PUT. 01350000
03 MAJSYS PIC X. 01360000
03 ACTION PIC X. 01370000
03 OBJFLD PIC X(2). 01380000
03 SRCH PIC X(2). 01390000
03 PFKIN PIC X(2). 01400000
03 DATAIN PIC X(60). 01410000
03 TRANDATA PIC X(40) OCCURS 15. 01420000
* 01430000
02 IN-PUT0 REDEFINES IN-PUT PIC X(668). 01440000
**************************************************************** 01450000
* DECLARATION FOR OUTPUT: MODNAME DSN8ICGO/DSN8ICDO * 01460000
**************************************************************** 01470000
* 01480000
01 OUT-MESSAGE. 01490000
02 LL PIC S9(3) COMP-5. 01500000
02 ZZ PIC S9(3) COMP-5 VALUE +0. 01510000
02 OUTPUTAREA. 01520000
03 MAJSYS PIC X. 01530000
03 ACTION PIC X. 01540000
03 OBJFLD PIC X(2). 01550000
03 SRCH PIC X(2). 01560000
03 DATAOUT PIC X(60). 01570000
03 HTITLE PIC X(50). 01580000
03 DESC2 PIC X(50). 01590000
03 DESC3 PIC X(50). 01600000
03 DESC4 PIC X(50). 01610000
03 MSG. 01620000
05 STC PIC X(4). 01630000
05 MSGTEXT PIC X(75). 01640000
03 PFKTEXT PIC X(79). 01650000
03 OUTPUT0 OCCURS 15. 01660000
05 LINE0 PIC X(79). 01670000
* 01680000
02 OUTPUTAREA0 REDEFINES OUTPUTAREA PIC X(1609). 01690000
**************************************************************** 01700000
* FIELDS SENT TO MESSAGE ROUTINE * 01710000
**************************************************************** 01720000
01 MSGCODE PIC X(04). 01730000
01740000
01 OUTMSG PIC X(69). 01750000
**************************************************************** 01760000
* DECLARATION FOR PGM-LOGIC * 01770000
**************************************************************** 01780000
* 01790000
77 GU-FKT PIC X(4) VALUE 'GU '. 01800000
77 ISRT-FKT PIC X(4) VALUE 'ISRT'. 01810000
77 CHNG-FKT PIC X(4) VALUE 'CHNG'. 01820000
77 ROLL-FKT PIC X(4) VALUE 'ROLL'. 01830000
* 01840000
77 MODNAME PIC X(8). 01850000
**************************************************************** 01860000
* LINKAGE SECTION * 01870000
**************************************************************** 01880000
LINKAGE SECTION. 01890000
**************************************************************** 01900000
* DECLARATION FOR IO / ALTPCB * 01910000
**************************************************************** 01920000
* 01930000
01 IOPCB. 01940000
02 IOLTERM PIC X(8). 01950000
02 FILLER PIC X(2). 01960000
02 STC-CODE PIC X(2). 01970000
02 CDATE PIC X(4). 01980000
02 CTIME PIC X(4). 01990000
02 SEQNUM PIC X(4). 02000000
02 MOD-NAME PIC X(8). 02010000
02 USERID PIC X(8). 02020000
* 02030000
01 ALTPCB. 02040000
02 ALTLTERM PIC X(8). 02050000
02 FILLER PIC X(2). 02060000
02 STC-CODE PIC X(2). 02070000
02080000
PROCEDURE DIVISION. 02090000
*--------------------- 02100000
* 02110000
ENTRY 'DLITCBL' USING IOPCB ALTPCB. 02120000
**************************************************************** 02130000
* ALLOCATE COBOL WORK AREA /INITIALIZATIONS * 02140000
**************************************************************** 02150000
* 02160000
CSTART. 02170000
MOVE SPACES TO COMMAREA. 02180000
MOVE SPACES TO IN-MESSAGE. 02190000
MOVE 'DSN8ICGO' TO MODNAME. 02200000
MOVE 'DSN8IC0' TO MAJOR IN DSN8-MODULE-NAME. 02210000
MOVE 'O' TO MAJSYS IN OUTAREA. 02220000
MOVE '0' TO EXITCODE. 02230000
MOVE +1613 TO LL IN OUT-MESSAGE. 02240000
* 02250000
**************************************************************** 02260000
* CALL DL1 GU INPUT MESSAGE * 02270000
* PRINT ERROR MESSAGE IF STATUS CODE NOT OK * 02280000
**************************************************************** 02290000
02300000
* **CALL DL1 GU 02310000
CALL 'CBLTDLI' 02320000
USING GU-FKT IOPCB IN-MESSAGE. 02330000
02340000
* **ERROR? 02350000
IF STC-CODE IN IOPCB NOT = ' ' 02360000
THEN MOVE '064E' TO MSGCODE 02370000
CALL 'DSN8MCG' USING MAJOR MSGCODE OUTMSG 02380000
MOVE OUTMSG TO MSGTEXT IN OUTPUTAREA 02390000
MOVE STC-CODE IN IOPCB TO STC IN OUTPUTAREA 02400000
GO TO CSEND. 02410000
02420000
**************************************************************** 02430000
* CLEARED AND UNFORMATTED SCREEN? * 02440000
**************************************************************** 02450000
02460000
IF Z2 = LOW-VALUE 02470000
THEN MOVE '00' TO PFKIN IN INAREA. 02480000
MOVE IOLTERM IN IOPCB TO TRMID IN CONVID. 02490000
MOVE USERID IN IOPCB TO USERID IN CONVID. 02500000
02510000
* **MOVE INPUT MESSAGE 02520000
* **FIELDS TO INAREA FIELDS 02530000
MOVE IN-PUT0 TO INAREA0. 02540000
MOVE 'O' TO MAJSYS IN INAREA. 02550000
* 02560000
CALL 'DSN8IC1' USING COMMAREA. 02570000
02580000
* **MOVE OUTAREA FIELDS TO 02590000
* **OUTPUT MESSAGE FIELDS 02600000
MOVE OUTAREA0 TO OUTPUTAREA0. 02610000
* 02620000
IF LASTSCR = 'DSN8002' 02630000
THEN MOVE 'DSN8ICDO' TO MODNAME 02640000
ELSE MOVE 'DSN8ICGO' TO MODNAME. 02650000
02660000
**************************************************************** 02670000
* CALL DL ISRT OUTPUT MESSAGE * 02680000
* PRINT ERROR MESSAGE IF STATUS CODE NOT OK * 02690000
**************************************************************** 02700000
02710000
CSEND. 02720000
02730000
* **CALL DL1 ISRT 02740000
CALL 'CBLTDLI' 02750000
USING ISRT-FKT IOPCB OUT-MESSAGE MODNAME. 02760000
02770000
* **STATUS CODE OK 02780000
IF STC-CODE IN IOPCB = ' ' THEN GO TO CEND. 02790000
02800000
* **STATUS CODE NOT OK 02810000
* **PRINT ERROR MESSAGE 02820000
MOVE '065E' TO MSGCODE. 02830000
CALL 'DSN8MCG' USING MAJOR MSGCODE OUTMSG. 02840000
MOVE OUTMSG TO MSGTEXT IN OUTPUTAREA. 02850000
02860000
MOVE STC-CODE IN IOPCB TO STC IN OUTPUTAREA. 02870000
02880000
* **CALL DL1 CHNG 02890000
CALL 'CBLTDLI' 02900000
USING CHNG-FKT ALTPCB IOLTERM. 02910000
02920000
* **ERROR? 02930000
IF STC-CODE IN ALTPCB NOT = ' ' THEN 02940000
GO TO CSEND1. 02950000
02960000
* **CALL DL1 ISRT 02970000
CALL 'CBLTDLI' 02980000
USING ISRT-FKT IOPCB OUT-MESSAGE MODNAME. 02990000
03000000
* **PERFORM ROLLBACK 03010000
CSEND1. 03020000
CALL 'CBLTDLI' USING ROLL-FKT. 03030000
03040000
* **RETURN 03050000
CEND. 03060000
GOBACK. 03070000
03071000