h DEBUG OPTION(*SRCSTMT:*NODEBUGIO) DATFMT(*ISO)
h DFTACTGRP(*NO) ACTGRP('ILE')
‚‚*--------------------------------------------------------------------
‚‚* Utility to Remove Members based on Numbers Days Old
‚‚*--------------------------------------------------------------------
*--------------------------------------------------------------------
* EX: CALL PGM(MBRDLT) PARM('EDILOGF' '*LIBL' '0014' ' ')
*--------------------------------------------------------------------
* THIS WILL DELETE ALL MEMBERS FROM THE FILE EDILOGF THAT ARE
* 14 DAYS AND OLDER. (THIS UTILITY DOES NOT DELETE THE MEMBER NAME
* NOTE: THIS UTILITY DOES NOT DELETE THE MEMBER NAME SAME AS FILE
*--------------------------------------------------------------------
d/COPY QSYSINC/QRPGLESRC,QUSRUSAT
d/COPY QSYSINC/QRPGLESRC,QUSGEN
d/COPY QSYSINC/QRPGLESRC,QUSLMBR
d/COPY QSYSINC/QRPGLESRC,QUSRMBRD
d CrtUsrSpc PR *
d CrtSpcName 20 const
d SpacePtr s *
d UserSpace s 20 inz('MBRLST QTEMP')
d FormatList s 8A Inz('MBRL0200')
d FormatMbr s 8A Inz('MBRD0200')
d AllMbrs s 10A Inz('*ALL ')
d OvrDbf s 1A Inz('1')
d Member s 10
d GenLen s 9B 0
d StrPos s 9B 0
d RtvLen s 9B 0
d RcvLen s 9B 0
d Count s 15 0
d Command s 80a INZ
d CommandLen s 15p 5 INZ(80)
d SQuote c ''''
d ObjNamLib ds
d ObjNam 10 OVERLAY(ObjNamLib)
d ObjLib 10 OVERLAY(ObjNamLib:11)
d Days ds
d NDays 4 0 OVERLAY(Days)
d ADays 4 OVERLAY(Days)
*--------------------------------------------------------------------
* Standard Error Code data structure
*--------------------------------------------------------------------
dError ds 116
d QUSBPRV 1 4B 0 inz(116)
d QUSBAVL 5 8B 0
d MessageId 9 15
d MessageDta 17 116
*--------------------------------------------------------------------
* Member Date data structure - Alpha 13
*--------------------------------------------------------------------
dQusDte ds
d QusCC 1 1
d QusYMD 2 7
d QusTim 8 13
*--------------------------------------------------------------------
* Member Date data structure - Alpha 8
*--------------------------------------------------------------------
d MbrDtCrt ds
d MbrCY 4 OVERLAY(MbrDtCrt)
d MbrMM 2 OVERLAY(MbrDtCrt:5)
d MbrDD 2 OVERLAY(MbrDtCrt:7)
*----------------------------------------------------------------
* DATE DATA STRUCTURE (*ISO 'ccyy-mm-dd')
*----------------------------------------------------------------
d ds INZ
d NewDat D DATFMT(*ISO) INZ
d NewCY 4 OVERLAY(NewDat)
d NewMM 2 OVERLAY(NewDat:6)
d NewDD 2 OVERLAY(NewDat:9)
*----------------------------------------------------------------
* ISO DATES (*ISO 'ccyy-mm-dd')
*----------------------------------------------------------------
d Today s D Inz(*SYS)
d CompDat s D Inz(*SYS)
*--------------------------------------------------------------------
* Receive Parms for Object Name, Library, Days, MsgId
*--------------------------------------------------------------------
c *Like Define ObjNam pmObjNam
c *Like Define ObjLib pmObjLib
c *Like Define ADays pmDays
c *Like Define MessageId pmMsgId
c *entry plist
c parm pmObjNam
c parm pmObjLib
c parm pmDays
c parm pmMsgId
c Eval ObjNam = pmObjNam
c Eval ObjLib = pmObjLib
c Eval ADays = pmDays
*--------------------------------------------------------------------
* Calculate new Comparison Date based on Number Days Old
*--------------------------------------------------------------------
c Today subdur NDays:*DAYS CompDat
*--------------------------------------------------------------------
* Create User Space for Member List Information
*--------------------------------------------------------------------
c Eval SpacePtr = CrtUsrSpc(UserSpace)
*--------------------------------------------------------------------
* Create Member List in User Space
*--------------------------------------------------------------------
c Call 'QUSLMBR'
c Parm UserSpace
c Parm FormatList
c Parm ObjNamLib
c Parm AllMbrs
c Parm OvrDbf
c Parm Error
*--------------------------------------------------------------------
* Continue if no Errors
*--------------------------------------------------------------------
c Eval pmMsgId = MessageId
c if MessageId = *blanks
*--------------------------------------------------------------------
* Set Values for Generic Header
*--------------------------------------------------------------------
c Eval GenLen = 140
c Eval StrPos = 1
*--------------------------------------------------------------------
* Retreive Number of Entries, Offset, and the size of each entry
*--------------------------------------------------------------------
c Call 'QUSRTVUS'
c Parm UserSpace
c Parm StrPos
c Parm GenLen
c Parm QUSH0100
c Parm Error
*--------------------------------------------------------------------
* Check the Generic Header data structure for number of list entry
* offset to list entries, and size of each list entry
*--------------------------------------------------------------------
c Eval StrPos = ( QUSOLD + 1 )
c Eval RtvLen = QUSSEE
c Eval RcvLen = 209
c Eval Count = 1
*--------------------------------------------------------------------
* Process Members
*--------------------------------------------------------------------
c DoW Count <= QUSNBRLE
c Call 'QUSRTVUS'
c Parm UserSpace
c Parm StrPos
c Parm RtvLen
c Parm QUSL0200
c Parm Error
c Eval StrPos = QUSSEE + StrPos
c Eval Count = Count + 1
c movel(p) QUSMN01 Member
*--------------------------------------------------------------------
* Get Member Information
*--------------------------------------------------------------------
c Call 'QUSRMBRD'
c Parm QusM0200
c Parm GenLen
c Parm FormatMbr
c Parm ObjNamLib
c Parm Member
c Parm OvrDbf
c Parm Error
*--------------------------------------------------------------------
* Remove Member if not same as File Name and Member Create Date
* is Less/Equal to new comparison Date
*--------------------------------------------------------------------
c if Member <> ObjNam
c eval QusDte = QusCD03
c if QusCC = '1'
c eval MbrDtCrt = '20' + QusYMD
c else
c eval MbrDtCrt = '19' + QusYMD
c endif
c eval NewCY = MbrCY
c eval NewMM = MbrMM
c eval NewDD = MbrDD
c if NewDat <= CompDat
c eval Command = 'RMVM FILE(' +
c %trimr(ObjLib) +
c '/' + %trimr(ObjNam) +
c ') MBR(' +
c %trimr(Member) + ')'
c call 'QCMDEXC'
c parm Command
c parm CommandLen
c endif
c endif
e01 c EndDo
*--------------------------------------------------------------------
* End Program
*--------------------------------------------------------------------
c endif
c eval *inlr = *on
*====================================================================
* Procedure to create extendable user space, return pointer to it.
*====================================================================
p CrtUsrSpc B export
d CrtUsrSpc PI *
d CrtSpcName 20 const
* Local Variables
d PasSpcName DS 20
d SLib 11 20
d ChgAttrDs DS 13
d NumberAttr 9B 0 inz(1)
d KeyAttr 9B 0 inz(3)
d DataSize 9B 0 inz(1)
d AttrData 1 inz('1')
d ListPtr S *
d SpaceAttr S 10 inz
d SpaceAuth S 10 INZ('*CHANGE')
d SpaceLen S 9B 0 INZ(2048)
d SpaceReplc S 10 INZ('*YES')
d SpaceText S 50
d SpaceValue S 1
* Create the user space
c move CrtSpcName PasSpcName
c CALL 'QUSCRTUS'
c PARM PasSpcName
c PARM SpaceAttr
c PARM SpaceLen
c PARM SpaceValue
c PARM SpaceAuth
c PARM SpaceText
c PARM '*YES' SpaceReplc
c PARM Error
* Get pointer to user space
c CALL 'QUSPTRUS'
c PARM PasSpcName
c PARM ListPtr
* Change user space to be extendable
c CALL 'QUSCUSAT'
c PARM Slib
c PARM PasSpcName
c PARM ChgAttrDs
c PARM Error
c return ListPtr
p CrtUsrSpc E
This was first published in April 2005