'===========================================================================
' Subject: MONTHLY CALENDAR                   Date: 01/08/93 (10:53)       
'  Author: Joe Negron                         Code: QB, QBasic, PDS        
'  Origin: MONTHLY,CALENDAR                 Packet: DATETIME.ABC
'===========================================================================
'Al, I'm reposting this as Richard Dale informs me that the copy he
'received had been cut off.  Let me know if you receive it OK.

DEFINT A-Z

DECLARE SUB OneMthCal (DateX$)

DECLARE FUNCTION Date2Day% (DateX$)
DECLARE FUNCTION Date2Mth% (DateX$)
DECLARE FUNCTION Date2Serial& (DateX$)
DECLARE FUNCTION Date2Year% (DateX$)
DECLARE FUNCTION DayOfTheWeek$ (DateX$)
DECLARE FUNCTION Serial2Date$ (Serial&)
DECLARE FUNCTION MDY2Date$ (Month%, Day%, Year%)
DECLARE FUNCTION MthName$ (DateX$)

CLS
OneMthCal DATE$

SYSTEM

'**********************************************************************
'* FUNCTION Date2Day%
'*
'* PURPOSE
'*    Returns the day number given a date in the standard date format.
'**********************************************************************

'**********************************************************************
'* FUNCTION Date2Mth%
'*
'* PURPOSE
'*    Returns the month number given a date in the standard date format.
'**********************************************************************

'**********************************************************************

'* FUNCTION Date2Serial&
'*
'* PURPOSE
'*    Returns the astronomical Julian day number given a date in the
'*    standard date format.  Note that the year must be 1583 or greater.
'*
'* INTERNAL ROUTINE(S)
'*    FUNCTION Date2Day% (DateX$)
'*    FUNCTION Date2Mth% (DateX$)
'*    FUNCTION Date2Year% (DateX$)
'**********************************************************************

'**********************************************************************
'* FUNCTION Date2Year%
'*
'* PURPOSE
'*    Returns the year number given a date in the standard date format.
'**********************************************************************

'**********************************************************************
'* FUNCTION DayOfTheWeek$
'*
'* PURPOSE
'*    Returns a string stating the day of the week given a date in the
'*    standard date format.
'*
'* INTERNAL ROUTINE(S)
'*    FUNCTION Date2Serial& (DateX$)
'**********************************************************************

'**********************************************************************
'* FUNCTION MDY2Date$
'*
'* PURPOSE
'*    Converts Month%, Day%, and Year% to a string in the standard date
'*    format.
'**********************************************************************

'**********************************************************************
'* FUNCTION MthName$
'*
'* PURPOSE
'*    Returns then name of the month given a string in the standard date
'*    format.
'**********************************************************************

'**********************************************************************
'* SUB OneMthCal
'*
'* PURPOSE
'*    Prints a one-month calendar for the given date at the current
'*    screen location.
'*
'* INTERNAL ROUTINE(S)
'*    FUNCTION Date2Day% (DateX$)
'*    FUNCTION Date2Mth% (DateX$)
'*    FUNCTION Date2Serial& (DateX$)
'*    FUNCTION Date2Year% (DateX$)
'*    FUNCTION DayOfTheWeek$ (DateX$)
'*    FUNCTION MDY2Date$ (Month%, Day%, Year%)
'*    FUNCTION MthName$ (DateX$)
'*    FUNCTION Serial2Date$ (Serial&)
'**********************************************************************

'**********************************************************************
'* FUNCTION Serial2Date$
'*
'* PURPOSE
'*    Returns a date in the standard date format given a Julian day
'*    number.
'*
'* INTERNAL ROUTINE(S)
'*    FUNCTION MDY2Date$ (Month%, Day%, Year%)
'**********************************************************************

FUNCTION Date2Day% (DateX$) STATIC
   Date2Day% = VAL(MID$(DateX$, 4))
END FUNCTION

FUNCTION Date2Mth% (DateX$) STATIC
   Date2Mth% = VAL(DateX$)
END FUNCTION

FUNCTION Date2Serial& (DateX$) STATIC
   Month% = Date2Mth%(DateX$)
   Day% = Date2Day%(DateX$)
   Year% = Date2Year%(DateX$)

   IF Month% > 2 THEN
      Month% = Month% - 3
   ELSE
      Month% = Month% + 9
      Year% = Year% - 1
   END IF

   TA& = 146097 * (Year% \ 100) \ 4
   TB& = 1461& * (Year% MOD 100) \ 4
   TC& = (153 * Month% + 2) \ 5 + Day% + 1721119
   Date2Serial& = TA& + TB& + TC&
END FUNCTION

FUNCTION Date2Year% (DateX$) STATIC
   Date2Year% = VAL(MID$(DateX$, 7))
END FUNCTION

FUNCTION DayOfTheWeek$ (DateX$) STATIC
   DayOfTheWeek$ = MID$("MonTueWedThuFriSatSun", ((Date2Serial&(DateX$) MOD 7) + 1) * 3 - 2, 3)
END FUNCTION

FUNCTION MDY2Date$ (Month%, Day%, Year%) STATIC
   MDY2Date$ = RIGHT$("0" + MID$(STR$(Month%), 2), 2) + "-" + RIGHT$("0" + MID$(STR$(Day%), 2), 2) + "-" + RIGHT$("000" + MID$(STR$(Year%), 2), 4)
END FUNCTION

FUNCTION MthName$ (DateX$) STATIC
   MthName$ = MID$("JanFebMarAprMayJunJulAugSepOctNovDec", VAL(DateX$) * 3 - 2, 3)
END FUNCTION

SUB OneMthCal (DateX$) STATIC
   Row% = CSRLIN
   Col% = POS(0)

   MName$ = MthName$(DateX$)
   LOCATE Row%, Col% + 12 - LEN(MName$) \ 2

   Year% = Date2Year%(DateX$)
   PRINT MName$; ","; Year%

   Month% = Date2Mth%(DateX$)
   Day% = 1
   Date1$ = MDY2Date$(Month%, Day%, Year%)
   Serial& = Date2Serial&(Date1$)
   Heading$ = " Sun Mon Tue Wed Thu Fri Sat"
   WA% = INSTR(1, Heading$, LEFT$(DayOfTheWeek$(Date1$), 3)) \ 4
   LOCATE Row% + 1, Col%
   PRINT Heading$

   RowLoc% = Row% + 2
   LOCATE RowLoc%, Col% + 4 * WA%

   DO
      PRINT USING "####"; Day%;

      IF WA% = 6 THEN
         RowLoc% = RowLoc% + 1
         LOCATE RowLoc%, Col%
      END IF

      WA% = (WA% + 1) MOD 7
      Serial& = Serial& + 1
      Day% = Date2Day%(Serial2Date$(Serial&))
   LOOP UNTIL Day% = 1
END SUB

FUNCTION Serial2Date$ (Serial&) STATIC
   X& = 4 * Serial& - 6884477
   Y& = (X& \ 146097) * 100
   D& = (X& MOD 146097) \ 4

   X& = 4 * D& + 3
   Y& = (X& \ 1461) + Y&
   D& = (X& MOD 1461) \ 4 + 1
   X& = 5 * D& - 3
   M& = X& \ 153 + 1
   D& = (X& MOD 153) \ 5 + 1

   IF M& < 11 THEN
      Month% = M& + 2
   ELSE
      Month% = M& - 10
   END IF

   Day% = D&
   Year% = Y& + M& \ 11

   DateX$ = MDY2Date$(Month%, Day%, Year%)
   Serial2Date$ = DateX$
END FUNCTION