QDBRTVFD
QUSROBJD
QSZRTVPR
QGYOLOBJ - Open List of Objects
QGYGTLE - Get List Entries
QGYCLST - Close List
QUSRJOBI
QMHSNDPM
QUIOPNDA
QUIOPNPA
QUIDSPP
QUIPRTP
QUIPUTV
QUIGETV
QUIADDLE
QUIGETLE
QUIRTVLA
QUISETLA
QUIDLTL
QUICLOA
**
** Program . . : CBX215
** Description : Analyze Logical File Origin - CPP
** Author . . : Carsten Flensburg
** Published . : System iNetwork Programming Tips Newsletter
** Date . . . : May 27, 2010
**
**
**
** Compile options:
** CrtRpgMod Module( CBX215 )
** DbgView( *LIST )
**
** CrtPgm Pgm( CBX215 )
** Module( CBX215 )
** ActGrp( *NEW )
**
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt ) BndDir( 'QC2LE' )
**-- API error data structure:
D ERRC0100 Ds Qualified
D BytPrv 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0
D MsgId 7a
D 1a
D MsgDta 128a
**-- Global constants:
D OFS_MSGDTA c 16
D NULL c ''
**
D BIN_SGN c 0
D NUM_ZON c 2
D CHAR_NLS c 4
D SORT_ASC c '1'
**
D TYP_JOIN c 2
**
D DB_OVRNOTPRC c '0'
D DB_OVRPRC c '1'
D DB_FIRST_MBR c '*FIRST'
**
D QGY_TYPE_FILE c '*FILE'
D QGY_BLD_SYNCH c -1
**-- UIM constants:
D PNLGRP_Q c 'CBX215P *LIBL '
D PNLGRP c 'CBX215P '
D SCP_AUT_RCL c -1
D RDS_OPT_INZ c 'N'
D PRM_IFC_0 c 0
D CLO_NORM c 'M'
D FNC_EXIT c -4
D FNC_CNL c -8
D KEY_F05 c 5
D KEY_F17 c 17
D KEY_F18 c 18
D RTN_ENTER c 500
D HLP_WDW c 'N'
D INC_EXP c 'Y'
D INC_EXP_NO c 'N'
D CPY_VAR c 'Y'
D CPY_VAR_NO c 'N'
D POS_TOP c 'TOP'
D POS_BOT c 'BOT'
D LIST_COMP c 'ALL'
D LIST_SAME c 'SAME'
D EXIT_SAME c '*SAME'
D TRIM_SAME c 'S'
**
D APP_PRTF c 'QPRINT *LIBL'
D ODP_SHR c 'N'
D SPLF_NAM c 'PANZLFITG '
D SPLF_USRDTA c 'ANZLFITG '
D EJECT_NO c 'N'
**-- Global variables:
D Idx s 10i 0
D SysDts s z
D ApiRcvSiz s 10i 0
D FilNamRtn_q s 20a
D Qdbfjoin s 10i 0
D ItgViolPf s n Inz( *Off )
D ItgViolLf s n Inz( *Off )
**-- UIM variables:
D UIM Ds Qualified
D AppHdl 8a
D LstHdl 4a
D EntHdl 4a
D FncRqs 10i 0
D EntLocOpt 4a
D LstPos 4a
**-- List attributes structure:
D LstAtr Ds Qualified
D LstCon 4a
D ExtPgmVar 10a
D DspPos 4a
D AlwTrim 1a
**-- UIM Panel exit prgram record:
D ExpRcd Ds Qualified
D ExitPg 20a Inz( 'CBX215E *LIBL' )
**-- UIM Panel header record:
D HdrRcd Ds Qualified
D SysDat 7a
D SysTim 6a
D TimZon 10a
D PrdInf 22a
D FilNam 10a
D FilLib 10a
D LstOrd 10a
D PosFld 10a
D JoinLf 1a
D MlFmLf 1a
D IbmLib 1a
D ViolTp 25a
**-- UIM List entry:
D LstEnt Ds Qualified
D Option 5i 0
D FilPos 20a
D FilNam 10a
D FilLib 10a
D FilDsc 50a
D CrtPrf 10a
D PhyNam 10a
D PhyLib 10a
D RcdFmt 10a
D PhyDsc 50a
D ViolTp 10a
D PosObj 10a
**
D LstEntPos Ds LikeDs( LstEnt )
**-- FILD0100 formats:
**-- File defintion header:
D Qdb_Qdbfh Ds Based( pQdb_Qdbfh ) Qualified
D Qdbfyret 10i 0
D Qdbfyavl 10i 0
D Qdbfhflg 2a
D* Reserved_1 :2
D* Qdbfhfpl :1
D* Reserved_2 :1
D* Qdbfhfsu :1
D* Reserved_3 :1
D* Qdbfhfky :1
D* Reserved_4 :1
D* Qdbfhflc :1
D* Qdbfkfso :1
D* Reserved_5 :4
D* Qdbfigcd :1
D* Qdbfigcl :1
D Reserved_7 4a
D Qdbflbnum 5i 0
D Qdbfkdat 14a
D Qdbfknum 5i 0 Overlay( Qdbfkdat: 1 )
D Qdbfkmxl 5i 0 Overlay( Qdbfkdat: *Next )
D Qdbfkflg 1a Overlay( Qdbfkdat: *Next )
D* Reserved_8 :1
D* Qdbfkfcs :1
D* Reserved_9 :4
D* Qdbfkfrc :1
D* Qdbfkflt :1
D Qdbfkfdm 1a Overlay( Qdbfkdat: *Next )
D Reserved_10 8a Overlay( Qdbfkdat: *Next )
D Qdbfhaut 10a
D Qdbfhupl 1a
D Qdbfhmxm 5i 0
D Qdbfwtfi 5i 0
D Qdbfhfrt 5i 0
D Qdbfhmnum 5i 0
D Reserved_11 9a
D Qdbfbrwt 5i 0
D Qaaf 1a
D* Reserved_12 :7
D* Qdbfpgmd :1
D Qdbffmtnum 5i 0
D Qdbfhfl2 2a
D* Qdbfjnap :1
D* Reserved_13 :1
D* Qdbfrdcp :1
D* Qdbfwtcp :1
D* Qdbfupcp :1
D* Qdbfdlcp :1
D* Reserved_14 :9
D* Qdbfkfnd :1
D Qdbfvrm 5i 0
D Qaaf2 2a
D* Qdbfhmcs :1
D* Reserved_15 :1
D* Qdbfknll :1
D* Qdbf_nfld :1
D* Qdbfvfld :1
D* Qdbftfld :1
D* Qdbfgrph :1
D* Qdbfpkey :1
D* Qdbfunqc :1
D* Reserved_118 :2
D* Qdbfapsz :1
D* Qdbfdisf :1
D* Reserved_68 :1
D* Reserved_69 :1
D* Reserved_70 :1
D Qdbfhcrt 13a
D Qdbfhtx 52a
D Reserved_18 2a Overlay( Qdbfhtx: 1 )
D Qdbfhtxt 50a Overlay( Qdbfhtx: *Next )
D Reserved_19 13a
D Qdbfsrc 30a
D Qdbfsrcf 10a Overlay( Qdbfsrc: 1 )
D Qdbfsrcm 10a Overlay( Qdbfsrc: *Next )
D Qdbfsrcl 10a Overlay( Qdbfsrc: *Next )
D Qdbfkrcv 1a
D Reserved_20 23a
D Qdbftcid 5i 0
D Qdbfasp 2a
D Qdbfnbit 1a
D* Qdbfhudt :1
D* Qdbfhlob :1
D* Qdbfhdtl :1
D* Qdbfhudf :1
D* Qdbfhlon :1
D* Qdbfhlop :1
D* Qdbfhdll :1
D* Reserved_21 :1
D Qdbfmxfnum 5i 0
D Reserved_22 76a
D Qdbfodic 10i 0
D Reserved_23 14a
D Qdbffigl 5i 0
D Qdbfmxrl 5i 0
D Reserved_24 8a
D Qdbfgkct 5i 0
D Qdbfos 10i 0
D Reserved_25 8a
D Qdbfocs 10i 0
D Reserved_26 4a
D Qdbfpact 2a
D Qdbfhrls 6a
D Reserved_27 20a
D Qdbpfof 10i 0
D Qdblfof 10i 0
D Qdbfssfp 6a
D Qdbfnlsb 1a Overlay( Qdbfssfp: 1 )
D* Qdbfsscs :3
D* Reserved_103 :5
D Qdbflang 3a Overlay( Qdbfssfp: *Next )
D Qdbfcnty 2a Overlay( Qdbfssfp: *Next )
D Qdbfjorn 10i 0
D Qdbfevid 10i 0
D Reserved_28 14a
**-- File scope array:
D Qdb_Qdbfb Ds Qualified Based( pQdb_Qdbfb )
D Reserved_48 48a
D Qdbfbf_q 20a
D Qdbfbf 10a Overlay( Qdbfbf_q: 1 )
D Qdbfbfl 10a Overlay( Qdbfbf_q: 11 )
D Qdbft 10a
D Reserved_49 37a
D Qdbfbgky 5i 0
D Reserved_50 2a
D Qdbfblky 5i 0
D Reserved_51 2a
D Qdbffogl 5i 0
D Reserved_52 3a
D Qdbfsoon 5i 0
D Qdbfsoof 10i 0
D Qdbfksof 10i 0
D Qdbfkyct 5i 0
D Qdbfgenf 5i 0
D Qdbfodis 10i 0
D Reserved_53 14a
**-- Logical file specific attributes
D Qdb_Qdbflogl Ds Based( pQdb_Qdbflogl ) Qualified
D Qdbfoj 10i 0
D Qdbfscsn 5i 0
D Qdbflxp 10a
D Qdbflxl 10a
D Qdbfovw 10i 0
D Qlfa 1a
D* Reserved_36 :2
D* Qdbfjoin :1
D* Qdbfdyns :1
D* Qdbfsqlv :1
D* Qdbfsqli :1
D* Reserved_37 :2
D Qdbfjtyp 1a
D Qdbfwchk 1a
D Qdbflotrg 10i 0
D Qdbfltrgn 5i 0
D Reserved_38 7a
**-- List API parameters:
D LstApi Ds Qualified Inz
D RtnRcdNbr 10i 0 Inz( 1 )
D NbrKeyRtn 10i 0 Inz( %Elem( LstApi.KeyFld ))
D KeyFld 10i 0 Dim( 2 )
**-- Object information:
D ObjInf Ds 4096 Qualified
D ObjNam_q 20a
D ObjNam 10a Overlay( ObjNam_q: 1 )
D ObjLib 10a Overlay( ObjNam_q: *Next )
D ObjTyp 10a
D InfSts 1a
D 1a
D FldNbrRtn 10i 0
D Data Like( KeyInf )
**-- Key information:
D KeyInf Ds Qualified Based( pKeyInf )
D FldInfLen 10i 0
D KeyFld 10i 0
D DtaTyp 1a
D 3a
D DtaLen 10i 0
D Data 256a
**-- Object information key fields:
D KEY0200 Ds Qualified
D InfSts 1a
D ExtObjAtr 10a
D TxtDsc 50a
D UsrDfnAtr 10a
D OrdLibL 10i 0
D 5a
**
D CrtPrf s 10a
**-- Authority control:
D AutCtl Ds Qualified
D AutFmtLen 10i 0 Inz( %Size( AutCtl ))
D CalLvl 10i 0 Inz( 0 )
D DplObjAut 10i 0 Inz( 0 )
D NbrObjAut 10i 0 Inz( 0 )
D DplLibAut 10i 0 Inz( 0 )
D NbrLibAut 10i 0 Inz( 0 )
D 10i 0 Inz( 0 )
D ObjAut 10a Dim( 10 )
D LibAut 10a Dim( 10 )
**-- Selection control:
D SltCtl Ds
D SltFmtLen 10i 0 Inz( %Size( SltCtl ))
D SltOmt 10i 0 Inz( 0 )
D DplSts 10i 0 Inz( 20 )
D NbrSts 10i 0 Inz( 1 )
D 10i 0 Inz( 0 )
D Status 1a Inz( '*' )
**-- Sort information:
D SrtInf Ds Qualified
D NbrKeys 10i 0 Inz( 4 )
D SrtStr 12a Dim( 4 )
D KeyFldOfs 10i 0 Overlay( SrtStr: 1 )
D KeyFldLen 10i 0 Overlay( SrtStr: 5 )
D KeyFldTyp 5i 0 Overlay( SrtStr: 9 )
D SrtOrd 1a Overlay( SrtStr: 11 )
D Rsv 1a Overlay( SrtStr: 12 )
**-- List information:
D LstInf Ds Qualified
D RcdNbrTot 10i 0
D RcdNbrRtn 10i 0
D Handle 4a
D RcdLen 10i 0
D InfSts 1a
D Dts 13a
D LstSts 1a
D 1a
D InfLen 10i 0
D Rcd1 10i 0
D 40a
**-- Retrieve database file description:
D RtvDbfDsc Pr ExtPgm( 'QDBRTVFD' )
D RcvVar 32767a Options( *VarSize )
D RcvVarLen 10i 0 Const
D FilNamRtn_q 20a
D FmtNam 8a Const
D FilNam_q 20a Const
D RcdFmtNam 10a Const
D OvrPrc 1a Const
D System 10a Const
D FmtTyp 10a Const
D Error 32767a Options( *VarSize )
**-- Retrieve object description:
D RtvObjD Pr ExtPgm( 'QUSROBJD' )
D RcvVar 32767a Options( *VarSize )
D RcvVarLen 10i 0 Const
D FmtNam 8a Const
D ObjNamQ 20a Const
D ObjTyp 10a Const
D Error 32767a Options( *VarSize )
**-- Retrieve product information:
D RtvPrdInf Pr ExtPgm( 'QSZRTVPR' )
D RcvVar 65535a Options( *VarSize )
D RcvVarLen 10i 0 Const
D FmtNam 8a Const
D PrdInf 27a Const
D Error 1024a Options( *VarSize )
**-- Open list of objects:
D LstObjs Pr ExtPgm( 'QGYOLOBJ' )
D RcvVar 65535a Options( *VarSize )
D RcvVarLen 10i 0 Const
D LstInf 80a
D NbrRcdRtn 10i 0 Const
D SrtInf 1024a Const Options( *VarSize )
D ObjNam_q 20a Const
D ObjTyp 10a Const
D AutCtl 1024a Const Options( *VarSize )
D SltCtl 1024a Const Options( *VarSize )
D NbrKeyRtn 10i 0 Const
D KeyFld 10i 0 Const Options( *VarSize ) Dim( 32 )
D Error 1024a Options( *VarSize )
**
D JobIdInf 256a Options( *NoPass: *VarSize )
D JobIdFmt 8a Const Options( *NoPass )
**
D AspCtl 256a Options( *NoPass: *VarSize )
**-- Get open list entry:
D GetOplEnt Pr ExtPgm( 'QGYGTLE' )
D RcvVar 65535a Options( *VarSize )
D RcvVarLen 10i 0 Const
D Handle 4a Const
D LstInf 80a
D NbrRcdRtn 10i 0 Const
D RtnRcdNbr 10i 0 Const
D Error 1024a Options( *VarSize )
**-- Close list:
D CloseLst Pr ExtPgm( 'QGYCLST' )
D Handle 4a Const
D Error 1024a Options( *VarSize )
**-- Retrieve job information:
D RtvJobInf Pr ExtPgm( 'QUSRJOBI' )
D RcvVar 32767a Options( *VarSize )
D RcvVarLen 10i 0 Const
D FmtNam 8a Const
D JobNamQ 26a Const
D JobIntId 16a Const
D Error 32767a Options( *NoPass: *VarSize )
**-- Send program message:
D SndPgmMsg Pr ExtPgm( 'QMHSNDPM' )
D MsgId 7a Const
D MsgFq 20a Const
D MsgDta 128a Const
D MsgDtaLen 10i 0 Const
D MsgTyp 10a Const
D CalStkE 10a Const Options( *VarSize )
D CalStkCtr 10i 0 Const
D MsgKey 4a
D Error 32767a Options( *VarSize )
**-- Open display application:
D OpnDspApp Pr ExtPgm( 'QUIOPNDA' )
D AppHdl 8a
D PnlGrp_q 20a Const
D AppScp 10i 0 Const
D ExtPrmIfc 10i 0 Const
D FulScrHlp 1a Const
D Error 32767a Options( *VarSize )
D OpnDtaRcv 128a Options( *NoPass: *VarSize )
D OpnDtaRcvLen 10i 0 Const Options( *NoPass )
D OpnDtaRcvAvl 10i 0 Options( *NoPass )
**-- Open print application:
D OpnPrtApp Pr ExtPgm( 'QUIOPNPA' )
D AppHdl 8a
D PnlGrp_q 20a Const
D AppScp 10i 0 Const
D ExtPrmIfc 10i 0 Const
D PrtDevF_q 20a Const
D AltFilNam 10a Const
D ShrOpnDtaPth 1a Const
D UsrDta 10a Const
D Error 32767a Options( *VarSize )
D OpnDtaRcv 128a Options( *NoPass: *VarSize )
D OpnDtaRcvLen 10i 0 Const Options( *NoPass )
D OpnDtaRcvAvl 10i 0 Options( *NoPass )
**-- Display panel:
D DspPnl Pr ExtPgm( 'QUIDSPP' )
D AppHdl 8a Const
D FncRqs 10i 0
D PnlNam 10a Const
D ReDspOpt 1a Const
D Error 32767a Options( *VarSize )
D UsrTsk 1a Const Options( *NoPass )
D CalStkCnt 10i 0 Const Options( *NoPass )
D CalMsgQue 256a Const Options( *NoPass: *VarSize )
D MsgKey 4a Const Options( *NoPass )
D CsrPosOpt 1a Const Options( *NoPass )
D FinLstEnt 4a Const Options( *NoPass )
D ErrLstEnt 4a Const Options( *NoPass )
D WaitTim 10i 0 Const Options( *NoPass )
D CalMsgQueLen 10i 0 Const Options( *NoPass )
D CalQlf 20a Const Options( *NoPass )
**-- Print panel:
D PrtPnl Pr ExtPgm( 'QUIPRTP' )
D AppHdl 8a Const
D PrtPnlNam 10a Const
D EjtOpt 1a Const
D Error 32767a Options( *VarSize )
**-- Put dialog variable:
D PutDlgVar Pr ExtPgm( 'QUIPUTV' )
D AppHdl 8a Const
D VarBuf 32767a Const Options( *VarSize )
D VarBufLen 10i 0 Const
D VarRcdNam 10a Const
D Error 32767a Options( *VarSize )
**-- Get dialog variable:
D GetDlgVar Pr ExtPgm( 'QUIGETV' )
D AppHdl 8a Const
D VarBuf 32767a Options( *VarSize )
D VarBufLen 10i 0 Const
D VarRcdNam 10a Const
D Error 32767a Options( *VarSize )
**-- Add list entry:
D AddLstEnt Pr ExtPgm( 'QUIADDLE' )
D AppHdl 8a Const
D VarBuf 32767a Const Options( *VarSize )
D VarBufLen 10i 0 Const
D VarRcdNam 10a Const
D LstNam 10a Const
D EntLocOpt 4a Const
D LstEntHdl 4a
D Error 32767a Options( *VarSize )
**-- Get list entry:
D GetLstEnt Pr ExtPgm( 'QUIGETLE' )
D AppHdl 8a Const
D VarBuf 32767a Const Options( *VarSize )
D VarBufLen 10i 0 Const
D VarRcdNam 10a Const
D LstNam 10a Const
D PosOpt 4a Const
D CpyOpt 1a Const
D SltCri 20a Const
D SltHdl 4a Const
D ExtOpt 1a Const
D LstEntHdl 4a
D Error 32767a Options( *VarSize )
**-- Retrieve list attributes:
D RtvLstAtr Pr ExtPgm( 'QUIRTVLA' )
D AppHdl 8a Const
D LstNam 10a Const
D AtrRcv 32767a Options( *VarSize )
D AtrRcvLen 10i 0 Const
D Error 32767a Options( *VarSize )
**-- Set list attributes:
D SetLstAtr Pr ExtPgm( 'QUISETLA' )
D AppHdl 8a Const
D LstNam 10a Const
D LstCon 4a Const
D ExtPgmVar 10a Const
D DspPos 4a Const
D AlwTrim 1a Const
D Error 32767a Options( *VarSize )
**-- Delete list:
D DltLst Pr ExtPgm( 'QUIDLTL' )
D AppHdl 8a Const
D LstNam 10a Const
D Error 32767a Options( *VarSize )
**-- Close application:
D CloApp Pr ExtPgm( 'QUICLOA' )
D AppHdl 8a Const
D CloOpt 1a Const
D Error 32767a Options( *VarSize )
**-- Test bit in string:
D tstbts Pr 10i 0 ExtProc( 'tstbts' )
D String * Value
D BitOfs 10u 0 Value
**-- Get job type:
D GetJobTyp Pr 1a
**-- Check object existence:
D ChkObj Pr n
D PxObjNam_q 20a Const
D PxObjTyp 10a Const
**-- Get object description:
D GetObjDsc Pr 50a
D PxObjNam_q 20a Const
D PxObjTyp 10a Const
**-- Get object creator:
D GetObjCrt Pr 10a
D PxObjNam_q 20a Const
D PxObjTyp 10a Const
**-- Get product information:
D GetPrdInf Pr 22a
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
**-- Send completion message:
D SndCmpMsg Pr 10i 0
D PxMsgDta 512a Const Varying
**-- Entry parameters:
D ObjNam_q Ds
D ObjNam 10a
D ObjLib 10a
**
D SltCri Ds Qualified
D NbrElm 5i 0
D PrmVal n Dim( 3 )
**
D ViolTp Ds Qualified
D NbrElm 5i 0
D TypViol 6a Dim( 2 )
**
D CBX215 Pr
D PxFilNam_q LikeDs( ObjNam_q )
D PxSltCri LikeDs( SltCri )
D PxViolTp LikeDs( ViolTp )
D PxLstOrd 10a
D PxOutOpt 3a
**
D CBX215 Pi
D PxFilNam_q LikeDs( ObjNam_q )
D PxSltCri LikeDs( SltCri )
D PxViolTp LikeDs( ViolTp )
D PxLstOrd 10a
D PxOutOpt 3a
/Free
ExSr InzApiPrm;
If PxOutOpt = 'DSP' And GetJobTyp() = 'I';
OpnDspApp( UIM.AppHdl
: PNLGRP_Q
: SCP_AUT_RCL
: PRM_IFC_0
: HLP_WDW
: ERRC0100
);
Else;
OpnPrtApp( UIM.AppHdl
: PNLGRP_Q
: SCP_AUT_RCL
: PRM_IFC_0
: APP_PRTF
: SPLF_NAM
: ODP_SHR
: SPLF_USRDTA
: ERRC0100
);
EndIf;
If ERRC0100.BytAvl > *Zero;
ExSr EscApiErr;
EndIf;
PutDlgVar( UIM.AppHdl: ExpRcd: %Size( ExpRcd ): 'EXPRCD': ERRC0100 );
ExSr BldHdrRcd;
ExSr BldFilLst;
If PxOutOpt = 'DSP' And GetJobTyp() = 'I';
ExSr DspLst;
Else;
ExSr WrtLst;
EndIf;
CloApp( UIM.AppHdl: CLO_NORM: ERRC0100 );
DeAlloc(n) pQdb_Qdbfh;
*InLr = *On;
Return;
BegSr DspLst;
DoU UIM.FncRqs = FNC_EXIT Or UIM.FncRqs = FNC_CNL;
DspPnl( UIM.AppHdl: UIM.FncRqs: PNLGRP: RDS_OPT_INZ: ERRC0100 );
If ERRC0100.BytAvl > *Zero;
ExSr EscApiErr;
EndIf;
GetDlgVar( UIM.AppHdl
: HdrRcd
: %Size( HdrRcd )
: 'HDRRCD'
: ERRC0100
);
Select;
When UIM.FncRqs = RTN_ENTER And
UIM.EntLocOpt = 'NEXT' And
HdrRcd.PosFld > *Blanks;
ExSr FndLstPos;
When UIM.FncRqs = RTN_ENTER;
Leave;
When UIM.FncRqs = KEY_F17;
ExSr PosLstTop;
When UIM.FncRqs = KEY_F18;
ExSr PosLstBot;
EndSl;
If UIM.FncRqs = KEY_F05 And UIM.EntLocOpt = 'NEXT';
ExSr GetLstPos;
ExSr DltFilLst;
EndIf;
If UIM.FncRqs = KEY_F05;
ExSr RstHdrRcd;
ExSr BldFilLst;
ExSr SetLstPos;
EndIf;
ExSr BldHdrRcd;
EndDo;
EndSr;
BegSr WrtLst;
PrtPnl( UIM.AppHdl
: 'PRTHDR'
: EJECT_NO
: ERRC0100
);
PrtPnl( UIM.AppHdl
: 'PRTLST'
: EJECT_NO
: ERRC0100
);
SndCmpMsg( 'List has been printed.' );
EndSr;
BegSr EscApiErr;
If ERRC0100.BytAvl < OFS_MSGDTA;
ERRC0100.BytAvl = OFS_MSGDTA;
EndIf;
SndEscMsg( ERRC0100.MsgId
: 'QCPFMSG'
: %Subst( ERRC0100.MsgDta: 1: ERRC0100.BytAvl - OFS_MSGDTA )
);
EndSr;
BegSr BldFilLst;
UIM.EntLocOpt = 'FRST';
LstApi.RtnRcdNbr = 1;
LstObjs( ObjInf
: %Size( ObjInf )
: LstInf
: QGY_BLD_SYNCH
: SrtInf
: PxFilNam_q
: QGY_TYPE_FILE
: AutCtl
: SltCtl
: LstApi.NbrKeyRtn
: LstApi.KeyFld
: ERRC0100
);
If ERRC0100.BytAvl = *Zero And LstInf.RcdNbrRtn > *Zero;
ExSr PrcLstEnt;
DoW LstInf.RcdNbrTot > LstApi.RtnRcdNbr;
LstApi.RtnRcdNbr += 1;
GetOplEnt( ObjInf
: %Size( ObjInf )
: LstInf.Handle
: LstInf
: 1
: LstApi.RtnRcdNbr
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Leave;
EndIf;
ExSr PrcLstEnt;
EndDo;
EndIf;
SetLstAtr( UIM.AppHdl
: 'DTLLST'
: LIST_COMP
: EXIT_SAME
: POS_TOP
: TRIM_SAME
: ERRC0100
);
CloseLst( LstInf.Handle: ERRC0100 );
EndSr;
BegSr PrcLstEnt;
ExSr GetKeyDta;
If KEY0200.ExtObjAtr = 'LF';
If PxSltCri.PrmVal(3) = '1' Or
GetObjCrt( ObjInf.ObjLib + 'QSYS': '*LIB' ) <> '*IBM';
DoU Qdb_Qdbfh.Qdbfyavl <= ApiRcvSiz;
If Qdb_Qdbfh.Qdbfyavl > ApiRcvSiz;
ApiRcvSiz = Qdb_Qdbfh.Qdbfyavl;
pQdb_Qdbfh = %ReAlloc( pQdb_Qdbfh: ApiRcvSiz );
EndIf;
RtvDbfDsc( Qdb_Qdbfh
: ApiRcvSiz
: FilNamRtn_q
: 'FILD0100'
: ObjInf.ObjNam_q
: DB_FIRST_MBR
: DB_OVRNOTPRC
: '*LCL'
: '*EXT'
: ERRC0100
);
EndDo;
If ERRC0100.BytAvl = *Zero;
ExSr PrcFilInf;
EndIf;
EndIf;
EndIf;
EndSr;
BegSr GetKeyDta;
pKeyInf = %Addr( ObjInf.Data );
For Idx = 1 To ObjInf.FldNbrRtn;
Select;
When KeyInf.KeyFld = 200;
KEY0200 = %Subst( KeyInf.Data: 1: KeyInf.DtaLen );
When KeyInf.KeyFld = 405;
CrtPrf = %Subst( KeyInf.Data: 1: KeyInf.DtaLen );
EndSl;
If Idx < ObjInf.FldNbrRtn;
pKeyInf = pKeyInf + KeyInf.FldInfLen;
EndIf;
EndFor;
EndSr;
Begsr PrcFilInf;
pQdb_Qdbflogl = pQdb_Qdbfh + Qdb_Qdbfh.Qdblfof;
Qdbfjoin = tstbts( %Addr( Qdb_Qdbflogl.Qlfa ): TYP_JOIN );
Select;
When PxSltCri.PrmVal(1) = '0' And Qdbfjoin = 1;
//-- Ignore
When PxSltCri.PrmVal(2) = '0' And Qdbfjoin = 0 And
Qdb_Qdbfh.Qdbflbnum > 1;
//-- Ignore
When Qdb_Qdbfh.Qdbflbnum > *Zero;
pQdb_Qdbfb = pQdb_Qdbfh + Qdb_Qdbfh.Qdbfos;
For Idx = 1 To Qdb_Qdbfh.Qdbflbnum;
If Qdb_Qdbfb.Qdbfbfl <> ObjInf.ObjLib;
LstEnt.ViolTp = '*LFLIB';
If ChkObj( Qdb_Qdbfb.Qdbfbf + ObjInf.ObjLib: '*FILE' ) = *On;
LstEnt.ViolTp = '*PFLIB';
EndIf;
If LstEnt.ViolTp = '*LFLIB' And ItgViolLf = *On Or
LstEnt.ViolTp = '*PFLIB' And ItgViolPf = *On;
ExSr AddFilLst;
EndIf;
EndIf;
If Idx < Qdb_Qdbfh.Qdbflbnum;
pQdb_Qdbfb += %Size( Qdb_Qdbfb );
EndIf;
EndFor;
EndSl;
EndSr;
BegSr AddFilLst;
LstEnt.Option = *Zero;
LstEnt.FilPos = ObjInf.ObjNam_q;
LstEnt.FilNam = ObjInf.ObjNam;
LstEnt.FilLib = ObjInf.ObjLib;
LstEnt.FilDsc = KEY0200.TxtDsc;
LstEnt.CrtPrf = CrtPrf;
LstEnt.PhyNam = Qdb_Qdbfb.Qdbfbf;
LstEnt.PhyLib = Qdb_Qdbfb.Qdbfbfl;
LstEnt.PhyDsc = GetObjDsc( Qdb_Qdbfb.Qdbfbf_q: '*FILE' );
LstEnt.RcdFmt = Qdb_Qdbfb.Qdbft;
If PxLstOrd = '*FILE';
LstEnt.PosObj = ObjInf.ObjNam;
Else;
LstEnt.PosObj = ObjInf.ObjLib;
EndIf;
AddLstEnt( UIM.AppHdl
: LstEnt
: %Size( LstEnt )
: 'DTLRCD'
: 'DTLLST'
: UIM.EntLocOpt
: UIM.LstHdl
: ERRC0100
);
UIM.EntLocOpt = 'NEXT';
EndSr;
BegSr FndLstPos;
LstEnt.PosObj = HdrRcd.PosFld;
PutDlgVar( UIM.AppHdl
: LstEnt
: %Size( LstEnt )
: 'DTLRCD'
: ERRC0100
);
GetLstEnt( UIM.AppHdl
: LstEnt
: %Size( LstEnt )
: 'DTLRCD'
: 'DTLLST'
: 'FSLT'
: CPY_VAR
: 'GE POSOBJ'
: *Blanks
: INC_EXP
: UIM.EntHdl
: ERRC0100
);
Select;
When ERRC0100.BytAvl > *Zero;
GetLstEnt( UIM.AppHdl
: LstEnt
: %Size( LstEnt )
: '*NONE'
: 'DTLLST'
: 'LAST'
: CPY_VAR_NO
: *Blanks
: *Blanks
: INC_EXP_NO
: UIM.EntHdl
: ERRC0100
);
When %Scan( %Trim( HdrRcd.PosFld ): LstEnt.PosObj ) <> 1;
GetLstEnt( UIM.AppHdl
: LstEnt
: %Size( LstEnt )
: '*NONE'
: 'DTLLST'
: 'PREV'
: CPY_VAR_NO
: *Blanks
: *Blanks
: INC_EXP_NO
: UIM.EntHdl
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
GetLstEnt( UIM.AppHdl
: LstEnt
: %Size( LstEnt )
: '*NONE'
: 'DTLLST'
: 'FRST'
: CPY_VAR_NO
: *Blanks
: *Blanks
: INC_EXP_NO
: UIM.EntHdl
: ERRC0100
);
EndIf;
EndSl;
If ERRC0100.BytAvl = *Zero;
SetLstAtr( UIM.AppHdl
: 'DTLLST'
: LIST_SAME
: EXIT_SAME
: UIM.EntHdl
: TRIM_SAME
: ERRC0100
);
EndIf;
HdrRcd.PosFld = *Blanks;
EndSr;
BegSr GetLstPos;
RtvLstAtr( UIM.AppHdl: 'DTLLST': LstAtr: %Size( LstAtr ): ERRC0100 );
If LstAtr.DspPos <> 'TOP';
GetLstEnt( UIM.AppHdl
: LstEnt
: %Size( LstEnt )
: 'DTLRCD'
: 'DTLLST'
: 'HNDL'
: 'Y'
: *Blanks
: LstAtr.DspPos
: 'N'
: UIM.EntHdl
: ERRC0100
);
LstEntPos = LstEnt;
EndIf;
EndSr;
BegSr SetLstPos;
If LstAtr.DspPos <> 'TOP';
LstEnt = LstEntPos;
PutDlgVar( UIM.AppHdl
: LstEnt
: %Size( LstEnt )
: 'DTLRCD'
: ERRC0100
);
GetLstEnt( UIM.AppHdl
: LstEnt
: %Size( LstEnt )
: '*NONE'
: 'DTLLST'
: 'FSLT'
: 'N'
: 'EQ FILPOS'
: LstAtr.DspPos
: 'N'
: UIM.EntHdl
: ERRC0100
);
If ERRC0100.BytAvl = *Zero;
SetLstAtr( UIM.AppHdl
: 'DTLLST'
: LIST_SAME
: EXIT_SAME
: UIM.EntHdl
: TRIM_SAME
: ERRC0100
);
EndIf;
EndIf;
EndSr;
BegSr BldHdrRcd;
SysDts = %Timestamp();
HdrRcd.SysDat = %Char( %Date( SysDts ): *CYMD0 );
HdrRcd.SysTim = %Char( %Time( SysDts ): *HMS0 );
HdrRcd.TimZon = '*SYS';
HdrRcd.PrdInf = GetPrdInf();
HdrRcd.FilNam = PxFilNam_q.ObjNam;
HdrRcd.FilLib = PxFilNam_q.ObjLib;
HdrRcd.LstOrd = PxLstOrd;
HdrRcd.JoinLf = PxSltCri.PrmVal(1);
HdrRcd.MlFmLf = PxSltCri.PrmVal(2);
HdrRcd.IbmLib = PxSltCri.PrmVal(3);
Select;
When PxViolTp.NbrElm = 1;
HdrRcd.ViolTp = PxViolTp.TypViol(1);
When PxViolTp.NbrElm = 2;
HdrRcd.ViolTp = %TrimR( PxViolTp.TypViol(1)) + ' ' +
%TrimR( PxViolTp.TypViol(2));
EndSl;
PutDlgVar( UIM.AppHdl: HdrRcd: %Size( HdrRcd ): 'HDRRCD': ERRC0100 );
EndSr;
BegSr RstHdrRcd;
HdrRcd.PosFld = *Blanks;
EndSr;
BegSr PosLstTop;
SetLstAtr( UIM.AppHdl
: 'DTLLST'
: LIST_SAME
: EXIT_SAME
: POS_TOP
: TRIM_SAME
: ERRC0100
);
EndSr;
BegSr PosLstBot;
SetLstAtr( UIM.AppHdl
: 'DTLLST'
: LIST_SAME
: EXIT_SAME
: POS_BOT
: TRIM_SAME
: ERRC0100
);
EndSr;
BegSr DltFilLst;
DltLst( UIM.AppHdl: 'DTLLST': ERRC0100 );
EndSr;
BegSr InzApiPrm;
ApiRcvSiz = 65535;
pQdb_Qdbfh = %Alloc( ApiRcvSiz );
LstApi.KeyFld(1) = 200;
LstApi.KeyFld(2) = 405;
SrtInf.NbrKeys = 2;
If PxLstOrd = '*FILE';
SrtInf.KeyFldOfs(1) = 1;
SrtInf.KeyFldLen(1) = %Size( LstEnt.FilNam );
SrtInf.KeyFldOfs(2) = 11;
SrtInf.KeyFldLen(2) = %Size( LstEnt.FilLib );
Else;
SrtInf.KeyFldOfs(1) = 11;
SrtInf.KeyFldLen(1) = %Size( LstEnt.FilLib );
SrtInf.KeyFldOfs(2) = 1;
SrtInf.KeyFldLen(2) = %Size( LstEnt.FilNam );
EndIf;
SrtInf.KeyFldTyp(1) = CHAR_NLS;
SrtInf.SrtOrd(1) = SORT_ASC;
SrtInf.Rsv(1) = x'00';
SrtInf.KeyFldTyp(2) = CHAR_NLS;
SrtInf.SrtOrd(2) = SORT_ASC;
SrtInf.Rsv(2) = x'00';
EndSr;
BegSr *InzSr;
Select;
When PxViolTp.TypViol(1) = '*ALL';
ItgViolLf = *On;
ItgViolPf = *On;
When %LookUp( '*LFLIB'
: PxViolTp.TypViol
: 1
: PxViolTp.NbrElm
) > *Zero;
ItgViolLf = *On;
When %LookUp( '*PFLIB'
: PxViolTp.TypViol
: 1
: PxViolTp.NbrElm
) > *Zero;
ItgViolPf = *On;
EndSl;
EndSr;
/End-Free
**-- Get job type:
P GetJobTyp B
D Pi 1a
D JOBI0400 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D JobNam 10a
D UsrNam 10a
D JobNbr 6a
D JobIntId 16a
D JobSts 10a
D JobTyp 1a
D JobSubTyp 1a
/Free
RtvJobInf( JOBI0400
: %Size( JOBI0400 )
: 'JOBI0400'
: '*'
: *Blank
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return *Blank;
Else;
Return JOBI0400.JobTyp;
EndIf;
/End-Free
P GetJobTyp E
**-- Check object existence:
P ChkObj B Export
D Pi n
D PxObjNam_q 20a Const
D PxObjTyp 10a Const
**
D OBJD0100 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D ObjNam 10a
D ObjLib 10a
D ObjTyp 10a
/Free
RtvObjD( OBJD0100
: %Size( OBJD0100 )
: 'OBJD0100'
: PxObjNam_q
: PxObjTyp
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return *Off;
Else;
Return *On;
EndIf;
/End-Free
P ChkObj E
**-- Get object description:
P GetObjDsc B
D Pi 50a
D PxObjNam_q 20a Const
D PxObjTyp 10a Const
**
D OBJD0200 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D ObjNam 10a
D ObjLib 10a
D ObjTyp 10a
D ObjDsc 50a Overlay( OBJD0200: 101 )
/Free
RtvObjD( OBJD0200
: %Size( OBJD0200 )
: 'OBJD0200'
: PxObjNam_q
: PxObjTyp
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return *Blanks;
Else;
Return OBJD0200.ObjDsc;
EndIf;
/End-Free
P GetObjDsc E
**-- Get object creator:
P GetObjCrt B
D Pi 10a
D PxObjNam_q 20a Const
D PxObjTyp 10a Const
**
D OBJD0300 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D ObjNam 10a
D ObjLib 10a
D ObjTyp 10a
D CrtPrf 10a Overlay( OBJD0300: 220 )
/Free
RtvObjD( OBJD0300
: %Size( OBJD0300 )
: 'OBJD0300'
: PxObjNam_q
: PxObjTyp
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return *Blanks;
Else;
Return OBJD0300.CrtPrf;
EndIf;
/End-Free
P GetObjCrt E
**-- Get product information:
P GetPrdInf B
D Pi 22a
**-- Product information - QSZRTVPR:
D PRDR0500 Ds Qualified
D BytPrv 10i 0
D BytRtn 10i 0
D 10i 0
D PrdId 7a
D Release 6a
D PrdOpt 4a
D LodId 4a
D LodTyp 10a
D SymLodStt 10a
D LodErrInd 10a
D LodStt 2a
D SupFlg 1a
D RegTyp 2a
D RegVal 14a
D 2a
D OfsAddInf 10i 0
D PriLodId 4a
D MinTrgRel 6a
D MinVrmBas 6a
D RqmBasOpt 1a
D Level 3a
D AlwMtpRls 1a
D RlsDatCen 1a
D RlsDat 6a
D CprFstYear 4a
D CprCurYear 4a
D MsgFilNam 10a
D MsgFilLib 10a
D NbrOptRcd 10i 0
D LenOptRcd 10i 0
/Free
RtvPrdInf( PRDR0500
: %Size( PRDR0500 )
: 'PRDR0500'
: '*OPSYS *CUR 0000*CODE '
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return *Blanks;
Else;
Return PRDR0500.PrdId + ' ' +
PRDR0500.Release + ' ' +
PRDR0500.RlsDat;
EndIf;
/End-Free
P GetPrdInf E
**-- Send escape message:
P SndEscMsg B
D Pi 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( PxMsgId
: PxMsgF + '*LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*ESCAPE'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndEscMsg E
**-- Send completion message:
P SndCmpMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( 'CPF9897'
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*COMP'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndCmpMsg E
