Retrieve Database File Description
**
** Program . . : CBX123
** Description : Print file field description
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : September 9, 2004
**
**
** Program summary
** ---------------
**
** Database and file API:
** QDBRTVFD Retrieve database Allows you to get the complete and
** file description specific information about a file.
**
** The information is returned to a
** receiver variable in either a file
** definition template or a format
** definition mapping.
**
** Message handling API:
** QMHSNDPM Send program message Sends a message to a program stack
** entry (current, previous, etc.) or
** an external message queue.
**
** Both messages defined in a message
** file and immediate messages can be
** used. For specific message types
** only one or the other is allowed.
**
** 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.
**
**
** Program description:
** This program will retrieve and print information about a database
** file's fields. The information is printed in a list and includes
** field attributes, key fields and, in case of a logical file being
** requested, any record select/omit specifications.
**
**
** Sequence of events:
** 1. Storage is allocated to the API receiver variable.
**
** 2. The QDBRTVFD API is called to collect information about file
** key fields and select/omit specifications. If more data is
** available than the storage currently allocated to the API
** receiver variable can hold, enough storage is reallocated,
** and the API call is repeated.
**
** 3. The key fields and select/omit specifications are retrieved
** and stored in two arrays for later processing.
**
** 4. The QDBRTVFD API is called again, this time to collect the
** requried information about record format and field attributes.
** Again storage is reallocated and the API call repeated until
** all available information is retrieved.
**
** 5. The file field list is printed and subsequently the key field
** information section is also printed. In case the requested
** file is a logical file, a select/omit specification section is
** printed.
**
** 6. The allocated storage is released and a completion message is
** sent to the caller.
**
** 7. If during the processing described above an API error occurs,
** the returned error message data is retrieved from the API
** error data structure, and an escape message is sent to the
** caller, informing about the specific error. Prior to sending
** the escape message, which terminates the program immediately,
** the allocated storage is deallocated.
**
**
** Programmer's notes:
** Overflow could occur during the formatting of the check values
** and select/omit criteria specification, if the number or size of
** these values result in a string larger than 70 respectively 98
** bytes.
**
** The format of the produced list can be adapted to any desired
** length and overflow values by adjusting the FormLen() and
** FormOfl() keywords in the QSYSPRT F-specification below.
**
** The 'dummy' structure specifications that are commented out, are
** included in order to document the bit-fields that are embedded in
** the return structures:
**
** D Qdbfhflg 2a
** D* Reserved_1 :2
** D* Qdbfhfpl :1
**
** In the above example the field Qdbfhflg is defined as a 2 byte
** character field but it contains a number of bit-settings storing
** different flags and attributes. The :n notation defines the
** number of bits that each bit-field occupies, from left to right.
**
** Thus the bit-field Reserved_1 occupies the two leftmost bits in
** the Qdbfhflg field and Qdbfhfpl the third bit. To extract the
** actual bit settings, the tstbts C library function is used.
**
**
** Compilation specification:
** CrtRpgMod Module( CBX123 )
** DbgView( *LIST )
**
** CrtPgm Pgm( CBX123 )
** Module( CBX123 )
** ActGrp( QILE )
**
**
**-- Header specifications: --------------------------------------------**
H BndDir( 'QC2LE' ) Option( *SrcStmt )
**-- Printer file:
FQSYSPRT O F 132 Printer InfDs( PrtInf ) OflInd( *InOf )
F FormLen( 70 ) FormOfl( 68 )
**-- Printer file information:
D PrtInf Ds Qualified
D WrtCnt 10i 0 Overlay( PrtInf: 243 )
D OvfLin 5i 0 Overlay( PrtInf: 188 )
D CurLin 5i 0 Overlay( PrtInf: 367 )
D CurPag 5i 0 Overlay( PrtInf: 369 )
**-- System information:
D SDs
D PsPgmNam *Proc
**-- API error data structure:
D ERRC0100 Ds Qualified
D BytPro 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0 Inz
D MsgId 7a
D 1a
D MsgDta 128a
**-- API parameters:
D FilRtnQ Ds Qualified
D FilNam 10a
D LibNam 10a
D ApiRcvSiz s 10u 0
**-- Global variables:
D RcdIdx s 10i 0
D FldIdx s 10i 0
D ChkIdx s 10i 0
D KeyIdx s 10i 0
D SltIdx s 10i 0
D ValIdx s 10i 0
D KeyTyp s 10a Varying
D AccPth s 10a Varying
**-- Output fields:
D OutHdr Ds Inz
D Time 6s 0
D FilNam 10a
D LibNam 10a
D FilTyp 10a
D RcdFmt 10a
D RcdLen 5i 0
D FldCnt 5i 0
**
D OutDtl Ds Inz
D FldNam 10a
D FldTyp 10a
D BufPos 5i 0
D FldLen 5i 0
D KeySeq 4a
D FldDig 3a
D FldDec 3a
D FldTxt 50a
D FldHdg 62a
D TxtLin2 70a
D SpcTxt 98a
**-- Key field & select/omit statement arrays:
D KeyFld s 10a Dim( 120 )
D SltStm s 128a Dim( 512 ) Varying
**-- Check keyword conversion:
D ChkDfn Ds
D ChkHex 21a Inz( x'636466677172737475767778797A-
D A0A1A2A3A5A6A7' )
D ChkKwd 231a Inz( 'CHKMSGID -
D CHECK(ME) -
D CHECK(FE) -
D CHECK(MF) -
D RANGE -
D VALUES -
D COMP GT -
D COMP GE -
D COMP EQ -
D COMP NE -
D COMP LE -
D COMP LT -
D COMP NL -
D COMP NG -
D CHECK(M10) -
D CHECK(M11) -
D CHECK(VN) -
D CHECK(AB) -
D CHECK(VNE) -
D CHECK(M10F)-
D CHECK(M11F)' )
D ChkHexA 1a Dim( 21 ) Overlay( ChkDfn: 1 )
D ChkKwdA 11a Dim( 21 ) Overlay( ChkDfn: 22 )
**-- Select/omit keyword conversion:
D SltDfn Ds
D SltCod 20a Inz( 'ALEQGEGTLELTNENGNLVA' )
D SltKwd 80a Inz( 'ALL -
D COMP EQ -
D COMP GE -
D COMP GT -
D COMP LE -
D COMP LT -
D COMP NE -
D COMP NG -
D COMP NL -
D VALUES ' )
D SltCodA 2a Dim( 10 ) Overlay( SltDfn: 1 )
D SltKwdA 8a Dim( 10 ) Overlay( SltDfn: 21 )
**-- Field type conversion:
D TypDfn Ds
D TypHex 38a Inz( x'0000000100020003000480040005-
D 800500068006000B000C000D400440054006-
D 80448046FFFF' )
D TypTxt 190a Inz( 'Binary -
D Float -
D Zoned -
D Packed -
D Char -
D Var char -
D Graph -
D Var graph -
D DBCS -
D Var DBCS -
D Date -
D Time -
D Timestamp -
D BLOB/CLOB -
D DBCLOB -
D CLOB-open -
D Datalink C-
D Datalink O-
D NULL ' )
D TypHexA 2a Dim( 19 ) Overlay( TypDfn: 1 )
D TypTxtA 10a Dim( 19 ) Overlay( TypDfn: 39 )
**-- FILD0100 formats:
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
**
D Qdb_Qdbfb Ds Qualified Based( pQdb_Qdbfb )
D Reserved_48 48a
D Qdbfbf 10a
D Qdbfbfl 10a
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
**
D Qdb_Qdbfk Ds Qualified Based( pQdb_Qdbfk )
D Qdbfkfld 10a
D Reserved_59 3a
D Qdbfksq 1a
D* Qdbfksad :1
D* Qdbfksn :2
D* Reserved_60 :1
D* Qdbfksac :1
D* Qdbfkszf :1
D* Qdbfksdf :1
D* Qdbfkft :1
D Reserved_61 18a
**
D Qdb_Qdbfss Ds Qualified Based( pQdb_Qdbfss )
D Reserved_54 2a
D Qdbfssso 1a
D Qdbfssop 2a
D Qdbfssfn 10a
D Qdbfsspnum 5i 0
D Qsosaf 1a
D* Reserved_55 :7
D* Qdbfssfi :1
D Qdbfssfj 5i 0
D Reserved_56 8a
D Qdbfsoso 10i 0
**
D Qdb_Qdbfsp Ds Qualified Based( pQdb_Qdbfsp )
D Qdbfspno 10i 0
D Qdbfspln 5i 0
D Qdbfspin 1a
D Qasopaf 1a
D* Qdbfsigc :1
D* Qdbfshex :1
D* Qdbfsnul :1
D* Reserved_57 :5
D Qdbfsppj 5i 0
D Reserved_58 10a
D Qdbfspvl 128a
**
**-- FILD0200 formats:
D Qdb_Qddfmt Ds Qualified Based( pQdb_Qddfmt )
D Qddbyrtn 10i 0
D Qddbyava 10i 0
D Reserved_62 24a
D Qddfmtf 1a
D Qddfxlto 10i 0
D Qddfrcao 10i 0
D Qddfdico 10i 0
D Qddfrcid 5i 0
D Qddfsrcd 5i 0
D Qddfrtcd 5i 0
D Qddfrlcd 5i 0
D Reserved_64 7a
D Qddftflgs 1a
D Qddflgs 1a
D Reserved_67 4a
D Qddfrlen 10i 0
D Qddfname 10a
D Qddfseq 13a
D Qddftext 50a
D Qddffldnum 5i 0
D Qddf_...
D Identity_Off 10i 0
**
D Qdb_Qddffld Ds Qualified Based( pQdb_Qddffld )
D Qddfdefl 10i 0
D Qddffldi 30a
D Qddfflde 30a
D Qddfftyp 2a
D Qddffiob 1a
D Qddffobo 10i 0
D Qddffibo 10i 0
D Qddffldb 5i 0
D Qddffldd 5i 0
D Qddffldp 5i 0
D Qddffkbs 1a
D Qddffldst 1a
D Qddfjref 5i 0
D Qddffldst2 1a
D Qddflgs2 1a
D Qddfvarx 5i 0
D Reserved_72 2a
D Qddflalc 5i 0
D Qddfdttf 1a
D Qddfdtts 1a
D Qddfcsid 5i 0
D Qddftsid 5i 0
D Qddfhsid 5i 0
D Qddflsid 5i 0
D Qddfldur 1a
D Reserved_73 1a
D Qddfwsid 5i 0
D Reserved_061 1a
D Reserved_062 1a
D Reserved_063 5i 0
D Qddflagco 1a
D Reserved_74 68a
D Qddfcplx 10i 0
D Qddfbmaxl 10i 0
D Qddfbpadl 5i 0
D Qddfdicd 10i 0
D Qddfdftd 10i 0
D Qddfderd 10i 0
D Reserved_75 6a
D Qddftxtd 10i 0
D Reserved_102 2a
D Qddfrefd 10i 0
D Qddfedtl 5i 0
D Qddfedtd 10i 0
D Reserved_76 5i 0
D Qddfchd 10i 0
D Qddfvckl 5i 0
D Qddfvckd 10i 0
D Qddfxals 10i 0
D Qddffpnd 10i 0
D Reserved_77 8a
D Qddfvpx 1a
**
D Qdb_Qddfvchk Ds Qualified Based( pQdb_Qddfvchk )
D Qddfvcnume 5i 0
D Reserved_82 14a
D Qddfvcen 1a
**
D Qdb_Qddfvcst Ds Qualified Based( pQdb_Qddfvcst )
D Qddfvccd 1a
D Qddfvcnump 5i 0
D Qddfvcel 5i 0
D Reserved_83 11a
D Qddfvcpm 1a
**
D Qdb_Qddfvcpr Ds Qualified Based( pQdb_Qddfvcpr )
D Qddfvcpl 5i 0
D Reserved_84 14a
D Qddfvcpv 256a
**
D Qdb_Qddfftxt Ds Qualified Based( pQdb_Qddfftxt )
D Qddfftst 50a
**
D Qdb_Qddfcolh Ds Qualified Based( pQdb_Qddfcolh )
D Qddfch1 20a
D Qddfch2 20a
D Qddfch3 20a
**-- Retrieve database file description:
D RtvDbfDsc Pr ExtPgm( 'QDBRTVFD' )
D RdRcvVar 32767a Options( *VarSize )
D RdRcvVarLen 10i 0 Const
D RdFilRtnQ 20a
D RdFmtNam 8a Const
D RdFilNamQ 20a Const
D RdRcdFmtNam 10a Const
D RdOvrPrc 1a Const
D RdSystem 10a Const
D RdFmtTyp 10a Const
D RdError 32767a Options( *VarSize )
**-- Send program message:
D SndPgmMsg Pr ExtPgm( 'QMHSNDPM' )
D SpMsgId 7a Const
D SpMsgFq 20a Const
D SpMsgDta 128a Const
D SpMsgDtaLen 10i 0 Const
D SpMsgTyp 10a Const
D SpCalStkE 10a Const Options( *VarSize )
D SpCalStkCtr 10i 0 Const
D SpMsgKey 4a
D SpError 1024a Options( *VarSize )
**-- Test bit in string:
D tstbts Pr 10i 0 ExtProc( 'tstbts' )
D String * Value
D BitOfs 10u 0 Value
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
**-- Send message by type:
D SndMsgTyp Pr 10i 0
D PxMsgDta 512a Const Varying
D PxMsgTyp 10a Const
**-- Entry parameters:
D CBX123 Pr
D PxDbfNamQ 20a
D PxRcdFmt 10a
**
D CBX123 Pi
D PxDbfNamQ 20a
D PxRcdFmt 10a
/Free
ApiRcvSiz = 65535;
pQdb_Qdbfh = %Alloc( ApiRcvSiz );
Qdb_Qdbfd.Qdbfyavl = 0;
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
: FilRtnQ
: 'FILD0100'
: PxDbfNamQ
: PxRcdFmt
: '0'
: '*LCL'
: '*EXT'
: ERRC0100
);
EndDo;
If ERRC0100.BytAvl = *Zero;
pQdb_Qdbfb = pQdb_Qdbfh + Qdb_Qdbfh.Qdbfos;
If tstbts( %Addr( Qdb_Qdbfh.Qdbfhflg ): 2 ) = 1;
FilTyp = 'LF';
Else;
FilTyp = 'PF';
EndIf;
FilNam = FilRtnQ.FilNam;
LibNam = FilRtnQ.LibNam;
For RcdIdx = 1 To Qdb_Qdbfh.Qdbflbnum;
If PxRcdFmt = Qdb_Qdbfb.Qdbft Or
PxRcdFmt = '*FIRST';
RcdFmt = Qdb_Qdbfb.Qdbft;
If Qdb_Qdbfh.Qdbfpact = 'AR';
AccPth = '*ARRIVAL';
Else;
AccPth = '*KEYED';
EndIf;
If tstbts( %Addr( Qdb_Qdbfh.Qdbfhflg ): 6 ) = 1;
ExSr GetKeyFlds;
EndIf;
If tstbts( %Addr( Qdb_Qdbfh.Qdbfhflg ): 9 ) = 1;
ExSr GetSltOmit;
EndIf;
Leave;
EndIf;
If RcdIdx < Qdb_Qdbfh.Qdbflbnum;
pQdb_Qdbfb = pQdb_Qdbfb + %Size( Qdb_Qdbfb );
EndIf;
EndFor;
EndIf;
If ERRC0100.BytAvl = *Zero;
ApiRcvSiz = 65535;
pQdb_Qddfmt = %Alloc( ApiRcvSiz );
DoU Qdb_Qddfmt.Qddbyava <= ApiRcvSiz;
If Qdb_Qddfmt.Qddbyava > ApiRcvSiz;
ApiRcvSiz = Qdb_Qddfmt.Qddbyava;
pQdb_Qddfmt = %ReAlloc( pQdb_Qddfmt: ApiRcvSiz );
EndIf;
RtvDbfDsc( Qdb_Qddfmt
: ApiRcvSiz
: FilRtnQ
: 'FILD0200'
: PxDbfNamQ
: PxRcdFmt
: '0'
: '*LCL'
: '*EXT'
: ERRC0100
);
EndDo;
If ERRC0100.BytAvl = *Zero;
pQdb_Qddffld = %Addr( Qdb_Qddfmt ) + 256;
RcdLen = Qdb_Qddfmt.Qddfrlen;
FldCnt = Qdb_Qddfmt.Qddffldnum;
For FldIdx = 1 To Qdb_Qddfmt.Qddffldnum;
If Qdb_Qddffld.Qddftxtd > *Zero;
pQdb_Qddfftxt = pQdb_Qddffld + Qdb_Qddffld.Qddftxtd;
Else;
pQdb_Qddfftxt = *Null;
EndIf;
If Qdb_Qddffld.Qddfchd > *Zero;
pQdb_Qddfcolh = pQdb_Qddffld + Qdb_Qddffld.Qddfchd;
Else;
pQdb_Qddfcolh = *Null;
EndIf;
ExSr PrtDtlLin;
If Qdb_Qddffld.Qddfvckd > *Zero;
ExSr PrtChkVal;
EndIf;
If FldIdx < Qdb_Qddfmt.Qddffldnum;
pQdb_Qddffld = pQdb_Qddffld + Qdb_Qddffld.Qddfdefl;
EndIf;
EndFor;
ExSr PrtKeyFld;
ExSr PrtSltStm;
EndIf;
DeAlloc pQdb_Qddfmt;
EndIf;
DeAlloc pQdb_Qdbfh;
If ERRC0100.BytAvl > *Zero;
SndEscMsg( ERRC0100.MsgId
: 'QCPFMSG'
: %Subst( ERRC0100.MsgDta: 1: ERRC0100.BytAvl - 16 )
);
EndIf;
SndMsgTyp( 'Field description list has been printed.': '*COMP' );
*InLr = *On;
Return;
BegSr PrtChkVal;
pQdb_Qddfvchk = pQdb_Qddffld + Qdb_Qddffld.Qddfvckd;
pQdb_Qddfvcst = %Addr( Qdb_Qddfvchk.Qddfvcen );
For ChkIdx = 1 To Qdb_Qddfvchk.Qddfvcnume;
pQdb_Qddfvcpr = %Addr( Qdb_Qddfvcst.Qddfvcpm );
TxtLin2 = ChkKwdA( %Lookup( Qdb_Qddfvcst.Qddfvccd: ChkHexA ));
For ValIdx = 1 To Qdb_Qddfvcst.Qddfvcnump;
TxtLin2 = %TrimR( TxtLin2 ) + ' ' +
%Subst( Qdb_Qddfvcpr.Qddfvcpv
: 1
: Qdb_Qddfvcpr.Qddfvcpl
);
If ValIdx < Qdb_Qddfvcst.Qddfvcnump;
pQdb_Qddfvcpr = pQdb_Qddfvcpr + 16 + Qdb_Qddfvcpr.Qddfvcpl;
EndIf;
EndFor;
ExSr PrtHdrLin;
Except DtlLin2;
If ChkIdx < Qdb_Qddfvchk.Qddfvcnume;
pQdb_Qddfvcpr = %Addr( Qdb_Qddfvcst.Qddfvcpm );
pQdb_Qddfvcst = pQdb_Qddfvcst + Qdb_Qddfvcst.Qddfvcel;
EndIf;
EndFor;
EndSr;
BegSr PrtKeyFld;
ExSr PrtHdrLin;
SpcTxt = AccPth + ' ' + KeyTyp;
Except HdrKey;
Except SpcLin;
For KeyIdx = 1 To %Elem( KeyFld );
If KeyFld(KeyIdx) = *Blank;
Leave;
EndIf;
ExSr PrtHdrLin;
SpcTxt = %Char( KeyIdx ) + ' ' + KeyFld(KeyIdx);
Except SpcLin;
EndFor;
EndSr;
BegSr PrtSltStm;
If FilTyp = 'LF';
ExSr PrtHdrLin;
Except HdrSlt;
If SltStm(1) = *Blank;
SpcTxt = '*NONE';
Except SpcLin;
Else;
For SltIdx = 1 To %Elem( SltStm );
If SltStm(SltIdx) = *Blank;
Leave;
EndIf;
ExSr PrtHdrLin;
SpcTxt = SltStm(SltIdx);
Except SpcLin;
EndFor;
EndIf;
EndIf;
EndSr;
BegSr GetKeyFlds;
If Qdb_Qdbfh.Qdbfpact = 'KU';
KeyTyp = '*UNIQUE';
EndIf;
pQdb_Qdbfk = pQdb_Qdbfh + Qdb_Qdbfb.Qdbfksof;
For KeyIdx = 1 To Qdb_Qdbfb.Qdbfbgky;
KeyFld(KeyIdx) = Qdb_Qdbfk.Qdbfkfld;
If KeyIdx < Qdb_Qdbfb.Qdbfbgky;
pQdb_Qdbfk = pQdb_Qdbfk + %Size( Qdb_Qdbfk );
EndIf;
EndFor;
EndSr;
BegSr GetSltOmit;
pQdb_Qdbfss = pQdb_Qdbfh + Qdb_Qdbfb.Qdbfsoof;
For SltIdx = 1 To Qdb_Qdbfb.Qdbfsoon;
If Qdb_Qdbfss.Qdbfssop <> 'AL';
SltStm(SltIdx) = Qdb_Qdbfss.Qdbfssso + ' ' +
Qdb_Qdbfss.Qdbfssfn + ' ' +
SltKwdA( %Lookup( Qdb_Qdbfss.Qdbfssop
: SltCodA
));
pQdb_Qdbfsp = pQdb_Qdbfh + Qdb_Qdbfss.Qdbfsoso;
For ValIdx = 1 To Qdb_Qdbfss.Qdbfsspnum;
SltStm(SltIdx) = SltStm(SltIdx) + ' ' +
%Subst( Qdb_Qdbfsp.Qdbfspvl
: 1
: Qdb_Qdbfsp.Qdbfspln - 20
);
If ValIdx < Qdb_Qdbfss.Qdbfsspnum;
pQdb_Qdbfsp = pQdb_Qdbfh + Qdb_Qdbfsp.Qdbfspno;
EndIf;
EndFor;
EndIf;
If SltIdx < Qdb_Qdbfb.Qdbfsoon;
pQdb_Qdbfss = pQdb_Qdbfss + %Size( Qdb_Qdbfss );
EndIf;
EndFor;
EndSr;
BegSr PrtDtlLin;
ExSr PrtHdrLin;
Clear OutDtl;
FldNam = Qdb_Qddffld.Qddfflde;
FldTyp = TypTxtA( %Lookup( Qdb_Qddffld.Qddfftyp
: TypHexA
));
KeyIdx = %Lookup( FldNam: KeyFld );
If KeyIdx > *Zero;
KeySeq = %Char( KeyIdx );
If KeyTyp = '*UNIQUE';
%Subst( KeySeq: %Size( KeySeq ): 1 ) = 'U';
EndIf;
EndIf;
BufPos = Qdb_Qddffld.Qddffobo + 1;
FldLen = Qdb_Qddffld.Qddffldb;
If Qdb_Qddffld.Qddffldd > *Zero;
EvalR FldDig = %Char( Qdb_Qddffld.Qddffldd );
EvalR FldDec = %Char( Qdb_Qddffld.Qddffldp );
EndIf;
If pQdb_Qddfftxt <> *Null;
FldTxt = Qdb_Qddfftxt.Qddfftst;
EndIf;
If pQdb_Qddfcolh <> *Null;
FldHdg = Qdb_Qddfcolh.Qddfch1 + ' ' +
Qdb_Qddfcolh.Qddfch2 + ' ' +
Qdb_Qddfcolh.Qddfch3;
EndIf;
Except DtlLin;
If FldTxt <> FldHdg And FldTxt > *Blanks;
TxtLin2 = FldTxt;
Except DtlLin2;
EndIf;
EndSr;
BegSr PrtHdrLin;
If PrtInf.CurLin > PrtInf.OvfLin - 6 Or
PrtInf.WrtCnt = *Zero;
Except Header;
EndIf;
EndSr;
Begsr *InzSr;
Time = Time;
PrtInf.WrtCnt = *Zero;
PrtInf.CurLin = *Zero;
EndSr;
/End-Free
**-- Print file definition:
OQSYSPRT EF Header 2 3
O UDATE Y 8
O Time 18 ' : : '
O 74 'Print file field descrip-
O tion'
O 107 'Program:'
O PsPgmNam 118
O 126 'Page:'
O PAGE + 1
OQSYSPRT EF Header 1
O 16 'File . . . . . :'
O FilNam 28
O 56 'Record format . . . :'
O RcdFmt 68
O 96 'Record length . . . :'
O RcdLen 3 103
OQSYSPRT EF Header 2
O 16 ' Library . . :'
O LibNam 28
O 56 'File type . . . . . :'
O FilTyp 68
O 96 'Record field count :'
O FldCnt 3 103
OQSYSPRT EF Header 1
O 10 'Field name'
O 22 'Field type'
O 30 'Buffer'
O 38 'Length'
O 46 'Digits'
O 52 'Dec.'
O 57 'Key'
O 93 'Column heading/text/check -
O values'
**
OQSYSPRT EF DtlLin 1
O FldNam 10
O FldTyp 22
O BufPos 3 29
O FldLen 3 36
O FldDig 44
O FldDec 50
O KeySeq 58
O FldHdg 123
**
OQSYSPRT EF DtlLin2 1
O TxtLin2 131
**
OQSYSPRT EF HdrKey 1
O 31 'Access path . . . . . . . -
O . . :'
**
OQSYSPRT EF HdrSlt 1
O 31 'Select/omit statements . -
O . . :'
**
OQSYSPRT EF SpcLin 1
O SpcTxt 131
**-- 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 message by type: ---------------------------------------------**
P SndMsgTyp B
D Pi 10i 0
D PxMsgDta 512a Const Varying
D PxMsgTyp 10a Const
**
D MsgKey s 4a
/Free
SndPgmMsg( 'CPF9897'
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: PxMsgTyp
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndMsgTyp E
Command
/*-------------------------------------------------------------------*/
/* */
/* Compile options: */
/* */
/* CrtCmd Cmd( PRTFFD ) */
/* Pgm( CBX123 ) */
/* SrcMbr( CBX123X ) */
/* HlpPnlGrp( CBX123H ) */
/* HlpId( *CMD ) */
/* */
/*-------------------------------------------------------------------*/
Cmd Prompt( 'Print File Field Description' )
Parm FILE Q0001 +
Min( 1 ) +
File( *UNSPFD ) +
Choice( *NONE ) +
Prompt( 'File' )
Parm RCDFMT *Name +
Dft( *FIRST ) +
SpcVal(( *FIRST )) +
Expr( *YES ) +
Prompt( 'Record format' )
Q0001: Qual *Name 10 +
Min( 1 ) +
Expr( *YES )
Qual *Name 10 +
Dft( *LIBL ) +
SpcVal(( *LIBL ) +
( *CURLIB )) +
Expr( *YES ) +
Prompt( 'Library' )
Panel group
.*-----------------------------------------------------------------------**
.*
.* Compile options:
.*
.* CrtPnlGrp PnlGrp( CBX123H )
.* SrcFile( QPNLSRC )
.* SrcMbr( *PNLGRP )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
:HELP NAME='PRTFFD'.Print file field description - Help
:P.
The Print File Field Description (PRTFFD) command prints database file
field-level information for the specified file. This information
includes data type, length, buffer position and check values as well as
key field specification and, for logical files, any select/omit criteria
specification.
:P.
:EHELP.
:HELP NAME='PRTFFD/FILE'.File (FILE) - Help
:XH3.File (FILE)
:P.
Specifies the name and library of the database file for which to print
the field information.
:P.
This is a required parameter.
:P.
:XH3.Library
:P.
Specify the name of the library where the database file is located.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*LIBL:EPK.
:PD.
All libraries in the job's library list are searched until the first
match is found.
:PT.:PK.*CURLIB:EPK.
:PD.
The current library for the job is searched. If no library is
specified as the current library for the job, the QGPL library is used.
:PT.:PV.library-name:EPV.
:PD.
Specify the name of the library to qualify the file name.
:EPARML.
:EHELP.
:HELP NAME='PRTFFD/RCDFMT'.Record format (RCDFMT) - Help
:XH3.Record format (RCDFMT)
:P.
If a logical file having more than one record format was specified as
the file name, this parameter is used to identify the record format
that you want used when retrieving the field information.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*FIRST:EPK.
:PD.
The first record format found will be used to identify the file record
format.
:PT.:PV.record-format-name:EPV.
:PD.
Specify the name of the record format to use.
:EPARML.
:EHELP.
:EPNLGRP.
Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
阅读(2671) | 评论(0) | 转发(0) |
