Home page  Up a level  Small Calendar Display File Source  Small Calendar RPG Source

Small Calendar RPG Source

     H BNDDIR('JHDUTIL')
     H DFTACTGRP(*NO)
     H ACTGRP(*CALLER)
      **************************************************************************
      ***   FILE NAME: CAL                                                   ***
      *** DESCRIPTION: Show a small calendar.                                ***
      ***                                                                    ***
      *** Copyright 1994 by John H. Daily III                                ***
      **************************************************************************
      ***         SUBROUTINES                                                ***
      ***                                                                    ***
      *** Subroutine     Description                                         ***
      *** s1RollUp       move to the next month                              ***
      *** s1RollDown     move to the previous month                          ***
      *** s1LoadCalendar load the calendar                                   ***
      *** CheckLeap      check for leap year                                 ***
      *** *INZSR         program initialization                              ***
      **************************************************************************
      ***    FUNCTION KEYS                                                   ***
      ***                                                                    ***
      *** FKey Usage                                                         ***
      *** F3   exit the program                                              ***
      *** F12  previous screen                                               ***
      **************************************************************************
      ***  INDICATOR SUMMARY                                                 ***
      ***                                                                    ***
      *** Inds   Defined  Usage                                              ***
      *** 01-42  display  hilight current day in calendar                    ***
      **************************************************************************
     FCalSmlD   CF   E             WORKSTN INFDS(DSPFDS)
      **************************************************************************
      ***                       TABLES AND ARRAYS                            ***
      **************************************************************************
     D TAB1            S              2  0 DIM(12) CTDATA PERRCD(1)              Number of days in m
     D TAB2            S              2  0 DIM(12) ALT(TAB1)
     D DAY             S              2  0 DIM(42)                               Calendar days array
      **************************************************************************
      ***EXTERNAL SUBPROCEDURES                                              ***
      **************************************************************************
      ***
      *** Retrieve the name of the month.
      ***
     D gRtvMonthName   PR             9
     D                                8
      ***
      *** Get the day of the week number.
      ***
     D gRtvDayNbr      PR            10I 0
     D                                8
      ***
      *** Capitalize a string in various ways.
      ***
     D gCapStr         PR           256
     D  p@Text                      256
     D  p@Format                      1
      ***
      *** Center a string.
      ***
     D gCenterStr      PR           256
     D  p@String                    256
     D  p@Length                      3P 0
      **************************************************************************
      ***                          CONSTANTS                                 ***
      **************************************************************************
     D F03             C                   CONST(X'33')
     D F12             C                   CONST(X'3C')
     D FEnter          C                   CONST(X'F1')
     D FRollDown       C                   CONST(X'F4')
     D FRollUp         C                   CONST(X'F5')

      **************************************************************************
      ***                   INTERNAL DATA STRUCTURES                         ***
      **************************************************************************
     D DSPFDS          DS
     D  w@FunctKey           369    369
      ***
     D                 DS
     D  w@CalDateC             1      8
     D  w@CalYear              1      4  0
     D  w@CalYearC             1      4
     D  w@CalMonth             5      6  0
     D  w@CalDay               7      8  0
      ***
      *** External program calls parameter data structure.
      ***
     D                 DS
     D w@CurDate               1      8  0
     D  w@CurYear              1      4  0
     D  w@CurMonth             5      6  0
     D  w@CurDay               7      8  0
      ***
      *** Date conversion data structure.
      ***
     D                 DS
     D  w@Calyy1               1      4  0
     D  w@Calmm                5      6  0
     D  w@Calyy2               9     12  0

      **************************************************************************
      ***                          WORK FIELDS                               ***
      **************************************************************************
     D w@Hold          S              4  0
     D w@Hold1         S              4  0
     D w@Last          S              2  0
     D w@HoldDay       S              2  0
     D #X              S              2  0
     D #Y              S                   Like(#X)
     D w@Today         S               D   Inz(*SYS)
     D w@String        S            256
     D w@StrLen        S              3P 0

     D w@DayOfWeek     S              1  0
     D w@MonthName     S              9
     D w@Day           S              2  0

      **************************************************************************
      ***                  EXTERNAL FILE DESCRIPTIONS                        ***
      **************************************************************************
     IScrn01
      ***
      *** Making the calendar days into an array.
      ***
     I              @DAY1                       DAY(1)
     I              @DAY2                       DAY(2)
     I              @DAY3                       DAY(3)
     I              @DAY4                       DAY(4)
     I              @DAY5                       DAY(5)
     I              @DAY6                       DAY(6)
     I              @DAY7                       DAY(7)
     I              @DAY8                       DAY(8)
     I              @DAY9                       DAY(9)
     I              @DAY10                      DAY(10)
     I              @DAY11                      DAY(11)
     I              @DAY12                      DAY(12)
     I              @DAY13                      DAY(13)
     I              @DAY14                      DAY(14)
     I              @DAY15                      DAY(15)
     I              @DAY16                      DAY(16)
     I              @DAY17                      DAY(17)
     I              @DAY18                      DAY(18)
     I              @DAY19                      DAY(19)
     I              @DAY20                      DAY(20)
     I              @DAY21                      DAY(21)
     I              @DAY22                      DAY(22)
     I              @DAY23                      DAY(23)
     I              @DAY24                      DAY(24)
     I              @DAY25                      DAY(25)
     I              @DAY26                      DAY(26)
     I              @DAY27                      DAY(27)
     I              @DAY28                      DAY(28)
     I              @DAY29                      DAY(29)
     I              @DAY30                      DAY(30)
     I              @DAY31                      DAY(31)
     I              @DAY32                      DAY(32)
     I              @DAY33                      DAY(33)
     I              @DAY34                      DAY(34)
     I              @DAY35                      DAY(35)
     I              @DAY36                      DAY(36)
     I              @DAY37                      DAY(37)
     I              @DAY38                      DAY(38)
     I              @DAY39                      DAY(39)
     I              @DAY40                      DAY(40)
     I              @DAY41                      DAY(41)
     I              @DAY42                      DAY(42)

      **************************************************************************
      ***                   CALCULATION SPECIFICATIONS                       ***
      **************************************************************************

      /Free

        //** Load the calendar.
        Exsr s1LoadCalendar;

        //** Display the calendar until F03 is pressed.
        Dou w@FunctKey = FEnter or w@FunctKey = F03 or w@FunctKey = F12;
          Exfmt Scrn01;
          Exsr s1FunctKey;
        EndDo;

        *INLR = *ON;

        //**********************************************************************
        //** SUBROUTINE: Handle the function keys from the calendar.         ***
        //** s1FunctKey                                                      ***
        //**********************************************************************
        Begsr s1FunctKey;

          Select;
            When w@FunctKey = FEnter;

              //** Roll up to display the previous month in the calendar.
              When w@FunctKey = FRollUp;
                Exsr s1RollUp;

              //** Roll down to display the next month in the calendar.
              When w@FunctKey = FRollDown;
                Exsr s1RollDown;

            EndSl;

        EndSr;

        //**********************************************************************
        //** SUBROUTINE: Show the next month on the calendar.                ***
        //** s1RollUp                                                        ***
        //**********************************************************************
        Begsr s1RollUp;

          //** Increment the calendar month.  If the month goes to 13
          //** then increment the calendar year and change the month to 1.

          w@CalMonth = w@CalMonth + 1;
          If w@CalMonth > 12;
            w@CalMonth = 1;
            w@CalYear = w@CalYear + 1;
          EndIf;

          //** Get the number of days in the month from the table; if
          //** the month is February, check to see if it is a leap year.

          *IN99 = %Tlookup(w@CalMonth : Tab1 : Tab2);
          w@Last = Tab2;

          If w@CalMonth = 2;
            Exsr CheckLeap;
          EndIf;

          //** If day of the month is greater than the last day of the
          //** next month a date error will occur.

          If w@CurDay > w@Last;
            w@CalDay = w@Last;
          Else;
            w@CalDay = w@CurDay;
          EndIf;

          Exsr s1LoadCalendar;

        EndSr;

        //**********************************************************************
        //** SUBROUTINE: Show the previous month on the calendar.            ***
        //** s1RollDown                                                      ***
        //**********************************************************************
        Begsr s1RollDown;

          //** Decrement the calendar month.  If the month goes to 0
          //** then decrement the calendar year and change the month to 12.

          w@CalMonth = w@CalMonth - 1;
          If w@CalMonth < 1;
            w@CalMonth = 12;
            w@CalYear = w@CalYear - 1;
          EndIf;

          //** Get the number of days in the month from the table; if
          //** the month is February, check to see if it is a leap year.

          *IN99 = %Tlookup(w@CalMonth : Tab1 : Tab2);
          w@Last = Tab2;

          If w@CalMonth = 2;
            Exsr CheckLeap;
          EndIf;

          //** If day of the month is greater than the last day of the
          //** next month a date error will occur.

          If w@CurDay > w@Last;
            w@CalDay = w@Last;
          Else;
            w@CalDay = w@CurDay;
          EndIf;

          Exsr s1LoadCalendar;

        EndSr;

      /End-Free

      **************************************************************************
      *** SUBROUTINE: This routine will load create the calendar in two      ***
      *** s1LoadCalendar steps.  The first step loads the days from the      ***
      *** current day back to the beginning of the month.  The second step   ***
      *** loads the rest of the calendar from tomorrow until the end of the  ***
      *** month.                                                             ***
      **************************************************************************
     C     s1LoadCalendarBEGSR
      ***
     C                   EVAL      w@MonthName = gRtvMonthName(w@CalDateC)
     C                   EVAL      w@DayOfWeek = gRtvDayNbr(w@CalDateC)
      ***
      *** Get the number of days in the month from the table and, if
      *** the month is February, check to see if it is a leap year.
      ***
     C     w@CalMonth    LOOKUP    TAB1          TAB2                     99
     C                   Z-ADD     TAB2          w@Last
     C     w@CalMonth    IFEQ      2
     C                   EXSR      CheckLeap
     C                   ENDIF
      ***
      *** Set up the day in the calendar to start on.
      ***
     C                   EVAL      w@Day = w@CalDay
     C     w@Day         DIV       7             w@Hold
     C                   MVR                     w@Hold1
      ***
     C     w@Hold        MULT      7             #X
     C                   ADD       w@DayOfWeek   #X
     C     #X            IFLT      w@Day
     C                   ADD       7             #X
     C                   ENDIF
      ***
      *** Clear the calendar variables.
      ***
     C                   Clear                   *IN
     C                   CLEAR                   DAY
     C                   CLEAR                   s1MnthYear
      ***
      *** Turn on the reverse indicator for today's date and save the
      *** day number.
      ***
     C                   MOVEA     '1'           *IN(#X)
     C                   Z-ADD     w@Day         w@HoldDay
     C                   Z-ADD     #X            #Y
     C                   EVAL      w@Calyy1 = w@CalYear
     C                   EVAL      w@Calyy2 = w@CalYear
     C                   EVAL      w@Calmm = w@CalMonth
      ***
      *** Load the calendar from today's date back to the first.
      ***
     C     w@Day         DOWGT     *ZEROS
      ***
      *** Move the date into the calendar day.
      ***
     C                   Z-ADD     w@Day         DAY(#X)
     C                   SUB       1             #X
     C                   SUB       1             w@Day
     C                   ENDDO
      ***
      *** Load the day numbers into the calendar from today + one
      *** until the end of the month.
      ***
     C     #Y            ADD       1             #X
     C     w@HoldDay     ADD       1             w@Day
     C     w@Day         DOWLE     w@Last
      ***
     C                   Z-ADD     w@Day         DAY(#X)
      ***
     C                   ADD       1             #X
     C                   ADD       1             w@Day
     C                   ENDDO

      /Free
        s1MnthYear = %Trim(w@MonthName) + ' ' + %Trim(w@CalYearC);
        w@String = s1MnthYear;
        w@StrLen = %Len(s1MnthYear);
        w@String = gCenterStr(w@String : w@StrLen);
        s1MnthYear = %Subst(w@String : 1 : %Len(s1MnthYear));
      /End-Free

      ***
     C                   ENDSR
      **************************************************************************
      *** SUBROUTINE:   Check to see if the month of February is in a leap   ***
      *** CheckLeap     year.                                                ***
      **************************************************************************
     C     CheckLeap     BEGSR
      ***
     C                   Z-ADD     28            w@Last
     C     w@CalYear     DIV       4             w@Hold
     C                   MVR                     w@Hold
      ***
      *** If the remainder is zero then the year is probably a leap year.
      ***
     C     w@Hold        IFEQ      *ZEROS
     C                   Z-ADD     29            w@Last
      ***
      *** If the year divides evenly by 100 and by 400, then it is a leap
      *** year.  If it divides evenly by 100 but not by 400 then it is not
      *** a leap year.
      ***
     C     w@CalYear     DIV       100           w@Hold
     C                   MVR                     w@Hold
      ***
     C     w@Hold        IFEQ      *ZEROS
     C     w@CalYear     DIV       400           w@Hold
     C                   MVR                     w@Hold
      ***
     C     w@Hold        IFEQ      *ZEROS
     C                   Z-ADD     29            w@Last
     C                   ELSE
     C                   Z-ADD     28            w@Last
     C                   ENDIF
     C                   ENDIF
     C                   ENDIF
      ***
     C                   ENDSR
      **************************************************************************
      *** SUBROUTINE: Program initialization - define key lists, define and  ***
      *** *INZSR      initialize variables, etc.                             ***
      **************************************************************************
     C     *INZSR        BEGSR

      ***
      *** Today's date - never gets changed: w@CurDate
      ***
     C                   MOVE      w@Today       w@CurDate
     C                   EVAL      w@CalMonth = w@CurMonth
     C                   EVAL      w@CalDay = w@CurDay
     C                   EVAL      w@CalYear = w@CurYear
      ***
     C                   ENDSR
      **************************************************************************
**  TAB1 and TAB2 - number of days in each month.
0131
0228
0331
0430
0531
0630
0731
0831
0930
1031
1130
1231