Joined: 14 Jan 2008 Posts: 2501 Location: Atlanta, Georgia, USA
Here's an Assembler sub-program (KIKSDESC, my own creation) which returns the description of a particular EIBRESP. It uses the CICS In-Core program "DFHEITAB" to find this description. Comments in the program-source should suffice for usage. Converting this to a HLL should not pose a major challenge.
Code:
*PROCESS RENT PROGRAM IS RE-ENTRANT
*ASM XOPTS(NOEPILOG) SUPPRESS EPILOGUE
***********************************************************************
*---------------------------------------------------------------------*
* *
* THIS SUB-PROGRAM WILL RETURN THE DESCRIPTION ASSOCIATED WITH *
* A PARTICULAR EIBRESP VALUE AS WELL AS THE EIBFN AND EIBRCODE *
* IN READABLE-HEX FORMAT (EXTRACTED FROM COMMAREA-DFHEIBLK). *
* *
* EXAMPLE COMMAREA - *
* *
* 03 WS-KIKSDESC-COMMAREA. *
* 05 WS-KIKSDESC-RESP-CODE *
* PIC 9(05). *
* 05 WS-KIKSDESC-DFHEIBLK *
* PIC X(85). *
* 05 WS-KIKSDESC-EIBFN PIC X(04). *
* 05 WS-KIKSDESC-EIBRCODE *
* PIC X(12). *
* 05 WS-KIKSDESC-DESCRIPTION-LGTH *
* PIC 9(02). *
* 05 WS-KIKSDESC-DESCRIPTION *
* PIC X(12). *
* 03 WS-KIKSDESC PIC X(08) VALUE 'KIKSDESC'. *
* *
* MOVE EIBRESP TO WS-KIKSDESC-RESP-CODE. *
* MOVE DFHEIBLK TO WS-KIKSDESC-DFHEIBLK. *
* *
* EXEC CICS LINK *
* PROGRAM (WS-KIKSDESC) *
* COMMAREA(WS-KIKSDESC-COMMAREA) *
* LENGTH (LENGTH OF WS-KIKSDESC-COMMAREA) *
* END-EXEC. *
* *
* UPON RETURN, 'WS-KIKSDESC-DESCRIPTION' WILL CONTAIN THE *
* DECRIPTION-TEXT ASSOCIATED WITH THE PASSED 'EIBRESP'. ALSO, *
* 'WS-KIKSDESC-DESCRIPTION-LGTH' WILL CONTAIN THE ACTUAL *
* LENGTH OF THE DESCRIPTION. FOR EXAMPLE, THE 'EIBRESP' VALUE *
* THAT WAS PASSED WAS 19 AND ITS ASSOCIATED DESCRIPTION WILL *
* BE 'NOTOPEN'. THE DESCRIPTION-LGTH WILL EQUAL 07. *
* *
* THE RETURN-CODE IS RETURNED IN R15 TO THE CALLER, OTHERWISE *
* KNOWN AS THE RETURN-CODE SPECIAL-REGISTER FOR COBOL-CALLERS. *
* *
*---------------------------------------------------------------------*
***********************************************************************
PRINT GEN ACTIVATE MACRO-EXPANSION
COMDSECT DSECT COMMAREA DSECT (R7)
USING *,R7 INFORM ASSEMBLER
COMMAREA EQU * BEGIN COMMAREA
COMMRSPC DS CL5 RESPONSE-CODE (DISPLAY-NUMERIC)
COMMAEIB DS CL(EIBLENG) CALLER'S DFHEIBLK
COMMFCTN DS CL(L'EIBFN*2) CALLER'S 'EIBFN' (READABLE HEX)
COMMRCDE DS CL(L'EIBRCODE*2) CALLER'S 'EIBRCODE' (SAME)
COMMDLEN DS CL2 DESCRIPTN-LGTH (DISPLAY-NUMERIC)
COMMDESC DS CL(L'EIBRCODE*2) DESCRIPTN-TEXT
COMMLGTH EQU *-COMMAREA COMMAREA-LGTH
TBLDSECT DSECT DFHEITAB DSECT (R9)
USING *,R9 INFORM ASSEMBLER
TBLENTRY EQU * BEGIN ENTRY
TBLDESC DS CL(L'COMMDESC) ASSOCIATED-DESCRIPTION
TBLEYECT DS XL2 EYECATCHER (X'50C0')
DS XL4 NOT USED
TBLRSPCD DS XL2 RESPONSE-CODE (UNALIGNED HWORD)
DS XL2 NOT USED
TBLLGTH EQU *-TBLENTRY LENGTH OF TBL-DSECT
DFHEISTG DSECT DYNAMIC-STG DSECT (R13)
DWORD DS D DOUBLEWORD WORK-AREA
RETNCODE DS H RETURN-CODE HWORD
RESPCODE DS XL2 RESPONSE-CODE FROM CALLER
WORKDESC DS CL(L'COMMDESC+1) DESCRIPTION-WORKAREA
UNPKAREA DS CL16 MULTI-USE UNPACK-AREA
HEXAREA DS CL(L'COMMFCTN+L'COMMRCDE)
TRANSTBL DS XL256 DYNAMIC TRANSLATE-TBL
KIKSDESC DFHEIENT CODEREG=R3,DATAREG=R13,EIBREG=R11
LA R14,4095 PREPARE FOR 'STH'
STH R14,RETNCODE STORE IN HWORD
LH R14,EIBCALEN LOAD COMMAREA-LGTH
CHI R14,COMMLGTH MINIMUM-LGTH?
BL CICSRETN NO, RETURN TO CALLER
XC DFHEIUSR(L'TRANSTBL),DFHEIUSR
XC DFHEIUSR+L'TRANSTBL((DFHEIEND-DFHEIUSR)-L'TRANSTBL),DFHEX
IUSR+L'TRANSTBL
L R7,DFHEICAP COMMAREA ADDRESSABILITY
LA R14,L'COMMDESC PREPARE FOR 'CVD'
CVD R14,DWORD MAKE IT DECIMAL
OI DWORD+L'DWORD-1,X'0F' ENSURE 'F' SIGN-NIBBLE
UNPK COMMDLEN,DWORD UNPACK MAXIMUM-LGTH
PACK DWORD,COMMRSPC COMMAREA RESPONSE-CODE
OI DWORD+L'DWORD-1,X'0F' ENSURE 'F' SIGN-NIBBLE
CVB R14,DWORD MAKE IT BINARY
STCM R14,B'0011',RESPCODE STORE AS UNALIGNED-HWORD
LA R14,COMMAEIB POINT TO COMMAREA-DFHEIBLK
UNPK UNPKAREA(L'COMMFCTN+1),EIBFN-DFHEIBLK(L'EIBFN+1,R14)
MVC HEXAREA(L'COMMFCTN),UNPKAREA
UNPK UNPKAREA(L'COMMRCDE+1),EIBRCODE-DFHEIBLK(L'EIBRCODE+1,R1X
4)
MVC HEXAREA+L'COMMFCTN(L'COMMRCDE),UNPKAREA
TR HEXAREA,=CL16'0123456789ABCDEF'-240
MVC COMMFCTN,HEXAREA POPULATE AS READABLE-HEX
MVC COMMRCDE,HEXAREA+L'COMMFCTN
MVI WORKDESC,C' ' ENSURE ALL SPACES
MVC WORKDESC+1(L'WORKDESC-1),WORKDESC
MVC COMMDESC,WORKDESC SAME
OC RESPCODE,RESPCODE NON-ZERO RESPONSE-CODE?
BNZ LOADPGM YES, LOAD PROGRAM
MVC COMMDESC(L'EIBRCODE),=C'NORMAL'
B CALCLGTH CALCULATE DESCRIPTION-LGTH
LOADPGM EQU *
*
EXEC CICS LOAD NOHANDLE, ESTABLISH ADDRESSABILITY TO THE X
PROGRAM('DFHEITAB'), CICS IN-CORE TABLE X
SET (R9),
*
ICM R15,B'1111',EIBRESP TABLE LOAD OK?
STH R15,RETNCODE STORE IN HWORD
BNZ BADLOAD NO, BAD TABLE LOAD
L R9,24(,R9) RE-CALCULATE STARTING-ADDRESS
B FIRSTEYE FIND FIRST 'EYECATCHER'
BADLOAD EQU *
MVC COMMDESC,=C'@TBLDERR000@'
CVD R15,DWORD MAKE IT DECIMAL
OI DWORD+L'DWORD-1,X'0F' ENSURE 'F' SIGN-NIBBLE
UNPK COMMDESC+8(3),DWORD UNPACK 'EIBRESP' FROM LOAD
B CICSRETN RETURN TO CALLER
FIRSTEYE EQU *
CLC =X'50C0',TBLENTRY FIRST EYECATCHER FOUND?
BNE BUMP4EYE NO, CHECK 'NEXT' BYTE
AHI R9,-L'TBLDESC REPOSITION AT ENTRY-START
B SRCHDESC BEGIN DESCRIPTION-SEARCH
BUMP4EYE EQU *
LA R9,1(,R9) BUMP TO 'NEXT' BYTE
B FIRSTEYE CONTINUE LOOP
SRCHDESC EQU *
CLC =X'50C0',TBLEYECT ANY MORE ENTRIES?
BNE NORESPCD NO, RESPONSE-CODE NOT FOUND
CLC RESPCODE,TBLRSPCD RESPONSE-CODES MATCH?
BNE BUMPDESC NO, CHECK 'NEXT' ENTRY
MVC COMMDESC,TBLDESC POPULATE DESCRIPTION
B CALCLGTH CALCULATE DESCRIPTION-LGTH
BUMPDESC EQU *
LA R9,TBLLGTH(,R9) BUMP TO 'NEXT' TBL-ENTRY
B SRCHDESC KEEP SEARCHING
NORESPCD EQU *
MVI RETNCODE+L'RETNCODE-1,X'08'
MVC COMMDESC,=C'@@NORESPCD@@'
B CICSRETN RETURN TO CALLER
CALCLGTH EQU *
MVI TRANSTBL+64,X'FF' SET SPACE-SLOT TO X'FF'
MVC WORKDESC(L'COMMDESC),COMMDESC
TRT WORKDESC,TRANSTBL FIND FIRST-SPACE
LA R2,WORKDESC POINT TO STARTING-ADDRESS
SR R1,R2 NON-ZERO DESCRIPTION-LGTH?
BZ NODSCRPT NO, DESCRIPTION NOT FOUND
BM NODSCRPT SAME
CVD R1,DWORD MAKE IT DECIMAL
OI DWORD+L'DWORD-1,X'0F' ENSURE 'F' SIGN-NIBBLE
UNPK COMMDLEN,DWORD UNPACK INTO COMMAREA
MVI RETNCODE+L'RETNCODE-1,X'00'
B CICSRETN RETURN TO CALLER
NODSCRPT EQU *
MVI RETNCODE+L'RETNCODE-1,X'08'
MVC COMMDESC,=C'@NODESCRPTN@'
CICSRETN EQU *
LH R15,RETNCODE LOAD RETURN-CODE
*
DFHEIRET RCREG=R15 RETURN TO CALLER
*
DFHREGS , CICS REGISTER-MACRO
*
LTORG ,
*
KIKSDESC AMODE 31 ,
KIKSDESC RMODE ANY ,
*
END , END 'KIKSDESC'
