RPGIV @ Work

A unique site for RPG and System i Lovers

Welcome!

Hi, this site will provide all what you need in System i and RPG developments.

My Name is Chamara Withanachchi, System i Expert and RPG Developer. And in the field for last 11 years.

I hope you will find lot of valuable information from this site

Obsolete Objects Checking Program Print E-mail
User Rating: / 2
PoorBest 
Written by Chamara Withanachchi   

Following program written to check obsolete objects in one of our customers libraries. I have used QUSLOBJ (List objects API), QUSRTVUS (Userspace pointer API), QUSCRTUS (Create Space API) and QUSROBJD (API to get the Object Details) APIs to achive this and referred www.code400.com site too.


     H Option(*SrcStmt: *NoDebugIO) DftActGRP(*No)                      
      ***************************************************************** 
      *                                                               * 
      * Application      : CMC                                        * 
      * Project Number   :                                            * 
      * Title            :  Find and print Obsoletes                  * 
      * Description      :  This program find and print Obsolete      * 
      *                     objects in the system, Number of years    * 
      *                     can be define in EMPARA00 file            * 
      *                                                               * 
      * Author           : Chamara Withanachchi                       * 
      * Date             : 2010/08/17                                 * 
      *                                                               * 
      ***************************************************************** 
      * MODIFICATIONS                                                 * 
      ***************************************************************** 
      *By              :                                              * 
      *Date yyyy/mm/dd :             Reference Number:                * 
      *Descreption                                                    * 
      *-----------                                                    *     
      *                                                               *     
      *                                                               *     
      *---------------------------------------------------------------*     
                                                                            
      * Parameter File.....                                                 
     FEMPARA01  IF   E           K Disk                                     
                                                                            
      * Printer File.....                                                   
     FCHKOBSP1  O    E             Printer InfDS(@FP1)                      
                                                                            
      * Printer file information data structure                             
     D @FP1            DS                                                   
      * Printer file name                                                   
     D  P1@NAM                83     92                                     
      * Overflow line number                                                
     D  P1@OvFlow            188    189B 0                                  
      * Current Report Line                                                 
     D  P1@Line              367    368B 0                                  
      * Current Report Page                                          
     D  P1@Page              369    372B 0                           
                                                                     
      * Api error data structure:                                    
     D ApiError        Ds                                            
     D  AeBytPro                     10i 0 Inz( %Size( ApiError ))   
     D  AeBytAvl                     10i 0 Inz                       
     D  AeMsgId                       7a                             
     D                                1a                             
     D  AeMsgDta                    128a                             
                                                                     
      * Object description structure OBJD0400:                       
     D ObjDscDs        Ds                  Inz                       
     D  ObjDscLen                    10i 0                           
     D  ObjDscSiz                    10i 0                           
     D  ObjNam                       10                              
     D  ObjLib                       10                              
     D  ObjTyp                       10                              
     D  ObjRtnLib                    10                              
     D  ObjAsp                       10i 0     
     D  ObjOwnr                      10        
     D  ObjDmn                        2        
     D  ObjCrtDat                    13        
     D  ObjChgDat                    13        
     D  ObjAtr                       10        
     D  ObjTxt                       50        
     D  ObjSrcFil                    10        
     D  ObjSrcLib                    10        
     D  ObjSrcMbr                    10        
     D  ObjSrcChgDat                 13        
     D  ObjSrcSavDat                 13        
     D  ObjSrcRstDat                 13        
     D  ObjCrtUsr                    10        
     D  ObjCrtSys                     8        
     D  ObjResDat                     7        
     D  ObjSavSiz                    10i 0     
     D  ObjSavSeq                    10i 0     
     D  ObjStg                       10        
     D  ObjSavCmd                    10        
     D  ObjSavVolId                  71        
     D  ObjSavDvc                    10        
     D  ObjSavFil                    10        
     D  ObjSavLib                    10        
     D  ObjSavLbl                    17        
     D  ObjSavLvl                     9        
     D  ObjCompiler                  16        
     D  ObjLvl                        8        
     D  ObjUsrChg                     1        
     D  ObjLicPgm                    16        
     D  ObjPtf                       10        
     D  ObjApar                      10        
     D  ObjUseDat                     7        
     D  ObjUsgInf                     1        
     D  ObjUseDay                    10i 0     
     D  ObjSiz                       10i 0     
     D  ObjSizMlt                    10i 0     
     D  ObjCprSts                     1        
     D  ObjAlwChg                     1       
     D  ObjChgByPgm                   1       
     D  ObjUsrAtr                    10       
     D  ObjOvrflwAsp                  1       
     D  ObjSavActDat                  7       
     D  ObjSavActTim                  6       
     D  ObjAudVal                    10       
     D  ObjPrmGrp                    10       
                                              
     DTheData          DS                     
     D QUSBR05                 1      4b 0    
     D QUSBA05                 5      8b 0    
     D QUSJN08                 9     18       
     D QUSUN07                19     28       
     D QUSJNBR07              29     34       
     D QUSIJID05              35     50       
     D QUSJS14                51     60       
     D QUSJT08                61     61       
     D QUSJS15                62     62       
     D QUSJS16                63     70                           
     D QUSES00                71     71                           
     D QUSSN00                72     81                           
     D QUSSL06                82     91                           
     D QUSCUN                 92    101                           
     D QUSDE                 102    102                           
     D QUSEK                 103    103                           
     D QUSCK00               104    104                           
     D QUSPRC                105    108b 0                        
     D QUSURC                109    112b 0                        
     D QUSPGMRC              113    116b 0                        
     D QUSSE02               117    126                           
     D QUSDN                 127    136                           
     D QUSGPN                137    146                           
     D QUSGRP                        10    DIM(00015)             
     D  QUSGN00                      10    OVERLAY(QUSGRP:00001)  
     D QUSJUID               297    306                           
     D QUSJUIDS              307    307                           
                                                                 
     D                 DS                                        
     D $$SYSTIMDAT                   12  0                       
     D $$DATE1                        6  0 OVERLAY($$SYSTIMDAT:7)
     D $$TIME                         6  0 OVERLAY($$SYSTIMDAT:1)
                                                                 
      * Work Fields...                                           
     D AllText         s             10    Inz('*ALL')           
     D CmdString       s            256                          
     D CmdLength       s             15  5                       
     D Count           s              4  0                       
     D Format          s              8                          
     D GenLen          s              8                          
     D InLibrary       s             10                          
     D InType          s             10                          
     D ObjectLib       s             20                          
     D SpaceVal        s              1    inz(*BLANKS)          
     D SpaceAuth       s             10    inz('*CHANGE')        
     D SpaceText       s             50    inz(*BLANKS)          
     D SpaceRepl       s             10    inz('*YES')           
     D SpaceRepl       s             10    inz('*YES')                     
     D SpaceAttr       s             10    inz(*BLANKS)                    
     D UserSpaceOut    s             20                                    
     D Worktype        s             10    inz('*ALL')                     
     D ObsDate         S               d                                   
     D Date#           S              8s 0                                 
     D objLstUsDat     S              6a                                   
     D charObsDate     S             10a                                   
     D chkObsDate      S              6a                                   
     D  #TEXTLEN       S              2  0                                 
     D  #SPC           S             30a                                   
     D objlibName      S             10a                                   
                                                                           
     D GenHdr          ds                  inz                             
     D  OffSet                 1      4b 0                                 
     D  NumEnt                 9     12b 0                                 
     D  Lstsiz                13     16b 0                                 
                                                                           
      * Data Structures                                                    
     D GENDS           ds                                                  
     D  OffsetHdr              1      4b 0        
     D  NbrInList              9     12b 0        
     D  SizeEntry             13     16b 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        
                                                  
      * API Error Data Structure                  
     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                 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            
                                                      
      * Date structure for retriving userspace info   
     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 ObjectDs        ds                                       
     D  Object                       10                         
     D  Library                      10                         
     D  ObjectType                   10                         
     D  InfoStatus                    1                         
     D  ExtObjAttrib                 10                         
     D  Description                  50                         
                                                                
      * Program status information data structure               
     D                SDS                                       
     D  S@USER               254    263                         
     D  S@PGM            *PROC                                  
                                                                
      * List objects API                                        
     D $ListObjects    Pr                  ExtPgm( 'QUSLOBJ' )  
     D  userspace                    20a   Const                
     D  format                        8a   Const                
     D  objectlib                    20a   Const                
     D  type                         10a   Const                

                                                                        
      * Userspace pointer API                                           
     D $Userspace      Pr                  ExtPgm( 'QUSRTVUS' )         
     D  userspace                    20a   Const                        
     D  start                        10i 0 Const                        
     D  Length                       10i 0 Const                        
     D  Returned                  32767a         Options( *VarSize )    
                                                                        
      * Create Space API                                                
     D $CreateSpace    Pr                  ExtPgm( 'QUSCRTUS' )         
     D  UserSpaceOut                 20a   Const                        
     D  SpaceAttr                    10    Const                        
     D  SpaceLen                     10i 0 Const                        
     D  SpaceVal                      1a   Const                        
     D  SpaceAuth                    10a   Const                        
     D  SpaceText                    50a   Const                        
     D  SpaceRepl                    10a   Const                        
     D  ErrorDs                   32767a         Options( *VarSize )    
                                                                        
      * API to get the Object Details                                                 
     D RtvObjD         Pr                  ExtPgm( 'QUSROBJD' )                       
     D  RoRcvVar                  32767a         Options( *VarSize )                  
     D  RoRcvVarLen                  10i 0 Const                                      
     D  RoFmtNam                      8a   Const                                      
     D  RoObjNamQ                    20a   Const                                      
     D  RoObjTyp                     10a   Const                                      
     D  RoError                   32767a         Options( *VarSize )                  
                                                                                      
     D k@Para1         S                   Like(EMPKEY1)                              
     D k@Para2         S                   Like(EMPKEY2)                              
     D k@Para3         S                   Like(EMPKEY3)                              
     D noYears         S              2s 0                                            
                                                                                      
      * ---------------------------------------------------------------------------   
      * Main Line Program                                                             
      * ---------------------------------------------------------------------------   
                                                                                      
      * Initialise Variables                                                          
     C                   Exsr      Sb_Initialize                               
     C                   Exsr      Sb_Head                                     
                                                                               
     C                   Exsr      Sb_GetObsYr                                 
                                                                               
     C                   Exsr      Sb_CrtUsrSpc                                
     C                   Eval      ObjectLib =  '*ALL      ' + objlibName      
                                                                               
      * List all the Files to the user space                                   
     C                   Eval      Format = 'OBJL0200'                         
     C                   CallP     $ListObjects( Userspace :                   
     C                                           Format    :                   
     C                                           ObjectLib :                   
     C                                           WorkType)                     
                                                                               
      * Retrive header entry and process the user space                        
     C                   Eval      StartPosit = 125                            
     C                   Eval      StartLen   = 16                             
     C                   CallP     $UserSpace( Userspace :                     
     C                                         StartPosit:     
     C                                         StartLen  :     
     C                                         GENDS)          
                                                               
     C                   Eval      StartPosit = OffsetHdr + 1  
     C                   Eval      StartLen = %size(ObjectDS)  
                                                               
      * Do for number of files in the userspace                
     C                   For       count = 1 to  NbrInList     
     C                   CallP     $UserSpace( Userspace :     
     C                                         StartPosit:     
     C                                         StartLen  :     
     C                                         ObjectDs)       
                                                               
      * Process the objects                                    
     C                   Eval      ObjNam = Object             
     C                   Eval      ObjLib = Library            
     C                   Eval      ObjTyp = ObjectType         
                                                               
     C                   CallP     RtvObjD( ObjDscDs                           
     C                                    : %Size( ObjDscDs )                  
     C                                    : 'OBJD0400'                         
     C                                    : ObjNam + ObjLib                    
     C                                    : ObjTyp                             
     C                                    : ApiError                           
     C                                    )                                    
                                                                               
     C                   If        AeBytAvl   >  *Zero                         
      * Object doesn't exist...                                                
     C                   Eval      AeMsgId    =  'CPF9801'                     
     C                   EndIf                                                 
                                                                               
      * Check the last use date of the object if the object is expired         
      * print object details and process next.                                 
     C                   Eval      objLstUsDat = %SubSt(ObjUseDat : 2 : 6)     
     C                   If        objLstUsDat < chkObsDate                    
     C                   Exsr      Sb_FillDtl                                  
     C                   Exsr      Sb_ChkOfl                                   
     C                   Exsr      Sb_WtrDtl                                        
     C                   EndIf                                                      
                                                                                    
     C                   Eval      StartPosit =  StartPosit + SizeEntry             
     C                   EndFor                                                     
                                                                                    
      * Process Trailer Records                                                     
     C                   Exsr      Sb_Foot                                          
                                                                                    
     C                   Eval      *INLR = *ON                                      
                                                                                    
      * --------------------------------------------------------------------------- 
      * Write the printer file header                                               
      * --------------------------------------------------------------------------- 
     C     Sb_Head       BEGSR                                                      
                                                                                    
     C                   Write     PR_HEAD01                                        
                                                                                    
     C                   ENDSR                                                      

                                                                                     
      * ---------------------------------------------------------------------------  
      * Write the Footer Record                                                      
      * ---------------------------------------------------------------------------  
     C     Sb_Foot       BEGSR                                                       
                                                                                     
      *    if no detail records printed, do No Record Found process                  
     C                   If        $$RCDP = *ZERO                                    
     C                   Exsr      Sb_NoRec                                          
      *    show totals and                                                           
     C                   Else                                                        
     C                   Exsr      Sb_Totals                                         
     C                   EndIf                                                       
                                                                                     
     C                   ENDSR                                                       
                                                                                     
      * ---------------------------------------------------------------------------  
      * No Records to Print                                                          
      * ---------------------------------------------------------------------------  
     C     Sb_NoRec      BEGSR                                                         
                                                                                       
      *    check for overflow before writing this record format.                       
      *    The number of lines to be printed by the NRP1 record format (2)             
      *    and the number of lines to be printed by EOFP1 record format (2)            
      *    are added to the current report line number. The sum will be                
      *    compared with the print overflow number of lines. If the sum is             
      *    is greater or equal, then print on the next page.                           
     C                   If        P1@OvFlow <= P1@Line + 2 + 2                        
     C                   Exsr      Sb_Head                                             
     C                   EndIf                                                         
     C                   Write     Pr_NOREC                                            
                                                                                       
     C                   ENDSR                                                         
                                                                                       
      * ---------------------------------------------------------------------------    
      * Writ the total no of records                                                   
      * ---------------------------------------------------------------------------    
     C     Sb_Totals     BEGSR                                                         
                                                                                     
      *    check for overflow before writing this record format                      
      *    The number of lines to be printed by the TL001P1 record format (2)        
      *    and the number of lines to be printed by EOFP1 record format (2)          
      *    are added to the current report line number. The sum will be              
      *    compared with the print overflow number of lines. If the sum is           
      *    is greater or equal, then print on the next page.                         
     C                   If        P1@OvFlow <= P1@Line + 2 + 2                      
     C                   Exsr      Sb_Head                                           
     C                   EndIf                                                       
     C                   Write     Pr_TOT01                                          
                                                                                     
     C                   ENDSR                                                       
                                                                                     
      * ---------------------------------------------------------------------------  
      * Check the Overflow                                                           
      * ---------------------------------------------------------------------------  
     C     Sb_ChkOfl     BEGSR                                                       

      *    check if the overflow line will be reached by adding the number             
      *    of lines of the print report format to the current printer line             
      *    position. The detail record format will print 1 line.                       
     C                   If        P1@OvFlow <= P1@Line + 2                            
     C                   Exsr      Sb_Head                                             
     C                   EndIf                                                         
                                                                                       
     C                   ENDSR                                                         
                                                                                       
      * ---------------------------------------------------------------------------    
      * Write the detail record                                                        
      * ---------------------------------------------------------------------------    
     C     Sb_WtrDtl     BEGSR                                                         
                                                                                       
     C                   Write     Pr_DTL01                                            
      *    increment number of records printed                                         
     C                   Eval      $$RCDP = $$RCDP + 1                                 
                                                                                       
     C                   ENDSR                                                         

      * ---------------------------------------------------------------------------    
      * Fill the details                                                               
      * ---------------------------------------------------------------------------    
     C     Sb_FillDtl    BEGSR                                                         
                                                                                       
     C                   Eval      $$OBJNAM   = ObjNam                                 
     C                   Eval      $$OBJTYP   = ObjTyp                                 
     C                   Eval      $$OBJLIB   = ObjLib                                 
     C                   Eval      $$OBJLSTUS = objLstUsDat                            
     C                   Eval      $$OBJTXT   = ObjTxt                                 
     C                   Eval      $$OBJCRTUS = ObjCrtUsr                              
     C                   Eval      $$OBJCRTDA = ObjCrtDat                              
     C                   Eval      $$OBJSIZ   = ObjSiz                                 
                                                                                       
     C                   ENDSR                                                         
                                                                                       
      * ---------------------------------------------------------------------------    
      * Get the number of years to check obsolete from parameter file                  
      * ---------------------------------------------------------------------------  
     C     Sb_GetObsYr   BEGSR                                                       
                                                                                     
     C                   Eval      k@Para1 = S@PGM                                   
     C                   Eval      k@Para2 = 'UT'                                    
     C                   Eval      k@Para3 = 'CHK_OBSOLETE_YEARS'                    
     C     KEMPARA01     Chain     EMPARAR                                           
     C                   If        %Found(EMPARA01)                                  
     C                   EvalR     EMPVAL1 = %Trim(EMPVAL1)                          
     C                   Move      EMPVAL1       noYears                             
     C                   Else                                                        
      * Default set to 5 Yeas if the paframeter not found                            
     C                   Eval      noYears = 5                                       
     C                   EndIf                                                       
                                                                                     
      * Get todays date and subdue number of years in parameter file and             
      * create the date to be check for obsolete objects.                            
     C                   Time                    $$SysTimDat                         
     C     *JOBRUN       MoveL     $$DATE1       ObsDate                             
     C                   Move      ObsDate       Date#                             
     C                   SubDur    noYears:*YearsObsDate                           
                                                                                   
     C                   Move      ObsDate       charObsDate                       
     C                   Eval      chkObsDate = %SubSt(charObsDate : 3 : 2) +      
     C                                          %SubSt(charObsDate : 6 : 2) +      
     C                                          %SubSt(charObsDate : 9 : 2)        
                                                                                   
     C                   ENDSR                                                     
                                                                                   
      * ---------------------------------------------------------------------------
      * Create the User Space to store object names in library                     
      * ---------------------------------------------------------------------------
     C     Sb_CrtUsrSpc  BEGSR                                                     
                                                                                   
     C                   Eval      BytesPrv = 116                                  
     C                   Eval      Spacename = 'LISTFILES'                         
     C                   Eval      SpaceLib = 'QTEMP'                              

                                                                                    
      * Create the User Space                                                       
     C                   CallP     $CreateSpace(Userspace :                         
     C                                          SpaceAttr :                         
     C                                          4096      :                         
     C                                          SpaceVal  :                         
     C                                          SpaceAuth :                         
     C                                          SpaceText :                         
     C                                          SpaceRepl :                         
     C                                          ErrorDs)                            
                                                                                    
     C                   ENDSR                                                      
                                                                                    
      * --------------------------------------------------------------------------- 
      * Initialise Every Time                                                       
      * --------------------------------------------------------------------------- 
     C     SB_Initialize BEGSR                                                      
                                                                                    
      * initialise program variables                                                
     C                   eval      $$RCDP = *ZERO                                            
                                                                                             
     C                   ENDSR                                                               
                                                                                             
      * ---------------------------------------------------------------------------          
      * *INZSR: Initialisation First Time Called                                             
      * ---------------------------------------------------------------------------          
     C     *INZSR        BEGSR                                                               
                                                                                             
      * initialise current printer line position to force a print overflow                   
      * before any line other than the header is printed.                                    
     C                   Eval      P1@Line = P1@OvFlow                                       
      * Retrieve Company Name                                                                
     C                   Eval      P@MSGI='CS00011'                             Message ID   
     C                   Call      'CS0048'      @P_CS0048                                   
     C                   Eval      $$CMPNAM=p@MSGDES                            Message Text.
      * Retrieve system name                                                                 
     C                   Eval      P@MSGI='CS00033'                             Message ID   
     C                   Call      'CS0048'      @P_CS0048                                   
     C                   Eval      $$SYSNAM=p@MSGDES                            Message Text.    
      * Retrieve report heading line 1 text                                                      
     C                   Eval      P@MSGI=%trim(S@PGM)+'1'                      Heading 1        
     C                   Call      'CS0048'      @P_CS0048                                       
     C                   Eval      $$HEAD01=p@MSGDES                            Message Text.    
     C                   Eval      #TextLen=      (%len($$HEAD01)                                
     C                                     -(%len(%trim($$HEAD01))))/2                           
     C                   Eval      $$HEAD01=%subst(#SPC:1:#TextLen) +                            
     C                             %trim($$HEAD01)                                               
      * Retrieve report heading line 2 text                                                      
     C                   Eval      P@MSGI=%trim(S@PGM)+'2'                      Heading 2        
     C                   Call      'CS0048'      @P_CS0048                                       
     C                   If        p@msgdes<>P@MSGI                                              
     C                   Eval      $$HEAD02=p@MSGDES                            Message Text.    
     C                   Eval      #TextLen=      (%len($$HEAD02)                                
     C                                     -(%len(%trim($$HEAD02))))/2                           
     C                   Eval      $$HEAD02=%subst(#SPC:1:#TextLen) +                            
     C                             %trim($$HEAD01)                                               
     C                   EndIf                                                                   
                                                                                            
     C                   ENDSR                                                              
                                                                                            
      * ---------------------------------------------------------------------------         
      * Key Lists                                                                           
      * ---------------------------------------------------------------------------         
     C     KEMPARA01     Klist                                                              
     C                   Kfld                    k@Para1                                    
     C                   Kfld                    k@Para2                                    
     C                   Kfld                    k@Para3                                    
                                                                                            
      * ---------------------------------------------------------------------------         
      * Parameter Lists                                                                     
      * ---------------------------------------------------------------------------         
      * Retrieve message descreption from a message id.                                     
     C     @P_CS0048     plist                                                              
     C                   PARM                    p@ERR             1            Error flag  
     C                   PARM                    p@CPGM           10            Calling Pgm 
     C                   PARM                    p@MSGI            7            Message ID  
     C                   PARM                    p@MSGDTA        100            Message data      
     C                   PARM                    p@MSGDES        256            Retrieved Message 
                                                                                                  
      * ---------------------------------------------------------------------------               
      * Entry Parameters                                                                          
      * ---------------------------------------------------------------------------               
     C     *Entry        Plist                                                                    
     C                   Parm                    objlibName                                       

User Comments

Please login or register to add comments

<Previous   Next>