/*+                     

TITLE:	    	MDM_MKDATE
    	    	Makes RFC822-compliant date/time strings.

VERSION:    	V1.0-001

FACILITY:   	MDMLIB

ABSTRACT:   	This module contains a routine that makes a valid
    	    	RFC822-style date/time string from a VMS date/time stamp.

ENVIRONMENT:	User mode, non-reentrant
                  
AUTHOR:	    	M. Madison
    	    	COPYRIGHT © 1988, RENSSELAER POLYTECHNIC INSTITUTE
    	    	    	    	  All rights reserved.

MODIFICATION HISTORY:

    09-JUN-1987	V1.0-001	Madison	    Initial coding.
                                               
-*/
%INCLUDE VMS_TYPES;
%INCLUDE S_DESC;
%INCLUDE SYS$GETTIM;
%INCLUDE SYS$NUMTIM;
%INCLUDE LIB$DAY_OF_WEEK;
%INCLUDE LIB$SYS_FAO;

    DECLARE (ACTUALCOUNT, PRESENT, NULL) BUILTIN;

    DECLARE MONSTR (12) CHARACTER (3) STATIC INITIAL
    	    	('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 
    	    	'Sep', 'Oct', 'Nov', 'Dec'),
    	    DAYSTR (0:6) CHARACTER(3) STATIC INIT
    	    	('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
%PAGE;
MDM_MKDATE: PROCEDURE (FS_DATE, FMT_DATE, FD_LEN)
    	    OPTIONS (IDENT ('V1.0-001'))
    	    RETURNS (VMS_COND_VALUE);
/*+

DESCRIPTION:	This procedure generates an RFC822-compliant date/time
    	    	string from a VMS quadword date/time stamp.

RETURNS:    	cond_value, longword (unsigned), write only, by value

PROTOTYPE:

    MDM_MKDATE ([fs_date], fmt_date [,fd_len])

fs_date:    vms_date_time, quadword (signed), read only, by reference
fmt_date:   char_string, character string, write only, by descriptor
fd_len:	    word_unsigned, word (unsigned), write only, by reference

COMPLETION CODES:   None.

-*/

    DECLARE FS_DATE VMS_DATE_TIME PARAMETER,
    	    FMT_DATE POINTER VALUE PARAMETER,
    	    FD_LEN VMS_WORD_UNSIGNED PARAMETER;

%INCLUDE $STSDEF;

    DECLARE 1 TIMBUF UNION,
    	    	2 ARRAY (1:7) FIXED BINARY(15),
    	    	2 STRUC,
    	    	    (3 YEAR, 3 MONTH, 3 DAY, 3 HOUR,
    	    	    3 MIN, 3 SEC, 3 HUND) FIXED BINARY(15);

    DECLARE ZONE CHARACTER(3),
    	    DOW FIXED BINARY,
    	    XFS_DATE VMS_DATE_TIME,
    	    XLEN FIXED BINARY(15);

/********************* BEGIN EXECUTABLE CODE ************************/

    IF PRESENT (FS_DATE) THEN XFS_DATE = FS_DATE;
    ELSE STS$VALUE = SYS$GETTIM (XFS_DATE);

    STS$VALUE = SYS$NUMTIM (TIMBUF.ARRAY, XFS_DATE);
    STS$VALUE = LIB$DAY_OF_WEEK (XFS_DATE, DOW);
    DOW = MOD (DOW, 7);

    IF ^STS$SUCCESS THEN RETURN (STS$VALUE);

    SELECT (MONTH);
    	WHEN (4) DO;
    	    IF DAY - DOW > 0 THEN
    	    	IF DOW = 0 THEN
    	    	    IF HOUR >= 3 THEN ZONE = 'EDT';
            	    ELSE ZONE = 'EST';
            	ELSE ZONE = 'EDT';
      	    ELSE ZONE = 'EST';
    	END;
    	WHEN (10) DO;
    	    IF DAY - DOW > 24 THEN
    	    	IF DOW = 0 THEN
    	    	    IF HOUR >= 1 THEN ZONE = 'EST';
    	    	    ELSE ZONE = 'EDT';
    	    	ELSE ZONE = 'EST';
    	    ELSE ZONE = 'EDT';
    	END;
    	WHEN (5, 6, 7, 8, 9) ZONE = 'EDT';
    	OTHERWISE ZONE = 'EST';
    END;

    STS$VALUE = LIB$SYS_FAO('!AS, !2ZW !AS !2ZW !2ZW:!2ZW:!2ZW !AS',
    	XLEN, VALUE (FMT_DATE), S_DESC (DAYSTR (DOW)),
    	VALUE (DAY), S_DESC (MONSTR (MONTH)),
    	VALUE (MOD (YEAR, 100)), VALUE (HOUR), VALUE (MIN),
    	VALUE (SEC), S_DESC (ZONE));

    IF PRESENT (FD_LEN) THEN FD_LEN = XLEN;
    RETURN (STS$VALUE);

END MDM_MKDATE;