iSeries & System i

#2 API - Table of Contents #4

API Name # Description
QUSRJOBI 1 Retrieve Job Information
QtqIConvOpen   Code Conversion Allocation
QsnQryModSup   Query Mode Support
QMHCTLJL   Control Job Log Output
QMHQRDQD   Retrieve Data Queue Description
QDMRTVFO   Retrieve File Override Information
QDCRCFGS   Retrieve Configuration Status
QLGRTVLI   Retrieve Language IDs
Qsn...... 1 Dynamic Screen Manager (prototypes)
QWCCVTDT 2 Convert Date and Time Format
QCMDCHK   Check Command Syntax
QMHRTVRQ   Retrieve info on last request message
QWDRJOBD   Retrieve job description information
QSPROUTQ   Retrieve output queue information
QCMDEXC 1 Execute Command (System program)
QCAPCMD 1 Execute Command
QjoRetrieveJournalInformation   Retrieve Journal Information
QjoRtvJrnReceiverInformation   Retrieve Journal Receiver Information
QjoRetrieveJournalEntries   Retrieve Journal Entries
QjoDeletePointerHandle   Delete Pointer Handle



QUSRJOBI

You can determine what subsystem a job is running in with the Retrieve
Job Information API.  The following sample CL determines, for the
active job, what subsystem it is active in and sends 'OK' if QCTL and
'NOT OK' if not QCTL.

The API documentation can be found in the Work Management APIs chapter
of the System API Reference.


             PGM
             DCL        VAR(&SBS) TYPE(*CHAR) LEN(10)
             DCL        VAR(&RCVVAR) TYPE(*CHAR) LEN(256)
             CALL       PGM(QUSRJOBI) PARM(&RCVVAR X'00000100' +
                          'JOBI0200' '*' ' ')
             CHGVAR     VAR(&SBS) VALUE(%SST(&RCVVAR 63 10))
             IF         COND(&SBS = 'QCTL') THEN(DO)
                SNDPGMMSG  MSG(OK) TOPGMQ(*EXT)
                ENDDO
             ELSE       CMD(DO)
                SNDPGMMSG  MSG('NOT OK') TOPGMQ(*EXT)
                ENDDO
             ENDPGM

Thanks to Bruce Vining
Back

QtqIConvOpen

Q:	We have a situation where some folks out of the country send data in thru a web
application. When the data arrives here it has upper ascii characters "mit der umlaut"
etc... I believe that the code page would help here, but do not know if the sender is
responsible or not. Actually it does not matter if the sender is or is not, we need to
convert this stuff to our code set. Anyone have any ideas on how to do this?

A:	There is a code page API which I posted below.  The hardest part is getting the right
to/from code pages.


      *------------------------------------------------------------------
      * Prototype for Code Conversion - Open
      *------------------------------------------------------------------
     d IConvOpen       PR            52A   ExtProc('QtqIconvOpen')
     d                                 *   Value options(*string) To Code
     d                                 *   Value options(*string) Fr Code
      *------------------------------------------------------------------
      * Prototype for Code Conversion
      *------------------------------------------------------------------
     d IConv           PR            10i 0 ExtProc('iconv')
     d                               52a   Value          Code Discripter
     d                                 *   Value          ptr to InBuffer Ptr
     d                                 *   Value          ptr to InSize ptr
     d                                 *   Value          ptr to OutBuffer Ptr
     d                                 *   Value          ptr to OutSize ptr
      ****************************************************************
      *  Code Page Conversions  (iconv_t)
      *****************************************************************
     d ToAscii         DS
     d  ICORV_A                1      4b 0
      *                  return value to indicate if error occurred
     d  ICOC_A                 5     52b 0 DIM(00012)
      *                                        cd
      *
     d ToEbcdic        DS
     d  ICORV_E                1      4b 0
      *                  return value to indicate if error occurred
     d  ICOC_E                 5     52b 0 DIM(00012)
      *                                        cd
      *
     d p_Qascii        S               *   inz(%addr(Qascii))
     d Qascii          DS            32
     d  asciiCP                1      4b 0 inz(00813)              Code page ID
     d  asciiCA                5      8b 0 inz(0)
     d  asciiSA                9     12b 0 inz(0)
     d  asciiSS               13     16b 0 inz(1)
     d  asciiIL               17     20b 0 inz(0)
     d  asciiEO               21     24b 0 inz(1)
     d  asciiR                25     32a   inz(*allx'00')
      *
     d p_Qebcdic       S               *   inz(%addr(Qebcdic))
     d Qebcdic         DS            32
     d  ebcdicCP               1      4b 0 inz(00037)              Code page ID
     d  ebcdicCA               5      8b 0 inz(0)
     d  ebcdicSA               9     12b 0 inz(0)
     d  ebcdicSS              13     16b 0 inz(1)
     d  ebcdicIL              17     20b 0 inz(0)
     d  ebcdicEO              21     24b 0 inz(1)
     d  ebcdicR               25     32a   inz(*allx'00')
      *
      * translate response to ASCII
     c                   eval      p_InBuff  = %addr(TXTIN)
     c                   eval      p_OutBuff = %addr(TXTOUT)
     c                   eval      InBytesLeft = %len(%trim(TXTIN))
     c                   eval      OutBytesLeft = %len(TXTOUT)
     c                   eval      rc = IConv(ToAscii:
     c                                        %addr(p_InBuff):
     c                                        p_InBytes:
     c                                        %addr(p_OutBuff):
     c                                        p_OutBytes)
     c                   if        ICORV_A > 0
     c                   eval      MsgToDsply = 'Error in Translate'
     c     MsgToDsply    dsply
     c                   endif
      * translate to ebcdic
     c                   eval      p_InBuff  = %addr(TXTIN)
     c                   eval      p_OutBuff = %addr(TXTOUT)
     c                   eval      InBytesLeft = %len(%trim(TXTIN))
     c                   eval      OutBytesLeft = %len(TXTOUT)
     c                   eval      rc = IConv(ToEbcdic:
     c                                        %addr(p_InBuff):
     c                                        p_InBytes:
     c                                        %addr(p_OutBuff):
     c                                        p_OutBytes)
     c                   if        ICORV_E > 0
     c                   eval      MsgToDsply = 'Error in Translate'
     c     MsgToDsply    dsply
     c                   endif
      *

      * FIRST PASS
     csr   *INZSR        begsr
      * setup code page conversion ebcdic - ascii
     c                   eval      ToAscii  = IConvOpen(p_Qascii:
     c                                        p_Qebcdic)
     c                   if        ICORV_A = -1
      * error processing here
     c                   endif

      * setup code page conversion ascii - ebcdic
     c                   eval      ToEbcdic = IConvOpen(p_Qebcdic:
     c                                        p_Qascii)
     c                   if        ICORV_E = -1
      * error processing here
     c                   endif
      *
     csr   #INZSR        endsr

Thanks to Chris Bipes
Back

QsnQryModSup

Q:	I'm working on a program that switches the display from 24x80 to
27x132 depending on the view option that the user selects.
...
Other than retrieving the device characteristics of the user's terminal
device, is there an easy way of determining if the user's terminal is a
27x132 device?

A:	I think the question is whether or not the device is capable of
27x132, not what is the current screen mode.  What I do is use the
Dynamic Screen Manager API's, but these can only be used from an ILE
language like RPG IV.

There is one API which will return all sorts of information about the
device capabilities.  The QsnQry5250 returns (among other things) a
12-byte value with bits used for denoting all sorts of thing from size
to color to GUI characteristics, etc.  But to just test if DS4 mode is
supported there is an even easier way.

The DSM API to query mode support (QsnQryModSup) can be passed a mode
and it will return a flag indicating if that mode is valid on the
device.  You pass a '3' to check if DS3 (24x80) is valid, and a '4' to
check if DS4 (27x132) is valid.

I use a prototype like this, where ApiErrorDS is my standard error DS:

     D QryModSup       PR             1    ExtProc( 'QsnQryModSup' )
     D  DspMode                       1    Const
     D  Handle                       10I 0 Options( *NoPass )
     D  ErrorDS                            Options( *NoPass )
     D                                     Like( ApiErrorDS )
Note that the last two parameters are optional, and you can just
     C                   Eval      Is27x132OK = QryModSup( '4' )

which will then have a true/false (1/0) status.  I rename it to less
than 12 characters so I can use it on V3R2 systems.  You do not need
to name a binding directory to use the DSM API's.

Similarly, another API will tell you if the device supports color
(QsnQryColorSup), or you can check a bit returned by QsnQry5250.
Other bits tell you if you can use the Write Extended Attributes to
get up to 14 colors instead of just those available in DDS.

Another useful API is QsnRtvMod which returns the current screen mode.
This is good in called programs which put up a window, and you want to
know if the underlying program is using 24x80 or 27x132 (regardless of
what the device is capable of).

The DSM API's are way too underutilized.  Many of them can be very
useful even if you only use DDS for all the screen formats.

Thanks to Douglas Handy
Back

QMHCTLJL

Q:	How can I prevent people from deleting their joblogs?

A:	There has been a lot of good discussion on this topic, but there is one
solution that has not been mentioned yet. You can use the Control Job Log
Output (QMHCTLJL) API to cause the job log to be placed into physical files
instead of being placed into a spooled file. Then by using object authority
you can prevent users from even reading those physical files. Here is a
sample CL program that uses this API to do just that.

	PGM
	DCL       VAR(&FILENAME) TYPE(*CHAR) LEN(65)
	DCL       VAR(&FORMAT) TYPE(*CHAR) LEN(8) VALUE('CTLJ0100')
	DCL       VAR(&MSG) TYPE(*CHAR) LEN(30)
	DCL       VAR(&FILTER) TYPE(*CHAR) LEN(4) VALUE(X'00000000')
	DCL       VAR(&MSGQ) TYPE(*CHAR) LEN(20) VALUE('*SYSOPR             ')
	DCL       VAR(&ERROR) TYPE(*CHAR) LEN(256) VALUE(X'00000000')
	DCL       VAR(&USR) TYPE(*CHAR) LEN(10)
	DCL       VAR(&NBR) TYPE(*CHAR) LEN(6)
	RTVJOBA   USER(&USR) NBR(&NBR)
	CHGVAR    VAR(%BIN(&FILENAME 1 4)) VALUE(65)
	CHGVAR    VAR(%SST(&FILENAME 5 10))  VALUE('P         ')
	CHGVAR    VAR(%SST(&FILENAME 6 9)) VALUE(&USR)
	CHGVAR    VAR(%SST(&FILENAME 15 10)) VALUE('JOBLOG    ')
	CHGVAR    VAR(%SST(&FILENAME 25 10)) VALUE('JOB       ')
	CHGVAR    VAR(%SST(&FILENAME 28 6)) VALUE(&NBR)
	CHGVAR    VAR(%SST(&FILENAME 35 10)) VALUE('S         ')
	CHGVAR    VAR(%SST(&FILENAME 36 9)) VALUE(&USR)
	CHGVAR    VAR(%SST(&FILENAME 45 10)) VALUE('JOBLOG    ')
	CHGVAR    VAR(%SST(&FILENAME 55 10)) VALUE(%SST(&FILENAME 25 10))
	CHGVAR    VAR(%SST(&FILENAME 65 1)) VALUE('0')
	CALL      PGM(QSYS/QMHCTLJL) PARM(&FILENAME &FORMAT &MSG &FILTER +
	            &MSGQ &ERROR)
	CHGOBJOWN OBJ(JOBLOG/%SST(&FILENAME 5 10)) OBJTYPE(*FILE) +
	            NEWOWN(______) CUROWNAUT(*REVOKE)
	RVKOBJAUT OBJ(JOBLOG/%SST(&FILENAME 5 10)) OBJTYPE(*FILE) +
	            USER(*PUBLIC) AUT(*ALL)
	CHGOBJOWN OBJ(JOBLOG/%SST(&FILENAME 35 10)) OBJTYPE(*FILE) +
	            NEWOWN(______) CUROWNAUT(*REVOKE)
	RVKOBJAUT OBJ(JOBLOG/%SST(&FILENAME 35 10)) OBJTYPE(*FILE) +
	            USER(*PUBLIC) AUT(*ALL)
	ENDPGM

Before using the program create library JOBLOG. Also change 'NEWOWN
(______)' in the above source to change the physical files created into
that library to be owned by the same user profile that will own the CL
program. Then create the program while specifying USRPRF(*OWNER). Now,
after the program is called in a job, if that job produces a job log that
job log will be placed into two member of two physical files in the JOBLOG
library. The names of the two physical files will be P and S followed by
the first 9 characters of the user profile name.

One enhancement that is needed is to have the program send a message
somewhere that includes the full job name and the names of the physical
files and the member that will be used for the job log. This should help
you determine which member to look at.

Thanks to Ed Fishel
Back

QMHQRDQD

Q:	Is there a formula for calculating max entries on a dataqueue ?

A:	You can just use the API to ask the system.  Here's a cmd, cl & dds that does it:

****************************************************************************
             CMD        PROMPT('Display Data Queue Information')
             PARM       KWD(DATAQ) TYPE(QUAL1) MIN(1) +
                          PROMPT('Data Queue' 1)
 QUAL1:      QUAL       TYPE(*NAME) LEN(10) MIN(1)
             QUAL       TYPE(*NAME) LEN(10) MIN(1) PROMPT('Library')
****************************************************************************
             PGM        PARM(&DATAQUEUE)
             DCL        VAR(&DATAQUEUE ) TYPE(*CHAR) LEN(  20)
             DCL        VAR(&QNAME     ) TYPE(*CHAR) LEN(  10)
             DCL        VAR(&QLIBRARY  ) TYPE(*CHAR) LEN(  10)
             DCL        VAR(&RCVR      ) TYPE(*CHAR) LEN( 108)
             DCL        VAR(&RCVRLEN   ) TYPE(*CHAR) LEN(   4)
             DCL        VAR(&COUNT     ) TYPE(*DEC ) LEN( 9 0)
             DCL        VAR(&CURRENT   ) TYPE(*DEC ) LEN( 9 0)
             DCL        VAR(&MAXIMUM   ) TYPE(*DEC ) LEN( 9 0)
             DCL        VAR(&MINIMUM   ) TYPE(*DEC ) LEN( 9 0)
             DCL        VAR(&QLENGTH   ) TYPE(*DEC ) LEN( 9 0)
             DCL        VAR(&KLENGTH   ) TYPE(*DEC ) LEN( 9 0)
             DCL        VAR(&TYPE      ) TYPE(*CHAR) LEN(   1)
             DCL        VAR(&QTYPE     ) TYPE(*CHAR) LEN(   4)
             DCL        VAR(&RCL       ) TYPE(*CHAR) LEN(   1)
             DCL        VAR(&SEQ       ) TYPE(*CHAR) LEN(   1)
             DCL        VAR(&SEQUENCE  ) TYPE(*CHAR) LEN(   6)
             DCL        VAR(&SND       ) TYPE(*CHAR) LEN(   1)
             DCL        VAR(&MAXENTRIES) TYPE(*CHAR) LEN(   8)
             DCL        VAR(&MSGTXT    ) TYPE(*CHAR) LEN( 512)

             DCLF       FILE(DSPDTAQINF)
             CHGVAR     VAR(%BIN(&RCVRLEN 1 4)) VALUE(108)
             SNDF       RCDFMT(FOOT)
             CHGVAR     VAR(&QNAME     ) VALUE(%SST(&DATAQUEUE  1 10))
             CHGVAR     VAR(&QLIBRARY  ) VALUE(%SST(&DATAQUEUE 11 10))
 TOP:        CHGVAR     VAR(&MSGTXT) VALUE('Retrieving data queue +
                          information... Please be patient')
             SNDPGMMSG  MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA(&MSGTXT) +
                          TOPGMQ(*EXT) MSGTYPE(*STATUS)
                        MONMSG     MSGID(CPF0000)
             CALL       PGM(QMHQRDQD) PARM(&RCVR &RCVRLEN RDQD0100 +
                          &DATAQUEUE)
                        MONMSG     MSGID(CPF0000) EXEC(CALL PGM(QMHRSNEM) +
                                     PARM('    ' X'00000000'))
             CHGVAR     VAR(&QLENGTH) VALUE(%BIN(&RCVR 9 4))
             CHGVAR     VAR(&IN50) VALUE('1')
             IF         COND(%SST(&RCVR 17 1) *EQ 'K') THEN(DO)
                        CHGVAR     VAR(&KLENGTH) VALUE(%BIN(&RCVR 13 4))
                        CHGVAR     VAR(&SEQ) VALUE(*KEYED)
                        CHGVAR     VAR(&IN50) VALUE('0')
             ENDDO

             ELSE       CMD(IF COND(%SST(&RCVR 17 1) *EQ 'L') +
                          THEN(CHGVAR VAR(&SEQUENCE) VALUE(*LIFO)))
             ELSE       CMD(CHGVAR VAR(&SEQUENCE) VALUE(*FIFO))
             IF         COND(%SST(&RCVR 18 1) *EQ 'N') THEN(CHGVAR +
                          VAR(&SENDER) VALUE(*NO))
             ELSE       CMD(CHGVAR VAR(&SENDER) VALUE(*YES))
             IF         COND(%SST(&RCVR 19 1) *EQ 'N') THEN(CHGVAR +
                          VAR(&FORCE) VALUE(*NO))
             ELSE       CMD(CHGVAR VAR(&FORCE) VALUE(*YES))
             IF         COND(%SST(&RCVR 70 1) *EQ '0') +
                          THEN(CHGVAR VAR(&QTYPE) VALUE(*STD))
             ELSE       CMD(CHGVAR VAR(&QTYPE) VALUE(*DDM))
             IF         COND(%SST(&RCVR 71 1) *EQ '0') +
                          THEN(CHGVAR VAR(&RECLAIM) VALUE(*NO ))
             ELSE       CMD(CHGVAR VAR(&RECLAIM) VALUE(*YES))
             CHGVAR     VAR(&COUNT  ) VALUE(%BIN(&RCVR  73 4))
             CHGVAR     VAR(&COUNT  ) VALUE(%BIN(&RCVR  73 4))
             CHGVAR     VAR(&CURRENT) VALUE(%BIN(&RCVR  77 4))
             CHGVAR     VAR(&MAXIMUM) VALUE(%BIN(&RCVR 101 4))
             CHGVAR     VAR(&MINIMUM) VALUE(%BIN(&RCVR 105 4))
             IF         COND(&RECLAIM *EQ '*YES') THEN(CHGVAR +
                          VAR(&MAXENTRIES) VALUE('*MAX2GB'))
             ELSE       CMD(CHGVAR VAR(&MAXENTRIES) VALUE('*MAX16MB'))
             CHGVAR     VAR(&TEXT) VALUE(%SST(&RCVR 20 50))
             SNDRCVF    RCDFMT(INFO)
             IF         COND(&IN03 = '1') THEN(RETURN)
             IF         COND(&IN05 = '1') THEN(GOTO CMDLBL(TOP))
             IF         COND(&IN12 = '1') THEN(RETURN)
             ENDPGM
****************************************************************************
     A                                      DSPSIZ(24 80 *DS3)
     A                                      CHGINPDFT
     A                                      MSGLOC(24)
     A                                      PRINT
     A                                      ERRSFL
*-------------------------------------------------------------------------
     A          R INFO
     A                                      CLRL(*NO)
     A                                      OVERLAY
     A                                      CA03(03)
     A                                      CA05(05)
     A                                      CA12(12)
     A                                  1  2DATE
     A                                      EDTCDE(Y)
     A                                  1 13TIME
     A                                  1 29' Data Queue Information '
     A                                      DSPATR(HI)
     A                                  1 59SYSNAME
     A                                  1 70USER
     A                                  4  2'Data Queue . . . . . . . . . .'
     A            QNAME         10A  O  4 37
     A                                  5  4'Library  . . . . . . . . . . .'
     A            QLIBRARY      10A  O  5 39
     A                                  6  2'Type . . . . . . . . . . . . .'
     A            QTYPE          4A  O  6 37
     A                                  7  2'Maximum entry length . . . . .'
     A            QLENGTH        9Y 0O  7 37EDTCDE(1)
     A                                  8  2'Force to auxiliary storage . .'
     A            FORCE          4A  O  8 37
     A                                  9  2'Sequence . . . . . . . . . . .'
     A            SEQUENCE       6A  O  9 37
     A                                 10  2'Key length . . . . . . . . . .'
     A  50                                  DSPATR(ND)
     A            KLENGTH        9Y 0O 10 37EDTCDE(3)
     A  50                                  DSPATR(ND)
     A                                 11  2'Include Sender ID  . . . . . .'
     A            SENDER         4A  O 11 37
     A                                 12  2'Queue size:'
     A                                 13  4'Maximum number of entries  . .'
     A            MAXENTRIES     8A  O 13 37
     A                                 13 46'or'
     A            MAXIMUM        9Y 0O 13 49EDTCDE(1)
     A                                 13 61'entries'
     A                                 14  4'Initial number of entries  . .'
     A            MINIMUM        9Y 0O 14 37EDTCDE(1)
     A                                 15  2'Automatic reclaim  . . . . . .'
     A            RECLAIM        4A  O 15 37
     A                                 16  2'Text ''description'' . . . . .'
     A            TEXT          50A  O 16 37
     A                                 18  2'Current allocation . . . . . .'
     A            CURRENT        9Y 0O 18 37EDTCDE(1)
     A                                 18 49'entries'
     A                                 20  2'Current entry count  . . . . .'
     A            COUNT          9Y 0O 20 37EDTCDE(1)
     A                                 20 49'entries'
*-------------------------------------------------------------------------
     A          R FOOT
     A                                 22  3'F3=Exit  F5=Refresh  F12=Cancel'
     A                                      COLOR(BLU)
****************************************************************************

Thanks to Tom Westdorp
Back

QDMRTVFO

Retrieve File Override Information

     D RtvFileOvr      PR                  ExtPgm('QDMRTVFO')
     D   RcvVar                   32766A   options(*varsize)
     d   RcvVarLen                   10I 0 const
     D   Format                       8A   const
     D   FileName                    10A   const
     D   ErrorCode                32766A   options(*varsize)

     D dsEC            DS
     D  dsECBytesP             1      4B 0 INZ(256)
     D  dsECBytesA             5      8B 0 INZ(0)
     D  dsECMsgID              9     15
     D  dsECReserv            16     16
     D  dsECMsgDta            17    256

     d dsOVRL0100      DS
     D   dsOvrBytRt                  10I 0
     D   dsOvrBytAv                  10I 0
     D   dsOvrFile                   10A
     D   dsOvrLib                    10A
     d   dsOvrMbr                    10A
     d   dsOvrFTyp                   10A

     D Msg             S             50A
     D peFileName      S             10A

     C     *entry        plist
     c                   parm                    peFileName

     c                   callp     RtvFileOvr(dsOVRL0100: %size(dsOVRL0100):
     c                               'OVRL0100': peFileName: dsEC)

     c                   if        dsECBytesA > 0
     c                   eval      Msg = 'Error ' + dsECMsgID + ' occurred'
     c                   dsply                   Msg
     c                   eval      *inlr = *on
     c                   return
     c                   endif

     c                   eval      Msg = 'Overridden to: ' +
     c                                 %trim(dsOvrLib) + '/' +
     c                                 %trim(dsOvrFile) + '(' +
     c                                 %trim(dsOvrMbr) + ')'

     c                   dsply                   Msg

     c                   eval      *inlr = *on

Thanks to Scott Klement
Back

QDCRCFGS

Retrieve Configuration Status

Compile with:  CRTBNDRPG PGM(xxx) SRCFILE(XXX/xxx) DBGVIEW(*LIST)
      run with:  CALL XXX PARM('*DEVD' 'DSP01')  (or whatever you like)

     H DFTACTGRP(*NO) ACTGRP(*NEW) OPTION(*SRCSTMT)
     D RtvCfgSts       PR                  ExtPgm('QDCRCFGS')
     D  RcvVar                    32766A   options(*varsize)
     D  RcvVarLen                    10I 0 const
     D  Format                        8A   const
     D  CfgDType                     10A   const
     d  CfgDName                     10A   const
     D  ErrorCode                 32766A   options(*varsize)

     D p_ds1           S               *
     D ds1             DS                  based(p_ds1)
     D  ds1BytesRtn                  10I 0
     D  ds1BytesAvl                  10I 0
     D  ds1Status                    10I 0
     D  ds1DateRtv                    7A
     D  ds1TimeRtv                    6A
     D  ds1StatusTxt                 20A
     D  ds1JobName                   10A
     D  ds1JobUser                   10A
     D  ds1JobNbr                     6A
     D  ds1PassThr                   10A
     D  ds1Reserv1                    3A
     D  ds1OffActCnv                 10I 0
     D  ds1NbrActCnv                 10I 0
     D  ds1LenActCnv                 10I 0
     D  ds1OffMulJob                 10I 0
     D  ds1NbrMulJob                 10I 0
     D  ds1LenMulJob                 10I 0

     D p_ds2           S               *
     D ds2             DS                  based(p_ds2)
     D  ds2CnvSts                    10I 0
     D  ds2CnvStsTxt                 20A
     D  ds2CnvStsMod                 10A
     D  ds2CnvStsJob                 10A
     D  ds2CnvStsUsr                 10A
     D  ds2CnvStsNbr                  6A

     D p_ds3           S               *
     D ds3             DS                  based(p_ds3)
     D  ds3MultJob                   10A
     D  ds3MultUser                  10A
     D  ds3MultNbr                    6A

     D dsEC            DS
     D  dsECBytesP             1      4I 0 inz(256)
     D  dsECBytesA             5      8I 0 inz(0)
     D  dsECMsgID              9     15
     D  dsECReserv            16     16
     D  dsECMsgDta            17    256

     D p_workspace     S               *
     D workspace       S              1A   based(p_workspace)
     D size            S             10I 0
     D Msg             S             52A
     D X               S             10I 0
     D pause           S              1A

     c     *entry        plist
     c                   parm                    CfgType          10
     c                   parm                    CfgName          10
     c                   eval      *inlr = *on

     C* Reserve space for up to 200 active convs & 200 multjobs...
     c                   eval      size = %size(ds1) + (%size(ds2)*200) +
     c                                 (%size(ds3)*200)
     c                   alloc     size          p_workspace

     C* Call Retrieve Cfg Status API:
     c                   callp     RtvCfgSts(workspace: size: 'CFGS0100':
     c                                CfgType: CfgName: dsEC)
     c                   if        dsECBytesA > 0
     c                   eval      Msg = 'QDCRCFGS failed with ' +
     c                                 dsECMsgID
     c                   dsply                   Msg
     c                   return
     c                   endif
     c                   eval      p_ds1 = p_workspace

     C** Show status of cfg descr:
     c                   eval      Msg = 'Status = ' + ds1StatusTxt
     c     Msg           dsply

     C** Show job using cfg descr:
     c                   if        ds1JobName <> *blanks
     c                   eval      Msg = 'Job = ' + %trimr(ds1JobName) +
     c                                  '/' + %trimr(ds1JobUser) + '/' +
     c                                  ds1JobNbr
     c     Msg           dsply
     c                   endif

     C** Show any active conversations:
     c                   do        ds1NbrActCnv  X
     c                   eval      p_ds2 = p_workspace + ds1OffActCnv +
     c                               ((X-1) * ds1LenActCnv)
     c                   eval      Msg = 'ActCnv ' + %trim(%editc(X:'Z'))
     c                              + ' status = ' + ds2CnvStsTxt
     c     Msg           dsply
     c                   eval      Msg = 'ActCnv ' + %trim(%editc(X:'Z')) +
     c                              ' job = ' + %trimr(ds2CnvStsJob) +
     c                              '/' + %trimr(ds2CnvStsUsr) + '/' +
     c                              ds2CnvStsNbr
     c     Msg           dsply
     c                   enddo

     C** If this device can be used by multiple jobs, show them all now:
     c                   do        ds1NbrMulJob  X
     c                   eval      p_ds2 = p_workspace + ds1OffMulJob +
     c                               ((X-1) * ds1LenMulJob)
     c                   eval      Msg = 'MultJob ' + %trim(%editc(X:'Z')) +
     c                              ' = ' + %trimr(ds3MultJob) +
     c                              '/' + %trimr(ds3MultUser) + '/' +
     c                              ds3MultNbr
     c     Msg           dsply
     c                   enddo
     c                   dsply                   pause
     c                   return

Thanks to Scott Klement
Back

QLGRTVLI

This API retrieves a list of language identifiers and you really
don't know for sure how many language identifiers there may be for any
given release.  So we call the API once to determine how many bytes of
data are available, allocate that size of storage, call the API again,
and then display each of the languages just to show we got there OK.
Note that the real processing is done with Based data structures.

     DQLGRTVLI         pr                  EXTPGM('QLGRTVLI')
     D                                1    OPTIONS(*VARSIZE)
     D                               10i 0 CONST
     D                                8    CONST
     D                               10i 0 CONST
     DBaseRcv          ds
     D BytAvl                        10i 0
     D BytRtn                        10i 0
     DRealRcv          ds                  based(RealRcvPtr)
     D RBytAvl                       10i 0
     D RBytRtn                       10i 0
     D NbrLng                        10i 0
     D TextCCSID                     10i 0
     D OffLngIDs                     10i 0
     DLngInfo          ds                  based(OffPtr)
     D LngID                          3
     D LngText                       40
     DErrCod           ds
     D BytPrv                        10i 0 inz(0)
     DRealRcvPtr       s               *
     DOffPtr           s               *
     DLenRcv           s             10i 0
     DFormat           s              8    inz('RTVL0100')
     C                   call      'QLGRTVLI'
     C                   parm                    BaseRcv
     C                   parm      8             LenRcv
     C                   parm                    Format
     C                   parm                    ErrCod
     C                   alloc     BytAvl        RealRcvPtr
     C                   call      'QLGRTVLI'
     C                   parm                    RealRcv
     C                   parm      BytAvl        LenRcv
     C                   parm                    Format
     C                   parm                    ErrCod
     C                   eval      OffPtr = RealRcvPtr + OffLngIDs
     C                   do        NbrLng
     C     LngInfo       dsply
     C                   eval      OffPtr = OffPtr + 43
     C                   enddo
     C                   eval      *inlr = '1'
     C                   return

Thanks to Bruce Vining
Back

Qsn......

Dynamic Screen Manager (prototypes)

      ******************************************************************************
      * DsmGetAID      Get AID code.                                               *
      *  Input:                                                                    *
      *   EnvHnd       Environment handle.                                         *
      *  Output:                                                                   *
      *   AIDCod       AID code.                                                   *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   AIDCod       AID code.                                                   *
      ******************************************************************************
     D DsmGetAID       PR             1A   EXTPROC('QsnGetAID')
     D  PR_AIDCod                     1A   OPTIONS(*OMIT)
     D  PR_EnvHnd                    10I 0 CONST OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmReadInp     Read input fields.                                          *
      *  Input:                                                                    *
      *   CtrChr1      Control character byte 1.                                   *
      *   CtrChr2      Control character byte 2.                                   *
      *   InpBfrHnd    Input buffer handle.                                        *
      *   CmdBfrHnd    Command buffer handle.                                      *
      *   EnvHnd       Environment handle.                                         *
      *  Output:                                                                   *
      *   InpBfrSiz    Size of input buffered used to return fields.               *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   AIDCod       AID code.                                                   *
      ******************************************************************************
     D DsmReadInp      PR            10I 0 EXTPROC('QsnReadInp')
     D  PR_CtrChr1                    1A   CONST
     D  PR_CtrChr2                    1A   CONST
     D  PR_InpBfrSiz                 10I 0
     D  PR_InpBfrHnd                 10I 0 CONST OPTIONS(*OMIT)
     D  PR_CmdBfrHnd                 10I 0 CONST OPTIONS(*OMIT)
     D  PR_EnvHnd                    10I 0 CONST OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmClrScr      Clear screen and set screen size.                           *
      *  Input:                                                                    *
      *   ScrMod       Screen mode: '0'-use current size, '3'=24x80, '4'-27x132.   *
      *   CmdBfrHnd    Command buffer handle.                                      *
      *   EnvHnd       Environment handle.                                         *
      *  Output:                                                                   *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   RtnCod       Return code: (0)-successful, (-1)-error                     *
      ******************************************************************************
     D DsmClrScr       PR            10I 0 EXTPROC('QsnClrScr')
     D  PR_ScrMod                     1A   CONST OPTIONS(*OMIT)
     D  PR_CmdBfrHnd                 10I 0 CONST OPTIONS(*OMIT)
     D  PR_EnvHnd                    10I 0 CONST OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmWrtDta      Write data to screen.                                       *
      *  Input:                                                                    *
      *   ChrDta       Character data.                                             *
      *   ChrDtaL      Character data length.                                      *
      *   FldID        Field identifier.                                           *
      *   Row          Row.                                                        *
      *   Col          Column.                                                     *
      *   StrMonAtr    Starting monochrome attribute.                              *
      *   EndMonAtr    Ending monochrome attribute.                                *
      *   StrColAtr    Starting color attribute.                                   *
      *   EndColAtr    Ending color attribute.                                     *
      *   CmdBfrHnd    Command buffer handle.                                      *
      *   EnvHnd       Environment handle.                                         *
      *  Output:                                                                   *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   RtnCod       Return code: (0)-successful, (-1)-error                     *
      ******************************************************************************
     D DsmWrtDta       PR            10I 0 EXTPROC('QsnWrtDta')
     D  PR_ChrDta                 32767A   CONST OPTIONS(*VARSIZE)
     D  PR_ChrDtaL                   10I 0 CONST
     D  PR_FldID                     10I 0 CONST OPTIONS(*OMIT)
     D  PR_Row                       10I 0 CONST OPTIONS(*OMIT)
     D  PR_Col                       10I 0 CONST OPTIONS(*OMIT)
     D  PR_StrMonAtr                  1A   CONST OPTIONS(*OMIT)
     D  PR_EndMonAtr                  1A   CONST OPTIONS(*OMIT)
     D  PR_StrColAtr                  1A   CONST OPTIONS(*OMIT)
     D  PR_EndColAtr                  1A   CONST OPTIONS(*OMIT)
     D  PR_CmdBfrHnd                 10I 0 CONST OPTIONS(*OMIT)
     D  PR_EnvHnd                    10I 0 CONST OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmSetFld      Define an input field.                                      *
      *  Input:                                                                    *
      *   FldID        Field identifier.                                           *
      *   FldLen       Field length.                                               *
      *   Row          Row.                                                        *
      *   Col          Column.                                                     *
      *   FldFmtWrd    Field format word.                                          *
      *   FldCtlWrd    Field control words.                                        *
      *   FldCtlWrdC   Field control word count.                                   *
      *   MonAtr       Monochrome attribute.                                       *
      *   ColAtr       Color attribute.                                            *
      *   CmdBfrHnd    Command buffer handle.                                      *
      *   EnvHnd       Environment handle.                                         *
      *  Output:                                                                   *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   RtnCod       Return code: (0)-successful, (-1)-error                     *
      ******************************************************************************
     D DsmSetFld       PR            10I 0 EXTPROC('QsnSetFld')
     D  PR_FldID                     10I 0 CONST OPTIONS(*OMIT)
     D  PR_FldLen                    10I 0 CONST OPTIONS(*OMIT)
     D  PR_Row                       10I 0 CONST OPTIONS(*OMIT)
     D  PR_Col                       10I 0 CONST OPTIONS(*OMIT)
     D  PR_FldFmtWrd                  2A   CONST OPTIONS(*OMIT)
     D  PR_FldCtlWrd                  2A   CONST DIM(256)
     D                                     OPTIONS(*VARSIZE:*OMIT)
     D  PR_FldCtlWrdC                10I 0 CONST OPTIONS(*OMIT)
     D  PR_MonAtr                     1A   CONST OPTIONS(*OMIT)
     D  PR_ColAtr                     1A   CONST OPTIONS(*OMIT)
     D  PR_CmdBfrHnd                 10I 0 CONST OPTIONS(*OMIT)
     D  PR_EnvHnd                    10I 0 CONST OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmCrtCmdBuf   Create command buffer.  This is used to create a buffer     *
      *                of more than one dynamic screen command to perform them     *
      *                all at once.                                                *
      *  Input:                                                                    *
      *   IntBufSiz    Initial buffer size.                                        *
      *   IncBufSiz    Incremental buffer size.                                    *
      *   MaxBufSiz    Maximum buffer size.                                        *
      *  Output:                                                                   *
      *   CmdBfrHnd    Command buffer handle.                                      *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   CmdBfrHnd    Command buffer handle.                                      *
      ******************************************************************************
     D DsmCrtCmdBuf    PR            10I 0 EXTPROC('QsnCrtCmdBuf')
     D  PR_IntBufSiz                 10I 0 CONST
     D  PR_IncBufSiz                 10I 0 CONST OPTIONS(*OMIT)
     D  PR_MaxBufSiz                 10I 0 CONST OPTIONS(*OMIT)
     D  PR_CmdBfrHnd                 10I 0 OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmClrBuf      Clear buffer.                                               *
      *  Input:                                                                    *
      *   BfrHnd       Buffer handle.                                              *
      *  Output:                                                                   *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   RtnCod       Return code: (0)-successful, (-1)-error                     *
      ******************************************************************************
     D DsmClrBuf       PR            10I 0 EXTPROC('QsnClrBuf')
     D  PR_BfrHnd                    10I 0 CONST
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmDltBuf      Delete buffer.                                              *
      *  Input:                                                                    *
      *   BfrHnd       Buffer handle.                                              *
      *  Output:                                                                   *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   RtnCod       Return code: (0)-successful, (-1)-error                     *
      ******************************************************************************
     D DsmDltBuf       PR            10I 0 EXTPROC('QsnDltBuf')
     D  PR_BfrHnd                    10I 0 CONST
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmPutBuf      Send command buffer to screen.                              *
      *  Input:                                                                    *
      *   CmdBfrHnd    Command buffer handle.                                      *
      *   EnvHnd       Environment handle.                                         *
      *  Output:                                                                   *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   RtnCod       Return code: (0)-successful, (-1)-error                     *
      ******************************************************************************
     D DsmPutBuf       PR            10I 0 EXTPROC('QsnPutBuf')
     D  PR_CmdBfrHnd                 10I 0 CONST
     D  PR_EnvHnd                    10I 0 CONST OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmPutGetBuf   Send command buffer to screen and get input buffer.         *
      *  Input:                                                                    *
      *   CmdBfrHnd    Command buffer handle.                                      *
      *   InpBfrHnd    Input buffer handle.                                        *
      *   EnvHnd       Environment handle.                                         *
      *  Output:                                                                   *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   RtnCod       Return code: (0)-successful, (-1)-error                     *
      ******************************************************************************
     D DsmPutGetBuf    PR            10I 0 EXTPROC('QsnPutGetBuf')
     D  PR_CmdBfrHnd                 10I 0 CONST
     D  PR_InpBfrHnd                 10I 0 CONST
     D  PR_EnvHnd                    10I 0 CONST OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmCrtInpBuf   Create input buffer.                                        *
      *  Input:                                                                    *
      *   IntBufSiz    Initial buffer size.                                        *
      *   IncBufSiz    Incremental buffer size.                                    *
      *   MaxBufSiz    Maximum buffer size.                                        *
      *  Output:                                                                   *
      *   InpBfrHnd    Input buffer handle.                                        *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   InpBfrHnd    Input buffer handle.                                        *
      ******************************************************************************
     D DsmCrtInpBuf    PR            10I 0 EXTPROC('QsnCrtInpBuf')
     D  PR_IntBufSiz                 10I 0 CONST
     D  PR_IncBufSiz                 10I 0 CONST OPTIONS(*OMIT)
     D  PR_MaxBufSiz                 10I 0 CONST OPTIONS(*OMIT)
     D  PR_InpBfrHnd                 10I 0 OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmRtvFldDta   Retrieve pointer to input field data.                       *
      *  Input:                                                                    *
      *   InpBfrHnd    Input buffer handle.                                        *
      *  Output:                                                                   *
      *   pInpFldDta   Pointer to input field data.                                *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   pInpFldDta   Pointer to input field data.                                *
      ******************************************************************************
     D DsmRtvFldDta    PR              *   EXTPROC('QsnRtvFldDta')
     D  PR_InpBfrHnd                 10I 0 CONST
     D  PR_pInpFldDta                  *   OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmRtvDta      Retrieve pointer to input data.                             *
      *  Input:                                                                    *
      *   InpBfrHnd    Input buffer handle.                                        *
      *  Output:                                                                   *
      *   pInpDta      Pointer to input data.                                      *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   pInpDta      Pointer to input data.                                      *
      ******************************************************************************
     D DsmRtvDta       PR              *   EXTPROC('QsnRtvDta')
     D  PR_InpBfrHnd                 10I 0 CONST
     D  PR_pInpDta                     *   OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmRtvReadAID  Retrieve AID code from input buffer after read.             *
      *  Input:                                                                    *
      *   InpBfrHnd    Input buffer handle.                                        *
      *  Output:                                                                   *
      *   AIDCod       AID code.            .                                      *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   AIDCod       AID code.            .                                      *
      ******************************************************************************
     D DsmRtvReadAID   PR             1A   EXTPROC('QsnRtvReadAID')
     D  PR_InpBfrHnd                 10I 0 CONST
     D  PR_AIDCod                     1A   OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmRtvReadAdr  Retrieve cursor row and column from input buffer after read.*
      *  Input:                                                                    *
      *   InpBfrHnd    Input buffer handle.                                        *
      *   EnvHnd       Environment handle.                                         *
      *  Output:                                                                   *
      *   Row          Row.                                                        *
      *   Col          Column.                                                     *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   RtnCod       Return code: (0)-successful, (-1)-error                     *
      ******************************************************************************
     D DsmRtvReadAdr   PR            10I 0 EXTPROC('QsnRtvReadAdr')
     D  PR_InpBfrHnd                 10I 0 CONST
     D  PR_Row                       10I 0 OPTIONS(*OMIT)
     D  PR_Col                       10I 0 OPTIONS(*OMIT)
     D  PR_EnvHnd                    10I 0 CONST OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmQryModSup   Query device mode support.                                  *
      *  Input:                                                                    *
      *   DspMod       Display mode: 3=24x80, 4=27x132                             *
      *   EnvHnd       Environment handle.                                         *
      *  Output:                                                                   *
      *   ModInd       Mode indication: 0=not supported, 1=supported.              *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   ModInd       Mode indication: 0=not supported, 1=supported.              *
      ******************************************************************************
     D DsmQryModSup    PR            10I 0 EXTPROC('QsnQryModSup')
     D  PR_DspMod                     1A   CONST
     D  PR_ModInd                     1A   CONST OPTIONS(*OMIT)
     D  PR_EnvHnd                    10I 0 CONST OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmWTD         Write to display.                                           *
      *  Input:                                                                    *
      *   InpBfrHnd    Input buffer handle.                                        *
      *   CmdBfrHnd    Command buffer handle.                                      *
      *   EnvHnd       Environment handle.                                         *
      *  Output:                                                                   *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   RtnCod       Return code: (0)-successful, (-1)-error                     *
      ******************************************************************************
     D DsmWTD          PR            10I 0 EXTPROC('QsnWTD')
     D  PR_CtrChr1                    1A   CONST
     D  PR_CtrChr2                    1A   CONST
     D  PR_CmdBfrHnd                 10I 0 CONST
     D  PR_EnvHnd                    10I 0 CONST OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * SetCsrAdr      Set cursor address.                                         *
      *  Input:                                                                    *
      *   FldID        Field identifier to position cursor on.                     *
      *   Row          Row.                                                        *
      *   Column       Column.                                                     *
      *   CmdBfrHnd    Command buffer handle.                                      *
      *   EnvHnd       Environment handle.                                         *
      *  Output:                                                                   *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   RtnCod       Return code: (0)-successful, (-1)-error                     *
      ******************************************************************************
     D DsmSetCsrAdr    PR            10I 0 EXTPROC('QsnSetCsrAdr')
     D  PR_FldID                     10I 0 CONST OPTIONS(*OMIT)
     D  PR_Row                       10I 0 CONST OPTIONS(*OMIT)
     D  PR_Col                       10I 0 CONST OPTIONS(*OMIT)
     D  PR_CmdBfrHnd                 10I 0 CONST OPTIONS(*OMIT)
     D  PR_EnvHnd                    10I 0 CONST OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmWrtPad      Pad for a number of positions.                              *
      *  Input:                                                                    *
      *   Chr          Character to pad.                                           *
      *   ChrC         Number of characters to pad.                                *
      *   FldID        Field identifier to beginning padding on.                   *
      *   Row          Row.                                                        *
      *   Column       Column.                                                     *
      *   CmdBfrHnd    Command buffer handle.                                      *
      *   EnvHnd       Environment handle.                                         *
      *  Output:                                                                   *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   RtnCod       Return code: (0)-successful, (-1)-error                     *
      ******************************************************************************
     D DsmWrtPad       PR            10I 0 EXTPROC('QsnWrtPad')
     D  PR_Chr                        1A   CONST
     D  PR_ChrC                      10I 0 CONST
     D  PR_FldID                     10I 0 CONST OPTIONS(*OMIT)
     D  PR_Row                       10I 0 CONST OPTIONS(*OMIT)
     D  PR_Col                       10I 0 CONST OPTIONS(*OMIT)
     D  PR_CmdBfrHnd                 10I 0 CONST OPTIONS(*OMIT)
     D  PR_EnvHnd                    10I 0 CONST OPTIONS(*OMIT)
     D  PR_APIErr                          LIKE(APIErr) OPTIONS(*OMIT)
      ******************************************************************************
      * DsmCrtEnv      Create low-level environment.                               *
      *  Input:                                                                    *
      *   LowLvlEnv    Environment description (see data structure).               *
      *   ChrC         Number of characters to pad.                                *
      *   FldID        Field identifier to beginning padding on.                   *
      *   Row          Row.                                                        *
      *   Column       Column.                                                     *
      *   CmdBfrHnd    Command buffer handle.                                      *
      *   EnvHnd       Environment handle.                                         *
      *  Output:                                                                   *
      *   APIErr       API error information.                                      *
      *  Return:                                                                   *
      *   RtnCod       Return code: (0)-successful, (-1)-error                     *
      ******************************************************************************
     D DsmCrtEnv       PR            10I 0 EXTPROC('QsnCrtEnv')
     D  LowLvlEnv                    38A   CONST
     D  LowLvlEnvSiz                 10I 0 CONST

Thanks to David Morris
Back

QWCCVTDT

Convert Date and Time Format

	 *  Input date and time
	D InpDatTim8      ds                                       Input for *YYMD ao.
	D  InpDat8                       8S 0
	D  InpTim8                       9S 0 Inz(*zeros)

	D InpDatTim6      ds                                       Input for *YMD ao.
	D  InpCty6                       1S 0 Inz(*zeros)
	D  InpDat6                       6S 0
	D  InpTim6                       9S 0 Inz(*zeros)

	 *  Output date and time
	D OutDatTim       ds
	D  OutCty                        1S 0
	D  OutDat                        6S 0
	D  OutTim                        9S 0 Inz(*zeros)

	 *  Inputformat this datefunction (fx. 20021231 til 311202)
	D InpFmt8         S             10A   Inz('*YYMD')
	 *  Inputformat this datefunction (fx. 991231 til 311299)
	D InpFmt6         S             10A   Inz('*YMD')
	 *  Outputformat this dateconversion
	D OutFmt          S             10A   Inz('*DMY')

	 *  API name
	D ApiNam          S             10A   Inz('QWCCVTDT')

	C                   Eval      InpDat6     = KlStrd         <---------------
	C                   exsr      DtoCvt6                      Date 6 digits
	C                   eval      Dsstrd      = OutDat         --------------->

	C                   eval      InpFmt8     = '*CURRENT'     <---------------
	C                   exsr      DtoCvt8                      Date 8 digits
	C                   eval      wsdate      = OutDat         --------------->
	 * change back to *YYMD
	C                   eval      InpFmt8     = '*YYMD   '

	 **********************************************************************
	 * DtoCvt6: Convert with 6 digits (*YMD)                              *
	 **********************************************************************
	C     DtoCvt6       Begsr
	C                   Eval      OutDatTim   = *zeros
	C                   Call      ApiNam
	C                   Parm                    InpFmt6
	C                   Parm                    InpDatTim6
	C                   Parm                    OutFmt
	C                   Parm                    OutDatTim
	C                   Parm                    ErrDta
	C     DtoCvt6X      Endsr

	 **********************************************************************
	 * DtoCvt8: Convert with 8 digits (*YYMD)                             *
	 **********************************************************************
	C     DtoCvt8       Begsr
	C                   Eval      OutDatTim   = *zeros
	C                   Call      ApiNam
	C                   Parm                    InpFmt8
	C                   Parm                    InpDatTim8
	C                   Parm                    OutFmt
	C                   Parm                    OutDatTim
	C                   Parm                    ErrDta
	C     DtoCvt8X      Endsr

Thanks to my self :^)
Back

QCMDCHK

Check Command Syntax

Q:	Does anyone know how to use the QCMDCHK API or something similar and allow
variables as command parameters?  Similar to user options in PDM.  Using the
QCMDCHK API and specifying a variable (like &F) for a command parameter produces
an error stating that variables can only be used in CL programs.

A:	I am using the QCMDCHK in a way that seems similar to your requirements.
Here is one example:

      If  ( &SrcType *eq 'RPG' ) Then( Do )
      ChgVar &Cmd Value('+
          ?CrtRpgPgm Pgm(' *cat &SrcFileLib *tcat '/' *cat &SrcMember *tcat ') +
                 SrcFile(' *cat &SrcFileLib *tcat '/' *cat &SrcFile   *tcat ') +
                                                                              ')
      Call QCmdChk ( &Cmd 2000 )
      SbmJob RqsDta( &Cmd )     Job( &SrcMember )
EndDo

Thanks to Dan Bale
Back

QMHRTVRQ

Retrieve info on last request message

I have written a program which may be called by a command validation
program (or other program) to determine the name of the calling command.
This technique uses the QMHRTVRQ API to retrieve the last *RQS message
(similar to what Simon Coulter described with RCVMSG).

Basically, the following gives you the last request message, which
contains the last command executed:

	/*** API variables ***/
	DCL        VAR(&APIDTAFMT) TYPE(*CHAR) LEN(8) +
	             VALUE('RTVQ0100') /* API data formt */
	DCL        VAR(&APIDTALEN) TYPE(*CHAR) LEN(4) +
	             VALUE(X'000007D0') /* API data length:  +
	             2000 */
	DCL        VAR(&APIDTARTV) TYPE(*CHAR) LEN(2000) /* +
	             Retrieved API data */
	DCL        VAR(&APIERRCD) TYPE(*CHAR) LEN(4) +
	             VALUE(X'00000000') /* API error code (no +
	             data returned) */
	DCL        VAR(&APILEN) TYPE(*CHAR) LEN(4) /* Data +
	             length returned */
	DCL        VAR(&APIMSGKEY) TYPE(*CHAR) LEN(4) +
	             VALUE('    ') /* No message key */
	DCL        VAR(&APIMSGTYP) TYPE(*CHAR) LEN(10) +
	             VALUE('*LAST') /* Request message type */

	/*** Retrieve info on last request message ***/
	CALL       PGM(QMHRTVRQ) PARM(&APIDTARTV &APIDTALEN +
	             &APIDTAFMT &APIMSGTYP &APIMSGKEY &APIERRCD)

Thanks to Jerry Jewel
Back

QWDRJOBD

Retrieve job description information

	*===================================================================
	* = Service Program... JobDsc
	* = Description....... Job description routines
	* = Compile........... CrtRPGMod Module(YourLib/JobDsc)
	* =                              SrcFile(YourLib/YourSrcFile)
	* =                    CrtSrvPgm SrvPgm(YourLib/JobDsc)
	* =                              Export(*All)
	*===================================================================
	H NoMain
	*===================================================================
	* = Prototypes
	*===================================================================
	* - RtvJobDInlLibL - Retrieve job description's initial library
	* - list
	D RtvJobDInlLibL...
	D Pr 275
	D 10 Value
	D 10 Value
	D 272 Options( *NoPass )

	* - RtvJobDAPI - Retrieve job description information API
	D RtvJobDAPI...
	D Pr ExtPgm( 'QWDRJOBD' )
	D 32767
	D 10I 0
	D 8
	D 20
	D 272

	* = Procedure..... RtvJobDInlLibL
	* = Description... Retrieve job description's initial library list
	P RtvJobDInlLibl...
	P B Export
	D PI 275
	D JobD 10 Value
	D JobDLib 10 Value
	D APIError 272 Options( *NoPass )

	* - Data definitions
	D RcvVar DS 32767
	D 360
	D OffsetToLibs 10I 0
	D NbrLibsInList 10I 0

	D RcvVarLen S 10I 0 Inz( %Len( RcvVar ) )
	D Format S 8 Inz( 'JOBD0100' )

	D QualJobD S 20
	D JobDLibs S 275 Inz( *Blank )

	D Pos S 10I 0

	D NoAPIError C Const( *Zero )
	D APIErrorPassed S N

	D APIErrorDS DS
	D BytesProvided 10I 0 Inz( %Size( APIErrorDS ) )
	D BytesAvail 10I 0 Inz( *Zero )
	D MsgID 7 Inz( *Blanks )
	D Reserved 1 Inz( X'00' )
	D MsgDta 256 Inz( *Blanks )

	* - Determine whether API error parameter was passed
	C If %Parms > 2
	C Eval APIErrorPassed = *On
	C EndIf

	* - Retrieve job description information
	C Reset APIErrorDS
	C Eval QualJobD = JobD + JobDLib
	C CallP RtvJobDAPI(
	C RcvVar :
	C RcvVarLen :
	C Format :
	C QualJobD :
	C APIErrorDS
	C )

	C If BytesAvail <> NoAPIError
	C ExSr ReturnError
	C EndIf

	* - Extract initial library list and return it to caller
	C Eval Pos = OffsetToLibs + 1
	C Eval JobDLibs = %Subst(
	C RcvVar :
	C Pos :
	C NbrLibsInList * 11
	C )
	C Return JobDLibs

	* - Subroutine.... ReturnError
	* - Description... Return error condition to caller
	C ReturnError BegSr

	C If APIErrorPassed
	C Eval APIError = APIErrorDS
	C EndIf
	C Return *Blank
	C EndSr

	P RtvJobDInlLibL...
	P E

	Below are code snippets showing how to use procedure RtvSrlNbr:
	* = Program....... JobDscEx
	* = Description... Sample demonstrating use of procedure
	* = RtvJobDInlLibL in applications

	* = Compile....... CrtRPGMod Module(YourLib/JobDscEx)
	* =                          SrcFile(YourLib/YourSrcFile)
	* =                CrtPgm    Pgm(YourLib/JobDscEx)
	* =                          BndSrvPgm(YourLib/JobDsc)
	* =                          ActGrp(*New)

	D RtvJobDInlLibL...
	D Pr 275
	D 10 Value
	D 10 Value
	D 272 Options( *NoPass )

	D JobD S 10 Inz( 'MYJOBD' )
	D JobDLIB S 10 Inz( 'MYLIB' )
	D InlLibL S 275

	D APIErrorDS DS
	D BytesProvided 10I 0 Inz( %Size( APIErrorDS ) )
	D BytesAvail 10I 0 Inz( *Zero )
	D MsgID 7 Inz( *Blanks )
	D Reserved 1 Inz( X'00' )
	D MsgDta 256 Inz( *Blanks )

	D NoAPIError C Const( *Zero )

	* - Retrieve job description's initial library list
	C Reset APIErrorDS

	C Eval InlLibL = RtvJobDInlLibL(
	C JobD :
	C JobDLib :
	C APIErrorDS
	C )

	C If BytesAvail <> NoAPIError
	C ExSr HandleError
	C EndIf

Thanks to Club Tech iSeries Newsletter
Back

QSPROUTQ

Retrieve output queue information

Here's a quick example of the QSPROUTQ (Retrieve output queue information) API which should give you the information you're after. The Connection type 2 identifies a TCP/IP network connected remote writer: **-- Header specification: ---------------------------------------------** H Option( *SrcStmt ) **-- API error data structure: -----------------------------------------** D ApiError Ds D AeBytPrv 10i 0 Inz( %Size( ApiError )) D AeBytAvl 10i 0 D AeExcpId 7a D 1a D AeExcpDta 128a **-- Output queue information structure: -------------------------------** D OUTQ0200 Ds D O2BytRtn 10i 0 D O2BytAvl 10i 0 D O2OutQnam 10a D O2OutQlib 10a D O2FilOrd 10a D O2DspAnyF 10a D O2JobSep 10i 0 D O2OprCtl 10a D O2DtaQnam 10a D O2DtaQlib 10a D O2AutChk 10a D O2NbrF 10i 0 D O2OutQsts 10a D O2OutQtxt 50a D O2NbrSplFpag 10i 0 D O2NbrWtrStr 10i 0 D O2AutWtrStr 10i 0 D O2RmtSysNamTp 1a D O2RmtSysNam 255a D O2RmtPrtQ 128a D O2MsgQnam 10a D O2MsgQlib 10a D O2ConTyp 10i 0 D O2DesTyp 10i 0 D O2VmMvsCls 1a D O2FrmCtlBuf 8a D O2HstPrtTfr 1a D O2MnfTypMod 17a D O2WscObjNam 10a D O2WscObjLib 10a D O2SplFaspA 1a D O2OfsMxSpfPge 10i 0 D O2NbrPgeRtn 10i 0 D O2LenPgeRtn 10i 0 D O2OfsWtrE 10i 0 D O2NbrWtrRtn 10i 0 D O2LenWtrRtn 10i 0 D O2DesOpt 128a D O2WtrTypStr 1a D O2PrtSepPag 1a D O2RmtPrtQLong 255a D 3a D O2OthFlds 120a D O2Data 1024a ** D O2MxSpfPge Ds D O2Nbrpag 10i 0 D O2StrTim 8a D O2EndTim 8a ** D O2WtrE Ds Based( pWtrE ) D O2WtrJobNam 10a D O2WtrJobUsr 10a D O2WtrJobNbr 6a D O2WtrJobSts 10a D O2PrtDevNam 10a ** D PxOutqNam s 20a D PxWtrSts s 12a **-- Retrieve output queue information: --------------------------------** D RtvOutqInf Pr ExtPgm( 'QSPROUTQ' ) D RqRcvVar 32767a Options( *VarSize ) D RqRcvVarLen 10i 0 Const D RqFmtNam 8a Const D RqOutQ 20a Const D RqError 32767a Options( *VarSize ) ** **-- Mainline: ---------------------------------------------------------** ** C *Entry Plist C Parm PxOutqNam C Parm PxWtrSts ** C Eval PxWtrSts = *Blanks ** C CallP RtvOutqInf( OUTQ0200 C : %Size( OUTQ0200 ) C : 'OUTQ0200' C : PxOutqNam C : ApiError C ) ** C If AeBytAvl = *Zero ** C If O2ConTyp = 2 C Eval PxWtrSts = 'STOPPED' ** C If O2NbrWtrRtn > *Zero C Eval pWtrE = %Addr( OUTQ0200 ) + C O2OfsWtrE ** C Select C When O2WtrJobSts = 'STR ' C Eval PxWtrSts = 'ACTIVE' ** C When O2WtrJobSts = 'END ' C Eval PxWtrSts = 'STOPPED' ** C When O2WtrJobSts = 'JOBQ' C Eval PxWtrSts = 'STARTING' ** C When O2WtrJobSts = 'HLD ' C Eval PxWtrSts = 'BEING HELD' ** C When O2WtrJobSts = 'MSGW' C Eval PxWtrSts = 'MESSAGE WAIT' C EndSl ** C EndIf C EndIf C EndIf ** C Return ** Thanks to Carsten Flensburg

Back

QCMDEXC

Execute Command (System program)

Q:	What's a good way to retrieve the full message or message data associated
with a failed call to QCMDEXC ?

A:	I suppose the "right" way is to call QCAPCMD instead of QCMDEXC.  With
QCAPCMD you get the "QUSEC" API data structure as a parameter, so you can
get the message data from that.

But, I'm not a huge fan of QCAPCMD, it's just too complicated :)  So, I
tend to just receive the message data from the program message queue.
This routine, by the way, was originally written to receive message
CPF5027 when a record is locked so that I can get the details of who is
locking a record -- but it works for your purpose too...

     H DFTACTGRP(*NO)

      **************************************
      ** start data taken from /copy member
      **************************************
     D MSG_DATA        DS                  qualified
     D                                     based(prototype_only)
     D   ID                           7A
     D   Sev                         10I 0
     D   Type                         2A
     D   Key                          4A
     D   Data                      4096A   varying

      ** Message types in the MSG_DATA.Type field:
     D MSGTYPE_COMP    C                   '01'
     D MSGTYPE_DIAG    C                   '02'
     D MSGTYPE_INFO    C                   '04'
     D MSGTYPE_INQ     C                   '05'
     D MSGTYPE_SNDCPY  C                   '06'
     D MSGTYPE_RQS     C                   '08'
     D MSGTYPE_RQSPMT  C                   '10'
     D MSGTYPE_NOTIFY  C                   '14'
     D MSGTYPE_ESCAPE  C                   '15'
     D MSGTYPE_NOTERR  C                   '16'
     D MSGTYPE_ESCERR  C                   '17'
     D MSGTYPE_RPY     C                   '21'
     D MSGTYPE_VLDRPY  C                   '22'
     D MSGTYPE_DFTRPY  C                   '23'
     D MSGTYPE_SYSDFT  C                   '24'
     D MSGTYPE_SYSRPY  C                   '25'

     D MSG_find        PR             1N
     D   peMsgID                      7A   const
     D   peStackCnt                  10I 0 value
     D   peDta                             likeds(MSG_DATA)
      **************************************
      ** end data taken from /copy member
      **************************************

     D psds           sds
     D   psds_msgid           40     46A

     D Command         PR                  ExtPgm('QCMDEXC')
     D  CmdStr                    32702    const options(*varsize)
     D  CmdLen                       15p 5 const

     D CmdStr          s            100A   varying
     D err             ds                  likeds(MSG_DATA)

     C                   eval      CmdStr = 'STRCMTCTL LCKLVL(*CHG)'
     c                   callp(e)  Command(cmdStr: %len(cmdStr))
     c                   if        %error
     c                   if        MSG_find(psds_msgid: 1: err) = *ON
      ** the err structure now contains the full message details
     c                   endif
     c                   endif

     c                   eval      *inlr = *on

      **************************************
      ** Start data from SRVPGM
      **************************************

      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      * MSG_find(): Search a program's message queue for the last
      *           time a given MsgID was found.
      *
      *     peMsgID = (input) message ID to search for
      *  peStackCnt = (input) call-stack entry to search
      *       peDta = (output) MSG_DATA structure w/returned msg info
      *
      * Returns *ON if successful, *OFF otherwise
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P MSG_find        B                   export
     D MSG_find        PI             1N
     D   peMsgID                      7A   const
     D   peStackCnt                  10I 0 value
     D   peDta                             likeds(MSG_DATA)

     D QMHRCVPM        PR                  ExtPgm('QMHRCVPM')
     D   MsgInfo                  32766A   options(*varsize)
     D   MsgInfoLen                  10I 0 const
     D   Format                       8A   const
     D   StackEntry                  10A   const
     D   StackCount                  10I 0 const
     D   MsgType                     10A   const
     D   MsgKey                       4A   const
     D   WaitTime                    10I 0 const
     D   MsgAction                   10A   const
     D   ErrorCode                 1024A   options(*varsize)

     D dsM1            DS
     D  dsM1_BytRtn                  10I 0
     D  dsM1_BytAvl                  10I 0
     D  dsM1_MsgSev                  10I 0
     D  dsM1_MsgID                    7A
     D  dsM1_MsgType                  2A
     D  dsM1_MsgKey                   4A
     D  dsM1_Reserv1                  7A
     D  dsM1_CCSID_st                10I 0
     D  dsM1_CCSID                   10I 0
     D  dsM1_DtaLen                  10I 0
     D  dsM1_DtaAvl                  10I 0
     D  dsM1_Dta                   4096A

     D dsEC            DS
     D  dsEC_BytesP            1      4I 0 INZ(%size(dsEC))
     D  dsEC_BytesA            5      8I 0 INZ(0)
     D  dsEC_MsgID             9     15
     D  dsEC_Reserv           16     16
     D  dsEC_MsgDta           17    256

     D wwMsgKey        S              4A

      *************************************************
      * Search program's message queue
      *************************************************
     c                   eval      wwMsgKey = *ALLx'00'

     c                   dou       dsEC_BytesA > 0
     c                               or dsM1_MsgID = PSDS_msgid

     c                   callp     QMHRCVPM(dsM1: %size(dsM1): 'RCVM0100':
     c                                '*': peStackCnt: '*PRV': wwMsgKey:
     c                                0: '*SAME': dsEC)

     c                   eval      wwMsgKey = dsM1_MsgKey
     c                   enddo

     C*********************************************************
     c*  Handle error
     C*********************************************************
     c                   if        dsEC_BytesA > 0
     c                   return    *Off
     c                   endif

      *********************************************************
      * return the result
      *********************************************************
     c                   eval      peDta.ID = dsM1_MsgID
     c                   eval      peDta.Sev = dsM1_MsgSev
     c                   eval      peDta.Type = dsM1_MsgType
     c                   eval      peDta.Key = dsM1_MsgKey
     c                   eval      peDta.Data =
     c                                 %subst(dsM1_Dta: 1: dsM1_DtaLen)
     c                   return    *on
     P                 E

Thanks to Scott Klement
Back

QCAPCMD

Execute Command

	h nomain
	 *------------------------------------------------------------------------
	 *    Program  . . :  PRCCMD           Author . . :  Rick Chevalier
	 *    Date . . . . :   1/19/2000
	 *    Purpose  . . :  Process or run a command.
	 *------------------------------------------------------------------------
	 *    Modifications:                               Date/Prgrmmr
	 *------------------------------------------------------------------------
	 *      None to this point.
	 *------------------------------------------------------------------------

	 * Required Parameter Group:
	 *  1  Source command string                     Input   Char(*)

	 * Optional Parameter Group:
	 *  2  Processing type                           Input   Char(1)
	 *        '0' - Never prompt the command
	 *        '1' - Always prompt the command
	 *   Dft  '2' - Prompt the command if selective prompting characters are
	                present in the command
	 *        '3' - Show help

	 *------------------------------------------------------------------------
	 * Internal procedure prototypes
	 *------------------------------------------------------------------------
	 * Prototype for process command procedure (PrcCmd)
	d PrcCmd          pr              *
	d                            32702                             Command
	d                                1    options(*nopass: *omit)  Prompt type

	 *------------------------------------------------------------------------
	 * External procedure prototypes.
	 *------------------------------------------------------------------------
	 * Send program message.
	dsndpgmmsg        pr             4
	d##_msgid                        7
	d##_msgf                        20
	d##_msgdta@                       *   const
	d##_msgtyp                      10    options(*nopass)    Defaults to *DIAG

	 *------------------------------------------------------------------------
	 * Process command (QCAPCMD) API.  Check or run a CL command.
	 *------------------------------------------------------------------------
	pprccmd           b                   export
	dprccmd           pi              *
	d##_cmd                      32702
	d##_pmttyp                       1    options(*nopass: *omit)  Default = 2

	 *  1  Length of source command string                       Input  Binary(4)
	 *  2  Options control block                                 Input  Char(*)
	 *  3  Options control block length                          Input  Binary(4)
	 *  4  Options control block format                          Input  Char(8)
	 *  5  Changed command string                                Output Char(*)
	 *  6  Length available for changed command string           Input  Binary(4)
	 *  7  Length of changed command string available to return  Output Binary(4)
	 *  8  Error code                                            I/O    Char(*)

	d##_cmdlen        s              9b 0
	d##_ocb           ds
	d  ##_typprc                     9b 0 inz(2)               Type of processing
	d  ##_dbcs                       1    inz('0')             DBCS data handling
	d  ##_pmtact                     1                         Prompter action
	d  ##_cmdstx                     1    inz('0')             Command syntax
	d  ##_msgkey                     4    inz(*blanks)         Msg retrieve key
	d  ##_reserve                    9    inz(x'000000000000000000')  Reserved
	d##_ocblen        s              9b 0 inz(20)
	d##_ocbfmt        s              8    inz('CPOP0100')
	d##_chgcmd        s          32702
	d##_chglen        s              9b 0
	d##_chgavl        s              9b 0 inz(32702)
	d##_error         ds
	d  ##_erbp                1      4B 0 inz(128)               Bytes provided
	d  ##_erba                5      8B 0                        Bytes available
	d  ##_erexid              9     15                           Exception ID
	d  ##_erexdta            17    116                           Exception data

	d##_msgf          s             20    inz('QCPFMSG   *LIBL     ')

	 * Parameter list for API call.
	c     qcapcmd       plist
	c                   parm                    ##_cmd
	c                   parm                    ##_cmdlen
	c                   parm                    ##_ocb
	c                   parm                    ##_ocblen
	c                   parm                    ##_ocbfmt
	c                   parm                    ##_chgcmd
	c                   parm                    ##_chglen
	c                   parm                    ##_chgavl
	c                   parm                    ##_error

	 * Determine the length of the command string to process.
	c                   eval      ##_cmdlen = %len(%trim(##_cmd))

	 * Determine the length of the command string to process.
	c                   if        (%parms = 2 and %addr(##_pmttyp) = *null) or
	c                             %parms = 1
	c                   eval      ##_pmtact = '2'
	c                   else
	c                   eval      ##_pmtact = ##_pmttyp
	c                   endif

	 * Process command.
	c                   call      'QCAPCMD'     qcapcmd

	 * If no error return address of attribute information.
	c                   if        ##_erexid = *blanks
	c                   return    %addr(##_chgcmd)

	 * Send error message to job log and return null address.
	c                   else
	c                   callp     sndpgmmsg(##_erexid: ##_msgf:
	c                                       %addr(##_erexdta))
	c                   return    *null
	c                   endif

	pprccmd           e

Thanks to Rick Chevalier
Back

QjoRetrieveJournalInformation & QjoRtvJrnReceiverInformation

Retrieve Journal Information (link).

Retrieve Journal Information (link).


Retrieve Journal Information & Retrieve Journal Receiver Information **-- Header specifications: --------------------------------------------** H Option( *SrcStmt ) **-- Global declarations: ----------------------------------------------** D Idx s 10u 0 D RdBytAlc s 10u 0 **-- Api error data structure: -----------------------------------------** D ApiError Ds D AeBytPro 10i 0 Inz( %Size( ApiError )) D AeBytAvl 10i 0 Inz D AeMsgId 7a D 1a D AeMsgDta 128a **-- Journal information: ----------------------------------------------** D RJRN0100 Ds Based( pJrnInf ) D RjBytRtn 10i 0 D RjBytAvl 10i 0 D RjOfsKeyInf 10i 0 D RjJrnNam 10a D RjJrnLib 10a D RjASP 10i 0 D RjMsgQnam 10a D RjMsgQlib 10a D RjMngRcvOpt 1a D RjDltRcvOpt 1a D RjRsoRit 1a D RjRsoMfl 1a D RjRsoMo1 1a D RjRsoMo2 1a D RjRsv1 3a D RjJrnTyp 1a D RjRmtJrnTyp 1a D RjJrnStt 1a D RjJrnDlvMod 1a D RjLocJrnNam 10a D RjLocJrnLib 10a D RjLocJrnSys 8a D RjSrcJrnNam 10a D RjSrcJrnLib 10a D RjSrcJrnSys 8a D RjRdrRcvLib 10a D RjJrnTxt 50a D RjMinEntDtaAr 1a D RjMinEntFiles 1a D RjRsv2 9a D RjNbrAtcRcv 10i 0 D RjAtcRcvNam 10a D RjAtcRcvLib 10a D RjAtcLocSys 8a D RjAtcSrcSys 8a D RjAtcRcvNamDu 10a D RjAtcRcvLibDu 10a D RjRsv3 192a D RjNbrKey 10i 0 ** D JrnKey Ds Based( pJrnKey ) D JkKey 10i 0 D JkOfsKeyInf 10i 0 D JkKeyHdrSecLn 10i 0 D JkNbrEnt 10i 0 D JkKeyInfEntLn 10i 0 ** D JrnKeyHdr1 Ds Based( pKeyHdr1 ) D K1RcvNbrTot 10i 0 D K1RcvSizTot 10i 0 D K1RcvSizMtp 10i 0 D K1Rsv 8a ** D JrnKeyEnt1 Ds Based( pKeyEnt1 ) D E1RcvNam 10a D E1RcvLib 10a D E1RcvNbr 5a D E1RcvAtcDts 13a D E1RcvSts 1a D E1RcvSavDts 13a D E1LocJrnSys 8a D E1SrcJrnSys 8a D E1RcvSiz 10i 0 D E1Rsv 56a **-- Journal information specification: --------------------------------** D JrnInfRtv Ds D IsNbrVarRcd 10i 0 Inz( 1 ) D IsVarRcdLen 10i 0 Inz( 12 ) D IsKey 10i 0 Inz( 1 ) D IsDtaLen 10i 0 Inz( 0 ) ** D JrnInfRtv2 Ds D I2NbrVarRcd 10i 0 Inz( 1 ) D I2VarRcdLen 10i 0 Inz( 22 ) D I2Key 10i 0 Inz( 2 ) D I2DtaLen 10i 0 Inz( %Size( I2Dta )) D I2Dta D I2JrnObjInf 10a Overlay( I2Dta ) ** D JrnInfRtv3 Ds D I3NbrVarRcd 10i 0 Inz( 1 ) D I3VarRcdLen 10i 0 Inz( 60 ) D I3Key 10i 0 Inz( 3 ) D I3DtaLen 10i 0 Inz( %Size( I3Dta )) D I3Dta D I3RdbDirEinf 18a Overlay( I3Dta ) D I3RmtJrnNam 20a Overlay( I3Dta: *Next ) **-- Receiver information: ---------------------------------------------** D RRCV0100 Ds D RrBytRtn 10i 0 D RrBytAvl 10i 0 D RrRcvNam 10a D RrRcvLib 10a D RrJrnNam 10a D RrJrnLib 10a D RrThh 10i 0 D RrSiz 10i 0 D RrASP 10i 0 D RrNbrJrnEnt 10i 0 D RrMaxEspDtaLn 10i 0 D RrMaxNulInd 10i 0 D RrFstSeqNbr 10i 0 D RrMinEntDtaAr 1a D RrMinEntFiles 1a D RrRsv1 2a D RrLstSeqNbr 10i 0 D RrRsv2 10i 0 D RrSts 1a D RrMinFxlVal 1a D RrRcvMaxOpt 1a D RrRsv3 4a D RrAtcDts 13a D RrDtcDts 13a D RrSavDts 13a D RrTxt 50a D RrPndTrn 1a D RrRmtJrnTyp 1a D RrLocJrnNam 10a D RrLocJrnLib 10a D RrLocJrnSys 8a D RrLocRcvLib 10a D RrSrcJrnNam 10a D RrSrcJrnLib 10a D RrSrcJrnSys 8a D RrSrcRcvLib 10a D RrRdcRcvLib 10a D RrDuaRcvNam 10a D RrDuaRcvLib 10a D RrPrvRcvNam 10a D RrPrvRcvLib 10a D RrPrvRcvNamDu 10a D RrPrvRcvLibDu 10a D RrNxtRcvNam 10a D RrNxtRcvLib 10a D RrNxtRcvNamDu 10a D RrNxtRcvLibDu 10a D RrNbrJrnEntL 20s 0 D RrMaxEspDtlL 20s 0 D RrFstSeqNbrL 20s 0 D RrLstSeqNbrL 20s 0 D RrRsv4 60a **-- Retrieve journal information: -------------------------------------** D RtvJrnInf Pr ExtProc( 'QjoRetrieveJournal- D Information' ) D JiRcvVar 65535a Options( *VarSize ) D JiRcvVarLen 10i 0 Const D JiJrnNam 20a Const D JiFmtNam 8a Const D JiInfRtv 65535a Const Options( *VarSize ) D JiError 32767a Options( *VarSize: *NoPass ) **-- Retrieve journal receiver information: ----------------------------** D RtvRcvInf Pr ExtProc( 'QjoRtvJrnReceiver- D Information' ) D RiRcvVar 65535a Options( *VarSize ) D RiRcvVarLen 10i 0 Const D RiRcvNam 20a Const D RiFmtNam 8a Const D RiError 32767a Options( *VarSize: *NoPass ) ** **-- Mainline: ---------------------------------------------------------** ** C Eval RdBytAlc = 65535 C Eval pJrnInf = %Alloc( RdBytAlc ) ** C DoU RjBytAvl <= RdBytAlc ** C If RjBytAvl > RdBytAlc C Eval RdBytAlc = RjBytAvl C Eval pJrnInf = %ReAlloc( pJrnInf: RdBytAlc ) C EndIf ** C CallP RtvJrnInf( RJRN0100 C : RdBytAlc C : 'jrnname jrnlib' C : 'RJRN0100' C : JrnInfRtv C : ApiError C ) ** C EndDo ** C If AeBytAvl = *Zero C ExSr PrcKeyEnt C EndIf ** C DeAlloc pJrnInf ** C Return ** **-- Process key entries: ----------------------------------------------** C PrcKeyEnt BegSr ** C Eval pJrnKey = pJrnInf + C RjOfsKeyInf + C %Size( RjNbrKey ) C Eval pKeyHdr1 = pJrnKey + JkOfsKeyInf C Eval pKeyEnt1 = pKeyHdr1 + %Size( JrnKeyHdr1 ) ** C For Idx = 1 to JkNbrEnt ** C CallP RtvRcvInf( RRCV0100 C : %Size( RRCV0100 ) C : E1RcvNam + E1RcvLib C : 'RRCV0100' C : ApiError C ) **-- Do whatever... ** C If Idx < JkNbrEnt C Eval pKeyEnt1 = pKeyEnt1 + JkKeyInfEntLn C EndIf C EndFor ** C EndSr Thanks to Carsten Flensburg


Germann Ergang sent me a version of QjoRtvJrnReceiverInformation in CLLE call from a CL: ( &rcvrname *char 10 &jrnlib *char 10 &attachdat char 6 /*YYMMDD*/ &detachdat *char 6 /*YYMMDD*/ ) CALL PGM(myLIB/JRNDATE) PARM(&rcvrname &rcvrlib ' ' ' &attachdat &detachdat) JRNDATE CLLE ***************** Datenanfang ********************************** PGM PARM(&RCVRNAME &RCVRLIB &JRNNAME + &JRNLIB &ATTACHDAT &DETACHDAT) dcl &RCVRNAME *char 10 dcl &RCVRLIB *char 10 dcl &JRNNAME *char 10 dcl &JRNLIB *char 10 dcl &ATTACHDAT *char 6 dcl &DETACHDAT *char 6 dcl &qjov0100 *char 512 dcl &format *char 8 dcl &errcode *char 10 dcl &rcvrinfo *char 20 dcl &rtnvarlen *dec len(4 0) chgvar &rtnvarlen 512 chgvar %sst(&RCVRINFO 1 10) &rcvrname chgvar %sst(&RCVRINFO 11 10) &rcvrlib chgvar &format 'RRCV0100' CALLPRC PRC('QjoRtvJrnReceiverInformation') + PARM((&QJOV0100) (&RTNVARLEN) (&RCVRINFO) + (&FORMAT) (&errcode)) CHGVAR VAR(&JRNNAME) VALUE(%SST(&QJOV0100 29 10)) CHGVAR VAR(&JRNlib) VALUE(%SST(&QJOV0100 39 10)) chgvar &ATTACHDAT VALUE(%SST(&QJOV0100 97 6)) chgvar &DETACHDAT VALUE(%SST(&QJOV0100 110 6)) /*SNDPGMMSG MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA(&JRNNAME) */ /*SNDPGMMSG MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA(&JRNlib) */ /*SNDPGMMSG MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA(&ATTACHDAT) */ /*SNDPGMMSG MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA(&DETACHDAT) */ ENDPGM Thanks to Germann Ergang


And another example (CLLE). /*------------------------------------------------------------*/ /* GETLSTSEQP() - GET LAST SEQUENCE EXT STORED PROCEDURE */ /* BASED ON CODE BY BRUCE VINING */ /*------------------------------------------------------------*/ PGM PARM(&RCVRNAME &RCVRLIB &SEQNBR) DCL VAR(&RCVRNAME) TYPE(*CHAR) LEN(10) DCL VAR(&RCVRLIB) TYPE(*CHAR) LEN(10) DCL VAR(&RCV) TYPE(*CHAR) LEN(512) DCL VAR(&RCVLEN) TYPE(*CHAR) LEN(4) DCL VAR(&JRNRCV) TYPE(*CHAR) LEN(20) DCL VAR(&SEQNBR) TYPE(*CHAR) LEN(20) DCL VAR(&RCVRINFO) TYPE(*CHAR) LEN(20) CHGVAR VAR( %bin(&RCVLEN )) VALUE(512) CHGVAR %SST(&RCVRINFO 1 10) &RCVRNAME CHGVAR %SST(&RCVRINFO 11 10) &RCVRLIB CALLPRC PRC('QjoRetrieveJournalInformation') + PARM((&RCV) (&RCVLEN) (&RCVRINFO) + ('RJRN0100') (X'00000000') + (*OMIT)) CHGVAR VAR(&JRNRCV) VALUE(%SST(&RCV 201 20)) CALLPRC PRC('QjoRtvJrnReceiverInformation') + PARM((&RCV) (&RCVLEN) (&JRNRCV) + ('RRCV0100') (*OMIT)) CHGVAR VAR(&SEQNBR) VALUE(%SST(&RCV 433 20)) ENDPGM Thanks to Bruce Vining.

Back

QjoRetrieveJournalEntries & QjoDeletePointerHandle

Retrieve Journal Entries & Delete Pointer Handle

     **
     **  Program summary
     **  ---------------
     **
     **  Journal and commit APIs:
     **    QjoRetrieveJournalEntries           Retrieves journal entries based on
     **                                        a variety of selection criteria.
     **
     **                                        The API provides a flexible and
     **                                        comprehensive interface to journal
     **                                        entries similar to - and also
     **                                        extending - the functions provided
     **                                        provided by journal CL commands
     **                                        like RCVJRNE and RTVJRNE.
     **
     **    QjoDeletePointerHandle              Deletes the specified pointer
     **                                        handle previously generated by the
     **                                        QjoRetrieveJournalEntries API.
     **
     **  Sequence of events:
     **    1. Initialization of the journal entry type selection criteria.
     **       A table describing the possible entry types is available here:
     **
     **       http://publib.boulder.ibm.com/iseries/v5r2/ic2924/info/rzaki/
     **         finder/rzakijournalfinderall.htm
     **
     **       All the journal entry selection records are optional - for
     **       each record not provided the default value is assumed.
     **       See API manual for the specific details.
     **
     **    2. The QjoRetrieveJournalEntries API is called until there are no
     **       more journal entries available for retrieval.
     **
     **    3. Each retrieved entry is processed - in this case written to
     **       the internally defined printer file.
     **
     **    4. If a pointer handle was returned by the API it is eventually
     **       deleted for housekeeping purposes.
     **
     **    5. After each call the journal sequence number of the last
     **       retrieved entry is used as offset for the next retrieval.
     **       See note below.
     **
     **
     **  Programmer's notes:
     **    Earliest release program will run:  V4R4
     **
     **    The RJNE0100 format has a potential problem when retrieving jounal
     **    entries from a chain of receivers.  If a journal sequence number
     **    reset occurs and the API has to be called repeatedly to retrieve
     **    all available entries a looping condition might be created.
     **
     **    The journal sequence number for this format is the offset for a
     **    continued retrieval progressing through the receiver chain.  A
     **    reset of the sequence number could therefore possibly lead to an
     **    offset number also found in an earlier receiver, creating a loop
     **    around the point of reset.
     **
     **    The RJNE0200 format available on V5R2 is capable of handling this
     **    situation.
     **
     **
     **  Compile options:
     **
     **    CrtRpgMod Module( CBX1041 )  DbgView( *LIST )
     **
     **    CrtPgm    Pgm( CBX1041 )
     **              Module( CBX1041 )
     **
     **
     **-- Header specifications:  --------------------------------------------**
     H Option( *SrcStmt )  DatEdit( *DMY/ )
     **-- Printer file:  -----------------------------------------------------**
     FQSYSPRT   O    F  132        Printer  InfDs( PrtLinInf )  OflInd( *InOf )
     **-- Printer file information:  -----------------------------------------**
     D PrtLinInf       Ds
     D  PlOvfLin                      5i 0  Overlay( PrtLinInf: 188 )
     D  PlCurLin                      5i 0  Overlay( PrtLinInf: 367 )
     D  PlCurPag                      5i 0  Overlay( PrtLinInf: 369 )
     **-- System information:  -----------------------------------------------**
     D                SDs
     D  PsPgmNam         *Proc
     **-- API error data structure:  -----------------------------------------**
     D ApiError        Ds
     D  AeBytPrv                     10i 0 Inz( %Size( ApiError ))
     D  AeBytAvl                     10i 0
     **-- Global variables:  -------------------------------------------------**
     D Idx             s             10i 0
     D EntDta          s           4096a   Varying
     **
     D Time            s              6s 0
     D NbrRcds         s             10u 0
     D JrnDta          s             18a
     **-- Retrieve journal entry data:  --------------------------------------**
     D JeRcvVar        Ds         32767    Align
     D  JhJrnHdr
     D   JhBytRtn                    10i 0 Overlay( JhJrnHdr: 1 )
     D   JhOfsHdrJrnE                10i 0 Overlay( JhJrnHdr: *Next )
     D   JhNbrEntRtv                 10i 0 Overlay( JhJrnHdr: *Next )
     D   JhConHdl                     1a   Overlay( JhJrnHdr: *Next )
     **-- Entry header:
     D JeEntHdr        Ds                  Based( pEntHdr )
     D  JeOfsHdrJrnE                 10i 0
     D  JeOfsNulValI                 10i 0
     D  JeOfsEntDta                  10i 0
     D  JePtrHdl                     10u 0
     D  JeSeqNbr                     20s 0
     D  JeJrnCde                      1a
     D  JeEntTyp                      2a
     D  JeTimStp                     26a
     D  JeJobNam                     10a
     D  JeUsrNam                     10a
     D  JeJobNbr                      6a
     D  JePgmNam                     10a
     D  JeObject                     30a
     D  JeCntRrn                     10a
     D  JeIndFlg                      1a
     D  JeCmtCci                     20a
     D  JeUsrPrf                     10a
     D  JeSysNam                      8a
     D  JeJrnId                      10a
     D  JeRefCst                      1a
     D  JeTrg                         1a
     D  JeIncDta                      1a
     D  JeObjNamInd                   1a
     D  JeIgnJrnChg                   1a
     D  JeMinEntDta                   1a
     **-- Null values (*VARLEN):
     D JeNulValVar     Ds                  Based( pNulVal )
     D  JnNulValLen                  10i 0
     D  JnNulValIndV                512a
     **-- Null values (length):
     D JeNulValLen     Ds                  Based( pNulVal )
     D  JnNulValIndL                512a
     **-- Entry data:
     D JeEntDta        Ds                  Based( pEntDta )
     D  JdEntDtaLen                   5s 0
     D                               11a
     D  JdEntDta                   4096a
     **
     **-- Retrieve journal entry selection records:  -------------------------**
     D JrnEntRtv       Ds
     D  JeNbrVarRcd                  10i 0
     **-- RCVRNG - *CURRENT, *CURCHAIN
     D JrnVarR01       Ds
     D  JvR01RcdLen                  10i 0 Inz( %Size( JrnVarR01 ))
     D  JvR01Key                     10i 0 Inz( 1 )
     D  JvR01DtaLen                  10i 0 Inz( %Size( JvR01Dta ))
     D  JvR01Dta                     40a   Inz( '*CURCHAIN' )
     **-- FROMENT - *FIRST
     D JrnVarR02       Ds
     D  JvR02RcdLen                  10i 0 Inz( %Size( JrnVarR02 ))
     D  JvR02Key                     10i 0 Inz( 2 )
     D  JvR02DtaLen                  10i 0 Inz( %Size( JvR02Dta ))
     D  JvR02Dta                     20a   Inz( '*FIRST' )
     **-- FROMTIME
     D JrnVarR03       Ds
     D  JvR03RcdLen                  10i 0 Inz( %Size( JrnVarR03 ))
     D  JvR03Key                     10i 0 Inz( 3 )
     D  JvR03DtaLen                  10i 0 Inz( %Size( JvR03Dta ))
     D  JvR03Dta                     26a
     **-- TOENT - *LAST
     D JrnVarR04       Ds
     D  JvR04RcdLen                  10i 0 Inz( %Size( JrnVarR04 ))
     D  JvR04Key                     10i 0 Inz( 4 )
     D  JvR04DtaLen                  10i 0 Inz( %Size( JvR04Dta ))
     D  JvR04Dta                     20a   Inz( '*LAST' )
     **-- TOTIME
     D JrnVarR05       Ds
     D  JvR05RcdLen                  10i 0 Inz( %Size( JrnVarR05 ))
     D  JvR05Key                     10i 0 Inz( 5 )
     D  JvR05DtaLen                  10i 0 Inz( %Size( JvR05Dta ))
     D  JvR05Dta                     26a
     **-- NBRENT
     D JrnVarR06       Ds
     D  JvR06RcdLen                  10i 0 Inz( %Size( JrnVarR06 ))
     D  JvR06Key                     10i 0 Inz( 6 )
     D  JvR06DtaLen                  10i 0 Inz( %Size( JvR06Dta ))
     D  JvR06Dta                     10i 0 Inz( 1000 )
     **-- JRNCDE - *ALL, *CTL / *ALLSLT, *IGNFILSLT
     D JrnVarR07       Ds
     D  JvR07RcdLen                  10i 0 Inz( %Size( JrnVarR07 ))
     D  JvR07Key                     10i 0 Inz( 7 )
     D  JvR07DtaLen                  10i 0 Inz( %Size( JvR07Dta ))
     D  JvR07Dta
     D   JcNbrCod                    10i 0 Overlay( JvR07Dta: 1 )
     D   JcJrnCod                    20a   Overlay( JvR07Dta: *Next )
     D                                     Dim( 16 )
     D    JcJrnCodVal                10a   Overlay( JcJrnCod: 1 )
     D    JcJrnCodSlt                10a   Overlay( JcJrnCod: *Next )
     **-- ENTTYP - *ALL, *RCD
     D JrnVarR08       Ds
     D  JvR08RcdLen                  10i 0 Inz( %Size( JrnVarR08 ))
     D  JvR08Key                     10i 0 Inz( 8 )
     D  JvR08DtaLen                  10i 0 Inz( %Size( JvR08Dta ))
     D  JvR08Dta
     D   JcNbrTyp                    10i 0 Overlay( JvR08Dta: 1 )
     D   JcEntTyp                    10a   Overlay( JvR08Dta: *Next )
     D                                     Dim( 16 )
     **-- JOB - *ALL
     D JrnVarR09       Ds
     D  JvR09RcdLen                  10i 0 Inz( %Size( JrnVarR09 ))
     D  JvR09Key                     10i 0 Inz( 9 )
     D  JvR09DtaLen                  10i 0 Inz( %Size( JvR09Dta ))
     D  JvR09Dta                     26a   Inz( '*ALL' )
     **-- PGM - *ALL
     D JrnVarR10       Ds
     D  JvR10RcdLen                  10i 0 Inz( %Size( JrnVarR10 ))
     D  JvR10Key                     10i 0 Inz( 10 )
     D  JvR10DtaLen                  10i 0 Inz( %Size( JvR10Dta ))
     D  JvR10Dta                     10a   Inz( '*ALL' )
     **-- USRPRF * *ALL
     D JrnVarR11       Ds
     D  JvR11RcdLen                  10i 0 Inz( %Size( JrnVarR11 ))
     D  JvR11Key                     10i 0 Inz( 11 )
     D  JvR11DtaLen                  10i 0 Inz( %Size( JvR11Dta ))
     D  JvR11Dta                     10a   Inz( '*ALL' )
     **-- CMTCYCID - *ALL
     D JrnVarR12       Ds
     D  JvR12RcdLen                  10i 0 Inz( %Size( JrnVarR12 ))
     D  JvR12Key                     10i 0 Inz( 12 )
     D  JvR12DtaLen                  10i 0 Inz( %Size( JvR12Dta ))
     D  JvR12Dta                     20a   Inz( '*ALL' )
     **-- DEPENT - *ALL, *NONE
     D JrnVarR13       Ds
     D  JvR13RcdLen                  10i 0 Inz( %Size( JrnVarR13 ))
     D  JvR13Key                     10i 0 Inz( 13 )
     D  JvR13DtaLen                  10i 0 Inz( %Size( JvR13Dta ))
     D  JvR13Dta                     10a   Inz( '*ALL' )
     **-- INCENT - *CONFIRMED, *ALL
     D JrnVarR14       Ds
     D  JvR14RcdLen                  10i 0 Inz( %Size( JrnVarR14 ))
     D  JvR14Key                     10i 0 Inz( 14 )
     D  JvR14DtaLen                  10i 0 Inz( %Size( JvR14Dta ))
     D  JvR14Dta                     10a   Inz( '*CONFIRMED' )
     **-- NULLINDLEN - *VARLEN
     D JrnVarR15       Ds
     D  JvR15RcdLen                  10i 0 Inz( %Size( JrnVarR15 ))
     D  JvR15Key                     10i 0 Inz( 15 )
     D  JvR15DtaLen                  10i 0 Inz( %Size( JvR15Dta ))
     D  JvR15Dta                     10a   Inz( '*VARLEN' )
     **-- FILE - *ALLFILE, *ALL
     D JrnVarR16       Ds
     D  JvR16RcdLen                  10i 0 Inz( %Size( JrnVarR16 ))
     D  JvR16Key                     10i 0 Inz( 16 )
     D  JvR16DtaLen                  10i 0 Inz( %Size( JvR01Dta ))
     D  JvR16Dta
     D   JcNbrFil                    10i 0 Overlay( JvR16Dta: 1 )
     D   JcFilNamQ                   30a   Overlay( JvR16Dta: *Next )
     D                                     Dim( 16 )
     D    JfFilNam                   10a   Overlay( JcFilNamQ: 1 )
     D    JfLibNam                   10a   Overlay( JcFilNamQ: *Next )
     D    JfMbrNam                   10a   Overlay( JcFilNamQ: *Next )
     **-- Retrieve journal entries:  -----------------------------------------**
     D RtvJrnE         Pr                  ExtProc( 'QjoRetrieveJournalEntries')
     D  RjRcvVar                  32767a          Options( *VarSize )
     D  RjRcvVarLen                  10i 0 Const
     D  RjJrnNamQ                    20a   Const
     D  RjRcvInfFmt                   8a   Const
     D  RjSltInf                  32767a   Const  Options( *NoPass: *VarSize )
     D  RjError                   32767a          Options( *NoPass: *VarSize )
     **-- Delete pointer handle:  --------------------------------------------**
     D DltPtrHdl       Pr                  ExtProc( 'QjoDeletePointerHandle' )
     D  DhPtrHdl                     10u 0 Const
     D  DhError                   32767a          Options( *NoPass: *VarSize )
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   Time                    Time
     C                   Except    Header
     **
     **-- Setup entry type selection criteria - replace values and number
     **-- of values if applicable for your test purposes:
     C                   Eval      JcNbrTyp    = 3
     C                   Eval      JcEntTyp(1) = 'PR'
     C                   Eval      JcEntTyp(2) = 'LG'
     C                   Eval      JcEntTyp(3) = 'SY'
     **
     **-- Replace journal name and library if appropriate for your
     **-- environment.  Journal selection entries can be added and
     **-- removed as necessary - just set JeNbrVarRcd accordingly:
     C                   Eval      JeNbrVarRcd = 3
     **
     C                   DoU       JhConHdl    = '0'           Or
     C                             AeBytAvl    > *Zero
     **
     C                   CallP     RtvJrnE( JeRcvVar
     C                                    : %Size( JeRcvVar )
     C                                    : 'QSNADS    *LIBL'
     C                                    : 'RJNE0100'
     C                                    : JrnEntRtv  +
     C                                      JrnVarR02  +
     C                                      JrnVarR06  +
     C                                      JrnVarR08
     C                                    : ApiError
     C                                    )
     **
     C                   If        AeBytAvl    = *Zero
     C                   Eval      pEntHdr     = %Addr( JeRcvVar ) +
     C                                           JhOfsHdrJrnE
     **
     C                   For       Idx = 1  to JhNbrEntRtv
     **
     C                   ExSr      PrcLstEnt
     **
     C                   If        JePtrHdl    > *Zero
     C                   CallP(e)  DltPtrHdl( JePtrHdl )
     C                   EndIf
     **
     C                   If        Idx         < JhNbrEntRtv
     C                   Eval      pEntHdr     = pEntHdr + JeOfsHdrJrnE
     C                   EndIf
     **
     C                   EndFor
     C                   EndIf
     **
     C                   Eval      JeSeqNbr    = JeSeqNbr + 1
     C                   Eval      JvR02Dta    = %EditC( JeSeqNbr: 'X' )
     C                   EndDo
     **
     C                   If        NbrRcds    =  *Zero
     C                   Except    NoRcds
     C                   EndIf
     **
     C                   Eval      *InLr       = *On
     C                   Return
     **
     **-- Process list entry:  -----------------------------------------------**
     C     PrcLstEnt     BegSr
     **
     C                   Eval      pEntDta      = pEntHdr + JeOfsEntDta
     C                   Eval      EntDta       = %SubSt( JdEntDta
     C                                                  : 1
     C                                                  : JdEntDtaLen
     C                                                  )
     **
     C                   If        JeOfsNulValI > *Zero
     C                   Eval      pNulVal      = pEntHdr + JeOfsNulValI
     C                   EndIf
     **
     C                   If        PlCurLin    > PlOvfLin - 3
     C                   Except    Header
     C                   EndIf
     **
     C                   Eval      NbrRcds    =  NbrRcds + 1
     C                   Eval      JrnDta     =  EntDta
     C                   Except    Detail
     **
     C                   EndSr
     **-- Print file definition:  --------------------------------------------**
     OQSYSPRT   EF           Header         2  3
     O                       UDATE         Y      8
     O                       Time                18 '  :  :  '
     O                                           75 'Print journal entries -
     O                                              report'
     O                                          107 'Program:'
     O                       PsPgmNam           118
     O                                          126 'Page:'
     O                       PAGE             +   1
     OQSYSPRT   EF           Header         1
     O                                           20 'Journal seq. nbr.'
     O                                           25 'Code'
     O                                           30 'Type'
     O                                           40 'Timestamp'
     O                                           62 'Job'
     O                                           75 'User'
     O                                           88 'Number'
     O                                           97 'Program'
     O                                          109 'User id'
     O                                          129 'Entry data 1-18'
     **
     OQSYSPRT   EF           Detail         1
     O                       JeSeqNbr      3     20
     O                       JeJrnCde            24
     O                       JeEntTyp            29
     O                       JeTimStp            57
     O                       JeJobNam            69
     O                       JeUsrNam            81
     O                       JeJobNbr            88
     O                       JePgmNam           100
     O                       JeUsrPrf           112
     O                       JrnDta             132
     **
     OQSYSPRT   EF           NoRcds      1
     O                                           26 '(No entries found)'

The same API, but for V5R2

** ** Program summary ** --------------- ** ** Journal and commit APIs: ** QjoRetrieveJournalEntries Retrieves journal entries based on ** a variety of selection criteria. ** ** The API provides a flexible and ** comprehensive interface to journal ** entries similar to - and also ** extending - the functions provided ** provided by journal CL commands ** like RCVJRNE and RTVJRNE. ** ** QjoDeletePointerHandle Deletes the specified pointer ** handle previously generated by the ** QjoRetrieveJournalEntries API. ** ** Miscellaneous APIs: ** QWCCVTDT Convert date and Converts date and time values from ** time format one format to another, including a ** system timestamp of type *DTS to ** character format. ** C library function: ** tstbts Test bits Tests the bit value of the bit ** located with the bit offset ** parameter, bit 0 being the ** leftmost and 64k the maximum. ** ** ** Sequence of events: ** 1. Initialization of the journal entry type selection criteria. ** A table describing the possible entry types is available here: ** ** http://publib.boulder.ibm.com/iseries/v5r2/ic2924/info/rzaki/ ** finder/rzakijournalfinderall.htm ** ** All the journal entry selection records are optional - for ** each record not provided the default value is assumed. ** See API manual for the specific details. ** ** 2. The QjoRetrieveJournalEntries API is called until there are no ** more journal entries available for retrieval. ** ** 3. Each retrieved entry is processed - in this case written to ** the internally defined printer file. ** ** 4. The entry's timestamp is converted from system timestamp to ** character format prior to printing. ** ** 5. Some entry information is provided in the form of bit fields ** retrieved using a C library function. ** ** 6. If a pointer handle was returned by the API it is eventually ** deleted for housekeeping purposes. ** ** 7. After each call the continuation information returned in the ** entry header data - including continuation journal sequence ** number and receiver name - is used to offset the next entry ** retrieval correctly. ** ** ** Programmer's notes: ** Earliest release program will run: V5R2 ** ** ** Compile options: ** ** CrtRpgMod Module( CBX1042 ) DbgView( *LIST ) ** ** CrtPgm Pgm( CBX1042 ) ** Module( CBX1042 ) ** ** **-- Header specifications: --------------------------------------------** H Option( *SrcStmt ) BndDir( 'QC2LE' ) DatEdit( *DMY/ ) **-- Printer file: -----------------------------------------------------** FQSYSPRT O F 132 Printer InfDs( PrtLinInf ) OflInd( *InOf ) **-- Printer file information: -----------------------------------------** D PrtLinInf Ds D PlOvfLin 5i 0 Overlay( PrtLinInf: 188 ) D PlCurLin 5i 0 Overlay( PrtLinInf: 367 ) D PlCurPag 5i 0 Overlay( PrtLinInf: 369 ) **-- System information: -----------------------------------------------** D SDs D PsPgmNam *Proc **-- API error data structure: -----------------------------------------** D ApiError Ds D AeBytPrv 10i 0 Inz( %Size( ApiError )) D AeBytAvl 10i 0 **-- Global variables: -------------------------------------------------** D Idx s 10i 0 D EntDta s 4096a Varying ** D Time s 6s 0 D NbrRcds s 10u 0 D JrnEntDts s 20a Inz( *All'0' ) D JrnDta s 24a **-- Retrieve journal entry data: --------------------------------------** D JeRcvVar Ds Align D JhJrnHdr D JhBytRtn 10i 0 Overlay( JhJrnHdr: 1 ) D JhOfsHdrJrnE 10i 0 Overlay( JhJrnHdr: *Next ) D JhNbrEntRtv 10i 0 Overlay( JhJrnHdr: *Next ) D JhConInd 1a Overlay( JhJrnHdr: *Next ) D JhConRcvStr 10a Overlay( JhJrnHdr: *Next ) D JhConLibStr 10a Overlay( JhJrnHdr: *Next ) D JhConSeqNbr 20s 0 Overlay( JhJrnHdr: *Next ) D 11a Overlay( JhJrnHdr: *Next ) D JeData 32754a **-- Entry header: D JeEntHdr Ds Based( pEntHdr ) D JeOfsHdrJrnE 10u 0 D JeOfsNulValI 10u 0 D JeOfsEntDta 10u 0 D JeOfsTrnId 10u 0 D JeOfsLglUoW 10u 0 D JeOfsRcvInf 10u 0 D JeSeqNbr 20u 0 D JeTimStp 20u 0 D JeTimStpC 8a Overlay( JeTimStp ) D JeThrId 20u 0 D JeSysSeqNbr 20u 0 D JeCntRrn 20u 0 D JeCmtCclId 20u 0 D JePtrHdl 10u 0 D JeRmtPort 5u 0 D JeArmNbr 5u 0 D JePgmLibAsp 5u 0 D JeRmtAdr 16a D JeJrnCde 1a D JeEntTyp 2a D JeJobNam 10a D JeUsrNam 10a D JeJobNbr 6a D JePgmNam 10a D JePgmLib 10a D JePgmLibAspDv 10a D JeObject 30a D JeUsrPrf 10a D JeJrnId 10a D JeAdrFam 1a D JeSysNam 8a D JeIndFlg 1a D JeObjNamInd 1a D JeBitFld 1a D JeRsv 9a ** ** JeBitFld: D Ds D JbRefCst 1s 0 D JbTrg 1s 0 D JbIncDta 1s 0 D JbIgnApyRmvJ 1s 0 D JbMinEntDta 1s 0 D JbRsv 3a **-- Null values - *VARLEN: D JeNulValVar Ds Based( pNulVal ) D JnNulValLen 10i 0 D JnNulValIndV 512a **-- Null values - length: D JeNulValLen Ds Based( pNulVal ) D JnNulValIndL 512a **-- Entry data: D JeEntDta Ds Based( pEntDta ) D JdEntDtaLen 5s 0 D 11a D JdEntDta 4096a **-- Logical unit of work: D JeLglUoW Ds Based( pLglUow ) D JuLglUoW 39a **-- Receiver information: D JeRcvInf Ds Based( pRcvInf ) D JrRcvNam 10a D JrRcvLib 10a D JrRcvLibAspDv 10a D JrRcvLibAspNb 5i 0 ** **-- Retrieve journal entry selection records: -------------------------** D JrnEntRtv Ds D JeNbrVarRcd 10i 0 **-- RCVRNG - *CURRENT, *CURCHAIN D JrnVarR01 Ds D JvR01RcdLen 10i 0 Inz( %Size( JrnVarR01 )) D JvR01Key 10i 0 Inz( 1 ) D JvR01DtaLen 10i 0 Inz( %Size( JvR01Dta )) D JvR01Dta 40a Inz( '*CURCHAIN' ) D JvR01RcvStr 10a Overlay( JvR01Dta: 1 ) D JvR01LibStr 10a Overlay( JvR01Dta: *Next ) D JvR01RcvEnd 10a Overlay( JvR01Dta: *Next ) D JvR01LibEnd 10a Overlay( JvR01Dta: *Next ) **-- FROMENT - *FIRST D JrnVarR02 Ds D JvR02RcdLen 10i 0 Inz( %Size( JrnVarR02 )) D JvR02Key 10i 0 Inz( 2 ) D JvR02DtaLen 10i 0 Inz( %Size( JvR02Dta )) D JvR02Dta 20a Inz( '*FIRST' ) D JvR02SeqNbr 20s 0 Overlay( JvR02Dta ) **-- FROMTIME D JrnVarR03 Ds D JvR03RcdLen 10i 0 Inz( %Size( JrnVarR03 )) D JvR03Key 10i 0 Inz( 3 ) D JvR03DtaLen 10i 0 Inz( %Size( JvR03Dta )) D JvR03Dta 26a **-- TOENT - *LAST D JrnVarR04 Ds D JvR04RcdLen 10i 0 Inz( %Size( JrnVarR04 )) D JvR04Key 10i 0 Inz( 4 ) D JvR04DtaLen 10i 0 Inz( %Size( JvR04Dta )) D JvR04Dta 20a Inz( '*LAST' ) **-- TOTIME D JrnVarR05 Ds D JvR05RcdLen 10i 0 Inz( %Size( JrnVarR05 )) D JvR05Key 10i 0 Inz( 5 ) D JvR05DtaLen 10i 0 Inz( %Size( JvR05Dta )) D JvR05Dta 26a **-- NBRENT D JrnVarR06 Ds D JvR06RcdLen 10i 0 Inz( %Size( JrnVarR06 )) D JvR06Key 10i 0 Inz( 6 ) D JvR06DtaLen 10i 0 Inz( %Size( JvR06Dta )) D JvR06Dta 10i 0 Inz( 1000 ) **-- JRNCDE - *ALL, *CTL / *ALLSLT, *IGNFILSLT D JrnVarR07 Ds D JvR07RcdLen 10i 0 Inz( %Size( JrnVarR07 )) D JvR07Key 10i 0 Inz( 7 ) D JvR07DtaLen 10i 0 Inz( %Size( JvR07Dta )) D JvR07Dta D JcNbrCod 10i 0 Overlay( JvR07Dta: 1 ) D JcJrnCod 20a Overlay( JvR07Dta: *Next ) D Dim( 16 ) D JcJrnCodVal 10a Overlay( JcJrnCod: 1 ) D JcJrnCodSlt 10a Overlay( JcJrnCod: *Next ) **-- ENTTYP - *ALL, *RCD D JrnVarR08 Ds D JvR08RcdLen 10i 0 Inz( %Size( JrnVarR08 )) D JvR08Key 10i 0 Inz( 8 ) D JvR08DtaLen 10i 0 Inz( %Size( JvR08Dta )) D JvR08Dta D JcNbrTyp 10i 0 Overlay( JvR08Dta: 1 ) D JcEntTyp 10a Overlay( JvR08Dta: *Next ) D Dim( 16 ) **-- JOB - *ALL D JrnVarR09 Ds D JvR09RcdLen 10i 0 Inz( %Size( JrnVarR09 )) D JvR09Key 10i 0 Inz( 9 ) D JvR09DtaLen 10i 0 Inz( %Size( JvR09Dta )) D JvR09Dta 26a Inz( '*ALL' ) **-- PGM - *ALL D JrnVarR10 Ds D JvR10RcdLen 10i 0 Inz( %Size( JrnVarR10 )) D JvR10Key 10i 0 Inz( 10 ) D JvR10DtaLen 10i 0 Inz( %Size( JvR10Dta )) D JvR10Dta 10a Inz( '*ALL' ) **-- USRPRF * *ALL D JrnVarR11 Ds D JvR11RcdLen 10i 0 Inz( %Size( JrnVarR11 )) D JvR11Key 10i 0 Inz( 11 ) D JvR11DtaLen 10i 0 Inz( %Size( JvR11Dta )) D JvR11Dta 10a Inz( '*ALL' ) **-- CMTCYCID - *ALL D JrnVarR12 Ds D JvR12RcdLen 10i 0 Inz( %Size( JrnVarR12 )) D JvR12Key 10i 0 Inz( 12 ) D JvR12DtaLen 10i 0 Inz( %Size( JvR12Dta )) D JvR12Dta 20a Inz( '*ALL' ) **-- DEPENT - *ALL, *NONE D JrnVarR13 Ds D JvR13RcdLen 10i 0 Inz( %Size( JrnVarR13 )) D JvR13Key 10i 0 Inz( 13 ) D JvR13DtaLen 10i 0 Inz( %Size( JvR13Dta )) D JvR13Dta 10a Inz( '*ALL' ) **-- INCENT - *CONFIRMED, *ALL D JrnVarR14 Ds D JvR14RcdLen 10i 0 Inz( %Size( JrnVarR14 )) D JvR14Key 10i 0 Inz( 14 ) D JvR14DtaLen 10i 0 Inz( %Size( JvR14Dta )) D JvR14Dta 10a Inz( '*CONFIRMED' ) **-- NULLINDLEN - *VARLEN D JrnVarR15 Ds D JvR15RcdLen 10i 0 Inz( %Size( JrnVarR15 )) D JvR15Key 10i 0 Inz( 15 ) D JvR15DtaLen 10i 0 Inz( %Size( JvR15Dta )) D JvR15Dta 10a Inz( '*VARLEN' ) **-- FILE - *ALLFILE, *ALL D JrnVarR16 Ds D JvR16RcdLen 10i 0 Inz( %Size( JrnVarR16 )) D JvR16Key 10i 0 Inz( 16 ) D JvR16DtaLen 10i 0 Inz( %Size( JvR01Dta )) D JvR16Dta D JcNbrFil 10i 0 Overlay( JvR16Dta: 1 ) D JcFilNamQ 30a Overlay( JvR16Dta: *Next ) D Dim( 16 ) D JfFilNam 10a Overlay( JcFilNamQ: 1 ) D JfLibNam 10a Overlay( JcFilNamQ: *Next ) D JfMbrNam 10a Overlay( JcFilNamQ: *Next ) **-- Retrieve journal entries: -----------------------------------------** D RtvJrnE Pr ExtProc( 'QjoRetrieveJournalEntries') D RjRcvVar 32767a Options( *VarSize ) D RjRcvVarLen 10i 0 Const D RjJrnNamQ 20a Const D RjRcvInfFmt 8a Const D RjSltInf 32767a Const Options( *NoPass: *VarSize ) D RjError 32767a Options( *NoPass: *VarSize ) **-- Delete pointer handle: --------------------------------------------** D DltPtrHdl Pr ExtProc( 'QjoDeletePointerHandle' ) D DhPtrHdl 10u 0 Const D DhError 32767a Options( *NoPass: *VarSize ) **-- Test bit in string: -----------------------------------------------** D tstbts Pr 10i 0 ExtProc( 'tstbts' ) D String * Value D BitOfs 10u 0 Value **-- Convert date & time: ----------------------------------------------** D CvtDtf Pr ExtPgm( 'QWCCVTDT' ) D CdInpFmt 10a Const D CdInpVar 17a Const Options( *VarSize ) D CdOutFmt 10a Const D CdOutVar 17a Options( *VarSize ) D CdError 10i 0 Const ** **-- Mainline: ---------------------------------------------------------** ** C Time Time C Except Header ** **-- Setup entry type selection criteria - replace values and number **-- of values if applicable for your test purposes: C Eval JcNbrTyp = 3 C Eval JcEntTyp(1) = 'PR' C Eval JcEntTyp(2) = 'LG' C Eval JcEntTyp(3) = 'SY' ** **-- Replace journal name and library if appropriate for your **-- environment. Journal selection entries can be added and **-- removed as necessary - just set JeNbrVarRcd accordingly: C Eval JeNbrVarRcd = 4 ** C DoU JhConInd = '0' Or C AeBytAvl > *Zero ** C CallP RtvJrnE( JeRcvVar C : %Size( JeRcvVar ) C : 'QSNADS *LIBL ' C : 'RJNE0200' C : JrnEntRtv + C JrnVarR01 + C JrnVarR02 + C JrnVarR06 + C JrnVarR08 C : ApiError C ) ** C If AeBytAvl = *Zero C Eval pEntHdr = %Addr( JeRcvVar ) + C JhOfsHdrJrnE ** C For Idx = 1 to JhNbrEntRtv ** C ExSr PrcLstEnt ** C If JePtrHdl > *Zero C CallP(e) DltPtrHdl( JePtrHdl ) C EndIf ** C If Idx < JhNbrEntRtv C Eval pEntHdr = pEntHdr + JeOfsHdrJrnE C EndIf ** C EndFor ** C If JhConInd = '1' C Eval JvR01RcvStr = JhConRcvStr C Eval JvR01LibStr = JhConLibStr C Eval JvR01RcvEnd = '*CURRENT' C Eval JvR02SeqNbr = JhConSeqNbr C EndIf C EndIf ** C EndDo ** C If NbrRcds = *Zero C Except NoRcds C EndIf ** C Eval *InLr = *On C Return ** **-- Process list entry: -----------------------------------------------** C PrcLstEnt BegSr ** C Eval JbRefCst = tstbts( %Addr( JeBitFld ): 0 ) C Eval JbTrg = tstbts( %Addr( JeBitFld ): 1 ) C Eval JbIncDta = tstbts( %Addr( JeBitFld ): 2 ) C Eval JbIgnApyRmvJ = tstbts( %Addr( JeBitFld ): 3 ) C Eval JbMinEntDta = tstbts( %Addr( JeBitFld ): 4 ) ** C Eval pEntDta = pEntHdr + JeOfsEntDta C Eval EntDta = %SubSt( JdEntDta C : 1 C : JdEntDtaLen C ) ** C If JeOfsNulValI > *Zero C Eval pNulVal = pEntHdr + JeOfsNulValI C EndIf ** C If JeOfsLglUoW > *Zero C Eval pLglUow = pEntHdr + JeOfsLglUoW C EndIf ** C If JeOfsRcvInf > *Zero C Eval pRcvInf = pEntHdr + JeOfsRcvInf C EndIf ** C If PlCurLin > PlOvfLin - 3 C Except Header C EndIf ** C Eval NbrRcds = NbrRcds + 1 C Eval JrnDta = EntDta ** C CallP CvtDtf( '*DTS' C : JeTimStpC C : '*YYMD' C : JrnEntDts C : 0 C ) ** C Except Detail ** C EndSr **-- Print file definition: --------------------------------------------** OQSYSPRT EF Header 2 3 O UDATE Y 8 O Time 18 ' : : ' O 75 'Print journal entries - O report' O 107 'Program:' O PsPgmNam 118 O 126 'Page:' O PAGE + 1 OQSYSPRT EF Header 1 O 20 'Journal seq. nbr.' O 25 'Code' O 30 'Type' O 40 'Timestamp' O 56 'Job' O 69 'User' O 82 'Number' O 91 'Program' O 103 'User id' O 123 'Entry data 1-24' ** OQSYSPRT EF Detail 1 O JeSeqNbr 3 20 O JeJrnCde 24 O JeEntTyp 29 O JrnEntDts 51 O JeJobNam 63 O JeUsrNam 75 O JeJobNbr 82 O JePgmNam 94 O JeUsrPrf 106 O JrnDta 132 ** OQSYSPRT EF NoRcds 1 O 26 '(No entries found)' Thanks to Carsten Flensburg

Back

Page #2 Page #4

Back