Generic Date Services
This service program example was created to standarize date calculations
Since RPG (and CL, and SQL) provide a multitude of date functions, why create a service program to calculate dates? The answer is fairly simple: standards. Since there are so many methods to derive dates, calculations may vary program to program. This might be a case of too much of a good thing.If not all of a development group uses a different methodology for date routines the possibility exists that not everyone will arrive with the same results. The idea behind creating a standard collection of date services is still valid. Bound to the service program, every date calculation will be consistent--program to program. And, each procedure may include specific business rules regarding the date to be returned. The code below is just a model of what might be included in a common date services application.
H DEBUG(*YES)
H nomain
****************************************************************
* PROGRAM NAME - SC0060RM *
* *
* FUNCTION - This is a module that was designed to serve *
* common date functions. *
* *
* PROGRAMMER - STEVE CROY 08/12/09 *
****************************************************************
****************************************************************
* MODIFICATION LOG *
* *
* DATE PROGRAMMER DESCRIPTION *
* *
****************************************************************
****************************************************************
* PROGRAM INTERFACE SECTION *
* *
* CALLS PROGRAMS: *
* *
****************************************************************
*---
/copy qrpglesrc SC0000_pr
*---
* Global variables
D Alert S 27 inz('Error SC0060RM Message')
D CurrDate S D inz
D CurrTime S T
D DateISO S 8 0
D DateUSA S 8 0
D DateYMD S 8 0
D DayJul S 3 0
D err_msg S 255
D FirstOfMn S D
D FirstOfQ S D
D FirstOfYr1 S D
D FirstOfYr2 S D
D FirstQ S 8
D HourMin S 4 0
D JulDate S 5 0
D LastOfMn S D
D LastOfQ S D
D MonthDay S 4 0
D MonthQtr S 2 0
D n S 3 0 inz(1)
D Now S T
D Quarter S 3 0
D ResultDy S D
D ResultMn S D
D ResultYr S D
D Stamped S Z
D test80 S 8 inz('20050231')
D TimeOfDay S 6 0
D TimeString S 26
D Today S D
D Warning S 27 inz('Warning SC0060RM Message')
D WeekDay S 3 0
D WorkDate S D
*//=================================================================//
* Date today in ISO format (CCYYMMDD)
*//=================================================================//
P DateToday B export
D DateToday PI 8S 0
D DateToday S 8 0
/free
DateToday = %dec(%char(%date():*iso0):8:0);
RETURN DateToday;
/end-free
P DateToday E
*//=================================================================//
* Time in 6 digit format (HHMMSS)
*//=================================================================//
P TimeNow B export
D TimeNow PI 6S 0
D TimeOfDay S 6 0
/free
TimeOfDay = %dec(%char(%time():*hms0):6:0);
RETURN TimeofDay;
/end-free
P TimeNow E
*------------------------------------------
* Return the day of the week
*------------------------------------------
P DayOfWeek B export
D DayOfWeek PI 3S 0
D DateIn D CONST options(*nopass)
/free
// To return a number based on 1=Monday use 01 for day.
// for 1=Sunday use 07 for day.
IF %parms < 1 ;
WeekDay = %rem(%diff(%date():d'0001-01-01':*d) : 7) + 1 ;
ELSE ;
WeekDay = %rem(%diff(DateIn:d'0001-01-01':*d) : 7) + 1 ;
ENDIF ;
RETURN WeekDay ;
/end-free
P DayOfWeek E
P ISOdate B export
D ISOdate PI 8S 0
D DateToday S 8 0
/free
DateToday = %dec(%char(%date():*iso0):8:0);
RETURN DateToday;
/end-free
P ISOdate E
P USAdate B export
D USAdate PI 8S 0
D DateToday S 8 0
/free
DateToday = %dec(%char(%date():*usa0):8:0);
RETURN DateToday;
/end-free
P USAdate E
P MDYdate B export
D MDYdate PI 6S 0
D DateToday S 6 0
/free
DateToday = %dec(%char(%date():*mdy0):6:0);
RETURN DateToday;
/end-free
P MDYdate E
P YMDdate B export
D YMDdate PI 6S 0
D DateToday S 6 0
/free
DateToday = %dec(%char(%date():*ymd0):6:0);
RETURN DateToday;
/end-free
P YMDdate E
P DMYdate B export
D DMYdate PI 6S 0
D DateToday S 6 0
/free
DateToday = %dec(%char(%date():*dmy0):6:0);
RETURN DateToday;
/end-free
P DMYdate E
P CYMDdate B export
D CYMDdate PI 7S 0
D DateToday S 7 0
/free
DateToday = %dec(%char(%date():*cymd0):7:0);
RETURN DateToday;
/end-free
P CYMDdate E
P JulianDate B export
D JulianDate PI 5S 0
/free
JulDate = %dec(%char(%date():*jul0):5:0) ; // return current date
RETURN JulDate ;
/end-free
P JulianDate E
P DayOfYear B export
D DayOfYear PI 3S 0
/free
// Get the Julian day the current day of the year
CurrDate = %date();
DayJul = %diff(CurrDate - %days(%subdt(CurrDate:*d)) :
d'0001-01-01' + %years(%subdt(CurrDate:*y) - 1) :
*d) + %subdt(CurrDate:*d) + 1 ;
RETURN DayJul ;
/end-free
P DayOfYear E
P TimeStamped B export
D TimeStamped PI z
/free
stamped = %date() + %time() ;
RETURN stamped ;
/end-free
P TimeStamped E
P CvtToJulian B export
D CvtToJulian PI 5S 0
D DateIn 8S 0 Const options(*nopass)
D FormatIn 5 Const options(*nopass)
D DteFormat S 5
D GrgDate S 8S 0
D JulianDate S 5S 0
D NbrParms S 3S 0
D InvalidDate S n
/free
//-----------------------------------------------------------
// If date format omitted default to ISO format
// If no date received default to current date
//-----------------------------------------------------------
InvalidDate = *OFF ;
IF %parms > 1 ;
DteFormat = UpperCase(FormatIn:%size(FormatIn)) ;
ELSE ;
DteFormat = '*ISO' ;
ENDIF ;
IF %parms < 1 ;
GrgDate = DateToday() ;
ELSE ;
GrgDate = DateIn ;
ENDIF ;
InvalidDate = CheckDate(GrgDate : DteFormat) ; // check date
IF InvalidDate ;
JulDate = -3 ;
ELSE ;
JulDate = %dec(%char(workDate:*jul0):5:0) ; // return Julian date
ENDIF ;
RETURN JulDate ;
/end-free
P CvtToJulian E
*------------------------------------------
* Convert to 6-digit date
*------------------------------------------
P CvtToDate6 B export
D CvtToDate6 PI 6S 0
D FmtOut 5 Const
D DateIn 8S 0 Const options(*nopass)
D FormatIn 5 Const options(*nopass)
D DteFormat S 5
D GrgDate S 8S 0
D Date6 S 6S 0
D NbrParms S 3S 0
D InvalidDate S n
/free
//-----------------------------------------------------------
// If date format omitted default to ISO format
// If no date received default to current date
//-----------------------------------------------------------
InvalidDate = *OFF ;
IF %parms > 2 ;
DteFormat = UpperCase(FormatIn:%size(FormatIn)) ;
ELSE ;
DteFormat = '*ISO' ;
ENDIF ;
IF %parms < 2 ;
GrgDate = DateToday() ;
ELSE ;
GrgDate = DateIn ;
ENDIF ;
InvalidDate = CheckDate(GrgDate : DteFormat) ; // check date
IF InvalidDate ;
Date6 = -1 ;
ELSE ;
SELECT ;
WHEN FmtOut = '*YMD' ;
Date6 = %dec(%char(workDate:*ymd0):6:0) ;
WHEN FmtOut = '*DMY' ;
Date6 = %dec(%char(workDate:*dmy0):6:0) ;
OTHER ;
Date6 = %dec(%char(workDate:*mdy0):6:0) ;
ENDSL ;
ENDIF ;
RETURN Date6 ;
/end-free
P CvtToDate6 E
*------------------------------------------
* Convert to 8-digit date
*------------------------------------------
P CvtToDate8 B export
D CvtToDate8 PI 8S 0
D FmtOut 5 Const
D DateIn 8S 0 Const options(*nopass)
D FormatIn 5 Const options(*nopass)
D DteFormat S 5
D GrgDate S 8S 0
D Date8 S 8S 0
D NbrParms S 3S 0
D InvalidDate S n
/free
//-----------------------------------------------------------
// If date format omitted default to ISO format
// If no date received default to current date
//-----------------------------------------------------------
InvalidDate = *OFF ;
IF %parms > 2 ;
DteFormat = UpperCase(FormatIn:%size(FormatIn)) ;
ELSE ;
DteFormat = '*ISO' ;
ENDIF ;
IF %parms < 2 ;
GrgDate = DateToday() ;
ELSE ;
GrgDate = DateIn ;
ENDIF ;
InvalidDate = CheckDate(GrgDate : DteFormat) ; // check date
IF InvalidDate ;
Date8 = -1 ;
ELSE ;
SELECT ;
WHEN FmtOut = '*ISO' ;
Date8 = %dec(%char(workDate:*iso0):8:0) ;
WHEN FmtOut = '*USA' ;
Date8 = %dec(%char(workDate:*usa0):8:0) ;
OTHER ;
Date8 = -3 ;
ENDSL ;
ENDIF ;
RETURN Date8 ;
/end-free
P CvtToDate8 E
*------------------------------------------
* Convert to 7-digit date
*------------------------------------------
P CvtToDate7 B export
D CvtToDate7 PI 7S 0
D FmtOut 5 Const
D DateIn 8S 0 Const options(*nopass)
D FormatIn 5 Const options(*nopass)
D DteFormat S 5
D GrgDate S 8S 0
D Date7 S 7S 0
D NbrParms S 3S 0
D InvalidDate S n
/free
InvalidDate = *OFF ; //----------------------
IF %parms > 2 ; // if date format omitted
DteFormat = UpperCase(FormatIn:%size(FormatIn)) ;
ELSE ; // date format
DteFormat = '*ISO' ;
ENDIF ; //----------------------
IF %parms < 2 ; // if no date received
GrgDate = DateToday() ; // default date to
ELSE ; // current date
GrgDate = DateIn ; //----------------------
ENDIF ;
InvalidDate = CheckDate(GrgDate : DteFormat) ; // check date
IF InvalidDate ;
Date7 = -1 ;
ELSE ;
Date7 = %dec(%char(workDate:*cymd0):7:0) ;
ENDIF ;
RETURN Date7 ;
/end-free
P CvtToDate7 E
*------------------------------------------
* Check to see if the date is valid
*------------------------------------------
P CheckDate B EXPORT
D CheckDate PI n
D DateValue 8S 0 Const
D DateFormat 5A Const options(*nopass)
D DateMessage n Const options(*nopass)
D NbrParms S 3 0
D DateError S n
D ShowMessage S n
D Work8 S 8
D Work7 S 7
D Work6 S 6
D format S 5
/free
DateError = *OFF ;
IF %parms > 1 ;
format = UpperCase(DateFormat:%size(DateFormat)) ;
ELSE ;
format = '*ISO' ;
ENDIF ;
IF %parms = 3 ;
ShowMessage = DateMessage ;
ELSE ;
ShowMessage = *off ;
ENDIF ;
SELECT ;
WHEN format = '*ISO' ;
work8 = %editc(DateValue: 'X') ;
TEST(DE) *ISO0 work8 ;
IF %error ;
EXSR @error ;
ELSE ;
workDate = %date(work8:*ISO0) ;
ENDIF ;
WHEN format = '*USA' ;
work8 = %editc(DateValue: 'X') ;
TEST(DE) *USA0 work8 ;
IF %error ;
EXSR @error ;
ELSE ;
workDate = %date(work8:*USA0) ;
ENDIF ;
WHEN format = '*MDY' ;
work6 = %subst(%editc(DateValue:'X'):3:6) ;
work6 = %xlate(' ':'0':work6) ;
TEST(DE) *MDY0 work6 ;
IF %error ;
EXSR @error ;
ELSE ;
workDate = %date(work6:*MDY0) ;
ENDIF ;
WHEN format = '*YMD' ;
work6 = %subst(%editc(DateValue:'X'):3:6) ;
TEST(DE) *YMD0 work6 ;
IF %error ;
EXSR @error ;
ELSE ;
workDate = %date(work6:*YMD0) ;
ENDIF ;
WHEN format = '*DMY' ;
work6 = %subst(%editc(DateValue:'X'):3:6) ;
TEST(DE) *DMY0 work6 ;
IF %error ;
EXSR @error ;
ELSE ;
workDate = %date(work6:*DMY0) ;
ENDIF ;
WHEN format = '*CYMD' ;
work7 = %subst(%editc(DateValue:'X'):2:7) ;
TEST(DE) *CYMD0 work7 ;
IF %error ;
EXSR @error ;
ELSE ;
workDate = %date(work7:*CYMD0) ;
ENDIF ;
OTHER ;
format = '*UNKNOWN' ;
EXSR @error ;
ENDSL ;
IF not DateError ;
IF %dec(%char(workDate:*iso0):8:0) > 20391231
or %dec(%char(workDate:*iso0):8:0) < 19391231 ;
err_msg = 'date out of window range' ;
DisplayMessage(err_msg: warning) ;
ENDIF ;
ENDIF ;
RETURN DateError ;
BEGSR @error ;
IF ShowMessage ;
err_msg = %char(DateValue) + ' is not a valid ' +
%trim(format) + ' date.' ;
DisplayMessage(err_msg: alert) ;
ENDIF ;
DateError = *ON ;
ENDSR ;
/end-free
P CheckDate E
*------------------------------------------
* Set the day of a date to a specific day
*------------------------------------------
P SetDay B export
D SetDay PI D
D DaysIn 2S 0 Const
D DateIn D OPTIONS(*nopass)
D BaseDate S D
/free
IF %parms > 1 ;
BaseDate = DateIn ;
ELSE ;
BaseDate = %date() ;
ENDIF ;
IF DaysIn < 1 or DaysIn > 31 ;
err_msg = %char(DaysIn) + ' is not a valid day value' ;
DisplayMessage(err_msg: alert) ;
ELSE ;
MONITOR ;
ResultDy = BaseDate - %days(%subdt(BaseDate:*d) - 1) +
%days(DaysIn - 1) ;
ON-ERROR ;
err_msg = 'Result is not a valid date' ;
DisplayMessage(err_msg: alert) ;
ResultDy = BaseDate ;
ENDMON ;
ENDIF ;
RETURN ResultDy ;
/end-free
P SetDay E
*--------------------------------------------
* Set the month of a date to a specific month
*--------------------------------------------
P SetMonth B export
D SetMonth PI D
D MnthIn 2S 0 Const
D DateIn D OPTIONS(*nopass)
D BaseDate S D
/free
IF %parms > 1 ;
BaseDate = DateIn ;
ELSE ;
BaseDate = %date() ;
ENDIF ;
IF mnthIn < 1 or MnthIn > 12 ;
err_msg = %char(MnthIn) + ' is not a valid month value' ;
DisplayMessage(err_msg: alert) ;
ELSE ;
MONITOR ;
ResultMn = BaseDate - %months(%subdt(BaseDate:*m) - 1) +
%months(MnthIn - 1) ;
ON-ERROR ;
err_msg = 'Result is not a valid date' ;
DisplayMessage(err_msg: alert) ;
ResultMn = BaseDate ;
ENDMON ;
ENDIF ;
RETURN ResultMn ;
/end-free
P SetMonth E
*--------------------------------------------
* Set the year of a date to a specific year
*--------------------------------------------
P SetYear B export
D SetYear PI D
D YearIn 4S 0 Const
D DateIn D OPTIONS(*nopass)
D BaseDate S D
/free
IF %parms > 1 ;
BaseDate = DateIn ;
ELSE ;
BaseDate = %date() ;
ENDIF ;
IF YearIn < 1939 or YearIn > 2040 ;
err_msg = %char(YearIn) + ' is out of year date range' ;
DisplayMessage(err_msg: alert) ;
ELSE ;
MONITOR ;
ResultYr = BaseDate - %years(%subdt(BaseDate:*y) - 1) +
%years(YearIn - 1) ;
ON-ERROR ;
err_msg = 'Result is not a valid date' ;
DisplayMessage(err_msg: alert) ;
ResultYr = BaseDate ;
ENDMON ;
ENDIF ;
RETURN ResultYr ;
/end-free
P SetYear E
*--------------------------------------------
* Get the quarter
*--------------------------------------------
P GetQuarter B export
D GetQuarter PI 3S 0
D DateIn 8S 0 CONST options(*nopass)
D InvalidDate S n
D DteFormat S 5 INZ('*ISO')
D DateValue S 8S 0
/free
IF %parms < 1;
Quarter = %div(%subdt(%date():*m) - 1 : 3) + 1 ;
ELSE ;
DateValue = DateIn ;
InvalidDate = CheckDate(DateValue:DteFormat) ;
IF not InvalidDate ;
Quarter = %div(%subdt(WorkDate:*m) - 1 : 3) + 1 ;
ENDIF ;
ENDIF ;
RETURN Quarter ;
/end-free
P GetQuarter E
*--------------------------------------------
* Find the date the quarter started
*--------------------------------------------
P QuarterStarted B export
D QuarterStarted PI 8S 0
D DateIn 8S 0 CONST options(*nopass)
D InvalidDate S n
D DteFormat S 5 INZ('*ISO')
D DateOut S 8S 0
D DateValue S 8S 0
/free
InvalidDate = *off ;
IF %parms < 1 ;
Quarter = GetQuarter() ;
DateValue = DateToday() ;
ELSE ;
DateValue = DateIn ;
InvalidDate = CheckDate(DateValue:DteFormat) ;
IF not InvalidDate ;
Quarter = GetQuarter(DateValue) ;
ENDIF ;
ENDIF ;
IF InvalidDate ;
DateOut = -3 ;
ELSE ;
MonthQtr = (Quarter - 1) * 3 + 1 ;
FirstQ = %subst(%char(DateValue):1:4) +
%editc(MonthQtr:'X') + '01' ;
DateOut = %dec(FirstQ :8 :0) ;
ENDIF ;
RETURN DateOut ;
/end-free
P QuarterStarted E
*--------------------------------------------
* Find the date the quarter ended
*--------------------------------------------
P QuarterEnded B export
D QuarterEnded PI 8S 0
D DateIn 8S 0 CONST options(*nopass)
D InvalidDate S n
D DteFormat S 5 INZ('*ISO')
D DateOut S 8S 0
D DateValue S 8S 0
/free
InvalidDate = *off ;
IF %parms < 1 ;
DateISO = %dec(%char(%date():*iso0):8:0) ;
ELSE ;
DateValue = DateIn ;
InvalidDate = CheckDate(DateValue:DteFormat) ;
IF not InvalidDate ;
DateISO = QuarterStarted(DateValue) ;
ENDIF ;
ENDIF ;
IF InvalidDate ;
DateOut = -3 ;
ELSE ;
FirstOfQ = %date(FirstQ:*iso0) ;
LastOfQ = FirstOfQ + %months(3) - %days(1) ;
DateOut = %dec(%char(LastOfQ:*iso0):8:0) ;
ENDIF ;
RETURN DateOut ;
/end-free
P QuarterEnded E
*--------------------------------------------
* Date text
*--------------------------------------------
P DateText B export
D DateText PI 30A
D DateType 1 CONST
D DateIn 8S 0 CONST options(*nopass)
D DateAlpha S 8
D DateCode S 1
D DateString S 30
D DateValue S 8S 0
D Date6E S 8
D Date8E S 10
D DayName S 10
D InvalidDate S n
D MonthName S 10
D ThisMonth S 2s 0
D WeekDay S 3s 0
D DS
D DayTable 70A Inz('Monday +
D Tuesday +
D Wednesday +
D Thursday +
D Friday +
D Saturday +
D Sunday ')
D Days 10A Dim(7) Overlay(DayTable)
D DS
D MonthTable 120 Inz('January +
D February +
D March +
D April +
D May +
D June +
D July +
D August +
D September +
D October +
D November +
D December ')
D Months 10A DIM(12) overlay(MonthTable)
D
/free
InvalidDate = *off ;
IF %parms < 2 ;
DateAlpha = %char(%date():*iso0) ;
ELSE ;
DateValue = DateIn ;
InvalidDate = CheckDate(DateValue:'*ISO') ;
IF not InvalidDate ;
DateAlpha = %editc(DateValue:'X') ;
ENDIF ;
ENDIF ;
IF not InvalidDate ;
ThisMonth = %dec(%subst(DateAlpha:5:2):2:0) ;
WeekDay = DayofWeek(%date(DateAlpha:*iso0)) ;
DayName = Days(WeekDay) ;
MonthName = Months(ThisMonth) ;
DateString = *blanks ;
DateCode = UpperCase(DateType:%size(DateType)) ;
SELECT ;
WHEN DateCode = 'D' ;
DateString = DayName ;
WHEN DateCode = 'F' ;
DateString = %trim(DayName) + ' ' +
%trim(MonthName) + ' ' +
%trim(%subst(DateAlpha:7:2)) + ' ' +
%trim(%subst(DateAlpha:1:4)) ;
WHEN DateCode = 'I' ;
Date8E = %char(%date():*iso) ;
DateString = %trim(DayName) + ' ' + Date8E ;
WHEN DateCode = 'M' ;
DateString = MonthName ;
WHEN DateCode = 'T' ;
Date6E = %char(%date():*mdy) ;
DateString = %trim(DayName) + ' ' + Date6E ;
OTHER ;
DateString = 'Unrecognized format.' ;
ENDSL ;
ELSE ;
DateString = 'Invalid date requested.' ;
ENDIF ;
RETURN DateString ;
/end-free
P DateText E