DAYSPAST CLLE program for AS/400: Compares object creation date with today's date

Raymond Johnson

This code was modified from an IBM-supplied example to make it simple for me to use.

I use it in programs where I interrogate the creation date of an object then use an "IF" statement to determine whether or not to delete it. I call my DAYSPAST program and if the returned numeric value is greater than the number of days old that I want to keep, I can delete the object.

As a side note, here is some technical information for the curious geek: The LILIAN routine is an IBM-supplied routine that will tell you the precise number of days between that date and October 14, 1582. If you're wondering who picked that date, I have no idea. The good news is that it doesn't change -- which is different than most everything else in this world.

The procedure CEEDAYS returns a 32-bit binary integer representing the Lilian date, the number of days since 14 October 1582.

/******************************************************************************/

/* Program name . . . . . . . . . . . . . . :   DAYSPAST                      */

/* Author . . . . . . . . . . . . . . . . . :   Raymond G. Johnson            */

/* Date created . . . . . . . . . . . . . . :   05/06/2008 QED                */

/*                                                                            */

/* Program information:  Return the number of days that have past since       */

/*                       a given date.                                        */

/*                       Pass date in YYYYMMDD format                         */

/*                       Return numeric value of days passed.                 */

/*                                                                            */

/* Required call format: CALL PGM(DAYSPAST)  PARM('20080502'   1   )

       */

/*                                                  *CHAR    *DEC (10.0)      */

/*                                                                            */

/* Parameter 1 is an 8 position character field for the date in question.     */

/* Parameter 2 is 10 position decimal field to return the number of days past.*/ 

/* Must be compiled as CLLE program.                                          */

/******************************************************************************/

/* Jim Sloan Error recovery procedure.                                        */

/******************************************************************************/

/* Change log:                                                                */

/******************************************************************************/

/* Date         Initials   Change Description                                 */

/******************************************************************************/

/* xx/xx/200x   XXX                                                           */

/*                                                                            */

/******************************************************************************/

             PGM        PARM(&date2 &dayspastd)                                 

             DCL        VAR(&ERRORSW) TYPE(*LGL) /*Std Error */                 

             DCL        VAR(&MSGID)   TYPE(*CHAR) LEN(7) /*Std Error */         

             DCL        VAR(&MSG)     TYPE(*CHAR) LEN(512) /*Std Error */       

             DCL        VAR(&MSGDTA)  TYPE(*CHAR) LEN(512) /*Std Error */      

             DCL        VAR(&MSGF)    TYPE(*CHAR) LEN(10) /*Std Error */        

             DCL        VAR(&MSGFLIB) TYPE(*CHAR) LEN(10) /*Std Error */        

             DCL        VAR(&KEYVAR)  TYPE(*CHAR) LEN(4) /*Std Error */         

             DCL        VAR(&KEYVAR2) TYPE(*CHAR) LEN(4) /*Std Error */         

             DCL        VAR(&RTNTYPE) TYPE(*CHAR) LEN(2) /*Std Error */        

             DCL        VAR(&DATETIME  ) TYPE(*CHAR) LEN(17)                    

             DCL        VAR(&DATE1     ) TYPE(*CHAR) LEN(8) /* Today */         

             DCL        VAR(&DATE2     ) TYPE(*CHAR) LEN(8) /* past date */     

             DCL        VAR(&DAYSpastD) TYPE(*DEC) LEN(10 0)                    

             DCL        VAR(&DAYSpastC ) TYPE(*CHAR) LEN(10)                    

           DCL        VAR(&LILDAT1c  ) TYPE(*CHAR) LEN(4)                     

             DCL        VAR(&LILDAT1d  ) TYPE(*DEC) LEN(10 0)                   

             DCL        VAR(&LILDAT2d  ) TYPE(*DEC) LEN(10 0)                   

           DCL        VAR(&RC) TYPE(*CHAR) LEN(4) VALUE(X'00000000')          

             DCL        VAR(&MSGTXT    ) TYPE(*CHAR) LEN(50)                    

             DCL        VAR(&FORMAT    ) Type(*CHAR) Len(8) +                   

                          VALUE('YYYYMMDD')                                     

                                                                               

/******************************************************************************/

/*           Start of program.                                                */

/******************************************************************************/

 /* Get current system date and time in YYYYMMDD. */                

             CALL       PGM(QWCCVTDT) PARM('*CURRENT' ' ' '*YYMD' +             

                          &DATETIME &RC)                                        

       /* Parse the date portion of the system date and time. */          

             CHGVAR     VAR(&DATE1) VALUE(%SST(&DATETIME 1 8))                  

            /* Get Lilian date for current date in character format. */        

             CALLPRC    PRC(CEEDAYS) PARM((&DATE1) ('YYYYMMDD') +               

                          (&LILDAT1c) (&RC))                                    

             CHGVAR     VAR(&LILDAT1d) VALUE(%BIN(&LILDAT1c))                   

             /* Get Lilian date for past date. */                               

             CALLPRC    PRC(CEEDAYS) PARM((&DATE2) ('YYYYMMDD') +               

                          (&LILDAT2c) (&RC))                                    

             /* Get Lilian date for past date in decimal format */              

             CHGVAR     VAR(&LILDAT2d) VALUE(%BIN(&LILDAT2c ))                  

            /* Calculate number of days different.             */              

             CHGVAR     VAR(&DAYSPASTD) VALUE(&LILDAT1d - &LILDAT2d)            

             /* Place value in Data area for validation and testing.          */

             CRTDTAARA  DTAARA(ADMIN400/DAYSPASTD) TYPE(*DEC) LEN(10 0) +       

                          TEXT('Days past in decimal')                          

             MONMSG     CPF1023                                                 

        CHGDTAARA  ADMIN400/DAYSPASTD &DAYSPASTD                           

 RETURN:     RETURN      /* Normal end of program. */                           

/******************************************************************************/

/*           END OF PROGRAM / ERROR EXIT                                      */

/******************************************************************************/

             IF         COND(&ERRORSW) THEN(SNDPGMMSG MSGID(CPF9999)  +         

                          MSGF(QCPFMSG) MSGTYPE(*ESCAPE))                       

             CHGVAR     VAR(&ERRORSW) VALUE('1') /* Set to FAIL on error */     

             RCVMSG     MSGTYPE(*EXCP) RMV(*NO) KEYVAR(&KEYVAR)                 

  STDERR2:                                                                       

             RCVMSG     MSGTYPE(*PRV) MSGKEY(&KEYVAR) RMV(*NO) +                

                          KEYVAR(&KEYVAR2) MSG(&MSG) MSGDTA(&MSGDTA) +          

                          MSGID(&MSGID) RTNTYPE(&RTNTYPE) MSGF(&MSGF) +         

                          SNDMSGFLIB(&MSGFLIB)                                  

            IF         COND(&RTNTYPE *NE '02') THEN(GOTO STDERR3)              

             IF         COND(&MSGID *NE ' ') THEN(SNDPGMMSG MSGID(&MSGID) +     

                          MSGF(&MSGFLIB/&MSGF) MSGDTA(&MSGDTA) +                

                          MSGTYPE(*DIAG))                                       

             IF         COND(&MSGID *EQ ' ') THEN(SNDPGMMSG MSG(&MSG) +         

                          MSGTYPE(*DIAG))                                       

             RMVMSG     MSGKEY(&KEYVAR2)                                        

 STDERR3:    RCVMSG     MSGKEY(&KEYVAR) MSGDTA(&MSGDTA) MSGID(&MSGID) +         

                          MSGF(&MSGF) SNDMSGFLIB(&MSGFLIB)                      

             SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) MSGDTA(&MSGDTA) +    

                          MSGTYPE(*ESCAPE)                                      

****************** End of data *************************************************

ABOUT THE AUTHOR: Raymond G. Johnson is owner of and consulant at iSolutions Consulting Inc. in Eugene, Ore. He has over 30 years of experience with IBM hardware and software systems and provides technical support for i5, System i, iSeries and/or AS/400.

Rate this Tip To rate tips, you must be a member of Search400.com. Register now to start rating these tips. Log in if you are already a member. Digg This!     StumbleUpon     Del.icio.us    RELATED CONTENT iSeries CL programming An automated CL method of moving a query from AS/400 to Excel Changing user password expiration Eight steps for creating program documentation using AS/400 utilities Advanced Job Scheduler help How do I retrieve the source for an output queue description to put in to a CL program? Top 10 programmer tips YTD Ways to put QSHELL to work in your day-to-day programming life Writing to a file from CL -- revisited Code examples to determine future end of month based on any given date A program to access stored text files Systems Management Tools How to: Monitoring job activity on the AS/400 Checking if a local port is used by another job on AS/400 How to: Reduce the percentage of ASP used on the AS/400 Changing BRMS configurations for new naming conventions for i5 AS/400 system values quiz Checking on System i disk space requires creating a new command: XRTVSYSSTS Setting up an automatic reply in the system reply list Clearing physical member file records Drive space management commands iSeries freeware/shareware library iSeries programmer tips Documenting nested program structures on the AS/400 What is an integrated database? An automated CL method of moving a query from AS/400 to Excel Using SQL on System i to create multicolored comment lines Eight steps for creating program documentation using AS/400 utilities Coloring source lines with COBOL and using a shortcut from within PDM Date calculation commands for AS/400 There is very little RPG on System i can't do: From RPG nay to RPG yay! Using SQL on System i to color source code and inline comments Controlling spool files with APIs RELATED RESOURCES 2020software.com, trial software downloads for accounting software, ERP software, CRM software and business software systems Search Bitpipe.com for the latest white papers and business webcasts Whatis.com, the online computer dictionary DISCLAIMER: Our Tips Exchange is a forum for you to share technical advice and expertise with your peers and to learn from other enterprise IT professionals. TechTarget provides the infrastructure to facilitate this sharing of information. However, we cannot guarantee the accuracy or validity of the material submitted. You agree that your use of the Ask The Expert services and your reliance on any questions, answers, information or other materials received through this Web site is at your own risk.