|
#2 |
API - Table of Contents |
#4 |
|
|
|
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
