|
Code:
- *-------------------------------------------------------------------------
- * Get Relative Date ***********************
- *-------------------------------------------------------------------------
- P getreldate B EXPORT
- D getreldate pi
- D inpreldate 15
- D inpformat 5 CONST OPTIONS(*NOPASS)
- D inpref 10 CONST OPTIONS(*NOPASS)
- D outvalid 1N OPTIONS(*NOPASS)
- *
- D ISO_DATE S D DATFMT(*ISO)
- D SYS_DATE S D DATFMT(*ISO)
- D CALC_DATE S D DATFMT(*ISO)
- D WK_DATE S 10 VARYING
- D WK_DATE2 S 10
- D WK_YEAR S 4
- D WK_YEAR# S 4 0
- D LEN S 4 0
- D RECHECK S N
- D SHORTDATE S N
- D POSA S 2 0
- D POSB S 2 0
- D VALID S 1 INZ('N')
- D TODAY S D INZ(*JOB)
- D WKNUM S 7S 0
- D WKDAY S 1S 0
- D CURRMTH S 6S 0
- D TEST_M1 S 6S 0
- D TEST_M2 S 6S 0
- D M1 S 1 0
- D M2 S 2 0
- D D S 10I 0
- *========================================================================*
- C IF NOT %OPEN(DATRELPF)
- C OPEN DATRELPF
- C ENDIF
- *
- C TIME SYS_DATE
- C EVAL WK_DATE = %TRIM(inpreldate)
- * Check to see if user keyed "MAXDATE"
- C IF WK_DATE = 'MAXDATE' OR
- C WK_DATE = 'MAX' OR
- C WK_DATE = 'M'
- C EVAL WK_DATE = '12/31/9999 '
- C EVAL inpreldate = '12/31/9999 '
- C ENDIF
- *
- C EXSR REL_DATE
- * Check if actually a date
- C IF VALID = 'N'
- C EXSR TEST_DATE
- C ENDIF
- *
- C IF VALID = 'Y'
- C IF %PARMS > 1
- C SELECT
- *
- C WHEN inpformat = '*ISO '
- C EVAL inpreldate = %CHAR(ISO_DATE:*ISO)
- *
- C WHEN inpformat = '*ISO0 '
- C EVAL inpreldate = %CHAR(ISO_DATE:*ISO0)
- *
- C WHEN inpformat = '*USA '
- C EVAL inpreldate = %CHAR(ISO_DATE:*USA)
- *
- C WHEN inpformat = '*USA0 '
- C EVAL inpreldate = %CHAR(ISO_DATE:*USA0)
- *
- C WHEN inpformat = '*MDY '
- C EVAL inpreldate = %CHAR(ISO_DATE:*MDY)
- *
- C WHEN inpformat = '*MDY0 '
- C EVAL inpreldate = %CHAR(ISO_DATE:*MDY0)
- *
- C WHEN inpformat = '*YMD '
- C EVAL inpreldate = %CHAR(ISO_DATE:*YMD)
- *
- C WHEN inpformat = '*YMD0 '
- C EVAL inpreldate = %CHAR(ISO_DATE:*YMD0)
- C OTHER
- * Date is converted to USA format
- C EVAL inpreldate = %CHAR(ISO_DATE:*USA)
- C ENDSL
- C ELSE
- C EVAL inpreldate = %CHAR(ISO_DATE:*USA)
- C ENDIF
- *
- C ENDIF
- *
- C IF %PARMS = 4
- C EVAL outvalid = VALID = 'Y'
- C ENDIF
- *
- C IF %OPEN(DATRELPF)
- C CLOSE DATRELPF
- C ENDIF
- *========================================================================*
- * Test Date
- *========================================================================*
- C TEST_DATE BEGSR
- *
- C CHKAGAIN TAG
- C EVAL LEN = %LEN(WK_DATE)
- C EVAL WK_DATE2 = WK_DATE
- * 10 character dates
- C *USA TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C EVAL ISO_DATE = %DATE(WK_DATE2:*USA)
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C *ISO TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *ISO MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C IF LEN > 8
- C GOTO CHKSHRDATE
- C ENDIF
- * 8 character dates or 8 digit date numbers
- C *USA0 TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *USA0 MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C *ISO0 TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *ISO0 MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C *MDY/ TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *MDY/ MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C *MDY- TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *MDY- MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C *MDY. TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *MDY. MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C *MDY, TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *MDY, MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C *MDY& TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *MDY& MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C *YMD/ TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *YMD/ MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C *YMD- TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *YMD- MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C *YMD. TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *YMD. MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C *YMD, TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *YMD, MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C *YMD& TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *YMD& MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C IF LEN > 6
- C GOTO CHKSHRDATE
- C ENDIF
- * 6 digit date numbers
- C *MDY0 TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *MDY0 MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C *YMD0 TEST(DE) WK_DATE2
- C IF NOT %ERROR
- C *YMD0 MOVEL WK_DATE2 ISO_DATE
- C EVAL VALID = 'Y'
- C GOTO EXIT
- C ENDIF
- *
- C CHKSHRDATE TAG
- * Check for abbreviated dates
- C IF SHORTDATE = *OFF
- C EVAL SHORTDATE = *ON
- C EVAL RECHECK = *OFF
- C EVAL WK_YEAR = %editc(*YEAR:'X')
- C EVAL POSA = %SCAN('/':WK_DATE)
- C EVAL POSB = %SCAN('/':WK_DATE:POSA+1)
- C IF POSA > 0
- * If date has month & day only
- C IF POSB = 0
- C SELECT
- *
- C WHEN LEN = 5 AND POSA = 3
- C EVAL WK_DATE = WK_DATE +'/'+WK_YEAR
- C EVAL RECHECK = *ON
- *
- C WHEN LEN = 4 AND POSA = 2
- C EVAL WK_DATE = '0'+WK_DATE +'/'+WK_YEAR
- C EVAL RECHECK = *ON
- *
- C WHEN LEN = 4 AND POSA = 3
- C EVAL WK_DATE = %SUBST(WK_DATE:1:3)
- C +'0'+%SUBST(WK_DATE:4:1) +'/'+WK_YEAR
- C EVAL RECHECK = *ON
- *
- C WHEN LEN = 3 AND POSA = 2
- C EVAL WK_DATE = '0'+%SUBST(WK_DATE:1:2)
- C +'0'+%SUBST(WK_DATE:3:1) +'/'+WK_YEAR
- C EVAL RECHECK = *ON
- C ENDSL
- C ELSE
- C SELECT
- *
- C WHEN LEN = 9 AND POSA = 2
- C EVAL WK_DATE = '0' +WK_DATE
- C EVAL RECHECK = *ON
- *
- C WHEN LEN = 9 AND POSA = 3
- C EVAL WK_DATE = %SUBST(WK_DATE:1:3)
- C +'0'+%SUBST(WK_DATE:4:6)
- C EVAL RECHECK = *ON
- *
- C WHEN LEN = 7 AND POSA = 2
- C EVAL WK_DATE = '0' +WK_DATE
- C EVAL RECHECK = *ON
- *
- C WHEN LEN = 7 AND POSA = 3
- C EVAL WK_DATE = %SUBST(WK_DATE:1:3)
- C +'0'+%SUBST(WK_DATE:4:4)
- C EVAL RECHECK = *ON
- *
- C WHEN LEN = 6 AND POSA = 2
- C EVAL WK_DATE ='0'+%SUBST(WK_DATE:1:2)
- C +'0'+%SUBST(WK_DATE:3:4)
- C EVAL RECHECK = *ON
- *
- C ENDSL
- C ENDIF
- *
- C IF RECHECK = *ON
- C GOTO CHKAGAIN
- C ENDIF
- *
- C ELSE
- *
- C TESTN WK_DATE 707070
- C N70 LEAVESR
- *
- C SELECT
- * Only need leading zero so dont adjust the year.
- C WHEN LEN = 7
- C OR LEN = 5
- C EVAL WK_DATE = '0' +WK_DATE
- C EVAL RECHECK = *ON
- C EVAL SHORTDATE = *OFF
- *
- C WHEN LEN = 4
- C EVAL WK_DATE = WK_DATE +WK_YEAR
- C EVAL RECHECK = *ON
- *
- C WHEN LEN = 3
- C EVAL WK_YEAR# = %SUBDT(TODAY:*Y)
- C EVAL M2 = %SUBDT(TODAY:*M)
- C Z-ADD M2 CURRMTH
- C MOVEL WK_YEAR# CURRMTH
- C MOVEL WK_DATE M1
- C Z-ADD M1 TEST_M1
- C MOVEL *YEAR TEST_M1
- C MOVEL WK_DATE M2
- C Z-ADD M2 TEST_M2
- C MOVEL *YEAR TEST_M2
- * Month 2 to 9
- C IF TEST_M1 = CURRMTH
- C EVAL WK_DATE = '0' +WK_DATE +WK_YEAR
- * Month 10 to 12
- C ELSEIF TEST_M2 = CURRMTH
- C EVAL WK_DATE = %SUBST(WK_DATE:1:2) +'0'
- C +%SUBST(WK_DATE:3:1) +WK_YEAR
- * Month 1 to 9 prior to current
- C ELSEIF M1 >= 1 OR M1 <= 9
- C EVAL WK_DATE2 = '0' +WK_DATE +WK_YEAR
- C *USA0 TEST(DE) WK_DATE2
- C IF %ERROR
- C EVAL VALID = 'N'
- C LEAVESR
- C ENDIF
- C EVAL ISO_DATE = %DATE(WK_DATE2:*USA0)
- C EVAL D = %DIFF(TODAY:ISO_DATE:*D)
- * Only JAN has the condition where it might also be
- * OCT, NOV or DEC.
- C IF M1 = 1 AND D > 60
- C AND NOT (WK_DATE = '120' OR WK_DAte = '110')
- C GOTO TESTM2DATE
- C ENDIF
- C EVAL WK_DATE = %TRIM(WK_DATE2)
- * Month 10 to 12 prior to current
- C ELSEIF M2 >= 10 OR M2 <= 12
- C TESTM2DATE TAG
- C EVAL WK_DATE2 = %SUBST(WK_DATE:1:2) +'0'
- C +%SUBST(WK_DATE:3:1) +WK_YEAR
- C *USA0 TEST(DE) WK_DATE2
- C IF %ERROR
- C EVAL VALID = 'N'
- C LEAVESR
- C ENDIF
- C EVAL WK_DATE = %TRIM(WK_DATE2)
- C EVAL ISO_DATE = %DATE(WK_DATE2:*USA0)
- C EVAL D = %DIFF(TODAY:ISO_DATE:*D)
- *
- C IF D > 60
- C EVAL WK_DATE = '0' +WK_DATE +WK_YEAR
- C ENDIF
- *
- C ENDIF
- C EVAL RECHECK = *ON
- C OTHER
- *
- C ENDSL
- *
- C IF RECHECK = *ON
- C GOTO CHKAGAIN
- C ENDIF
- *
- C EXIT TAG
- C IF SHORTDATE = *ON AND ISO_DATE < TODAY
- C EVAL D = %DIFF(TODAY:ISO_DATE:*D)
- C IF D > 60
- C EVAL ISO_DATE = ISO_DATE +%YEARS(1)
- C ENDIF
- C ENDIF
- C EVAL SHORTDATE = *OFF
- C ENDIF
- C ENDIF
- *
- C ENDSR
- *
- *========================================================================*
- * Relative Date
- *========================================================================*
- C REL_DATE BEGSR
- *
- C EVAL inpreldate = %TRIML(inpreldate )
- *
- C inpreldate CHAIN DATRELPF
- C IF %FOUND(DATRELPF)
- C EVAL CALC_DATE = TODAY
- *
- C IF DRWEEK = 'D'
- C MONITOR
- C EVAL CALC_DATE = CALC_DATE + %DAYS(DRDOW)
- C ON-ERROR 00113
- C EVAL VALID = 'N'
- C CLEAR WK_DATE
- C LEAVESR
- C ENDMON
- C GOTO EXITRD
- C ENDIF
- *
- C IF DRWEEK = 'S'
- C IF %PARMS >= 3
- C EVAL WK_DATE = %TRIML(inpref )
- C EXSR TEST_DATE
- C IF VALID = 'Y'
- C EVAL CALC_DATE = ISO_DATE
- C ENDIF
- C ENDIF
- C MONITOR
- C EVAL CALC_DATE = CALC_DATE + %DAYS(DRDOW)
- C ON-ERROR 00113
- C EVAL VALID = 'N'
- C CLEAR WK_DATE
- C LEAVESR
- C ENDMON
- C GOTO EXITRD
- C ENDIF
- *
- C CALC_DATE SUBDUR BASEDATE WKNUM:*D
- C WKNUM DIV 7 WKNUM
- C MVR WKDAY
- C ADD 1 WKDAY
- *
- C EVAL CALC_DATE = CALC_DATE - %DAYS(WKDAY)
- *
- C SELECT
- C WHEN DRWEEK = 'L'
- C EVAL CALC_DATE = CALC_DATE - %DAYS(7)
- *
- C WHEN DRWEEK = 'N'
- C EVAL CALC_DATE = CALC_DATE + %DAYS(7)
- *
- C OTHER
- C MOVE CALC_DATE CALC_DATE
- *
- C ENDSL
- *
- C EVAL CALC_DATE = CALC_DATE + %DAYS(DRDOW)
- *
- C EXITRD TAG
- C MOVE CALC_DATE ISO_DATE
- C EVAL VALID = 'Y'
- *
- C ENDIF
- *
- C ENDSR
- *==================
- C *PSSR BegSr
-
- C If pgmisinerror()
- C IF %OPEN(DATRELPF)
- C CLOSE DATRELPF
- C ENDIF
- C Return
- C EndIf
-
- C EndSr
- *==================
- *
- P E
- *
- *-------------------------------------------------------------------------
- * Check for a progam error
- *-------------------------------------------------------------------------
- P pgmisinerror b
- D pgmisinerror pi 1N
-
-
- C Select
- * Invalid Date, Time or Timestamp value, Date overflow or Date mapping errors
- C When %STATUS >= 00112 and %STATUS <= 00114
- C Exsr SNDMSG
- C Return *ON
- * Called pgm or procedure failed, Error calling pgm or procedure, Pointer or parameter error
- C When %STATUS >= 00202 and %STATUS <= 00222
- C Exsr SNDMSG
- C Return *ON
- C EndSL
-
- C Return *OFF
-
- * Send Error Message
- C SNDMSG BegSr
-
- C Eval MSGTOOLS.ID = 'ERR9999'
- C Eval MSGTOOLS.DATA = StatusMsg
- C****Your message send tool goes here
- C EndSr
-
- P E
-
-
- *--------------------------------------------------
- * Procedure name: getreldate
- * Purpose: Returns a true date replacing the psuedo
- * date that may have been passed. A psuedo
- * date can be like +1d, NEXT WED, etc. See
- * date in DATRELPF for all possible relative
- * date values.
- * You can also pass in a shortened date like
- * 0504 and get back as date like 05/04/2006.
- * Parameter: A real date, psuedo date or short date.
- * Parameter: The format of the returned date value.
- * Parameter: For incremental psuedo date (+2D) a date
- * string that is used to increment starting from.
- * If not passed, TODAY is assumed.
- * Parameter: Logical condition siginfying a valid date,
- * psuedo or short date was passed in.
- *--------------------------------------------------
- D getreldate PR
- D inpreldate 15
- D inpformat 5 CONST OPTIONS(*NOPASS)
- D inpref 10 CONST OPTIONS(*NOPASS)
- D outvalid 1N OPTIONS(*NOPASS)
-
- D pgmisinerror pr 1N
-
-
-
-
- STRPGMEXP PGMLVL(*CURRENT) SIGNATURE('V1R1M0')
- EXPORT SYMBOL(getreldate)
- ENDPGMEXP
-
- CRTSRVPGM SRVPGM(WFIOBJ/DATEUTL) ACTGRP(DATEUTL) OPTION(*DUPPROC)
-
|
|