	PROGRAM REMINDER

**
*	PROGRAM REMINDER
*
*
*	10 Jan 84	Disable Resource Wait Mode in REMINDER/LOGIN
*			to prevent hang if batch job is not running
*			and the mailbox has filled dynamic memory.
*
*	22 Aug 84	In GET_DATE, truncate '199x' to '9x'.
*
*	22 Aug 84	Establish condition handler to trap 'mailbox
*			full' errors when batch job is not running,
*			and give a more meaningful message to users.
*
*	22 Aug 84	Use STR_LEN function, to simplify coding.
*
*	22 Aug 84	For SHOW of dates > 365 days hence, show year.
*
*	23 Aug 84	Support dates past 1999.
*
*	 2 May 85	Add support for /ACCESS, /ALLOW, /DISALLOW,
*			/USER, and /OUTPUT qualifiers.
*
*	12 Aug 85	Allow '*' as date entry for TODAY.  Allow system
*			people to set reminders for anyone.  Allow entry
*			of all data on command line.
*
*	25 Sep 85	Fix error introduced last time which disallowed
*			five-character times ("11:23").
*
*	Alan L. Zirkle     Naval Surface Weapons Center
*			   Code K105
*	5 December 1983    Dahlgren, Virginia  22448
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*128 FILE

	COMMON /FILE/ FILE

	LOGICAL CLI$PRESENT

	EXTERNAL CONDITION_HANDLER

	CALL GET_USERNAME(1)

	CALL LIB$ESTABLISH(CONDITION_HANDLER)

	IF (CLI$PRESENT('LOGIN')) THEN
	    CALL LOGIN
	    CALL EXIT
	ENDIF

	IF (CLI$PRESENT('OUTPUT')) CALL OUTPUT_FILE

	CALL CLI$GET_VALUE('ZZFILE',FILE)

	OPEN (1,FILE=FILE,STATUS='OLD',SHARED,ACCESS='KEYED',
	1				FORM='FORMATTED',ERR=100)

	IF (CLI$PRESENT('USER')) CALL GET_USERNAME(2)

	IF (CLI$PRESENT('ADD')) THEN

	    CALL ADD_ENTRY

	ELSE IF (CLI$PRESENT('DELETE')) THEN

	    CALL DELETE_ENTRY

	ELSE IF (CLI$PRESENT('ALLOW')) THEN

	    CALL ALLOW_OTHER_USER

	ELSE IF (CLI$PRESENT('DISALLOW')) THEN

	    CALL DISALLOW_OTHER_USER

	ELSE IF (CLI$PRESENT('ACCESS')) THEN

	    CALL SHOW_ACCESS

	ELSE

	    CALL SHOW

	ENDIF

	CALL EXIT

100	PRINT 1000

1000	FORMAT ('0Cannot open Reminder Event File -',
	1			'- notify System Manager'/)

	END
	SUBROUTINE OUTPUT_FILE

	IMPLICIT INTEGER (A-Z)

	CHARACTER*128 FILE
	LOGICAL OUTFILE / .FALSE. /

	COMMON /FILE/ FILE,OUTFILE

	OUTFILE = .TRUE.

	CALL CLI$GET_VALUE('OUTPUT',FILE,LEN)

	OPEN (6,FILE=FILE(1:LEN),STATUS='NEW')

	END
	SUBROUTINE ADD_ENTRY

	IMPLICIT INTEGER (A-Z)

	CHARACTER*9  DATE
	CHARACTER*5  TIME
	CHARACTER*48 APPOINTMENT

	CHARACTER*25 USER,OTHER_USER,KEY
	LOGICAL*1 NOT_ME

	COMMON /USERNAME/ ULEN,OULEN,USER,OTHER_USER,KEY,NOT_ME

	LOGICAL CLI_USED,INTERACT

	COMMON /INPUT/ CLI_USED,INTERACT

	LOGICAL CLI$PRESENT

	CALL GET_DATE(DATE)

	CALL GET_TIME(TIME)

	IF (CLI$PRESENT('P3')) THEN

	    CALL CLI$GET_VALUE('P3',APPOINTMENT,LEN)

	ELSE

	    IF (.NOT.INTERACT)
	1		     CALL ERROR('NOREASON, no reason specified')

	    PRINT 1000

	    READ 1001,LEN,APPOINTMENT

	    PRINT 1002

	ENDIF

	IF (LEN.NE.0) THEN

	    LEN = MIN(LEN,48)

	    WRITE (1,1002) USER,DATE,TIME,APPOINTMENT(1:LEN)

	ELSE

	    WRITE (1,1002) USER,DATE,TIME

	ENDIF

	CLOSE (1)

	CALL COMMUNICATE

1000	FORMAT (/'$ Reason: ')
1001	FORMAT (Q,A)
1002	FORMAT (A,' ',A,' ',A,' ',A)

	END
	SUBROUTINE DELETE_ENTRY

	IMPLICIT INTEGER (A-Z)

	CHARACTER*9  DATE
	CHARACTER*5  TIME
	CHARACTER*48 APPOINTMENT

	CHARACTER*25 USER,OTHER_USER,KEY
	LOGICAL*1 NOT_ME

	COMMON /USERNAME/ ULEN,OULEN,USER,OTHER_USER,KEY,NOT_ME

	LOGICAL CLI_USED,INTERACT

	COMMON /INPUT/ CLI_USED,INTERACT

	CHARACTER*90 EVENT

	COMMON /EVENT_/ LEV,EVENT

	ASSIGN  10 TO LOCK	 ! Where to return to after locked record error
	ASSIGN 100 TO NOTFOUND	 ! Where to go if appointment not found

!	First do dummy read to see if user has any appointments to delete.

10	READ (1,1001,KEY=USER,ERR=110,IOSTAT=ERR) LEV,EVENT

	UNLOCK (1)

	CALL GET_DATE(DATE)

	CALL GET_TIME(TIME)

	IF (.NOT.CLI_USED) PRINT 1000

	ASSIGN  20 TO LOCK

20	READ (1,1001,KEY=USER,ERR=110,IOSTAT=ERR) LEV,EVENT

	ASSIGN 40 TO LOCK

30	IF ( EVENT(27:41) .EQ. DATE//' '//TIME ) THEN

	    DELETE (1,ERR=110,IOSTAT=ERR)

	    CLOSE (1)

	    CALL COMMUNICATE

	    RETURN

	ENDIF

40	READ (1,1001,END=105,ERR=110,IOSTAT=ERR) LEV,EVENT

	IF (EVENT(1:25).EQ.USER) GO TO 30

	UNLOCK (1)

	GO TO 105

100	IF (NOT_ME) THEN
	    PRINT 1002,USER(1:ULEN)//' has no appointments.'
	ELSE
	    PRINT 1002,'You have no appointments.'
	ENDIF
	RETURN

105	IF (NOT_ME) THEN
	    PRINT 1002,USER(1:ULEN)//' has no such appointment.'
	ELSE
	    PRINT 1002,'You have no such appointment.'
	ENDIF
	RETURN

110	IF (ERR.EQ.52) THEN				    ! Is record locked?
	    CALL GO_WAIT(1)
	    GO TO LOCK,(10,20,40)
	ELSE
	    IF (ERR.EQ.36) GO TO 100
	    PRINT 1003
	    CALL FILE_ERROR
	    CALL EXIT
	ENDIF

1000	FORMAT (' ')
1001	FORMAT (Q,A)
1002	FORMAT ('     ',A/)
1003	FORMAT ('0Error on the Reminder Event File.')

	END
	SUBROUTINE SHOW

	IMPLICIT INTEGER (A-Z)

	CHARACTER*90 EVENT

	COMMON /EVENT_/ LEV,EVENT

	CHARACTER*25 USER,OTHER_USER,KEY
	LOGICAL*1 NOT_ME

	COMMON /USERNAME/ ULEN,OULEN,USER,OTHER_USER,KEY,NOT_ME

	CHARACTER*64 EVENTS(32)
	INTEGER*4 TIMES(32)
	INTEGER*4 LEVS(32)

	COMMON /SAVE/ APPTS,TIMES,LEVS,EVENTS

	CHARACTER*80 BUFFER

	COMMON /BUF/ BLEN,BUFFER

	CALL DISPLAY_DATE

	APPTS = 0

	ASSIGN 10 TO LOCK	 ! Where to return to after locked record error

10	READ (1,1000,KEY=USER,ERR=110,IOSTAT=ERR) LEV,EVENT

	UNLOCK (1)

	ASSIGN 30 TO LOCK

20	APPTS = APPTS + 1

	CALL CV_TIME(DAYS,MINUTES,*30)

	TIMES(APPTS) = DAYS * 10000 + MINUTES
	LEVS(APPTS)  = LEV - 26

	EVENTS(APPTS)(1:LEV-26) = EVENT(27:LEV)

	IF (APPTS.EQ.32) GO TO 100		 ! Ignore events after first 32

30	READ (1,1000,END=100,ERR=110,IOSTAT=ERR) LEV,EVENT

	UNLOCK (1)

	IF (EVENT(1:25).EQ.USER) GO TO 20

100	CLOSE (1)

	IF (APPTS.EQ.0) THEN

	 IF (NOT_ME) THEN
	   WRITE (6,1002) BUFFER(1:BLEN)//'.  '//USER(1:ULEN)//
	1					 ' has no appointments.'
	 ELSE
	   WRITE (6,1002) BUFFER(1:BLEN)//'.  You have no appointments.'
	 ENDIF
	   WRITE (6,1001)

	   RETURN

	ELSE IF (APPTS.EQ.1) THEN

	 IF (NOT_ME) THEN
	   WRITE (6,1002) BUFFER(1:BLEN)//'.  '//USER(1:ULEN)//
	1					 ' has one appointment:'
	 ELSE
	   WRITE (6,1002) BUFFER(1:BLEN)//'.  You have one appointment:'
	 ENDIF

	ELSE IF (APPTS.GT.1) THEN

	 IF (NOT_ME) THEN
	    CALL SYS$FAO('.  !AS has !SL appointments:',
	1		 BLEN2,BUFFER(BLEN+1:),USER(1:ULEN),%VAL(APPTS))
	 ELSE
	    CALL SYS$FAO('.  You have !SL appointments:',
	1			      BLEN2,BUFFER(BLEN+1:),%VAL(APPTS))
	 ENDIF

	    BLEN = BLEN + BLEN2

	    WRITE (6,1002) BUFFER(1:BLEN)

	    CALL SORT_EVENTS

	ENDIF

	DO I=1,APPTS

	    CALL SHOW_2(EVENTS(I)(1:LEVS(I)),TIMES(I)/10000)

	ENDDO

	WRITE (6,1001)

	RETURN

110	IF (ERR.EQ.52) THEN				    ! Is record locked?
	    CALL GO_WAIT(1)
	    GO TO LOCK,(10,30)
	ELSE
	    IF (ERR.EQ.36) GO TO 100
	    PRINT 1003
	    CALL FILE_ERROR
	    CALL EXIT
	ENDIF

1000	FORMAT (Q,A)
1001	FORMAT (1X,A)
1002	FORMAT ('0    ',A)
1003	FORMAT ('0Error on the Reminder Event File.')

	END
	SUBROUTINE SORT_EVENTS

	IMPLICIT INTEGER (A-Z)

	LOGICAL SORTED

	CHARACTER*64 S2

	CHARACTER*64 EVENTS(32)
	INTEGER*4 TIMES(32)
	INTEGER*4 LEVS(32)

	COMMON /SAVE/ APPTS,TIMES,LEVS,EVENTS

	DO I=APPTS,2,-1

	    SORTED = .TRUE.

	    DO J=2,I

		IF (TIMES(J-1).GT.TIMES(J)) THEN

		    S1 = TIMES(J-1)
		    TIMES(J-1) = TIMES(J)
		    TIMES(J) = S1

		    S1 = LEVS(J-1)
		    LEVS(J-1) = LEVS(J)
		    LEVS(J) = S1

		    S2 = EVENTS(J-1)
		    EVENTS(J-1) = EVENTS(J)
		    EVENTS(J) = S2

		    SORTED = .FALSE.

		ENDIF

	    ENDDO

	    IF (SORTED) RETURN

	ENDDO

	END
	SUBROUTINE SHOW_2(EVENT,DAYS)

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) EVENT

	COMMON /TODAY_/ TODAY

	CHARACTER*64 BUFFER
	CHARACTER*10 DATE
	CHARACTER*10 DAY

	COMMON /BUF/ BLEN,BUFFER,DATE,DAY

	CHARACTER*10 WEEK(0:6)

	COMMON /WEEK_/ WEEK

	DATA WEEK / 'Wednesday','Thursday','Friday','Saturday',
	1				'Sunday','Monday','Tuesday' /

	IF (DAYS.EQ.0) THEN

	    CALL SHOW_3('Today',EVENT)

	ELSE IF (DAYS.EQ.1) THEN

	    CALL SHOW_3('Tomorrow',EVENT)

	ELSE IF (DAYS.LE.5) THEN

	    DAY = WEEK(MOD(TODAY+DAYS,7))

	    CALL SHOW_3(DAY,EVENT)

	ELSE

	    DATE = ' '

	    DATE(5:6) = EVENT(1:2)
	    DATE(1:1) = EVENT(4:4)
	    DATE(2:2) = CHAR(ICHAR(EVENT(5:5))+32)
	    DATE(3:3) = CHAR(ICHAR(EVENT(6:6))+32)

	    IF (DAYS.GT.365) THEN
		DATE(8:8)  = ''''
		DATE(9:10) = EVENT(8:9)
	    ENDIF

	    CALL SHOW_3(DATE,EVENT)

	ENDIF

	END
	SUBROUTINE SHOW_3(TEXT,EVENT)

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) TEXT,EVENT

	CHARACTER*1 ESC
	CHARACTER*6 ON
	CHARACTER*3 OFF

	PARAMETER ( ESC = CHAR(27)     )
	PARAMETER ( ON  = ESC//'[1;5m' )
	PARAMETER ( OFF = ESC//'[m'    )

	CHARACTER*128 FILE
	LOGICAL OUTFILE

	COMMON /FILE/ FILE,OUTFILE

	TLEN = STR_LEN(TEXT)

	IF (EVENT(16:16).EQ.' ' .OR. OUTFILE) THEN

	    IF (LEN(EVENT).LE.16) THEN

		WRITE (6,1000) TEXT(1:TLEN),EVENT(11:15)

	    ELSE

	        WRITE (6,1000) TEXT(1:TLEN),EVENT(11:15),EVENT(17:)

	    ENDIF

	ELSE

	    IF (LEN(EVENT).LE.16) THEN

		PRINT 1000,ON//TEXT(1:TLEN),EVENT(11:15)//OFF

	    ELSE

		PRINT 1000,ON//TEXT(1:TLEN),EVENT(11:15),EVENT(17:)//OFF

	    ENDIF

	ENDIF

1000	FORMAT ('0',T<16-TLEN>,A,' at ',A,:,' -- ',A)

	END
	SUBROUTINE CV_TIME(DAYS,MINUTES,*)

*
*	STRING -- AN ASCII TIME, FORMAT '18-NOV-83 12:00'  (note 83, not 1983)
*
*	DAYS -- DIFFERENCE BETWEEN TODAY AND TIME STRING IN EVENT RECORD
*
*	MINUTES -- IF DAYS=0, DIFFERENCE BETWEEN CURRENT TIME AND STRING TIME
*		   IF DAYS>0, MINUTES FROM THAT DAY'S MIDNIGHT AND STRING TIME
*
*	THE ALTERNATE RETURN IS TAKEN IF THE TIME IS BADLY FORMATTED.
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*90 EVENT

	COMMON /EVENT_/ LEV,EVENT
	COMMON /TODAY_/ TODAY

	INTEGER*4 NOW(2),TIME(2)

	LOGICAL FIRST_CALL / .TRUE. /

	IF (FIRST_CALL) THEN

	    FIRST_CALL = .FALSE.

	    CALL SYS$GETTIM(NOW)

	    CALL LIB$DAY(TODAY,NOW)

	ENDIF

	IF (EVENT(34:34).GE.'8') THEN		! 1980's, or 1990's

	    STATUS = SYS$BINTIM(EVENT(27:33)//'19'//EVENT(34:41),TIME)

	ELSE					! 2000 or beyond

	    STATUS = SYS$BINTIM(EVENT(27:33)//'20'//EVENT(34:41),TIME)

	ENDIF

	IF (.NOT.STATUS) RETURN 1

	CALL LIB$DAY(EVENT_DAY,TIME,SECS)

	DAYS = EVENT_DAY - TODAY

	IF (DAYS.EQ.0) THEN

	    CALL LIB$SUBX(TIME,NOW,TIME)

	    CALL LIB$EDIV(600000000,TIME,MINUTES,REM)

	ELSE

	    MINUTES = SECS / (60*100)

	ENDIF

	END
	SUBROUTINE GET_USERNAME(WHICH_CALL)

	IMPLICIT INTEGER (A-Z)

	CHARACTER*16 PROCNAME
	CHARACTER*8  TERMNAME
	CHARACTER*12 USERNAME
	INTEGER*2 PNLEN,TNLEN,UNLEN

	COMMON /USER_DATA_/ PID,PROC_STAT,UIC,PROCNAME,TERMNAME,USERNAME,
	1				       PNLEN,   TNLEN,   UNLEN

	CHARACTER*25 USER,OTHER_USER,KEY
	LOGICAL*1 NOTME / .FALSE. /

	COMMON /USERNAME/ ULEN,OULEN,USER,OTHER_USER,KEY,NOT_ME

	CHARACTER*90 EVENT

	COMMON /EVENT_/ LEV,EVENT

	LOGICAL CLI$PRESENT,USER_HAS_PRIV

	IF (WHICH_CALL.EQ.1) THEN

	    CALL USER_HAS_PRIV(' ')

	    USER = USERNAME(1:UNLEN)
	    ULEN = UNLEN

	ELSE

	    CALL CLI$GET_VALUE('USER',OTHER_USER,OULEN)

	    IF (OTHER_USER.EQ.USER) RETURN

	    IF (.NOT.USER_HAS_PRIV('SYSPRV')) THEN

		KEY(1:13)  = '\' // OTHER_USER
		KEY(14:25) = USER

10		READ (1,1001,KEY=KEY,ERR=110,IOSTAT=ERR) LEV,EVENT

		UNLOCK (1)

	    ENDIF

	    USER = OTHER_USER
	    ULEN = OULEN

	    NOT_ME = .TRUE.

	    RETURN

20	    PRINT 1002,OTHER_USER(1:OULEN)

	    CALL EXIT

	ENDIF

	RETURN

110	IF (ERR.EQ.52) THEN				    ! Is record locked?
	    CALL GO_WAIT(1)
	    GO TO 10
	ELSE
	    IF (ERR.EQ.36) GO TO 20
	    PRINT 1003
	    CALL FILE_ERROR
	    CALL EXIT
	ENDIF

1001	FORMAT (Q,A)
1002	FORMAT ('0You cannot access user ',A,'''s reminders.'/)
1003	FORMAT ('0Error on the Reminder Event File.')

	END
	SUBROUTINE GET_DATE(IN_DATE)

**
*	SUBROUTINE GET_DATE( in_date )
*
*	Reads in a date, which may be in many formats, and puts the normally-
*	formatted equivalent (in the format '13-FEB-84') in the character
*	string 'IN_DATE'.
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*9 IN_DATE

	CHARACTER*3 FRAG1,FRAG2,FRAG3,FRAG4

	CHARACTER*16 DATE_IN,DATE

	COMMON /SYSTIME_/ DATE,SYSTIME(2)

	LOGICAL CLI_USED,INTERACT

	COMMON /INPUT/ CLI_USED,INTERACT

	LOGICAL INTERACTIVE_INPUT,CLI$PRESENT

	DATA CLI_USED / .TRUE. /

	INTERACT = INTERACTIVE_INPUT()

	CALL SYS$GETTIM(SYSTIME)	  ! Put today's date in VAX time format

	IF (CLI$PRESENT('P1')) THEN

	    CALL CLI$GET_VALUE('P1',DATE_IN,LEN)

	ELSE

	    CLI_USED = .FALSE.

	    IF (.NOT.INTERACT) CALL ERROR('NODATE, no date specified')

10	    PRINT 1000

	    READ 1001,LEN,DATE_IN

	ENDIF

	DATE = DATE_IN(1:LEN)

	IF (DATE.EQ.' ') GO TO 90	! Null string entered; use today's date
	IF (DATE.EQ.'*') GO TO 90	! An asterisk entered; use today's date

	CALL STR$UPCASE(DATE,DATE)			! Convert to upper case

	CALL SUBSTRING_CONVERT(DATE,'-',' ')	 ! Change minus signs to blanks

	CALL SUBSTRING_CONVERT(DATE,',',' ')	      ! Change commas to blanks

	CALL SUBSTRING_CONVERT(DATE,'198','8')		! Change '1984' to '84'
	CALL SUBSTRING_CONVERT(DATE,'199','9')		! Change '1994' to '94'
	CALL SUBSTRING_CONVERT(DATE,'200','0')		! Change '2004' to '04'
	CALL SUBSTRING_CONVERT(DATE,'201','0')		! Change '2014' to '14'

	CALL SUBSTRING_FIELD(DATE,FRAG1,L1)	      ! Get first or only field

	IF (L1.EQ.0) GO TO 100		   ! Error if no fields (e.g. was '--')

	CALL SUBSTRING_FIELD(DATE,FRAG2,L2)	     ! Get second field, if any

	IF (L2.EQ.0) THEN			! Date is composed of one field

	    IF (FRAG1.EQ.'TOD') THEN				      ! 'TODAY'

		GO TO 90

	    ELSE IF (FRAG1.EQ.'TOM') THEN			   ! 'TOMORROW'

		CALL ADD_DAYS(1)		  ! Add one day to today's date
		GO TO 90

	    ELSE IF (FRAG1(1:1).EQ.'+' .AND. L1.GT.1) THEN		! '+nn'

		IF (.NOT.LEGAL_INTEGER(FRAG1(2:L1),OFFSET)) GO TO 100

		CALL ADD_DAYS(OFFSET)
		GO TO 90

	    ELSE

		CALL TRY_DAY_OF_WEEK(FRAG1,*90)	       ! See if 'SUN','MON',...

		CALL TRY_DAY_OF_MONTH(FRAG1(1:L1),*80)	! See if an integer day
		GO TO 100

	    ENDIF

	ENDIF

	CALL SUBSTRING_FIELD(DATE,FRAG3,L3)	      ! Get third field, if any

	IF (L3.EQ.0) THEN		       ! Date is composed of two fields

	    CALL TWO_FIELD_DATE(FRAG1(1:L1),FRAG2(1:L2))
	    GO TO 80

	ENDIF

	CALL SUBSTRING_FIELD(DATE,FRAG4,L4)    ! Make sure there's no 4th field

	IF (L4.NE.0) GO TO 100			    ! Error; more than 3 fields

	CALL THREE_FIELD_DATE(FRAG1(:L1),FRAG2(:L2),FRAG3(:L3),*100)

80	STATUS = SYS$BINTIM(DATE,SYSTIME)	      ! Definitive syntax check

	IF (.NOT.STATUS) GO TO 100				! Syntax is bad

90	CALL SYS$ASCTIM(,DATE(1:11),SYSTIME,)	! Convert to format dd-mmm-yyyy

	IN_DATE = DATE(1:7) // DATE(10:11)

	RETURN

100	IF (CLI_USED)
	1	 CALL ERROR('DATE, invalid date /'//DATE_IN(1:LEN)//'/')

	GO TO 10

1000	FORMAT (/'$   Date: ')
1001	FORMAT (Q,A)

	END
	SUBROUTINE TRY_DAY_OF_WEEK(STRING,*)

**
*	SUBROUTINE TRY_DAY_OF_WEEK ( string , * )
*
*	Checks to see if character string STRING is one of the days
*	of the week, like 'SUN' or 'MON'.  If so, then the VAX binary
*	time quadword SYSTIME is set to the date of the next occur-
*	rence after today of the given day-of-the-week, and the alt-
*	ernate return is taken.
*
*	If today's day-of-the-week is specified, this is considered
*	invalid, because it is a sign that the user does not know
*	what day it is.
*
*	If STRING is not a valid day-of-the-week, the normal return
*	is taken.
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) STRING

	CHARACTER*3 WEEK(0:6)

	DATA WEEK / 'WED','THU','FRI','SAT','SUN','MON','TUE' /

	DO DAY=0,6

	    IF (STRING.EQ.WEEK(DAY)) THEN

		CALL LIB$DAY(TODAY)

		NDAYS = DAY - MOD(TODAY,7)

		IF (NDAYS.LT.0) NDAYS = NDAYS + 7

		IF (NDAYS.EQ.0) RETURN	! Don't allow today to be done this way

		CALL ADD_DAYS(NDAYS)

	        RETURN 1

	    ENDIF

	ENDDO

	END
	SUBROUTINE TRY_DAY_OF_MONTH(STRING,*)

**
*	SUBROUTINE TRY_DAY_OF_MONTH( string , * )
*
*	Checks to see if the character string STRING contains a valid
*	integer day-of-the-month; if so, the alternate return is
*	taken.  If the day is before today in the month, it is assumed
*	to be a day of next month.
*
*	If it is today's day, it is assumed invalid; this ensures that
*	the user knows what day today is.
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) STRING

	CHARACTER*3 YEAR(13)

	DATA YEAR / 'JAN','FEB','MAR','APR','MAY','JUN',
	1	    'JUL','AUG','SEP','OCT','NOV','DEC','JAN' /

	LOGICAL LEGAL_INTEGER

	CHARACTER*16 DATE

	COMMON /SYSTIME_/ DATE,SYSTIME(2)

	IF (.NOT.LEGAL_INTEGER(STRING,DAY)) RETURN

	CALL IDATE(MONTH,TODAY,YR)

	IF (DAY.EQ.TODAY) RETURN	! Don't allow today to be done this way

	IF (DAY.LT.TODAY) MONTH = MONTH + 1

	IF (MONTH.EQ.13) YR = YR + 1

	DATE = STRING // '-' // YEAR(MONTH) // '-198' //
	1				     CHAR(MOD(YR,10)+ICHAR('0'))

	RETURN 1

	END
	SUBROUTINE ADD_DAYS(NDAYS)

**
*	SUBROUTINE ADD_DAYS( ndays )
*
*	Places in VAX quadword binary time variable SYSTIME the date
*	of NDAYS from today, where NDAYS is a positive integer.
*

	IMPLICIT INTEGER (A-Z)

	INTEGER WORK(2)

	CHARACTER*16 DATE

	COMMON /SYSTIME_/ DATE,SYSTIME(2)

	CALL LIB$EMUL(NDAYS*24*60*60,10000000,0,WORK)	! Convert NDAYS to VAX
							!   units (100ns ticks)
	CALL LIB$ADDX(WORK,SYSTIME,SYSTIME)		! Add to current time,
							!   already in SYSTIME
	END
	SUBROUTINE SUBSTRING_CONVERT(STRING,FROM,TO)

**
*	SUBROUTINE SUBSTRING_CONVERT( string , from , to )
*
*	Converts all occurrences of substring FROM in string STRING
*	to string TO.  TO does not have to be the same length as
*	FROM.
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) STRING,FROM,TO

10	COL = INDEX(STRING,FROM)

	IF (COL.EQ.0) RETURN

	STRING = STRING(1:COL-1) // TO // STRING(COL+LEN(FROM):)

	GO TO 10

	END
	SUBROUTINE SUBSTRING_FIELD(STRING,FIELD,LENGTH)

**
*	SUBROUTINE SUBSTRING_FIELD( string , field , length )
*
*	Obtains the next non-blank field from string STRING.  If
*	there were no more fields, LENGTH=0 on return; else the
*	field is returned in string FIELD, and its length is in
*	integer LENGTH.  The first character of STRING is destroyed
*	(The current scan position is kept there).
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) STRING,FIELD

	LENGTH = 0
	FIELD  = ' '

	IF (ICHAR(STRING(1:1)).LE.127) THEN
	    COL = 0				   ! First call for this string
	ELSE
	    COL = ICHAR(STRING(1:1)) - 128	   ! Not first call; continue
	ENDIF					   !   where last call finished

10	IF (COL.GE.LEN(STRING)) THEN		! Quit if end of STRING reached

20	    STRING(1:1) = CHAR(COL+128)		 ! Keep record of where this
	    RETURN				 !   field ended, for next time

	ENDIF

	COL = COL + 1			     ! Examine next character in STRING

	IF (STRING(COL:COL).EQ.' ') THEN	! If blank, quit if end of
						!  field, else loop if field
	    IF (LENGTH.GT.0) GO TO 20		!   not started yet.

	ELSE IF (LENGTH.LT.LEN(FIELD)) THEN	 ! If not blank, move it to
						 !  FIELD, unless FIELD is full
	    LENGTH = LENGTH + 1
	    FIELD(LENGTH:LENGTH) = STRING(COL:COL)

	ENDIF

	GO TO 10		       ! Loop to check next character in STRING

	END
	LOGICAL FUNCTION LEGAL_INTEGER(STRING,VALUE)

**
*	LOGICAL FUNCTION LEGAL_INTEGER( string [ , value ] )
*
*	Returns a .TRUE. result if character string STRING contains a
*	valid representation of a decimal integer; leading and trail-
*	ing blanks are ignored.  If the optional integer argument VALUE
*	is present, the converted integral value is returned there.
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) STRING

	LOGICAL ARG_EXIST

	LEGAL_INTEGER = OTS$CVT_TI_L(STRING,I,%VAL(4),%VAL(1))

	IF (ARG_EXIST(2)) VALUE = I

	END
	SUBROUTINE TWO_FIELD_DATE(FIELD1,FIELD2)

**
*	SUBROUTINE TWO_FIELD_DATE ( field1 , field2 )
*
*	Parses a date composed of two fields, a month and a day (in
*	either order).
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) FIELD1,FIELD2

	LOGICAL LEGAL_INTEGER,OUT_OF_DATE

	CHARACTER*16 DATE

	COMMON /SYSTIME_/ DATE,SYSTIME(2)

	IF (LEGAL_INTEGER(FIELD1)) THEN

	    DATE = FIELD1 // '-' // FIELD2 // '-'		       ! 19 JUN

	ELSE

	    DATE = FIELD2 // '-' // FIELD1 // '-'		       ! JUN 19

	ENDIF

	IF (OUT_OF_DATE()) THEN		   ! If the date is past, use next year

	    CALL SYS$ASCTIM(,DATE,SYSTIME,)
	    
	    DATE(11:11) = CHAR(ICHAR(DATE(11:11))+1) ! Incr units digit of year

	ENDIF

	END
	SUBROUTINE THREE_FIELD_DATE(FIELD1,FIELD2,FIELD3,*)

**
*	SUBROUTINE THREE_FIELD_DATE( field1 , field2 , field3 , * )
*
*	Parses a date string composed of three fields.  The alternate
*	return is taken if the date is before today.
*

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) FIELD1,FIELD2,FIELD3

	LOGICAL LEGAL_INTEGER,OUT_OF_DATE

	CHARACTER*16 DATE
	CHARACTER*3 CENTURY

	COMMON /SYSTIME_/ DATE,SYSTIME(2)

	IF (FIELD3(1:1).GE.'8') THEN
	    CENTURY = '-19'
	ELSE
	    CENTURY = '-20'
	ENDIF

	IF (LEGAL_INTEGER(FIELD1)) THEN

	    DATE = FIELD1 // '-' // FIELD2 // CENTURY // FIELD3	    ! 10 DEC 83

	ELSE

	    DATE = FIELD2 // '-' // FIELD1 // CENTURY // FIELD3	    ! DEC 10 83

	ENDIF

	IF (OUT_OF_DATE()) RETURN 1

	END
	LOGICAL FUNCTION OUT_OF_DATE()

**
*	LOGICAL FUNCTION OUT_OF_DATE
*
*	returns a .TRUE. result if the ASCII date in character
*	string DATE has past; i.e. is before today.
*
*	If the date in DATE is not a valid date, a .FALSE.
*	result is returned.
*
*	If DATE is valid, then the VAX binary time quadword SYSTIME is
*	set to the date from DATE.
*

	IMPLICIT INTEGER (A-Z)

	INTEGER SYSTIME2(2),WORK(2)

	CHARACTER*16 DATE

	COMMON /SYSTIME_/ DATE,SYSTIME(2)

	STATUS = SYS$BINTIM(DATE,SYSTIME2)    ! Convert DATE to VAX binary time

	IF (.NOT.STATUS) THEN		

	    OUT_OF_DATE = .FALSE.			  ! DATE has bad syntax
	    RETURN

	ENDIF

	CALL LIB$SUBX(SYSTIME2,SYSTIME,WORK)		! Subtract time of NOW

	OUT_OF_DATE = WORK(2) .LT. 0	  ! If result is negative, DATE is old

	SYSTIME(1) = SYSTIME2(1)
	SYSTIME(2) = SYSTIME2(2)

	END
	SUBROUTINE GET_TIME(IN_TIME)

	IMPLICIT INTEGER (A-Z)

	CHARACTER*16 TIME,IN_TIME

	LOGICAL CLI_USED,INTERACT

	COMMON /INPUT/ CLI_USED,INTERACT

	INTEGER*4 ITIME(2)

	LOGICAL CLI$PRESENT,SYS$BINTIM

	IF (CLI$PRESENT('P2')) THEN

	    CALL CLI$GET_VALUE('P2',TIME,LEN)

	ELSE

	    IF (.NOT.INTERACT) CALL ERROR('NOTIME, no time specified')

	    CLI_USED = .FALSE.

10	    PRINT 1000

	    READ 1001,LEN,TIME

	ENDIF

	IF (LEN.EQ.0) THEN

	    GO TO 100

	ELSE IF (LEN.EQ.1) THEN					! 9 -> 09:00

	    IN_TIME = '0' // TIME(1:1) // ':00'

	ELSE IF (LEN.EQ.2) THEN					! 12 -> 12:00

	    IN_TIME = TIME(1:2) // ':00'

	ELSE IF (LEN.EQ.3) THEN					! 915 -> 09:15

	    IN_TIME = '0' // TIME(1:1) // ':' // TIME(2:3)

	ELSE IF (LEN.EQ.4) THEN				    ! 1245 or 9:15

	    IF (TIME(2:2).NE.':') THEN				! 1245 -> 12:45

		IN_TIME = TIME(1:2) // ':' // TIME(3:4)

	    ELSE						! 9:15 -> 09:15

		IN_TIME = '0' // TIME(1:4)

	    ENDIF

	ELSE IF (LEN.EQ.5) THEN				    ! 12:45

	    IN_TIME = TIME(1:5)

	ELSE

	    GO TO 100

	ENDIF

	IF (SYS$BINTIM('-- '//IN_TIME,ITIME)) RETURN

100	IF (CLI_USED)
	1	    CALL ERROR('TIME, invalid time /'//TIME(1:LEN)//'/')

	GO TO 10

1000	FORMAT (/'$   Time: ')
1001	FORMAT (Q,A)

	END
	SUBROUTINE COMMUNICATE

	IMPLICIT INTEGER (A-Z)

	INTEGER*4 MB_DATA(4)

	LOGICAL LOGICAL_NAME

	IF (LOGICAL_NAME('REMINDERS_')) THEN

	    CALL MAILBOX('REMINDERS_',MB_DATA)

	    CALL MAILBOX_WRITE(MB_DATA,'Reminder')

	ENDIF

	END
	SUBROUTINE DISPLAY_DATE

	IMPLICIT INTEGER (A-Z)

	CHARACTER*55 BUFFER
	CHARACTER*5  NOW
	CHARACTER*10 MONTH
	CHARACTER*10 DAY

	COMMON /BUF/ BLEN,BUFFER,NOW,MONTH,DAY

	CHARACTER*10 WEEK(0:6)

	COMMON /WEEK_/ WEEK

	CHARACTER*10 MONTHS(12)

	DATA MONTHS / 'January','February','March','April',
	1		'May','June','July','August','September',
	2			       'October','November','December' /

	CALL TIME(NOW)

	CALL LIB$DAY(TODAY)

	DAY = WEEK(MOD(TODAY,7))

	LD = STR_LEN(DAY)

	CALL IDATE(M,D,Y)

	MONTH = MONTHS(M)

	LM = STR_LEN(MONTH)

	STATUS = SYS$FAO('It is !AS, !AS !SL at !AS',BLEN,BUFFER,
	1				DAY(:LD),MONTH(:LM),%VAL(D),NOW)

	END
	SUBROUTINE ALLOW_OTHER_USER

	IMPLICIT INTEGER (A-Z)

	CHARACTER*25 USER,OTHER_USER,KEY
	LOGICAL*1 NOT_ME

	COMMON /USERNAME/ ULEN,OULEN,USER,OTHER_USER,KEY,NOT_ME

	CHARACTER*90 EVENT

	COMMON /EVENT_/ LEV,EVENT

	CALL CLI$GET_VALUE('ALLOW',OTHER_USER,OULEN)

	IF (OTHER_USER.EQ.USER) RETURN

	KEY(1:13)  = '\' // USER
	KEY(14:25) = OTHER_USER

!	First do dummy read to see if /ALLOW has already been done for
!	this other user.

10	READ (1,1001,KEY=KEY,ERR=110,IOSTAT=ERR) LEV,EVENT

	UNLOCK (1)

	IF (NOT_ME) THEN
	    PRINT 1000,OTHER_USER(1:OULEN),USER(1:ULEN)//'''s'
	ELSE
	    PRINT 1000,OTHER_USER(1:OULEN),'your'
	ENDIF

	GO TO 30

20	WRITE (1,1002) KEY

	IF (NOT_ME) THEN
	    PRINT 1004,OTHER_USER(1:OULEN),USER(1:ULEN)//'''s'
	ELSE
	    PRINT 1004,OTHER_USER(1:OULEN),'your'
	ENDIF

30	RETURN

110	IF (ERR.EQ.52) THEN				    ! Is record locked?
	    CALL GO_WAIT(1)
	    GO TO 10
	ELSE
	    IF (ERR.EQ.36) GO TO 20
	    PRINT 1003
	    CALL FILE_ERROR
	    CALL EXIT
	ENDIF

1000	FORMAT ('0User ',A,' was already allowed to access ',A,
	1						 ' reminders.'/)
1001	FORMAT (Q,A)
1002	FORMAT (A)
1003	FORMAT ('0Error on the Reminder Event File.')
1004	FORMAT ('0User ',A,' can now access ',A,' reminders.'/)

	END
	SUBROUTINE SHOW_ACCESS

	IMPLICIT INTEGER (A-Z)

	CHARACTER*25 USER,OTHER_USER,KEY
	LOGICAL*1 NOT_ME

	COMMON /USERNAME/ ULEN,OULEN,USER,OTHER_USER,KEY,NOT_ME

	CHARACTER*90 EVENT

	COMMON /EVENT_/ LEV,EVENT

	LOGICAL FOUND / .FALSE. /

	KEY = '\' // USER

	ASSIGN 10 TO LOCK	 ! Where to return to after locked record error

10	READ (1,1000,KEY=KEY(1:13),ERR=110,IOSTAT=ERR) LEV,EVENT   ! Partial key

	UNLOCK (1)

	ASSIGN 30 TO LOCK

	IF (NOT_ME) THEN
	    WRITE (6,1001) USER(1:ULEN)//'''s'
	ELSE
	    WRITE (6,1001) 'your'
	ENDIF

20	WRITE (6,1002) EVENT(14:25)

30	READ (1,1000,END=40,ERR=110,IOSTAT=ERR) LEV,EVENT

	UNLOCK (1)

	IF (EVENT(1:13).EQ.KEY) GO TO 20

40	ASSIGN 50 TO LOCK

50	READ (1,1000,KEY=' ',ERR=110,IOSTAT=ERR) LEV,EVENT	! Rewind

	UNLOCK (1)

	ASSIGN 60 TO LOCK

60	READ (1,1000,END=100,ERR=110,IOSTAT=ERR) LEV,EVENT

	UNLOCK (1)

	IF (EVENT(14:25).EQ.USER) THEN

	    IF (.NOT.FOUND) THEN
		IF (NOT_ME) THEN
		    WRITE (6,1005) USER(1:ULEN)
		ELSE
		    WRITE (6,1005) 'You'
		ENDIF
	    ENDIF

	    FOUND = .TRUE.

	    WRITE (6,1002) EVENT(2:13)

	ENDIF

	GO TO 60
	
100	IF (.NOT.FOUND) THEN
	    IF (NOT_ME) THEN
		WRITE (6,1006) USER(1:ULEN)
	    ELSE
		WRITE (6,1006) 'You'
	    ENDIF
	ENDIF

	WRITE (6,1002)

	RETURN

110	IF (ERR.EQ.52) THEN				    ! Is record locked?
	    CALL GO_WAIT(1)
	    GO TO LOCK,(10,30,50,60)
	ELSE
	    IF (ERR.EQ.36) GO TO 120
	    PRINT 1003
	    CALL FILE_ERROR
	    CALL EXIT
	ENDIF

120	IF (NOT_ME) THEN
	    WRITE (6,1004) USER(1:ULEN)//'''s'
	ELSE
	    WRITE (6,1004) 'your'
	ENDIF

	GO TO 40

1000	FORMAT (Q,A)
1001	FORMAT ('0The following user(s) can access ',A,' reminders:'/)
1002	FORMAT (20X,A)
1003	FORMAT ('0Error on the Reminder Event File.')
1004	FORMAT ('0No other users can access ',A,' reminders.')
1005	FORMAT ('0',A,' can access the following users'' reminders:'/)
1006	FORMAT ('0',A,' can access no other users'' reminders.')

	END
	SUBROUTINE DISALLOW_OTHER_USER

	IMPLICIT INTEGER (A-Z)

	CHARACTER*25 USER,OTHER_USER,KEY
	LOGICAL*1 NOT_ME

	COMMON /USERNAME/ ULEN,OULEN,USER,OTHER_USER,KEY,NOT_ME

	CHARACTER*90 EVENT

	COMMON /EVENT_/ LEV,EVENT

	CALL CLI$GET_VALUE('DISALLOW',OTHER_USER,OULEN)

	IF (OTHER_USER.EQ.USER) RETURN

	KEY(1:13)  = '\' // USER
	KEY(14:25) = OTHER_USER

10	READ (1,1001,KEY=KEY,ERR=110,IOSTAT=ERR) LEV,EVENT

	DELETE (1,ERR=110,IOSTAT=ERR)

	UNLOCK (1)

	IF (NOT_ME) THEN
	    PRINT 1000,OTHER_USER(1:OULEN),USER(1:ULEN)//'''s'
	ELSE
	    PRINT 1000,OTHER_USER(1:OULEN),'your'
	ENDIF

	GO TO 30

20	IF (NOT_ME) THEN
	    PRINT 1004,OTHER_USER(1:OULEN),USER(1:ULEN)//'''s'
	ELSE
	    PRINT 1004,OTHER_USER(1:OULEN),'your'
	ENDIF

30	RETURN

110	IF (ERR.EQ.52) THEN				    ! Is record locked?
	    CALL GO_WAIT(1)
	    GO TO 10
	ELSE
	    IF (ERR.EQ.36) GO TO 20
	    PRINT 1003
	    CALL FILE_ERROR
	    CALL EXIT
	ENDIF

1000	FORMAT ('0User ',A,' can no longer access ',A,' reminders.'/)
1001	FORMAT (Q,A)
1003	FORMAT ('0Error on the Reminder Event File.')
1004	FORMAT ('0User ',A,' had no access to ',A,' reminders.'/)

	END
	SUBROUTINE LOGIN

	IMPLICIT INTEGER (A-Z)

	INTEGER*4 MB_DATA(4)

	LOGICAL LOGICAL_NAME

	CHARACTER*16 PROCNAME
	CHARACTER*8  TERMNAME
	CHARACTER*12 USERNAME
	INTEGER*2 PNLEN,TNLEN,UNLEN

	COMMON /USER_DATA_/ PID,PROC_STAT,UIC,PROCNAME,TERMNAME,USERNAME,
	1				       PNLEN,   TNLEN,   UNLEN

	IF (LOGICAL_NAME('REMINDERS_')) THEN

	    CALL SYS$SETRWM(%VAL(1))		! Abort if batch job not run-
						!  ning, but mailbox is open
						!  and too full of messages.
	    CALL MAILBOX('REMINDERS_',MB_DATA)

	    CALL MAILBOX_WRITE(MB_DATA, 'I am ' //
	1	USERNAME(1:UNLEN) // ' on ' // TERMNAME(1:TNLEN) )

	    CALL SYS$SETRWM()

	ENDIF

	END
	INTEGER*4 FUNCTION CONDITION_HANDLER(SIGARGS,MECHARGS)

	IMPLICIT INTEGER*4 (A-Z)

	INTEGER*4 SIGARGS(*),MECHARGS(*)

	EXTERNAL SS$_RESIGNAL,SS$_MBFULL

	CONDITION_HANDLER = %LOC(SS$_RESIGNAL)

	IF (LIB$MATCH_COND(SIGARGS(2),%LOC(SS$_MBFULL))) THEN

	    PRINT 1000

	    CALL SYS$UNWIND(MECHARGS(3),)	! Must do this, LIB$STOP used.

	ENDIF

1000	FORMAT ('0Please notify the System Manager that REMINDER ',
	1	'is not working properly.'/)

	END
	SUBROUTINE ERROR(TEXT)

	IMPLICIT INTEGER (A-Z)

	CHARACTER*(*) TEXT

	PRINT 1000,TEXT

	CALL EXIT('10000004'X)

1000	FORMAT (' %REMINDER-F-',A)

	END
