Get a list of tables that contain a field.
DOWNLOAD
Download text files
I was asked to rename a product on our system because they were re-releasing this
product under the same name.
I had to find all tables on the system (data library) which contained this field.
I thought I could use some API's and develop a cannon
to kill a mosquito. (so here it is)
This program takes in a field value, its description, size and attributes from
a table in a library.
Then it searches all tables in that library for fields with like characteristics.
Once identified it writes them to a table.
Opportunities
- It runs interactive and needs to be submitted
- Entry field is needed for the search library
- Flexible selection critera should be made available
- Need to develop application that reads the generated file and does a replace (SQL?)
Select a file to begin search.
Select a field from the file. - I searched for PGPRDC
What you get.
A list of all tables that contain '%LIKE%' product code fields.
also the record count so you can skip tables with *Zeros records.
I know I could have not written them to table but Its better to
see them for example.
H*------------------------------------------
H dftactgrp(*no) option(*srcstmt : *nodebugio)
H*------------------------------------------
FPICKFLDD CF E WORKSTN
FFIELDSP UF A E DISK Prefix(@)
D AR S 1 DIM(9999)
D AKEY S 10 DIM(9999)
D AK# S 2 0 DIM(9999)
D J S 2 0
D JJ S 2 0
D I S 7 0
D S S 7 0
D RelRecNbr S 4 0
D XX S 7 0
D I1 S 1
D I2 S 2
D pDataQLib s 10
D pDataQName s 10
D pFileLib S 20
D FileLib s 20 inz(*blanks)
D pInputLib s 10
D pInputName s 10
D InputLib s 10 inz(*blanks)
D InputName s 10 inz(*blanks)
D InFormat S 10
D EntryFmt S 10 inz('*FIRST')
D SFLRcdCnt S 04 0
D RRn S 04 0
D SavRRn S 04 0
D NbrofField S 04 0
D OutField S 10
D OutDesc S 30
D OutSize S 15 5
D OutDecimal S 15 5
D OutType2 S 01
D FileName S 10
D LibName S 10
D*
*
D GENDS DS
D OffsetHdr 117 120B 0
D SizeHeader 121 124B 0
D OffsetList 125 128B 0
D NbrInList 133 136B 0
D SizeEntry 137 140B 0
D HeaderDs DS
D OutFileNam 1 10
D OutLibName 11 20
D OutType 21 25
D OutFormat 31 40
D RecordLen 41 44B 0
D InputDs DS
D UserSpace 1 20
D SpaceName 1 10
D SpaceLib 11 20
D InpFileLib 29 48
D InpFFilNam 29 38
D InpFFilLib 39 48
D InpRcdFmt 49 58
D ListDs DS
D FieldName 1 10
D FieldType 11 11
D BufferOut 13 16B 0
D FieldLen 21 24B 0
D Digits 25 28B 0
D Decimals 29 32B 0
D FieldDesc 33 82
D ErrorDs DS INZ
D BytesPrv 1 4B 0
D BytesAvl 5 8B 0
D MessageId 9 15
D ERR### 16 16
D MessageDta 17 116
D ReceiveVr2 S 100
D ReceiveVar DS 4096
D NbrOfFmts 62 63B 0
D DBFileOff 317 320B 0
D FindSelDs DS 150
D NbrOfKeys 117 118B 0
D KeyOffset 136 139B 0
D KeyDataDs DS
D DependKey 1 10
D DS
D StartPosit 1 4B 0
D StartLen 5 8B 0
D SpaceLen 9 12B 0
D ReceiveLen 13 16B 0
D MessageKey 17 20B 0
D MsgDtaLen 21 24B 0
D MsgQueNbr 25 28B 0
DGenSpcPtr *
DLstSpcPtr *
DHdrPtr *
*
* API
*
D ReturnCode s 1
D SQLQDBXREF ds
D qDBXFIL 10
D qDBXLIB 10
D qDBXATR 2
D qDBXTYP 1
D qDBXTXT 50
*
* Retrieve member description
*
D szMsgText S 255A
** Tells the APIs how long the buffers are that are being used.
D nBufLen S 10I 0
** The structure returned by the QusRMBRD API.
D szMbrd0100 DS INZ
D nBytesRtn 10I 0
D nBytesAval 10I 0
D szFileName 10A
D szLibName 10A
D szMbrName 10A
D szFileAttr 10A
D szSrcType 10A
D dtCrtDate 13A
D dtLstChg 13A
D szMbrText 50A
D bIsSource 1A
D RmtFile 1A
D LglPhyFile 1A
D ODPSharing 1A
D filler2 2A
D RecCount 10I 0
D DltRecCnt 10I 0
D DataSpaceSz 10I 0
D AccpthSz 10I 0
D NbrBasedOnMbr 10I 0
**----------------------------------------------------------------
** Input Parameters for the program.
**----------------------------------------------------------------
** Source file name
D szSrcFile S 10A
D szSrcLib S 10A
D szSrcMbr S 10A
**----------------------------------------------------------------
** Input Parameters to the QUSRMBRD API
**----------------------------------------------------------------
** Format to be returned
D szFmt S 8A Inz('MBRD0200')
** Qualified source file and library name
D szQualName S 20A
** Whether or not to ignore overrides (0=Ignore, 1 = Apply)
D bOvr S 1A Inz('0')
*
* Field Definitions
*
D @Scrn1 S 01 inz('Y')
D*
D CmdString s 500 inz(*blanks)
D CmdLength s 15 5 inz(0)
*
D InField s 10
D InDesc s 30
D InType s 01
D InSize s 15 5
D InDec s 15 5
D
D Searchfile s 10
D Searchlib s 10
D WorkDesc s 30
C*------------------------------------------
C* M A I N L I N E
C*------------------------------------------
C Dow @Scrn1 = 'Y'
C Eval W1LIB = 'RC1380BFR1'
C Eval W1FILE = 'SRBPRG'
C Exfmt WIN1
C Select
C When *In03 Or *In12
C Clear @Scrn1
C Other
C Exsr $Process
C Endsl
C Enddo
C Eval *InLR = *on
C return
C*------------------------------------------
C* $Process - Process the screen
C*------------------------------------------
C $Process begsr
C*
C If W1LIB <> *Blanks
C And W1FILE <> *Blanks
C Call 'LSTFLDR'
C Parm W1LIB
C Parm W1FILE
C Parm InField
C Parm InDesc
C Parm InType
C Parm InSize
C Parm InDec
C*
C If InField <> *Blanks
C*
C Movel(p) InDesc WorkDesc
C*
C Exsr $Find_Field
C*
C Endif
C Endif
C*
C endsr
C*------------------------------------------
C* $Find_Field
C*------------------------------------------
C $Find_Field begsr
C*
C Exsr $Close
C Exsr $Selection
C Exsr $Open
C Exsr $Fetch
C*
C Dow SQLCOD = 0
C Exsr $Search
C Exsr $Fetch
C Enddo
C*
C endsr
C*------------------------------------------
C* $Selection
C*------------------------------------------
C $Selection begsr
C/EXEC SQL
C+ DECLARE A CURSOR FOR
C+ SELECT DBXFIL, DBXLIB, DBXATR, DBXTYP, DBXTXT
C+ FROM QADBXREF
C+ WHERE DBXTYP = 'D' And DBXATR = 'PF' AND DBXLIB = :W1LIB
C/END-EXEC
C endsr
C*------------------------------------------
C* $Fetch - SQL fetch
C*------------------------------------------
C $Fetch begsr
C/EXEC SQL
C+ FETCH A INTO :SQLQDBXREF
C/END-EXEC
C endsr
C*------------------------------------------
C* $Close - SQL Close
C*------------------------------------------
C $Close begsr
C/EXEC SQL
C+ CLOSE A
C/END-EXEC
C endsr
C*------------------------------------------
C* $Open - SQL Open
C*------------------------------------------
C $Open begsr
C/EXEC SQL
C+ OPEN A
C/END-EXEC
C endsr
C*------------------------------------------
C* $Search - Seach for the field in the file
C*------------------------------------------
C $Search begsr
C*
C* run API again to list all fields in a file.
C* Then check to see if it matches the criteria
C* of the selected field.
C*
C If %Subst(QDBXFIL:1:1) <> 'Q'
C And %Subst(QDBXFIL:1:1) <> '#'
C eval SpaceName = 'PICKFLD'
C eval SpaceLib = 'QTEMP'
C eval InpFFilNam = QDBXFIL
C eval InpFFilLib = QDBXLIB
C eval filelib = QDBXFIL + QDBXLIB
C Movel(p) QDBXFIL FileName
C Movel(p) QDBXLIB LibName
*
* Create the user space
*
C call 'QUSCRTUS'
C parm UserSpace
C parm *BLANKS SpaceAttr 10
C parm 4096 SpaceLen
C parm *BLANKS Spaceval 1
C parm '*CHANGE' SpaceAuth 10
C parm *BLANKS SpaceText 50
C parm '*YES' SpaceRepl 10
C parm ErrorDs
*
* Attemp to retrieve object description
*
C call 'QUSROBJD' 99
C parm ReceiveVr2
C parm 100 ReceiveLen
C parm 'OBJD0100' FileFormat 8
C parm FileLib
C parm '*FILE' ObjectType 10
C parm ErrorDs
*
C if *in99 = *off
*
* List fields to user space
*
C call 'QUSLFLD'
C parm UserSpace
C parm 'FLDL0100' ListFormat 8
C parm InpFileLib
C parm '*FIRST' InpRcdFmt
C parm '1' OverRide 1
C eval StartPosit = 1
C eval StartLen = 140
*
C call 'QUSRTVUS'
C parm UserSpace
C parm StartPosit
C parm StartLen
C parm GENDS
C eval StartPosit = OffsetHdr + 1
C eval StartLen = SizeHeader
*
C call 'QUSRTVUS'
C parm UserSpace
C parm StartPosit
C parm StartLen
C parm HeaderDs
*
C eval StartPosit = OffsetList + 1
C eval StartLen = SizeEntry
C eval SpaceName = 'PICKFLD'
C eval SpaceLib = 'QTEMP'
*
* Start the do loop to read the FFD userspace
*
C do NbrInList NbrOfField
C call 'QUSRTVUS'
C parm UserSpace
C parm StartPosit
C parm StartLen
C parm ListDs
C*
C* The big old if or list modify to fit your needs
C*
C If Fieldname = InField
C Or
C %Trim(%Subst(Fieldname:3:4)) =
C %Trim(%Subst(InField:3:4))
C Or
C WorkDesc = FieldDesc
C Or
C InSize = FieldLen And
C InType = FieldType
C Movel(p) LibName @LIBRARY
C Movel(p) FileName @FILE
C Eval @FIELD = FieldName
C Eval @DESC = FieldDesc
C Eval @TYPE = FieldType
C Eval @LENGTH = FieldLen
C Eval @DEC = Decimals
C Exsr $GetMbrDesc
C Movel(p) SZMBRTEXT @FDESC
C Z-add RecCount @RECORDS
C Write FIELDR
C Endif
C eval StartPosit = StartPosit + SizeEntry
C enddo
C Endif
C Endif
C endsr
C*------------------------------------------
C* $GetMbrDesc - Get member description
C*------------------------------------------
C $GetMbrDesc begsr
*
C Eval nBufLen = %size(szMbrD0100)
C Call(E) 'QUSRMBRD'
C Parm szMbrD0100
C Parm nBufLen
C Parm szFmt
C Parm FileLib
C Parm '*FIRST' szSrcMbr
C Parm bOvr
C endsr
C*------------------------------------------
* *inzsr - Initial one time run subroutine
C*------------------------------------------
C *inzsr begsr
*
*
C endsr
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Okay I kinda did it
Source included in zip file above.
Here is a program that reads file
FIELDSP and generates a source file with SQL statements
and uses the RUNSQLSTM command to process the file.
Yes the product ID's are hardcoded but some clever programmer could
develop screens for scan replace.
H dftactgrp(*no) option(*srcstmt : *nodebugio)
FFIELDSP IF E DISK usropn
FSOURCE UF A E DISK rename(SOURCE:src)
F usropn
*
* Fields Definition
* ~~~~~~~~~~~~~~~~~
D CmdString s 500 inz(*blanks)
D CmdLength s 15 5 inz(0)
D Q s 01 inz('''')
*
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* M A I N L I N E
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
*
* CLRPFM FILE(JJFLIB/SOURCE) MBR(GENSQL)
*
C Eval CmdString = 'CLRPFM FILE(JJFLIB/'
C + %trim('SOURCE) MBR(GENSQL')
C eval CmdLength = %len(%trim(CmdString))
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C*
C If Not%Open(FIELDSP)
C Open FIELDSP
C Endif
C*
C *Start Setll FIELDSP
C Read FIELDSP
C Dow Not%Eof(FIELDSP)
*
* OVRDBF FILE(ZSOURCE) TOFILE(JJFLIB/SOURCE) MBR(SOMEMEMBER)
*
C Eval CmdString = 'OVRDBF FILE(SOURCE) T'
C + %trim('OFILE(JJFLIB/SOURCE) M')
C + %trim('BR(GENSQL)')
C eval CmdLength = %len(%trim(CmdString))
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C If Not%Open(SOURCE)
C Open SOURCE
C Endif
C If RECORDS > *Zeros
C And LENGTH = 33.
C Exsr $SQLWrite
C Endif
C Read FIELDSP
C Enddo
C Eval CmdString = 'DLTOVR *ALL'
C eval CmdLength = %len(%trim(CmdString))
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C*
C If %Open(FIELDSP)
C Close FIELDSP
C Endif
C*
C*RUNSQLSTM SRCFILE(JJFLIB/SOURCE) SRCMBR(GENSQL) OUTPUT(*PRINT)
C*
C Eval CmdString = 'RUNSQLSTM SRCFILE('
C + %Trim('JJFLIB/SOURCE) SRCMBR(GENSQL')
C + %Trim(') COMMIT(*NONE) OUTPUT(*PRINT) ')
C eval CmdLength = %len(%trim(CmdString))
C call 'QCMDEXC' 99
C parm CmdString
C parm CmdLength
C Eval *INLR = *On
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* $SQLWrite - Write the SQL stuff.
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
C $SQLWrite begsr
*
C Clear SRCDTA
C Write SRC
C Eval SRCDTA = %Trim('UPDATE')
C +%Trim('!RC1380BFR1/') + %Trim(FILE)
C +%Trim('!!') + %Trim('SET')
C +%Trim('!!') + %Trim(FIELD)
C +%Trim('!!') + %Trim('=')
C +%Trim('!!')
C +%Trim(Q) + %Trim('ASB AT-5OLD')
C +%Trim(Q) +%TRIM('!!')
C Eval SRCDTA = %Xlate('!':' ':SRCDTA)
C Write SRC
C Eval SRCDTA =
C %Trim('WHERE')
C +%Trim('!!') + %Trim(FIELD)
C +%Trim('!!') + %Trim('=') + %Trim('!!')
C +%Trim(Q) + %Trim('ASB AT-5') + %Trim(Q)
C +%TRIM('!!;')
C Eval SRCDTA = %Xlate('!':' ':SRCDTA)
C Write SRC
*
C endsr
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* *inzsr - Initial one time run subroutine
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
C *inzsr begsr
*
C endsr
*-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
