Y2K Date Procedures in PL/I:
DATETIME, DAYS, DAYSTODATE, DAYSTOSECS, REPATTERN, SECS, SECSTODATE, etc.
<![CDATA[
/* Copyright (c) 1995, 2002 by R. A. Vowels, from "Introduction to PL/I, Algorithms, and */
/* Structured Programming". Permission is given to reproduce and to use these procedures */
/* as part of a program, and to include them as part of a larger work to be sold for profit. */
/* However, the user is not permitted to sell the procedures separately. Provided always */
/* that these procedures and this copyright notice are reproduced in full. */
/* Unless hours were cups of sack, and minutes capons, and clocks the tongues of bawds, . . . */
/* I see no reason why thou should be so superfluous to demand the time of the day. */
/* - Shakespeare, Henry IV Part 1, I, ii */
/* These procedures implement the following date functions: */
/* DATETIME, DAYS, DAYSTODATE, DAYSTOSECS, REPATTERN, SECS, SECSTODATE, */
/* SECSTODAYS, VALIDDATE, WEEKDAY, Y4DATE, Y4JULIAN, Y4YEAR. */
/* Also implemented is the function TODAY. */
/* Updated 4 July 2002. */
/* This procedure prints the day, date, month, and year of today's date. */
(SUBSCRIPTRANGE, CONVERSION):
TODAY:
PROCEDURE;
DECLARE MONTHS(12) CHARACTER (9) VARYING STATIC INITIAL
( 'January', 'February', 'March', 'April', 'May', 'June',
'July', 'August', 'September', 'October', 'November',
'December' );
DECLARE DAYS (0:6) CHARACTER (9) VARYING STATIC INITIAL
( 'Sunday', 'Monday', 'Tuesday', 'Wednesday',
'Thursday', 'Friday', 'Saturday' );
DECLARE (YEAR, MONTH, DAY) FIXED BINARY;
DECLARE DAY_CODE CHARACTER (6);
DECLARE (DATE, SUBSTR) BUILTIN;
/* This function procedure returns the current day of the week as an integer (0 = Sunday, */
/* 1 = Monday, etc). */
WEEKDAY:
PROCEDURE RETURNS (FIXED BINARY);
DECLARE DW FIXED BINARY,
T(1:12) FIXED BINARY (7) STATIC INITIAL
(1, 4, 4, 0, 2, 5, 0, 3, 6, 1, 4, 6);
DECLARE (MOD, BINARY) BUILTIN;
IF YEAR < 96 THEN
YEAR = YEAR + 100;
DW = MOD (BINARY(YEAR*5/4, 15, 0) + T(MONTH) + DAY + 6, 7);
IF (MOD (YEAR, 4) = 0) & (MONTH <= 2) THEN
IF YEAR > 0 THEN
DW = DW - 1; /* No decrement for 1900 */
IF DW < 0 THEN
DW = DW + 7;
RETURN (DW);
END WEEKDAY;
ON CONVERSION SNAP GO TO AVOID;
DAY_CODE = DATE;
YEAR = SUBSTR (DAY_CODE, 1, 2);
MONTH = SUBSTR (DAY_CODE, 3, 2);
DAY = SUBSTR (DAY_CODE, 5, 2);
PUT SKIP EDIT ('Today is ', DAYS(WEEKDAY()), DAY, MONTHS(MONTH), YEAR+1900 )
(2 A, F(3), X(1), A, F(5));
AVOID:
END TODAY;
/* This function procedure returns today's date in the readable form DD Mmm YYYY. */
NEW_DATE:
PROCEDURE RETURNS (CHARACTER (11) );
DECLARE Squashed_date CHARACTER (9);
Squashed_date = DATETIME ( 'DDMmmYYYY' );
RETURN (SUBSTR (Squashed_date, 1, 2) || ' ' ||
SUBSTR (Squashed_date, 3, 3) || ' ' ||
SUBSTR (Squashed_date, 6, 4) );
END NEW_DATE;
/**************************************************************** */
/* Generic procedures to implement the WEEKDAY built-in function. */
/**************************************************************** */
DECLARE WEEKDAY GENERIC
(WEEKDAY0 WHEN ( ),
WEEKDAY1 WHEN (*) );
/* This function procedure returns the current day of the week as an integer */
/* (1 = Sunday, 2 = Monday, etc). */
WEEKDAY0:
PROCEDURE RETURNS (FIXED BINARY (31) );
DECLARE DW FIXED BINARY,
T(1:12) FIXED BINARY (7) STATIC INITIAL
(1, 4, 4, 0, 2, 5, 0, 3, 6, 1, 4, 6);
DECLARE (YEAR, MONTH, DAY) FIXED BINARY;
DECLARE DAY_CODE CHARACTER (6);
DECLARE (DATE, SUBSTR,
MOD, BINARY) BUILTIN;
DAY_CODE = DATE;
YEAR = SUBSTR (DAY_CODE, 1, 2);
MONTH = SUBSTR (DAY_CODE, 3, 2);
DAY = SUBSTR (DAY_CODE, 5, 2);
IF YEAR < 96 THEN
YEAR = YEAR + 100;
DW = MOD (BINARY (YEAR*5/4, 15, 0) + T(MONTH) + DAY + 6, 7);
IF (MOD (YEAR, 4) = 0) & (MONTH <= 2) THEN
IF YEAR > 0 THEN
DW = DW - 1; /* No decrement for 1900 */
/* At this point, DW = 0 for Sunday, 1 for Monday, etc. */
IF DW < 0 THEN
DW = DW +7;
RETURN (DW+1); /* Here, 1 = Sunday, 2 = Monday, etc. */
END WEEKDAY0;
/* This function procedure returns the current day of the week as an integer */
/* (1 = Sunday, 2 = Monday, etc). */
WEEKDAY1:
PROCEDURE (DAY_No) RETURNS (FIXED BINARY (31) );
DECLARE DAY_No FIXED BINARY (31);
DECLARE DW FIXED BINARY,
T(1:12) FIXED BINARY (7) STATIC INITIAL
(1, 4, 4, 0, 2, 5, 0, 3, 6, 1, 4, 6);
DECLARE CENTURY FIXED BINARY (7);
DECLARE (YEAR, MONTH, DAY) FIXED BINARY;
DECLARE DAY_CODE CHARACTER (8);
DECLARE (DATE, SUBSTR,
MOD, BINARY) BUILTIN;
DAY_CODE = DAYSTODATE (DAY_No, 'YYYYMMDD' );
CENTURY = SUBSTR (DAY_CODE, 1, 2);
YEAR = SUBSTR (DAY_CODE, 3, 2);
YEAR = YEAR + (CENTURY-19)*100;
MONTH = SUBSTR (DAY_CODE, 5, 2);
DAY = SUBSTR (DAY_CODE, 7, 2);
DW = MOD (BINARY (YEAR*5/4, 15, 0) + T(MONTH) + DAY + 6, 7);
IF (MOD (YEAR, 4) = 0) & (MONTH <= 2) THEN
IF YEAR > 0 THEN /* No decrement for 1900. */
DW = DW - 1;
/* At this point, DW = 0 for Sunday, 1 for Monday, etc. */
IF DW < 0 THEN
DW = DW +7;
RETURN (DW+1); /* Here, 1 = Sunday, 2 = Monday, etc. */
END WEEKDAY1;
/* These generic procedures implement the DATETIME built-in function. */
DECLARE DATETIME GENERIC /* {XE "INCLUDE files: DATETIME"} */
(DATETIME1 WHEN ( ),
DATETIME2 WHEN (*) );
/* This function procedure returns the date & time in default DATETIME format. */
DATETIME1:
PROCEDURE RETURNS (CHARACTER (17));
DECLARE (DATE, TIME, SUBSTR) BUILTIN;
DECLARE TDATE CHARACTER (6);
DECLARE (Y, CENTURY) CHARACTER (2);
TDATE = DATE;
Y = SUBSTR (TDATE, 1, 2);
IF Y >= '98' THEN
CENTURY = '19';
ELSE
CENTURY = '20';
RETURN (CENTURY || TDATE || TIME);
END DATETIME1;
/* This function procedure returns the date, or date & time, */
/* in the form specified by the template format. */
DATETIME2:
PROCEDURE (DATE_FORMAT) RETURNS (CHARACTER (17) VARYING);
DECLARE DATE_FORMAT CHARACTER (*);
DECLARE HBOUND BUILTIN;
DECLARE J FIXED BINARY;
DECLARE FORMS (37) CHARACTER (17) VARYING STATIC INITIAL (
'YYYYMMDDHHMISS999', 'YYYYMMDD', 'YYYYMMMDD',
'YYYYMmmDD', 'YYYYDDD', 'YYYYMM',
'YYYYMMM', 'YYYYMmm', 'YYYY',
'YYMMDD', 'YYMMMDD', 'YYMmmDD',
'YYDDD', 'YYMM', 'YYMMM',
'YYMmm', 'YY',
'MMDDYYYY', 'MMMDDYYYY', 'MmmDDYYYY',
'MMYYYY', 'MMMYYYY', 'MmmYYYY',
'MMDDYY', 'MMMDDYY', 'MmmDDYY',
'MMYY', 'MMMYY', 'MmmYY',
'DDMMYYYY', 'DDMMMYYYY', 'DDMmmYYYY',
'DDDYYYY', 'DDMMYY', 'DDMMMYY',
'DDMmmYY', 'DDDYY' );
DO J = 1 TO HBOUND (FORMS, 1); /* Search the list of permitted templates. */
IF DATE_FORMAT = FORMS (J) THEN
RETURN (MAKE_DATETIME (J) );
END;
PUT SKIP EDIT ( 'The template ', DATE_FORMAT, ' is not one of the permitted forms.' )
(A);
SIGNAL ERROR;
END DATETIME2;
/* This procedure returns the date, or the date and time in one of 37 formats, selected */
/* according to the value of N. */
MAKE_DATETIME:
PROCEDURE (N) RETURNS (CHARACTER(17) VARYING);
/* INCOMING: N = selector value, in the range 1 to 23. */
DECLARE N FIXED BINARY;
DECLARE (DATE, TIME,
SUBSTR) BUILTIN;
DECLARE TDATE CHARACTER (6);
DECLARE TTIME CHARACTER (9);
DECLARE (D, MM, YY,
CENTURY) CHARACTER (2);
TDATE = DATE; TTIME = TIME;
YY = SUBSTR (TDATE, 1, 2);
IF YY >= '95' THEN
CENTURY = '19';
ELSE
CENTURY = '20';
/* The first argument is converted to a 4-digit year prior to the call. */
RETURN ( MAKE_DATETIMES (CENTURY || TDATE, N) );
END MAKE_DATETIME;
/* This function returns the day number within the current year. */
DOY:
PROCEDURE RETURNS (CHARACTER (3));
DECLARE (DATE,
LENGTH, SUBSTR) BUILTIN;
DECLARE TDATE CHARACTER (6);
DECLARE (J, DAYS, M) FIXED BINARY;
DECLARE SDAYS CHARACTER (30) VARYING;
DECLARE DM(1:12) FIXED BINARY (7) STATIC INITIAL
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31 ,30 ,31);
TDATE = DATE;
M = SUBSTR (TDATE, 3, 2);
DAYS = SUBSTR (TDATE, 5, 2);
DO J = 1 TO M-1;
DAYS = DAYS + DM(J);
END;
IF MOD (SUBSTR (TDATE, 1, 2), 4 ) = 0 THEN /* It's a leap year. */
IF DAYS > 59 THEN
DAYS = DAYS + 1;
SDAYS = DAYS;
J = LENGTH (SDAYS);
RETURN (SUBSTR (SDAYS, J-2, 3));
END DOY;
/* This function returns the day number of the date specified, from the start of that year. */
DOY1:
PROCEDURE (TDATE) RETURNS (CHARACTER (3));
DECLARE TDATE CHARACTER (*);
DECLARE (DATE,
LENGTH, SUBSTR) BUILTIN;
DECLARE (J, DAYS, M) FIXED BINARY;
DECLARE SDAYS CHARACTER (30) VARYING;
DECLARE DM(1:12) FIXED BINARY (7) STATIC INITIAL
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31 ,30 ,31);
M = SUBSTR (TDATE, 5, 2);
DAYS = SUBSTR (TDATE, 7, 2);
DO J = 1 TO M-1;
DAYS = DAYS + DM(J);
END;
IF MOD (SUBSTR (TDATE, 3, 2), 4 ) = 0 THEN /* It's a leap year. */
IF DAYS > 59 THEN
DAYS = DAYS + 1;
SDAYS = DAYS;
J = LENGTH (SDAYS);
RETURN (SUBSTR (SDAYS, J-2, 3));
END DOY1;
DECLARE DAYS GENERIC /* {XE "INCLUDE files: DAYS"} */
(DAYS0 WHEN ( ),
DAYS1 WHEN (*),
DAYS2 WHEN (*, *),
DAYS3 WHEN (*, *, *) );
/* This function procedure returns the number of days since the beginning of time. */
/* Dates allowed start from 1 January 1900. */
DAYS0:
PROCEDURE RETURNS (FIXED BINARY (31));
DECLARE (DATE, SUBSTR,
DIVIDE) BUILTIN;
DECLARE TDATE CHARACTER (6);
DECLARE (Y, CENTURY) FIXED BINARY;
DECLARE NDAYS FIXED BINARY (31);
TDATE = DATE;
Y = SUBSTR (TDATE, 1, 2);
IF Y >= 96 THEN
CENTURY = 19;
ELSE
CENTURY = 20;
NDAYS = (CENTURY*100 + Y - 1900)*365 /* The number of days in whole years . . . */
+ DIVIDE (Y-1, 4, 15, 0) /* the number of leap days . . . */
+ DOY(); /* the number of days so far in the current year.*/
RETURN (NDAYS + 115860);
END DAYS0;
/* This function procedure returns the number of days since the beginning of time */
/* until the date TDATE (assumed to be the default for DATETIME). */
/* Dates allowed start from 1 January 1900. */
DAYS1:
PROCEDURE (TDATE) RETURNS (FIXED BINARY (31));
DECLARE TDATE CHARACTER (*);
DECLARE (SUBSTR,
DIVIDE) BUILTIN;
DECLARE Y FIXED BINARY;
DECLARE NDAYS FIXED BINARY (31);
Y = SUBSTR (TDATE, 1, 4);
NDAYS = (Y - 1900)*365 /* The number of days in whole years . . . */
+ DIVIDE (Y-1900-1, 4, 15, 0) /* the number of leap days . . . */
+ DOY1(TDATE); /* the number of days so far in the current year.*/
RETURN (NDAYS + 115860);
END DAYS1;
/* This function procedure returns the number of days since the beginning of time */
/* to the date TDATE (given in the specified format). */
/* Dates allowed start from 1 January 1900. */
DAYS2:
PROCEDURE (TDATE, LAYOUT) RETURNS (FIXED BINARY (31));
DECLARE TDATE CHARACTER (*),
LAYOUT CHARACTER (*);
RETURN (DAYS3(TDATE, LAYOUT, 1950) ); /* Assume that the window starts at 1950. */
END DAYS2;
/* This function procedure returns the number of days since the beginning of time */
/* to the date TDATE (given in the specified format). */
/* Dates allowed start from 1 January 1900. */
/* This procedure accepts a date window, for use with a 2-digit year. */
DAYS3:
PROCEDURE (TDATE, LAYOUT, Window) RETURNS (FIXED BINARY (31));
/* INCOMING: TDATE = A date, in a format corresponding to: */
/* LAYOUT = One of the standard date patterns; and */
/* Window = a 4-digit year, being the beginning of the 100-year window. */
/* If the 2-digit year specified in TDATE is less than */
/* the 2-digit component of the 4-digit year in Window, then the */
/* century is increnemted. */
/* E.G., if Window = 1970, then dates 70 to 99 are 1970 to 1999, while */
/* dates 00 through 69 are 2000 through 2069. */
DECLARE TDATE CHARACTER (*),
LAYOUT CHARACTER (*);
DECLARE Window FIXED BINARY;
DECLARE NSDAYS CHARACTER (2);
DECLARE Year CHARACTER (4),
STD_DATE CHARACTER(8);
DECLARE S CHARACTER (17);
DECLARE Ndays FIXED BINARY (31);
DECLARE (K, M, Y) FIXED BINARY;
DECLARE MONTHC (12) CHARACTER(3) STATIC INITIAL (
'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN',
'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC' );
DECLARE MONTH (12) CHARACTER(3) STATIC INITIAL (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
S = DATETIME2 (LAYOUT); /* Checks the layout, but discards the returned date. */
K = INDEX(LAYOUT, 'YY' );
IF K = 0 THEN
DO;
PUT SKIP EDIT ( '***ERROR, Invalid pattern ', Layout ) (A);
SIGNAL ERROR;
END;
IF SUBSTR (LAYOUT, K, 4) = 'YYYY' THEN /* We have a 4-digit year. */
Y, Year = SUBSTR (TDATE, K, 4);
ELSE /* We have a 2-digit year, so ... */
Y, Year = Y4YEAR ( SUBSTR (TDATE, K, 2), Window); /* ... expand the year to 4 digits, */
/* with a 100-year window from the year "Window".*/
IF Y < 1900 THEN
DO;
PUT SKIP LIST ( '***ERROR, the year is earlier than 1900.' );
SIGNAL ERROR;
END;
K = INDEX (Layout, 'M' );
IF SUBSTR (Layout, K+1, 1) = 'm' THEN /* Lower-case month is always 3 characters. */
DO M = 1 TO 12;
IF Month(M) = SUBSTR(TDATE, K, 3) THEN LEAVE;
END;
ELSE IF LENGTH(Layout) >= K+2 THEN /* We can look for 3-character months. */
DO;
IF SUBSTR(Layout, K+2, 1) = 'M' THEN /* We have 3-character upper-case months. */
DO M = 1 TO 12;
IF Monthc(M) = SUBSTR (TDATE, K, 3) THEN LEAVE;
END;
ELSE /* We have 2-digit months. */
M = SUBSTR(TDATE, K, 2);
END;
ELSE /* The only other possibility is 2-digit months.*/
M = SUBSTR(TDATE, K, 2);
IF M > 12 | M = 0 THEN
DO;
PUT SKIP EDIT ( 'The month is out of range in the date ', TDATE) (A);
SIGNAL ERROR;
END;
K = INDEX(Layout, 'DD' );
NSdays = SUBSTR (TDATE, K, 2);
PUT STRING (STD_DATE) EDIT (Year, M, NSdays) (A, F(2), A);
NDAYS = (Y - 1900)*365 /* The number of days in whole years . . . */
+ DIVIDE (Y-1900-1, 4, 15, 0) /* the number of leap days . . . */
+ DOY1(STD_DATE); /* the number of days so far in the current year. */
RETURN (Ndays + 115860);
END DAYS3;
/********************************************************************* */
/* Generic procedures to implement the DAYSTODATE function. */
/********************************************************************* */
DECLARE DAYSTODATE GENERIC /* {XE "INCLUDE files: DAYSTODATE"} */
(DAYSTODATE_long WHEN (*),
DAYSTODATE_specific WHEN (*,*),
DAYSTODATE_windowed WHEN (*,*, *) );
/* This procedure converts the number of days PDAYS to a character string date in the */
/* default DATETIME format YYYYMMDDHHMISS999. */
/* Modified 4 July 2002. */
DAYSTODATE_long:
PROCEDURE (PDAYS) RETURNS (CHARACTER(17) );
/* INCOMING: DAYS = the number of days since the beginning of time. */
DECLARE PDAYS FIXED BINARY (31);
DECLARE DAYS FIXED BINARY (31);
DECLARE (TIME, MOD) BUILTIN;
DECLARE SDATE CHARACTER (8);
DECLARE NDAYS FIXED BINARY (31);
DECLARE (ND, NYEARS,
DAYNO, MONTH) FIXED BINARY;
DECLARE DM(1:12) FIXED BINARY (7) STATIC INITIAL
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31 ,30 ,31);
DAYS = PDAYS - 6287; /* Adjust to 1600. */
IF DAYS < 0 THEN
DO;
PUT SKIP LIST ('Implementation restriction: days earlier than 1600 are not permitted.');
SIGNAL ERROR;
END;
NDAYS, NYEARS = 0;
DO WHILE (NDAYS < DAYS);
ND = 365;
NDAYS = NDAYS + 365;
IF ((MOD (NYEARS, 4) = 0) & (MOD (NYEARS, 100) ^= 0)) | (MOD(NYears, 400) = 0) THEN
DO; /* It's a leap year. */
NDAYS = NDAYS + 1;
ND = ND + 1;
END;
NYEARS = NYEARS + 1;
END;
NDAYS = NDAYS - ND; NYEARS = NYEARS - 1;
NDAYS = DAYS - NDAYS;
/* Determine the month and day for the year requested. */
IF ((MOD (NYEARS, 4) = 0) & (MOD (NYEARS, 100) ^= 0)) | (MOD(NYears, 400) = 0) THEN
DM(2) = 29;
ELSE
DM(2) = 28;
DAYNO = 0;
DO MONTH = 1 TO 12 WHILE (DAYNO + DM(MONTH) < NDAYS);
DAYNO = DAYNO + DM(MONTH);
END;
DAYNO = NDAYS - DAYNO;
PUT STRING (SDATE) EDIT (1600 + NYEARS, MONTH, DAYNO) (P'9999', 2 P'99' );
RETURN (SDATE || TIME);
END DAYSTODATE_long;
/* This procedure converts the number of days PDAYS to a character string date in the */
/* specific format given by LAYOUT. */
DAYSTODATE_specific:
PROCEDURE (PDAYS, LAYOUT) RETURNS (CHARACTER(17) VARYING);
/* INCOMING: PDAYS = the number of days since the beginning of time. */
/* LAYOUT = one of the permissible date/time formats. */
DECLARE PDAYS FIXED BINARY (31);
DECLARE LAYOUT CHARACTER (*);
RETURN (DAYSTODATE_Windowed (PDAYS, LAYOUT, 1950) );
END DAYSTODATE_specific;
/* This procedure converts the number of days PDAYS to a character string date in the */
/* specific format given by LAYOUT. */
DAYSTODATE_windowed:
PROCEDURE (PDAYS, LAYOUT, Window) RETURNS (CHARACTER(17) VARYING);
/* INCOMING: PDAYS = the number of days since the beginning of time. */
/* LAYOUT = one of the permissible date/time formats. */
/* Window = a 4-digit year, being the beginning of the 100-year window. */
/* If the 2-digit year specified in TDATE is less than */
/* the 2-digit component of the 4-digit year in Window, then the */
/* century is increnemted. */
/* E.G., if Window = 1970, then dates 70 to 99 are 1970 to 1999, while */
/* dates 00 through 69 are 2000 through 2069. */
/* Modified 4 July 2002. */
DECLARE PDAYS FIXED BINARY (31);
DECLARE LAYOUT CHARACTER (*);
DECLARE DAYS FIXED BINARY (31);
DECLARE (TIME, MOD) BUILTIN;
DECLARE SDATE CHARACTER (8);
DECLARE NDAYS FIXED BINARY (31);
DECLARE (ND, NYEARS,
DAYNO, MONTH) FIXED BINARY;
DECLARE DM(1:12) FIXED BINARY (7) STATIC INITIAL
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31 ,30 ,31);
DAYS = PDAYS - 6287; /* Adjust to 1600. */
IF DAYS < 0 THEN
DO;
PUT SKIP LIST ('Implementation restriction: days earlier than 1600 are not permitted.');
SIGNAL ERROR;
END;
NDAYS, NYEARS = 0;
DO WHILE (NDAYS < DAYS);
ND = 365;
NDAYS = NDAYS + 365;
IF ((MOD (NYEARS, 4) = 0) & (MOD (NYEARS, 100) ^= 0)) | (MOD(NYears, 400) = 0) THEN
DO; /* It's a leap year. */
NDAYS = NDAYS + 1;
ND = ND + 1;
END;
NYEARS = NYEARS + 1;
END;
NDAYS = NDAYS - ND; NYEARS = NYEARS - 1;
NDAYS = DAYS - NDAYS;
/* Determine the month and day for the year requested. */
IF ((MOD (NYEARS, 4) = 0) & (MOD (NYEARS, 100) ^= 0)) | (MOD(NYears, 400) = 0) THEN
DM(2) = 29;
ELSE
DM(2) = 28;
DAYNO = 0;
DO MONTH = 1 TO 12 WHILE (DAYNO + DM(MONTH) < NDAYS);
DAYNO = DAYNO + DM(MONTH);
END;
DAYNO = NDAYS - DAYNO;
IF Window < 0 THEN
NYEARS = NYEARS - Window;
PUT STRING (SDATE) EDIT (1600 + NYEARS, MONTH, DAYNO) (P'9999', 2 P'99' );
RETURN (DATETIMES (SDATE, LAYOUT) );
END DAYSTODATE_windowed;
/* This function procedure compares the given date/time format with the list of 37 */
/* possible formats. */
DATETIMES:
PROCEDURE (SDATE, DATE_FORMAT) RETURNS (CHARACTER (17) VARYING);
/* INCOMING: SDATE = the date, as a string, in the form produced by the DATE built-in */
/* function. */
/* DATE_FORMAT = the pro-forma of one of the permissible 23 formats for date/time. */
DECLARE SDATE CHARACTER (8);
DECLARE DATE_FORMAT CHARACTER (*);
DECLARE HBOUND BUILTIN;
DECLARE J FIXED BINARY;
DECLARE FORMS (37) CHARACTER (17) VARYING STATIC INITIAL (
'YYYYMMDDHHMISS999', 'YYYYMMDD', 'YYYYMMMDD',
'YYYYMmmDD', 'YYYYDDD', 'YYYYMM',
'YYYYMMM', 'YYYYMmm', 'YYYY',
'YYMMDD', 'YYMMMDD', 'YYMmmDD',
'YYDDD', 'YYMM', 'YYMMM',
'YYMmm', 'YY',
'MMDDYYYY', 'MMMDDYYYY', 'MmmDDYYYY',
'MMYYYY', 'MMMYYYY', 'MmmYYYY',
'MMDDYY', 'MMMDDYY', 'MmmDDYY',
'MMYY', 'MMMYY', 'MmmYY',
'DDMMYYYY', 'DDMMMYYYY', 'DDMmmYYYY',
'DDDYYYY', 'DDMMYY', 'DDMMMYY',
'DDMmmYY', 'DDDYY' );
DO J = 1 TO HBOUND (FORMS, 1); /* Search the list of permissible date/time forms. */
IF DATE_FORMAT = FORMS (J) THEN
RETURN (MAKE_DATETIMES (SDATE, J) );
END;
PUT SKIP EDIT ( 'The template ', DATE_FORMAT, ' is not one of the permitted forms.' )
(A);
SIGNAL ERROR;
END DATETIMES;
/* This function procedure prepares the date, or the date and the time, */
/* in one of the 37 possible formats. */
MAKE_DATETIMES:
PROCEDURE (SDATE, N) RETURNS (CHARACTER(17) VARYING);
/* INCOMING: SDATE = the date, as a string, in the form YYYYMMDD */
/* N = the number of the requested format, in the range 1 <= N <= 23. */
DECLARE SDATE CHARACTER (8);
DECLARE N FIXED BINARY;
DECLARE (DATE, TIME,
SUBSTR) BUILTIN;
DECLARE TDATE CHARACTER (6);
DECLARE TTIME CHARACTER (9);
DECLARE (D, MM, YY,
CENTURY) CHARACTER (2);
DECLARE YYYY CHARACTER (4);
DECLARE M FIXED BINARY;
DECLARE MONTHC (12) CHARACTER (3) STATIC INITIAL (
'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN',
'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC' );
DECLARE MONTH (12) CHARACTER (3) STATIC INITIAL (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
TDATE = SUBSTR (SDATE, 3); TTIME = TIME;
YY = SUBSTR (TDATE, 1, 2);
CENTURY = SUBSTR (SDATE, 1, 2);
/* Four-digit years, Year first. */
IF N = 1 THEN RETURN ( CENTURY || TDATE || TIME );
IF N = 2 THEN RETURN ( CENTURY || TDATE );
M, MM = SUBSTR (TDATE, 3,2); D = SUBSTR (TDATE, 5,2);
YYYY = CENTURY || YY;
IF N = 3 THEN RETURN ( YYYY || MONTHC(M) || D );
IF N = 4 THEN RETURN ( YYYY || MONTH (M) || D );
IF N = 5 THEN RETURN ( YYYY || DOY( ) );
IF N = 6 THEN RETURN ( YYYY || MM);
IF N = 7 THEN RETURN ( YYYY || MONTHC(M) );
IF N = 8 THEN RETURN ( YYYY || MONTH (M) );
IF N = 9 THEN RETURN ( YYYY );
/* Two-digit years, Year first. */
IF N = 10 THEN RETURN ( TDATE );
IF N = 11 THEN RETURN ( YY || MONTHC(M) || D );
IF N = 12 THEN RETURN ( YY || MONTH (M) || D );
IF N = 13 THEN RETURN ( YY || DOY ( ) );
IF N = 14 THEN RETURN ( YY || MM );
IF N = 15 THEN RETURN ( YY || MONTHC(M) );
IF N = 16 THEN RETURN ( YY || MONTH (M) );
IF N = 17 THEN RETURN (YY);
/* Four-digit years, Month first. */
IF N = 18 THEN RETURN (MM || D || YYYY );
IF N = 19 THEN RETURN (MONTHC(M) || D || YYYY );
IF N = 20 THEN RETURN (MONTH (M) || D || YYYY );
IF N = 21 THEN RETURN (MM || YYYY );
IF N = 22 THEN RETURN (MONTHC(M) || YYYY );
IF N = 23 THEN RETURN (MONTH (M) || YYYY );
/* Two-digit years, Month first. */
IF N = 24 THEN RETURN (MM || D || YY);
IF N = 25 THEN RETURN (MONTHC(M) || D || YY);
IF N = 26 THEN RETURN (MONTH (M) || D || YY);
IF N = 27 THEN RETURN (MM || YY);
IF N = 28 THEN RETURN (MONTHC(M) || YY);
IF N = 29 THEN RETURN (MONTH (M) || YY);
/* Four-digit years, Day first. */
IF N = 30 THEN RETURN (D || MM || YYYY);
IF N = 31 THEN RETURN (D || MONTHC(M) || YYYY);
IF N = 32 THEN RETURN (D || MONTH (M) || YYYY);
IF N = 33 THEN RETURN (DOY( ) || YYYY );
/* Two-digit years, Day first. */
IF N = 34 THEN RETURN (D || MM || YY);
IF N = 35 THEN RETURN (D || MONTHC(M) || YY);
IF N = 36 THEN RETURN (D || MONTH (M) || YY);
IF N = 37 THEN RETURN (DOY( ) || YY);
RETURN ( CENTURY || D); /* Return something. */
END MAKE_DATETIMES;
/****************************************************************** */
/* These generic procedures implement the SECS function. */
/****************************************************************** */
/* A generic procedure to convert a date in DATETIME format, into seconds. */
DECLARE SECS GENERIC (
SECS0 WHEN ( ),
SECS1 WHEN (*),
SECS2 WHEN (*, *),
SECS3 WHEN (*, *, *) );
/* Converts the current (default) date and time to seconds. */
SECS0:
PROCEDURE RETURNS (FLOAT BINARY (53) );
RETURN (SECS(DATETIME () ) );
END SECS0;
/* Converts the specified date in default DATETIME form YYYMMDDHHMISS999 to */
/* seconds. */
SECS1:
PROCEDURE (D) RETURNS (FLOAT BINARY (53) );
DECLARE D CHARACTER (*);
DECLARE 1 T,
2 Hours PICTURE '99',
2 Minutes PICTURE '99',
2 Seconds PICTURE '99V999';
DECLARE X FLOAT BINARY (53);
DECLARE TIME BUILTIN;
X = DAYS(D) * FLOAT(BINARY(24 * 60 * 60));
STRING (T) = TIME;
X = X + (Hours * 3600 + Minutes * 60 + Seconds);
RETURN (X);
END SECS1;
/* Converts the given date <D> in the DATETIME form <Pattern>, into seconds. */
SECS2:
PROCEDURE (D, Pattern) RETURNS (FLOAT BINARY (53) );
DECLARE D CHARACTER (*),
Pattern CHARACTER (*);
RETURN (SECS3 (D, Pattern, 1950) );
END SECS2;
/* Converts the given date <D> in the DATETIME form <Pattern>, into seconds. */
SECS3:
PROCEDURE (D, Pattern, Window) RETURNS (FLOAT BINARY (53) );
/* INCOMING: D = A date, in a format corresponding to: */
/* Pattern = One of the standard date patterns; and */
/* Window = a 4-digit year, being the beginning of the 100-year window. */
/* If the 2-digit year specified in TDATE is less than */
/* the 2-digit component of the 4-digit year in Window, then the */
/* century is increnemted. */
/* E.G., if Window = 1970, then dates 70 to 99 are 1970 to 1999, while */
/* dates 00 through 69 are 2000 through 2069. */
DECLARE D CHARACTER (*),
Pattern CHARACTER (*);
DECLARE Window FIXED BINARY;
DECLARE 1 T,
2 Hours PICTURE '99',
2 Minutes PICTURE '99',
2 Seconds PICTURE '99V999';
DECLARE X FLOAT BINARY (53);
DECLARE TIME BUILTIN;
X = DAYS(D, Pattern, Window) * FLOAT(BINARY(24 * 60 * 60));
IF Pattern ^= 'YYYYMMDDHHMISS999' THEN
RETURN (X);
STRING (T) = SUBSTR (D, LENGTH(D)-8);
X = X + (Hours * 3600 + Minutes * 60 + Seconds);
RETURN (X);
END SECS3;
/******************************************************************* */
/* Generic procedures to implement the SECSTODATE function. */
/******************************************************************* */
DECLARE SECSTODATE GENERIC ( /* {"UTILITY function: SECSTODATE"} */
SECSTODATE1 WHEN (*),
SECSTODATE2 WHEN (*,*) );
/* This function procedure returns the time in default DATETIME format YYYYMMDDHHMISS999. */
SECSTODATE1:
PROCEDURE (Seconds ) RETURNS (CHARACTER (17) VARYING);
DECLARE SECONDS FLOAT BINARY (53);
DECLARE No_of_Days FIXED BINARY (31);
DECLARE No_of_Seconds FIXED BINARY (31);
DECLARE Hours_and_Minutes FIXED BINARY (31);
DECLARE 1 Time,
2 SS999 PICTURE '99999',
2 MM PICTURE '99',
2 HH PICTURE '99';
No_of_Days = Seconds / (60000 * 60 * 24);
No_of_Seconds = MOD (Seconds, 60000 * 60 * 24);
SS999 = MOD (No_of_Seconds, 60000);
Hours_and_Minutes = Seconds / 60000;
MM = MOD (Hours_and_Minutes, 60);
HH = Hours_and_Minutes / 60;
RETURN ( DAYSTODATE(No_of_Days, 'YYYYMMDD' ) || STRING(Time) );
END SECSTODATE1;
/* This function procedure returns the time in default DATETIME format */
/* specified by Pattern. */
SECSTODATE2:
PROCEDURE (Seconds, Pattern) RETURNS (CHARACTER (17) VARYING);
DECLARE Seconds FLOAT BINARY (53);
DECLARE Pattern CHARACTER (*);
DECLARE No_of_Days FIXED BINARY (31);
IF Pattern = 'YYYYMMDDHHMISS999' THEN
RETURN (SECSTODATE (Seconds) );
/* We can forget about fractions of a day. */
No_of_Days = Seconds / (60.0000000000000E3 * 60 * 24 );
RETURN (DAYSTODATE (No_of_Days, Pattern) );
END SECSTODATE2;
/******************************************************************* */
/* Generic procedures to implement the VALIDDATE function. */
/******************************************************************* */
DECLARE VALIDDATE GENERIC (
VALID_DATE WHEN (),
VALID_DATE1 WHEN (*),
VALID_DATE2 WHEN (*,*),
VALID_DATE3 WHEN (*,*,*) );
VALID_DATE:
PROCEDURE RETURNS (BIT (1) );
RETURN (VALID_DATE1 (DATETIME() ) );
END VALID_DATE;
VALID_DATE1:
PROCEDURE (Date) RETURNS (BIT (1) );
DECLARE Date CHARACTER (*);
RETURN ( VALID_DATE2 ( Date, 'YYYYMMDDHHMISS999' ) );
END VALID_DATE1;
VALID_DATE2:
PROCEDURE (Date, Pattern) RETURNS (BIT (1) );
DECLARE Date CHARACTER (*);
DECLARE Pattern CHARACTER (*);
RETURN ( VALID_DATE3 ( Date, Pattern, 1950) );
END VALID_DATE2;
VALID_DATE3:
PROCEDURE (Date, Pattern, Window) RETURNS (BIT (1) );
DECLARE Date CHARACTER (*);
DECLARE Pattern CHARACTER (*);
DECLARE Window FIXED BINARY;
DECLARE HBOUND BUILTIN;
DECLARE MonthC (12) CHARACTER(3) STATIC INITIAL (
'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN',
'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC' );
DECLARE Month (12) CHARACTER(3) STATIC INITIAL (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
DECLARE Day_Table(12) FIXED BINARY (5) STATIC INITIAL
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
DECLARE (J, K, M) FIXED BINARY;
DECLARE FORMS (37) CHARACTER (17) VARYING STATIC INITIAL (
'YYYYMMDDHHMISS999', 'YYYYMMDD', 'YYYYMMMDD',
'YYYYMmmDD', 'YYYYDDD', 'YYYYMM',
'YYYYMMM', 'YYYYMmm', 'YYYY',
'YYMMDD', 'YYMMMDD', 'YYMmmDD',
'YYDDD', 'YYMM', 'YYMMM',
'YYMmm', 'YY',
'MMDDYYYY', 'MMMDDYYYY', 'MmmDDYYYY',
'MMYYYY', 'MMMYYYY', 'MmmYYYY',
'MMDDYY', 'MMMDDYY', 'MmmDDYY',
'MMYY', 'MMMYY', 'MmmYY',
'DDMMYYYY', 'DDMMMYYYY', 'DDMmmYYYY',
'DDDYYYY', 'DDMMYY', 'DDMMMYY',
'DDMmmYY', 'DDDYY' );
DECLARE (Day_No, Days_In_Month) FIXED BINARY;
DECLARE Century PICTURE '99';
DECLARE Leap_Year_Day FIXED BINARY (1);
DECLARE Y4 CHARACTER (4);
DO J = 1 TO HBOUND (FORMS, 1); /* Search the list of permitted templates. */
IF Pattern = FORMS (J) THEN /* Found a pattern. */
DO; /* Check whether the date is valid. */
K = INDEX (Pattern, 'YYYY');
IF K > 0 THEN /* A 4-digit year. */
DO;
IF VERIFY (SUBSTR (Date, K, 4), '0123456789') ^= 0 THEN
RETURN ('0'B);
IF SUBSTR (Date, K, 4) < '1582' THEN
RETURN ('0'B);
Y4 = SUBSTR (Date, K, 4);
END;
ELSE /* A 2-digit year. */
DO;
K = INDEX (Pattern, 'YY');
IF K > 0 THEN
IF VERIFY (SUBSTR (Date, K, 2), '0123456789') ^= 0 THEN
RETURN ('0'B);
Century = Window/100;
IF SUBSTR (Date, K, 2) < MOD (Window, 100) THEN
Century = Century + 1;
Y4 = Century || SUBSTR (Date, K, 2);
END;
IF MOD (Y4, 400) = 0 THEN Leap_Year_Day = 1;
ELSE IF MOD (Y4, 100) = 0 THEN Leap_Year_Day = 0;
ELSE IF MOD (Y4, 4) = 0 THEN leap_Year_Day = 1;
ELSE Leap_Year_Day = 0;
K = INDEX (Pattern, 'MMM');
IF K > 0 THEN
Month_Loop: DO;
DO M = 1 TO 12;
IF SUBSTR (Date, K, 3) = MonthC(M) THEN
LEAVE Month_Loop;
END;
RETURN ('0'B);
END;
ELSE
DO;
K = INDEX (Pattern, 'MM');
IF K > 0 THEN
DO;
M = SUBSTR (Date, K, 2);
IF (M < 1) | (M > 12) THEN RETURN ('0'B);
END;
END;
K = INDEX (Pattern, 'Mmm');
IF K > 0 THEN
Month_Loop2: DO;
DO M = 1 TO 12;
IF SUBSTR (Date, K, 3) = Month(M) THEN
LEAVE Month_Loop2;
END;
RETURN ('0'B);
END;
K = INDEX (Pattern, 'DDD');
IF K > 0 THEN
DO;
M = SUBSTR (Date, K, 3);
IF (M < 1) | (M > (365+Leap_Year_Day) ) THEN
RETURN ('0'B);
END;
ELSE
DO;
K = INDEX (Pattern, 'DD');
IF K > 0 THEN
DO;
Day_No = SUBSTR (Date, K, 2);
Days_In_Month = Day_Table(M);
IF M = 2 THEN
Days_In_Month = Days_In_Month + Leap_Year_Day;
IF (Day_No < 1) | (Day_No > Days_In_Month) THEN
RETURN ('0'B);
END;
END;
/* If we arrive here, Date must be a valid date. */
RETURN ('1'B);
END;
END;
PUT SKIP EDIT ('***ERROR, the layout ', Pattern, ' is not a standard date pattern.' )
(A);
SIGNAL ERROR; /* Not a standard pattern. */
RETURN ('0'B);
END VALID_DATE3;
/******************************************************************* */
/* Generic procedures to implement the REPATTERN function. */
/******************************************************************* */
DECLARE REPATTERN GENERIC (
REPATTERN_3 WHEN (*, *, *),
REPATTERN_4 WHEN (*, *, *, *) );
REPATTERN_3: /* {XE"INCLUDE files: REPATTERN" } */
PROCEDURE (D, Destination_Pattern, Source_Pattern) RETURNS (CHARACTER(17) VARYING);
/* INCOMING: D = a date (possibly with a two-digit year, lacking the century). */
/* RETURNS: The date in the the form YYYY. The window defaults to 1950. */
/* To ensure that the function performs consistently on systems */
/* that support the WINDOW compiler option, that option */
/* must be set to 1950. */
DECLARE D CHARACTER (*);
DECLARE Source_Pattern CHARACTER (*);
DECLARE Destination_Pattern CHARACTER (*);
RETURN (REPATTERN_4 (D, Destination_Pattern, Source_Pattern, 1950) );
END REPATTERN_3;
REPATTERN_4:
PROCEDURE (A_Date, Destination_Pattern, Source_Pattern, Window) RETURNS (CHARACTER(17) VARYING);
/* INCOMING: A_Date = a date (possibly with a two-digit year, lacking the century). */
/* Destination_Pattern = the date pattern into which A_Date is to be converted; */
/* Source_Pattern = the date pattern corresponding to A_Date; */
/* Window = a 4-digit year, being the beginning of the 100-year window. */
/* If the 2-digit year specified in TDATE is less than */
/* the 2-digit component of the 4-digit year in Window, then the */
/* century is increnemted. */
/* E.G., if Window = 1970, then dates 70 to 99 are 1970 to 1999, while */
/* dates 00 through 69 are 2000 through 2069. */
/* RETURNS: The date in the form specified by Destination_Pattern. */
/* Copyright (c) 2000 by R. A. Vowels. Expanded 4 July 2002. */
DECLARE A_Date CHARACTER (*);
DECLARE Source_Pattern CHARACTER (*);
DECLARE Destination_Pattern CHARACTER (*);
DECLARE Window FIXED BINARY;
DECLARE Date CHARACTER (17) VARYING;
DECLARE Year FIXED BINARY;
DECLARE Century PICTURE '99';
DECLARE Time CHARACTER (9);
DECLARE New_Form CHARACTER (8);
DECLARE Final_Form CHARACTER (17) VARYING;
DECLARE No_of_Days FIXED BINARY (31);
DECLARE K FIXED BINARY;
/* Method: 1. Convert the date to the number of days; */
/* 2. Convert the days to the fixed date form YYYYMMDD. */
/* 3. Adjust the century; */
/* 4. Convert the date to the number of days. */
/* 5. Convert the days to a date in the new format. */
Date = TRIM (A_Date, ' ', ''); /* A_Date is permitted to have leading blanks only. */
No_of_Days = DAYS (Date, Source_Pattern);
IF Source_Pattern = 'YYYYMMDDHHMISS999' THEN
Time = SUBSTR (Date, 9);
ELSE
Time = (9)'0';
New_Form = DAYSTODATE (No_of_Days, 'YYYYMMDD');
/* Gets the date in a fixed form. */
IF INDEX (Source_Pattern, 'YYYY') = 0 THEN /* A_Date has a two-digit year. */
DO; /* Convert the year to a 4-digit year. */
Year = SUBSTR(New_Form, 1, 2); /* Extract the year. */
Century = Window/100;
IF Year < MOD(Window, 100) THEN
Century = Century + 1;
SUBSTR (New_Form, 1, 2) = Century; /* Substitute the new century. */
No_of_Days = DAYS (New_Form, 'YYYYMMDD' ); /* Convert to days again. */
END;
IF INDEX (Destination_Pattern, 'YYYY') = 0 THEN /* The destination has 2-digit year. */
DO; /* Check that the year is in the required date window. */
IF (SUBSTR (New_Form, 1, 4) < Window) &
(SUBSTR (new_Form, 1, 4) > Window + 99) THEN
DO;
PUT SKIP LIST ('The date is outside the current data window.');
SIGNAL ERROR;
END;
END;
Final_Form = DAYSTODATE (No_of_Days, Destination_Pattern);
/* Convert to the new pattern. */
IF Destination_Pattern = 'YYYYMMDDHHMISS999' THEN
RETURN (SUBSTR(Final_Form, 1, 8) || Time);
ELSE
RETURN (Final_Form);
END REPATTERN_4;
/******************************************************************* */
/* Generic procedures to implement the Y4DATE function. */
/******************************************************************* */
DECLARE Y4DATE GENERIC ( /* {XE"UTILITY function: Y4DATE"} */
Y4DATE_1 WHEN (*),
Y4DATE_2 WHEN (*, *));
Y4DATE_1:
PROCEDURE (D) RETURNS (CHARACTER(8) );
/* INCOMING: D = a date in DATE () format (YYMMDD), with a 2-digit year. */
/* RETURNS: The date in the the form YYYYMMDD. The window defaults to 1950. */
/* To ensure that the function performs consistently on systems */
/* that support the WINDOW compiler option, that option */
/* must be set to 1950. */
DECLARE D CHARACTER (*);
RETURN (Y4DATE_2 (D, 1950) );
END Y4DATE_1;
Y4DATE_2:
PROCEDURE (D, Window) RETURNS (CHARACTER(8) );
/* INCOMING: D = a date in DATE () format (YYMMDD), with a 2-digit year. */
/* Window = a 4-digit year from which the year will be windowed. */
/* RETURNS: The date in the the form YYYYMMDD. */
DECLARE D CHARACTER (*);
DECLARE Window FIXED BINARY;
DECLARE Year FIXED BINARY;
DECLARE Century PICTURE '99';
Year = SUBSTR (D, 1, 2); /* Extract the year. */
Century = Window/100;
IF Year < MOD(Window, 100) THEN
Century = Century + 1;
RETURN (Century || D);
END Y4DATE_2;
/******************************************************************* */
/* Generic procedures to implement the Y4JULIAN function. */
/******************************************************************* */
DECLARE Y4JULIAN GENERIC ( /* {XE"UTILITY function: Y4JULIAN"} */
Y4JULIAN_1 WHEN (*),
Y4JULIAN_2 WHEN (*, *));
Y4JULIAN_1:
PROCEDURE (D) RETURNS (CHARACTER (8) );
/* INCOMING: D = a date in DATE () format (YYMMDD), with a 2-digit year. */
/* RETURNS: The date in the the form YYYYMMDD. The window defaults to 1950. */
/* To ensure that the function performs consistently on systems */
/* that support the WINDOW compiler option, that option */
/* must be set to 1950. */
DECLARE D CHARACTER (*);
RETURN (Y4JULIAN_2 (D, 1950) );
END Y4JULIAN_1;
Y4JULIAN_2:
PROCEDURE (D, Window) RETURNS (CHARACTER(8) );
/* INCOMING: D = a date in DATE () format (YYMMDD), with a 2-digit year. */
/* Window = a 4-digit year from which the year will be windowed. */
/* RETURNS: The date in the the form YYYYMMDD. */
DECLARE D CHARACTER (*);
DECLARE Window FIXED BINARY;
DECLARE Year FIXED BINARY;
DECLARE Century PICTURE '99';
Year = SUBSTR (TRIM(D), 1, 2); /* Extract the year. */
Century = Window/100;
IF Year < MOD(Window, 100) THEN
Century = Century + 1;
RETURN (Century || D);
END Y4JULIAN_2;
/******************************************************************* */
/* Generic procedures to implement the Y4YEAR function. */
/******************************************************************* */
DECLARE Y4YEAR GENERIC (
Y4YEAR_1 WHEN (*),
Y4YEAR_2 WHEN (*, *));
Y4YEAR_1: /* {XE" UTILITY function: Y4YEAR" } */
PROCEDURE (D) RETURNS (CHARACTER(4) );
/* INCOMING: D = a two-digit year, lacking the century. */
/* RETURNS: The year in the the form YYYY. The window defaults to 1950. */
/* To ensure that the function performs consistently on systems */
/* that support the WINDOW compiler option, that option */
/* must be set to 1950. */
DECLARE D CHARACTER (*);
RETURN (Y4YEAR_2 (D, 1950) );
END Y4YEAR_1;
Y4YEAR_2:
PROCEDURE (D, Window) RETURNS (CHARACTER(4) );
/* INCOMING: D = a two-digit year, lacking the century. */
/* Window = a 4-digit year from which the year will be windowed. */
/* RETURNS: The year in the the form YYYY. */
DECLARE D CHARACTER (*);
DECLARE Window FIXED BINARY;
DECLARE Year FIXED BINARY;
DECLARE Century PICTURE '99';
Year = TRIM(D); /* Extract the year. */
Century = Window/100;
IF Year < MOD(Window, 100) THEN
Century = Century + 1;
RETURN (Century || D);
END Y4YEAR_2;
]]>
For further information, contact
email: robin_v@bigpond.com