contact image



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
      *-=-=-=--=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-