Portal | Manuals | References | Downloads | Info | Programs | JCLs | Master the Mainframes
IBM Mainframe Computers Forums Index
 
Register
 
IBM Mainframe Computers Forums Index Mainframe: Search IBM Mainframe Forum: FAQ Memberlist Usergroups Profile Log in to check your private messages Log in
 

 

CICS Program "KIKSDESC"

 
Post new topic   Reply to topic    IBMMAINFRAMES.com Support Forums -> CICS
View previous topic :: :: View next topic  
Author Message
Bill O'Boyle

CICS Moderator


Joined: 14 Jan 2008
Posts: 2502
Location: Atlanta, Georgia, USA

PostPosted: Tue Nov 12, 2013 11:29 pm    Post subject: CICS Program "KIKSDESC"
Reply with quote

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.

Note - As of 2015/09/01, this is an updated version of KIKSDESC, which includes an adjustment factor for the TBLDSECT, due to the expansion of a single table-entry from 22 to 24 positions, beginning with CICS/TS 5.1. The adjustment factor is calculated accordingly, based upon the CICSTSLEVEL obtained from an INQUIRE SYSTEM API.

Code:

*PROCESS RENT                      PROGRAM IS RE-ENTRANT               
*ASM XOPTS(NOEPILOG)               SUPPRESS EPILOGUE                   
***********************************************************************
*---------------------------------------------------------------------*
*                                                                     *
*        THIS SUB-PROGRAM WILL RETURN THE DESCRIPTN ASSOCIATED WITH   *
*        A PARTICULAR EIBRESP VALUE AS WELL AS THE EIBFN AND EIBRCODE *
*        IN READABLE-HEX FORMAT.                                      *
*                                                                     *
*        EXAMPLE COMMAREA (LENGTH IS ALWAYS 40) -                     *
*                                                                     *
*        03  WS-KIKSDESC-COMMAREA.                                    *
*            05  WS-KIKSDESC-EIBRESP                                  *
*                                  PIC  9(08)      COMP-5.            *
*            05  WS-KIKSDESC-EIBRESP2                                 *
*                                  PIC  9(08)      COMP-5.            *
*            05  WS-KIKSDESC-EIBFN PIC  X(04).                        *
*            05  WS-KIKSDESC-EIBRCODE                                 *
*                                  PIC  X(12).                        *
*            05  WS-KIKSDESC-DESCRIPTN-LGTH                           *
*                                  PIC  9(04)      COMP-5.            *
*            05  WS-KIKSDESC-DESCRIPTN                                *
*                                  PIC  X(12).                        *
*            05  WS-KIKSDESC-RETURN-CODE                              *
*                                  PIC  9(04)      COMP-5.            *
*        03  WS-KIKSDESC           PIC  X(08)      VALUE 'KIKSDESC'.  *
*                                                                     *
*        MOVE LOW-VALUES               TO WS-KIKSDESC-COMMAREA        *
*        MOVE EIBRESP                  TO WS-KIKSDESC-EIBRESP         *
*        MOVE EIBRESP2                 TO WS-KIKSDESC-EIBRESP2        *
*        MOVE EIBFN                    TO WS-KIKSDESC-EIBFN           *
*                                             (1:LENGTH OF EIBFN)     *
*        MOVE EIBRCODE                 TO WS-KIKSDESC-EIBRCODE        *
*                                             (1:LENGTH OF EIBRCODE)  *
*        MOVE SPACES                   TO WS-KIKSDESC-DESCRIPTN       *
*                                                                     *
*        EXEC CICS LINK                                               *
*                  PROGRAM (WS-KIKSDESC)                              *
*                  COMMAREA(WS-KIKSDESC-COMMAREA)                     *
*        END-EXEC                                                     *
*                                                                     *
*        UPON RETURN, 'WS-KIKSDESC-DESCRIPTN' WILL CONTAIN THE        *
*        DESCRIPTN-TEXT ASSOCIATED WITH THE PASSED 'EIBRESP'. ALSO,   *
*        'WS-KIKSDESC-DESCRIPTN-LGTH' WILL CONTAIN THE ACTUAL LENGTH  *
*        OF THE DESCRIPTN-TEXT. FOR EXAMPLE, THE 'EIBRESP' VALUE THAT *
*        WAS PASSED WAS 19 AND ITS ASSOCIATED DESCRIPTN-TEXT WILL BE  *
*        'NOTOPEN'. THE DESCRIPTN-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. *
*                                                                     *
*        IT IS ALSO RETURNED IN THE COMMAREA AS A BINARY-HALFWORD.    *
*                                                                     *
*---------------------------------------------------------------------*
***********************************************************************
         PRINT GEN                     ACTIVATE MACRO-EXPANSION         
         GBLC  &PGMNAME                                                 
&PGMNAME SETC  'KIKSDESC'                                               
COMDSECT DSECT                         COMMAREA DSECT (R7)             
         USING *,R7                    INFORM ASSEMBLER                 
COMMAREA EQU   *                       BEGIN COMMAREA                   
COMMRSP1 DS    AL4                     PASSED 'EIBRESP' (FWORD)         
COMMRSP2 DS    AL4                     CALLER'S 'EIBRESP2' (SAVED)     
COMMFCTN DS    CL4                     CALLER'S 'EIBFN' (READABLE HEX) 
COMMRCDE DS    CL12                    CALLER'S 'EIBRCODE' (SAME)       
COMMDLEN DS    AL2                     DESCRIPTN-LGTH (HWORD)           
COMMDESC DS    CL12                    DESCRIPTN-TEXT                   
COMMRTNC DS    AL2                     RETURN-CODE (HWORD)             
COMMLGTH EQU   *-COMMAREA              COMMAREA-LGTH                   
TBLDSECT DSECT                         DFHEITAB DSECT (R9)             
         USING *,R9                    INFORM ASSEMBLER                 
TBLENTRY EQU   *                       BEGIN ENTRY                     
TBLDESC  DS    CL(L'COMMDESC)          ASSOCIATED-DESCRIPTN             
TBLEYECT DS    H                       EYECATCHER (X'50C0')             
         DS    XL4                     NOT USED                         
TBLRSPCD DS    H                       RESPONSE-CODE (ALIGNED-HWORD)   
         DS    XL2                     NOT USED                         
TBLLGTH  EQU   *-TBLENTRY              BASE-LGTH OF TBL-DSECT (22)     
DFHEISTG DSECT                         DYNAMIC-STG DSECT (R13)         
DWORD    DS    D                       DBLWORD-WORKAREA                 
DBLWORD  DS    D                       SAME                             
TSLEVEL  DS    F                       CICS/TS LEVEL (FMT=X'00NNNNNN') 
SANITYMX DS    F                       SANITY-MAX TBL-SEARCH           
RESPCODE DS    F                       RESPONSE/RETURN CODE FWORD       
ADJFACTR DS    H                       TBL-ADJUSTMENT FACTOR-HWORD     
WORKDESC DS    CL(L'COMMDESC+1)        DESCRIPTN-WORKAREA               
UNPKAREA DS    CL16                    UNPACK-WORKAREA                 
TRANSTBL DS    XL256                   DYNAMIC TRANSLATE-TBL           
&PGMNAME DFHEIENT                      USE DEFAULTS (R3, R13, R11)     
         LA    R1,22                   PREPARE FOR 'ST' (LENGERR)       
         ST    R1,RESPCODE             STORE IN FWORD                   
         LH    R1,EIBCALEN             LOAD COMMAREA-LGTH               
         CHI   R1,COMMLGTH             MINIMUM-LGTH?                   
         JL    CICSRETN                NO, RETURN TO CALLER             
         L     R7,DFHEICAP             COMMAREA ADDRESSABILITY         
         NILF  R7,X'7FFFFFFF'          CLEAR TOP-BIT                   
         XC    COMMRTNC,COMMRTNC       ENSURE X'00'S                   
         XC    DFHEIUSR(L'TRANSTBL),DFHEIUSR                           
         XC    DFHEIUSR+L'TRANSTBL((DFHEIEND-DFHEIUSR)-L'TRANSTBL),DFHEX
               IUSR+L'TRANSTBL                                         
         OI    DWORD+L'DWORD-1,15      ENSURE 'F' SIGN-NIBBLE           
         LA    R1,L'COMMDESC           PREPARE FOR 'STH'               
         STH   R1,COMMDLEN             MAX DESCRIPTN-LGTH               
         UNPK  UNPKAREA(L'COMMFCTN+1),EIBFN(L'EIBFN+1)                 
         MVC   COMMFCTN,UNPKAREA       PREPARE FOR 'TR'                 
         LA    R1,=CL16'0123456789ABCDEF'-240                           
         TR    COMMFCTN,0(R1)          MAKE IT READABLE-HEX             
         UNPK  UNPKAREA(L'COMMRCDE+1),EIBRCODE(L'EIBRCODE+1)           
         MVC   COMMRCDE,UNPKAREA       PREPARE FOR 'TR'                 
         TR    COMMRCDE,0(R1)          MAKE IT READABLE-HEX             
         UNPK  UNPKAREA,DWORD          ENSURE CHARACTER-ZEROS           
         MVI   WORKDESC,C' '           ENSURE SPACES                   
         MVC   WORKDESC+1(L'WORKDESC-1),WORKDESC                       
         MVC   COMMDESC,WORKDESC       SAME                             
*                                                                       
         EXEC  CICS INQUIRE SYSTEM,    OBTAIN THE CICS/TS LEVEL,       X
               CICSTSLEVEL(UNPKAREA),  SUPPRESSING ALL ERRORS          X
               NOHANDLE,                                               
*                                                                       
         PACK  DWORD,UNPKAREA(L'EIBRCODE)                               
         MVO   DWORD,DWORD             SHIFT-LEFT 4-BITS               
         L     R1,DWORD+L'TSLEVEL      PREPARE FOR 'SRL'               
         SRL   R1,L'DWORD              RIGHT-JUSTIFY AS X'00NNNNNN'     
         ST    R1,TSLEVEL              STORE IN FWORD (SAFEKEEPING)     
         CFI   R1,X'00050100'          TS/5.1 LEVEL OR GREATER?         
         JL    MAXVALUE                NO, CHECK FOR MAX-VALUE         
         LA    R1,2                    LOAD ADJUSTMENT-FACTOR           
         STH   R1,ADJFACTR             STORE IN HWORD                   
MAXVALUE EQU   *                                                       
         L     R1,COMMRSP1             PREPARE FOR 'CFI' AND 'LTR'     
         CFI   R1,32767                EXCEEDS HWORD-MAXIMUM?           
         JH    INVRSPCD                YES, THIS IS INVALID             
         LTR   R1,R1                   EXCEEDS X'00'S?                 
         JP    LOADTBL                 YES, LOAD IN-CORE TBL           
         XC    COMMRSP1,COMMRSP1       ENSURE X'00'S                   
         MVC   COMMDESC(L'EIBRCODE),=C'NORMAL'                         
         MVI   RESPCODE+L'RESPCODE-1,L'RESPCODE                         
         J     CALCLGTH                CALCULATE DESCRIPTN-LGTH         
LOADTBL  EQU   *                                                       
*                                                                       
         EXEC  CICS LOAD NOHANDLE,     ESTABLISH ADDRESSABILITY TO THE X
               PROGRAM('DFHEITAB'),    CICS IN-CORE TABLE 'DFHEITAB',  X
               SET    (R9),            SUPPRESSING ALL ERRORS          X
               FLENGTH(DBLWORD),                                       
*                                                                       
         ICM   R15,B'1111',EIBRESP     TABLE-LOAD OK?                   
         ST    R15,RESPCODE            STORE IN FWORD                   
         JNZ   BADTABLD                NO, THERE WAS A PROBLEM         
         LHI   R6,20672                PREPARE FOR SEARCH (X'50C0')     
         LM    R14,R15,24(R9)          PREPARE FOR 'MHI'               
         MHI   R15,24                  CALCULATE 'SANITY-MAX'           
         LA    R1,0(R14,R15)           LOAD 'SANITY-MAX'               
         ST    R1,SANITYMX             STORE IN FWORD                   
         L     R9,24(,R9)              RECALCULATE STARTING-ADDRESS     
         LAY   R9,5676(,R9)            INITIAL STARTING-ADDRESS BUMP   
         L     R1,TSLEVEL              RELOAD FOR 'CFI'                 
         CFI   R1,X'00050100'          TS/5.1 LEVEL OR GREATER?         
         JL    FFRSTEYE                NO, FIND FIRST 'EYECATCHER'     
         LA    R9,732(,R9)             BUMP STARTING-ADDRESS AGAIN     
         J     FFRSTEYE                FIND FIRST 'EYECATCHER'         
BADTABLD EQU   *                                                       
         MVC   COMMDESC,=C'@TBLDERR000@'                               
         CVD   R15,DWORD               MAKE IT DECIMAL                 
         OI    DWORD+L'DWORD-1,15      ENSURE 'F' SIGN-NIBBLE           
         UNPK  COMMDESC+8(3),DWORD     UNPACK 'EIBRESP' FROM LOAD       
         J     SETRETCD                SET COMMAREA RETURN-CODE         
FFRSTEYE EQU   *                                                       
         CH    R6,0(,R9)               1ST-EYECATCHER FOUND?           
         JNE   BUMP4EYE                NO, BUMP TO 'NEXT' BYTE         
         AHI   R9,-L'TBLDESC           REPOSITION AT ENTRY-START       
         LH    R1,ADJFACTR             LOAD 'ADJUSTMENT' FACTOR         
         LA    R1,TBLLGTH(,R1)         COMPLETE 'ADJUSTMENT' FACTOR     
         STH   R1,ADJFACTR             STORE BACK IN HWORD             
         L     R1,COMMRSP1             LOAD AS FWORD                   
         J     SRCHDESC                BEGIN DESCRIPTN-SEARCH           
BUMP4EYE EQU   *                                                       
         LA    R9,1(,R9)               BUMP TO 'NEXT' BYTE             
         C     R9,SANITYMX             EXCEEDS 'SANITY-MAX'?           
         JNH   FFRSTEYE                NO, KEEP SEARCHING               
         LA    R1,241                  LOAD WITH X'F1'                 
         J     NORESPCD                RESPONSE-CODE NOT FOUND         
SRCHDESC EQU   *                                                       
         CH    R1,TBLRSPCD             RESPONSE-CODES MATCH?           
         JNE   BUMPDESC                NO, CHECK 'NEXT' ENTRY           
         MVC   COMMDESC,TBLDESC        POPULATE DESCRIPTN               
         J     CALCLGTH                CALCULATE DESCRIPTN-LGTH         
BUMPDESC EQU   *                                                       
         AH    R9,ADJFACTR             BUMP TO 'NEXT' TBL-ENTRY         
         CH    R6,TBLEYECT             ANY MORE ENTRIES?               
         JE    SRCHDESC                YES, KEEP SEARCHING             
         LA    R1,242                  LOAD WITH X'F2'                 
         J     NORESPCD                RESPONSE-CODE NOT FOUND         
CALCLGTH EQU   *                                                       
         MVC   WORKDESC(L'COMMDESC),COMMDESC                           
         MVI   TRANSTBL+64,X'FF'       SET SPACE-SLOT TO X'FF'         
         TRT   WORKDESC,TRANSTBL       FIND 1ST-SPACE                   
         LA    R2,WORKDESC             POINT TO STARTING-ADDRESS       
         SR    R1,R2                   IS THERE A DESCRIPTN?           
         JNP   NODSCRPT                NO, USE OUR DEFAULT             
         STH   R1,COMMDLEN             POPULATE DESCRIPTN-LGTH         
         J     SETRETCD                SET COMMAREA RETURN-CODE         
INVRSPCD EQU   *                                                       
         MVI   RESPCODE+L'RESPCODE-1,L'DWORD                           
         MVC   COMMDESC,=C'@@INVRSPCD@@'                               
         J     SETRETCD                SET COMMAREA RETURN-CODE         
NORESPCD EQU   *                                                       
         MVI   RESPCODE+L'RESPCODE-1,L'DWORD                           
         MVC   COMMDESC,=C'@NORESPCD-0@'                               
         STC   R1,COMMDESC+10          STORE R1 LOW-ORDER               
         J     SETRETCD                SET COMMAREA RETURN-CODE         
NODSCRPT EQU   *                                                       
         MVI   RESPCODE+L'RESPCODE-1,L'DWORD                           
         MVC   COMMDESC,=C'@NODESCRPTN@'                               
SETRETCD EQU   *                                                       
         L     R1,RESPCODE             PREPARE FOR 'STH'               
         STH   R1,COMMRTNC             STORE IN COMMAREA               
CICSRETN EQU   *                                                       
         L     R15,RESPCODE            LOAD FOR CALLER                 
*                                                                       
         DFHEIRET RCREG=R15            RETURN TO CALLER                 
*                                                                       
         DFHREGS ,                     CICS REGISTER-MACRO             
*                                                                       
&PGMNAME AMODE 31 ,                                                     
&PGMNAME RMODE ANY ,                                                   
*                                                                       
         END   ,                       END 'KIKSDESC'                   
Back to top
View user's profile Send private message

Robert.Barnes

New User


Joined: 20 Oct 2014
Posts: 8
Location: Auckland, New Zealand

PostPosted: Sun Oct 26, 2014 4:51 am    Post subject: Reply to: CICS Program "KIKSDESC"
Reply with quote

Thank you Bill, I'll brush off my ancient Assembler knowledge and figure out what I need to write.

It's a shame that IBM don't seem to provide something that works like this: -
DECLARE DFHEITAB ENTRY(BIN FIXED(31)) RETURNS (CHAR(20) VARYING);
Result = DFHEITAB(Code);

or the COBOL equivalent which is messier, but still brief.
Back to top
View user's profile Send private message
Robert.Barnes

New User


Joined: 20 Oct 2014
Posts: 8
Location: Auckland, New Zealand

PostPosted: Thu Nov 20, 2014 10:00 am    Post subject: Reply to: CICS Program "KIKSDESC"
Reply with quote

Thank you for this Bill, I'm sorry for my rudeness in not getting back to you sooner- I got diverted off on to other problems. I'll assemble it and see if I can get it to work from my COBOL programs.

Regards, Robert.
Back to top
View user's profile Send private message
View previous topic :: :: View next topic  
Post new topic   Reply to topic    IBMMAINFRAMES.com Support Forums -> CICS All times are GMT + 6 Hours
Page 1 of 1

 

Search our Forum:

Similar Topics
Topic Author Forum Replies Posted
No new posts IMS T-Pipe queue counts in a COBOL Pr... Siva NKK Kothamasu IMS DB/DC 0 Tue May 09, 2017 6:31 pm
No new posts READ A PACKED "NEGATIVE" FI... jdesouza CA Products 3 Tue May 02, 2017 11:43 pm
No new posts Need help in REXX CALL program Raje1002 CLIST & REXX 5 Wed Apr 19, 2017 11:18 pm
No new posts RC 20 for Address ISPEXEC "ISRED... pkmurali CLIST & REXX 3 Sun Apr 16, 2017 11:30 pm
No new posts CICS Transaction Timeout Hooman24 CICS 2 Sun Apr 16, 2017 2:16 pm


Facebook
Back to Top
 
Mainframe Wiki | Forum Rules | Bookmarks | Subscriptions | FAQ | Tutorials | Contact Us