/*CRT** CRTRPGMOD dbgview(*none) ****************************************************************** ** ** Service routines ** AddUsrIdxEntry Add User Index Entry ** CrtUsrIdx Create User Index ** Execute Execute Command ** GetObjTxt Get Object Text ** malloc - Allocate memory ** MovPgmMsg Move Program Messages ** ObjExist Check if Object Exists ** RmvPgmMsg Remove Program Messages ** RSndEscMsg Resend Escape Message ** RtvUsrIdxEntry Retrieve User Index Entry ** SndPgmMsg Send Program Message ** SndStsMsg Send Status Message to *EXT ** ** Programmer Date Change reason ** USE DSPHIST COMMAND TO DISPLAY CHANGE HISTORY ** ****************************************************************** H datedit(*YMD) NOMAIN H/copy utlsrc,copyright D oldObjD0200 ds 180 export('OBJD0200') d RtvOBJD0200 pr 180 D xObj 10 const D xLib 10 const D xObjType 10 const D RtvUsrIdxAttr pr D xUsrIdx 10 const D xUsrIdxLib 10 const D xKeyLen 9b 0 D xDtaLen 9b 0 D/COPY utlsrc,UTLSYS_PR ****************************************************************** ** Retrieve Object Description ****************************************************************** P RtvOBJD0200 b D pi 180 D xObj 10 const D xLib 10 const D xObjType 10 const D ObjD0200 ds 180 D QUSROBJD pr extpgm('QUSROBJD') D Rcv 180 D RcvLen 9b 0 const D Fmt 8 const D ObjName 20 const D ObjType 10 const D ErrorCode 8 D ds D wErr 8 D wErr1 9b 0 inz(8) overlay(wErr) D wErr2 9b 0 inz overlay(wErr:5) C callp QUSROBJD (ObjD0200 : %size(ObjD0200) : C 'OBJD0200' : xObj + xlib : xObjType : wErr) C if wErr2 = 0 C return ObjD0200 C else C return *blanks C endif P RtvOBJD0200 e ****************************************************************** ** RtvUsrIdxAttr ****************************************************************** P RtvUsrIdxAttr b D pi D xUsrIdx 10 const D xUsrIdxLib 10 const D xKeyLen 9b 0 D xDtaLen 9b 0 D QUSRUIAT pr extpgm('QUSRUIAT') D 60 Receiver variable D 9b 0 const Length of receiver D 8 const Format D 20 const User Index D 8 Error Code D wErr s 8 inz(x'0000000000000000') D wRcv ds 60 D wDtaLen 37 40b 0 D wKeyLen 45 48b 0 D wRcvLen s 9b 0 inz(%size(wRcv)) C callp QUSRUIAT (wRcv : wRcvLen : 'IDXA0100' : C xUsrIdx + xUsrIdxLib : wErr) C eval xKeyLen = wKeyLen C eval xDtaLen = wDtaLen C return P RtvUsrIdxAttr e ****************************************************************** ** AddUsrIdxEntry ****************************************************************** P AddUsrIdxEntry b export D pi 1 D xUsrIdx 10 const D xUsrIdxLib 10 const D xReplace 1 const D xData 2000 const options(*varsize) D QUSADDUI pr extpgm('QUSADDUI') D 10 Returned Library Nam D 9b 0 # of entries added D 20 const User Index D 9b 0 const Insert type D 2000 const Index entries D 9b 0 const Length of Index entr D 16 const Entry Length & offse D 9b 0 const # of entries D 8 Error Code D ds D wErr 8 D wErrPrv 9b 0 inz(8) overlay(wErr) D wErrAvl 9b 0 inz(0) overlay(wErr:5) D wDtaLen s 9b 0 D wELO s 16 D wInsType s 9b 0 D wKeyLen s 9b 0 D wNbrEntries s 9b 0 D wRtnLib s 10 D wSts s 1 C if xReplace = '1' C eval wInsType = 2 C else C eval wInsType = 3 C endif C callp RtvUsrIdxAttr ( xUsrIdx : xUsrIdxLib : c wKeyLen : wDtaLen) C callp QUSADDUI (wRtnLib : wNbrEntries : C xUsrIdx + xUsrIdxLib : wInsType : xData : C wDtaLen : wELO : 1 : wErr) C if wNbrEntries < 1 C eval wSts = '1' C else C eval wSts = '0' C endif C return wSts P AddUsrIdxEntry e ****************************************************************** ** CrtUsrIdx ****************************************************************** P CrtUsrIdx b export D pi D xUsrIdx 10 const D xUsrIdxLib 10 const D xKeyLen 5 0 const D xDtaLen 5 0 const D QUSCRTUI pr extpgm('QUSCRTUI') D 20 const User Index D 10 const Extended Attribute D 1 const Entry Length Attribu D 9b 0 const Entry Length D 1 const Key Insertion D 9b 0 const Key Length D 1 const Immediate Update D 1 const Optimization D 10 const Public authority D 50 const Text Description D 10 const Replace D 8 Error Code D wErr s 8 inz(x'0000000000000000') C callp QUSCRTUI (xUsrIdx + xUsrIdxLib : 'FIGU' : 'F' C : xDtaLen : '1' : xKeyLen : '0' : '1' : C '*ALL' : 'Temporary index' : '*YES' : wErr) C return P CrtUsrIdx e ****************************************************************** ** Execute Command ****************************************************************** P Execute b export D pi D xCommand 6000 const D xIgnErr 1 const options(*nopass) D QCMDEXC pr extpgm('QCMDEXC') D 6000 D 15 5 D wCommand s 6000 D wCmdLen s 15 5 C eval wCommand = xCommand C eval wCmdLen = %len(%trimr(wCommand)) C if %parms = 1 or xIgnErr <> '1' C callp QCMDEXC (wCommand : wCmdLen) C else C call 'QCMDEXC' 99 C parm wCommand C parm wCmdLen C endif C return P Execute e ****************************************************************** ** Get Object Attributes ****************************************************************** P GetObjAtr b export D pi 10 D xObj 10 const D xLib 10 const D xObjType 10 const D objd0200 ds 180 D wObjAtr 91 100 C eval objd0200 = RtvOBJD0200 (xobj : xlib : C xObjType) C return wObjAtr P GetObjAtr e ****************************************************************** ** GetObjTxt ****************************************************************** P GetObjTxt b export D pi 50 D xObj 10 const D xLib 10 const D xObjType 10 const D objd0200 ds 180 D wObjTxt 101 150 C eval objd0200 = RtvOBJD0200 (xobj : xlib : C xObjType) C return wObjTxt P GetObjTxt e *********************************************************************************************** ** Allocate memory *********************************************************************************************** p malloc b export d pi * d xSize 9b 0 const d pPtr s * C alloc xSize pPtr C return pPtr p malloc e *********************************************************************************************** ** MovPgmMsg *********************************************************************************************** P MovPgmMsg b export D pi D QMHMOVPM pr extpgm('QMHMOVPM') D 4 Message Key D 10 dim(3) Msg types to move D 9b 0 Nbr of types to move D 10 const Call Stack Entry D 9b 0 const Call Stack Counter D 8 Error Code D wMsgKey s 4 D wMsgTypes s 10 dim(3) D wNbrMsgTyp s 9b 0 inz(3) D wErr s 8 inz(x'0000000000000000') C eval wMsgTypes(1) = '*COMP' C eval wMsgTypes(2) = '*DIAG' C eval wMsgTypes(3) = '*INFO' C callp QMHMOVPM (wMsgKey : wMsgTypes : wNbrMsgTyp : C '*' : 2 : wErr) C return P MovPgmMsg e ****************************************************************** ** Check if object exists ****************************************************************** P ObjExist b export D pi n D xObj 10 const D xLib 10 const D xObjType 10 const D QUSROBJD pr extpgm('QUSROBJD') D Rcv 90 D RcvLen 9b 0 const D Fmt 8 const D ObjName 20 const D ObjType 10 const D ErrorCode 8 D objd0100 ds 90 D ds D wErr 8 D wErr1 9b 0 inz(8) overlay(wErr) D wErr2 9b 0 inz overlay(wErr:5) C callp QUSROBJD (objd0100 : %size(objd0100) : C 'OBJD0100' : xObj + xLib : xObjType : C wErr) C if wErr2 = 0 C return '1' C else C return '0' C endif P ObjExist e ****************************************************************** ** RmvPgmMsg ****************************************************************** P RmvPgmMsg b export D pi D xMsgDest 10 const options(*nopass) D xMsgOpt 10 const options(*nopass) D QMHRMVPM pr extpgm('QMHRMVPM') D 10 Call Stack Entry D 9b 0 Call Stack Counter D 4 Message Key D 10 Messages to remove D 8 Error Code D wCSE s 10 inz('*') D wCSC s 9b 0 inz(1) D wMsgKey s 4 inz D wMsgOpt s 10 D wErr s 8 inz(x'0000000000000000') C if %parms >= 1 C if xMsgDest = '*PRV' C eval wCSC = 2 C else C eval wCSE = xMsgDest C endif C endif C if %parms >= 2 C eval wMsgOpt = xMsgOpt C else C eval wMsgOpt = '*ALL' C endif C callp QMHRMVPM (wCSE : wCSC : wMsgKey : C wMsgOpt : wErr) C return P RmvPgmMsg e *********************************************************************************************** ** RSndEscMsg *********************************************************************************************** P RSndEscMsg b export D pi D QMHRSNEM pr extpgm('QMHRSNEM') D 4 Message Key D 8 Error Code D wMsgKey s 4 D wErr s 8 inz(x'0000000000000000') C callp QMHRSNEM (wMsgKey : wErr) C return P RSndEscMsg e ****************************************************************** ** RtvUsrIdxEntry ****************************************************************** P RtvUsrIdxEntry b export D pi 1 D xData 2000 options(*varsize) D xUsrIdx 10 const D xUsrIdxLib 10 const D xKeyOpt 3 const D xKey 2000 const options(*varsize) D QUSRTVUI pr extpgm('QUSRTVUI') D 2008 Receiver variable D 9b 0 const Length of receiver D 8 Entry Length & offse D 9b 0 const Length of ent len & D 9b 0 # entries returned D 10 Returned Library Nam D 20 const User Index D 8 const Format D 9b 0 const Maximum # of entries D 9b 0 const Search type D 2000 const Search criteria D 9b 0 const Length of Search cri D 9b 0 const Search criteria offs D 8 Error Code D wDtaLen s 9b 0 D wELO s 8 D wELOLen s 9b 0 inz(%size(wELO)) D wErr s 8 inz(x'0000000000000000') D wNbrEntries s 9b 0 D wKey s 2000 D wKeyLen s 9b 0 D wKeyOpt s 9b 0 D wRcv s 2008 D wRcvLen s 9b 0 inz(%size(wRcv)) D wRtnLib s 10 D wSts s 1 C select C when xKeyOpt = 'EQ' C eval wKeyOpt = 1 C when xKeyOpt = 'GT' C eval wKeyOpt = 2 C when xKeyOpt = 'LT' C eval wKeyOpt = 3 C when xKeyOpt = 'GE' C eval wKeyOpt = 4 C when xKeyOpt = 'LE' C eval wKeyOpt = 5 C when xKeyOpt = 'TOP' C eval wKeyOpt = 6 C when xKeyOpt = 'BOT' C eval wKeyOpt = 7 C other C eval wKeyOpt = 0 C eval wSts = '1' C endsl C if wKeyOpt > 0 C callp RtvUsrIdxAttr ( xUsrIdx : xUsrIdxLib : C wKeyLen : wDtaLen) C eval wKey = xKey C callp QUSRTVUI (wRcv : wRcvLen : wELO : WELOLen C : wNbrEntries : wRtnLib : C xUsrIdx + xUsrIdxLib : 'IDXE0100' : 1 : C wKeyOpt : wKey : wKeyLen : 0 : wErr) C if wNbrEntries < 1 C eval wSts = '1' C else C eval wSts = '0' C eval %subst(xData : 1 : wDtaLen) = %subst(wRcv:9) C endif C endif C return wSts P RtvUsrIdxEntry e ****************************************************************** ** SndPgmMsg ****************************************************************** P SndPgmMsg b export D pi opdesc D xMsgId 7 const D xMsgF 20 const options(*varsize) D xMsgDta 2048 const options(*nopass : *varsize) D xMsgDest 10 const options(*nopass) D QMHSNDPM pr extpgm('QMHSNDPM') D 7 const Message Id D 20 Message File D 2048 Message Data D 9b 0 Message Data Length D 10 const Message Type D 10 Call Stack Entry D 9b 0 Call Stack Counter D 4 Message Key D 8 Error Code D CEETSTA pr D 10i 0 D ParmNum 10i 0 const D 12a options(*omit) D CEEGSI pr D ParmNum 10i 0 const D 10i 0 D 10i 0 D 10i 0 D 12a options(*omit) * Parameters passed to CEETSTA, CEEGSI D wArg s 10i 0 D wSIType s 10i 0 D wSiLen s 10i 0 D wSIMaxLen s 10i 0 D wMsgFile ds D wMsgF 10 D wMsgFLib 10 D wMsgDta s 2048 D wMsgDtaLen s 9b 0 inz D wCSE s 10 inz('*') D wCSC s 9b 0 inz(1) D wMsgKey s 4 inz D wErr s 8 inz(x'0000000000000000') C callp CEEGSI (2 : wSIType : wSILen : C wSIMaxLen : *OMIT) C eval wMsgF = xMsgF C if wSILen < 10 C eval wMsgFLib = '*LIBL' C endif C if %parms >= 3 C callp CEETSTA (wArg : 3 : *omit) C if wArg = 1 C callp CEEGSI (3 : wSIType : wSILen : C wSIMaxLen : *OMIT) C eval wMsgDta = xMsgDta C eval wMsgDtaLen = wSILen C endif C callp CEETSTA (wArg : 4 : *omit) C if wArg = 1 C if xMsgDest = '*PRV' C eval wCSC = 2 C else C eval wCSE = xMsgDest C endif C endif C endif C callp QMHSNDPM (xMsgID : wMsgFile : wMsgDta : C wMsgDtaLen : '*INFO' : wCSE : wCSC : C wMsgKey : wErr) C return P SndPgmMsg e ****************************************************************** ** SndStsMsg ****************************************************************** P SndStsMsg b export D pi opdesc D xMsgId 7 const D xMsgF 20 const options(*varsize) D xMsgDta 2048 const options(*nopass : *varsize) D QMHSNDPM pr extpgm('QMHSNDPM') D 7 const Message Id D 20 Message File D 2048 Message Data D 9b 0 Message Data Length D 10 const Message Type D 10 const Call Stack Entry D 9b 0 const Call Stack Counter D 4 Message Key D 8 Error Code D CEETSTA pr D 10i 0 D ParmNum 10i 0 const D 12a options(*omit) D CEEGSI pr D ParmNum 10i 0 const D 10i 0 D 10i 0 D 10i 0 D 12a options(*omit) * Parameters passed to CEETSTA, CEEGSI D wArg s 10i 0 D wSIType s 10i 0 D wSiLen s 10i 0 D wSIMaxLen s 10i 0 D wMsgFile ds D wMsgF 10 D wMsgFLib 10 D wMsgDta s 2048 D wMsgDtaLen s 9b 0 inz D wMsgKey s 4 inz D wErr s 8 inz(x'0000000000000000') C callp CEEGSI (2 : wSIType : wSILen : C wSIMaxLen : *OMIT) C eval wMsgF = xMsgF C if wSILen < 10 C eval wMsgFLib = '*LIBL' C endif C if %parms >= 3 C callp CEETSTA (wArg : 3 : *omit) C if wArg = 1 C callp CEEGSI (3 : wSIType : wSILen : C wSIMaxLen : *OMIT) C eval wMsgDta = xMsgDta C eval wMsgDtaLen = wSILen C endif C endif C callp QMHSNDPM (xMsgID : wMsgFile : wMsgDta : C wMsgDtaLen : '*STATUS' : '*EXT' : 0 : C wMsgKey : wErr) C return P SndStsMsg e