* ================================================================= * Date-handling routines for use with CL procedures. * Published January 11, 2005 in Four Hundred Guru * No warranties implied or expressed. Use at your own risk! * ================================================================= * This ILE module contains procedures for verifying dates, * performing date arithmetic, and deriving beginning and * ending dates of a month. * ================================================================= * The exported routines use two types of parameters -- dates and * offsets. The dates are six-byte character variables that use the * job's date format. The offsets represent a number of days, months * or years and are 5-digit packed decimal values. * ================================================================= * To create: * CRTRPGMOD MODULE(xxx/CLDATERTNS) * SRCFILE(x/QRPGLESRC) SRCMBR(CLDATERTNS) * ================================================================= * To create the escape messages: * CRTMSGF MSGF(XXX/USRMSG) * ADDMSGD MSGID(USR2101) MSGF(XXX/USRMSG) + * MSG('Value ''&1'' is not a valid date.') + * FMT((*CHAR 6)) * ADDMSGD MSGID(USR2102) MSGF(XXX/USRMSG) + * MSG('Value X''&1'' is not a valid decimal value.') + * FMT((*CHAR 6)) * ================================================================= H nomain H option(*srcstmt: *nodebugio) * ================================================================= * Type definitions * ================================================================= D NumOffsetDef s 5p 0 D DateTypeDef s 6a D OffsetTypeDef ds D Value like(NumOffsetDef) * ================================================================= * The job date, not the system date, is used for the current date. * ================================================================= D gCurrDate s d inz(*job) * =============================================================== * Procedure prototypes * =============================================================== D AddDays pr extproc(*CL: 'ADDDAYS') D like(DateTypeDef) D BaseDate like(DateTypeDef) const D OffSet likeds(OffsetTypeDef) const D AddDaysCalc pr like(DateTypeDef) D BaseDate like(DateTypeDef) const D OffSet like(NumOffsetDef) const D AddMonths pr extproc(*CL: 'ADDMONTHS') D like(DateTypeDef) D BaseDate like(DateTypeDef) const D OffSet likeds(OffsetTypeDef) const D AddMonthsCalc pr like(DateTypeDef) D BaseDate like(DateTypeDef) const D OffSet like(NumOffsetDef) const D AddYears pr extproc(*CL: 'ADDYEARS') D like(DateTypeDef) D BaseDate like(DateTypeDef) const D OffSet likeds(OffsetTypeDef) const D AddYearsCalc pr like(DateTypeDef) D BaseDate like(DateTypeDef) const D OffSet like(NumOffsetDef) const D CurrDate pr extproc(*CL: 'CURRDATE') D like(DateTypeDef) D CurrMonthBegin pr extproc(*CL: 'CURRMONTHBEGIN') D like(DateTypeDef) D CurrMonthEnd pr like(DateTypeDef) D DaysDiff pr like(NumOffsetDef) D BaseDate1 like(DateTypeDef) const D BaseDate2 like(DateTypeDef) const D IsNotValidDate pr n extproc(*CL:'ISNOTVALIDDATE') D BaseDate like(DateTypeDef) const D IsValidDate pr n extproc(*CL:'ISVALIDDATE') D BaseDate like(DateTypeDef) const D MonthBegin pr extproc(*CL: 'MONTHBEGIN') D like(DateTypeDef) D BaseDate like(DateTypeDef) const D MonthEnd pr extproc(*CL: 'MONTHEND') D like(DateTypeDef) D BaseDate like(DateTypeDef) const D PrevMonthBegin pr extproc(*CL: 'PREVMONTHBEGIN') D like(DateTypeDef) D PrevMonthEnd pr extproc(*CL: 'PREVMONTHEND') D like(DateTypeDef) D ToChar pr like(DateTypeDef) D BaseDate d value D ToDate pr d D BaseDate like(DateTypeDef) value D ToHex pr 2a D Char 1a value D VerifyDate pr D BaseDate like(DateTypeDef) value D VerifyOffset pr D Offset likeds(OffsetTypeDef) value * =============================================================== * The following data structure and prototype are needed for * sending escape messages to the caller. * =============================================================== D ErrorDS ds 16 D BytesProv 10i 0 inz(%size(ErrorDS)) D BytesAvail 10i 0 D ExceptionID 7 D SendMsg pr extpgm('QMHSNDPM') D MsgID 7a const D MsgF 20a const D MsgData 30a const D MsgDataLen 10i 0 const D MsgType 10a const D CallStackEnt 10a const D CallStackCtr 10i 0 const D MsgKey 4a const D Error like(ErrorDS) * =============================================================== * Add days to a date. * =============================================================== P AddDays b export D pi like(DateTypeDef) D BaseDate like(DateTypeDef) const D OffSet likeds(OffsetTypeDef) const /free VerifyOffset(Offset); return AddDaysCalc(BaseDate: Offset.Value); /end-free P e * ========================================================= * Internal routine to add days to a date. * =============================================================== P AddDaysCalc b D pi like(DateTypeDef) D BaseDate like(DateTypeDef) const D OffSet like(NumOffsetDef) const /free return ToChar(ToDate(BaseDate) + %days(Offset)); /end-free P e * ========================================================= * Add months to a date. * =============================================================== P AddMonths b export D pi like(DateTypeDef) D BaseDate like(DateTypeDef) const D OffSet likeds(OffsetTypeDef) const /free VerifyOffset(Offset); return AddMonthsCalc(BaseDate: Offset.Value); /end-free P e * ========================================================= * Internal routine to add months to a date. * =============================================================== P AddMonthsCalc b D pi like(DateTypeDef) D BaseDate like(DateTypeDef) const D OffSet like(NumOffsetDef) const /free return ToChar(ToDate(BaseDate) + %months(Offset)); /end-free P e * ========================================================= * Add years to a date. * =============================================================== P AddYears b export D pi like(DateTypeDef) D BaseDate like(DateTypeDef) const D OffSet likeds(OffsetTypeDef) const /free VerifyOffset(Offset); return AddYearsCalc(BaseDate: Offset.Value); /end-free P e * ========================================================= * Internal routine to add years to a date. * =============================================================== P AddYearsCalc b D pi like(DateTypeDef) D BaseDate like(DateTypeDef) const D OffSet like(NumOffsetDef) const /free return ToChar(ToDate(BaseDate) + %years(Offset)); /end-free P e * ========================================================= * Return the job date. * ========================================================= P CurrDate b export D pi like(DateTypeDef) /free return ToChar(gCurrDate); /end-free P e * ========================================================= * Return the first date of the current month. * ========================================================= P CurrMonthBegin b export D pi like(DateTypeDef) /free return MonthBegin(ToChar(gCurrDate)); /end-free P e * ========================================================= * Return the last date of the current month. * ========================================================= P CurrMonthEnd b export D pi like(DateTypeDef) /free return MonthEnd(ToChar(gCurrDate)); /end-free P e * ========================================================= * Return the number of days between two dates. * Positive result = second date is after first date * Zero = dates are the same * Negative result = second date is before first date * ========================================================= P DaysDiff b export D pi like(NumOffsetDef) D BaseDate1 like(DateTypeDef) const D BaseDate2 like(DateTypeDef) const /free return %diff(ToDate(BaseDate2):ToDate(BaseDate1):*d); /end-free P e * ========================================================= * Return true if a character value does not contain a valid * date in the job's date format. * ========================================================= P IsNotValidDate b export D pi n D BaseDate like(DateTypeDef) const /free test(de) *jobrun0 BaseDate; return %error(); /end-free P e * ========================================================= * Return true if a character value contains a valid date in * the job's date format. * ========================================================= P IsValidDate b export D pi n D BaseDate like(DateTypeDef) const /free test(de) *jobrun0 BaseDate; return (not %error()); /end-free P e * ========================================================= * Return the first date of a month. * ========================================================= P MonthBegin b export D pi like(DateTypeDef) D BaseDate like(DateTypeDef) const D D Days s 3u 0 D Date2 s d /free VerifyDate(BaseDate); Date2 = %date(BaseDate:*jobrun0); Days = %subdt(Date2:*d); if Days > 1; Date2 -= %days(Days-1); endif; return %char(Date2:*jobrun0); /end-free P e * ========================================================= * Return the last date of a month. * ========================================================= P MonthEnd b export D pi like(DateTypeDef) D BaseDate like(DateTypeDef) const D Date2 s d /free VerifyDate(BaseDate); Date2 = %date(BaseDate:*jobrun0) + %months(1); Date2 -= %days(%subdt(Date2:*d)); return %char(Date2:*jobrun0); /end-free P e * ========================================================= * Return the first date of the previous month. * ========================================================= P PrevMonthBegin b export D pi like(DateTypeDef) /free return MonthBegin(AddMonthsCalc(ToChar(gCurrDate):-1)); /end-free P e * ========================================================= * Return the last date of the previous month. * ========================================================= P PrevMonthEnd b export D pi like(DateTypeDef) /free return MonthEnd(AddMonthsCalc(ToChar(gCurrDate):-1)); /end-free P e * ========================================================= * Convert a date to a character value in the job's date format. * ========================================================= P ToChar b D pi like(DateTypeDef) D BaseDate d value /free return %char(BaseDate:*Jobrun0); /end-free P e * ========================================================= * Convert a character variable that contains a date. * ========================================================= P ToDate b D pi d D BaseDate like(DateTypeDef) value /free VerifyDate(BaseDate); return %date(BaseDate:*Jobrun0); /end-free P e * ========================================================= * Convert a character to its hex representation. * ========================================================= P ToHex b D pi 2a D Char 1a value D Zone s 1a D Digit s 1a /free select; when Char >= x'F0'; Zone = 'F'; when Char >= x'E0'; Zone = 'E'; when Char >= x'D0'; Zone = 'D'; when Char >= x'C0'; Zone = 'C'; when Char >= x'B0'; Zone = 'B'; when Char >= x'A0'; Zone = 'A'; when Char >= x'90'; Zone = '9'; when Char >= x'80'; Zone = '8'; when Char >= x'70'; Zone = '7'; when Char >= x'60'; Zone = '6'; when Char >= x'50'; Zone = '5'; when Char >= x'40'; Zone = '4'; when Char >= x'30'; Zone = '3'; when Char >= x'20'; Zone = '2'; when Char >= x'10'; Zone = '1'; other; Zone = '0'; endsl; digit = %bitand(char:x'0F'); select; when digit = x'0F'; digit = 'F'; when digit = x'0E'; digit = 'E'; when digit = x'0D'; digit = 'D'; when digit = x'0C'; digit = 'C'; when digit = x'0B'; digit = 'B'; when digit = x'0A'; digit = 'A'; when digit = x'09'; digit = '9'; when digit = x'08'; digit = '8'; when digit = x'07'; digit = '7'; when digit = x'06'; digit = '6'; when digit = x'05'; digit = '5'; when digit = x'04'; digit = '4'; when digit = x'03'; digit = '3'; when digit = x'02'; digit = '2'; when digit = x'01'; digit = '1'; other; digit = '0'; endsl; return zone + digit; /end-free P e * ========================================================= * Send an escape message if a character variable does not * contain a valid date in the job's date format. * ========================================================= P VerifyDate b D pi D BaseDate like(DateTypeDef) value D MsgKey s 4a /free test(de) *jobrun0 BaseDate; if %error(); SendMsg ('USR2101': 'USRMSG *LIBL': BaseDate: %len(BaseDate): '*ESCAPE': '*': 1: MsgKey: ErrorDS); return; endif; /end-free P e * ========================================================= * Send an escape message if a 5-digit packed decimal number * does not contain valid packed data. * ========================================================= P VerifyOffset b D pi D Offset likeds(OffsetTypeDef) value D D MsgKey s 4a /free monitor; if Offset.Value = *zero; endif; on-error; SendMsg ('USR2102': 'USRMSG *LIBL': ToHex(%subst(Offset:1:1)) + ToHex(%subst(Offset:2:1)) + ToHex(%subst(Offset:3:1)): 6: '*ESCAPE': '*': 1: MsgKey: ErrorDS); return; endmon; /end-free P e