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. * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 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 PRINT 1002 CALL GET_DATE(DATE) PRINT 1002 CALL GET_TIME(TIME) PRINT 1000 READ 1001,LEN,APPOINTMENT 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 PRINT 1002 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 CHARACTER*90 EVENT COMMON /EVENT_/ LEV,EVENT PRINT 1000 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) PRINT 1000 CALL GET_TIME(TIME) 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 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 KEY(1:13) = '\' // OTHER_USER KEY(14:25) = USER 10 READ (1,1001,KEY=KEY,ERR=110,IOSTAT=ERR) LEV,EVENT UNLOCK (1) 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 COMMON /SYSTIME_/ DATE,SYSTIME(2) 10 CALL SYS$GETTIM(SYSTIME) ! Put today's date in VAX time format PRINT 1000 READ 1001,DATE IF (DATE.EQ.' ') GO TO 90 ! Null string 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 10 ! 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 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 10 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 10 ! Error; more than 3 fields CALL THREE_FIELD_DATE(FRAG1(:L1),FRAG2(:L2),FRAG3(:L3),*10) 80 STATUS = SYS$BINTIM(DATE,SYSTIME) ! Definitive syntax check IF (.NOT.STATUS) GO TO 10 ! 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) 1000 FORMAT ('$ Date: ') 1001 FORMAT (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*5 IN_TIME INTEGER*4 ITIME(2) LOGICAL SYS$BINTIM 10 PRINT 1000 READ 1001,LEN,IN_TIME IF (LEN.EQ.0) THEN GO TO 10 ELSE IF (LEN.EQ.1) THEN ! 9 -> 09:00 IN_TIME = '0' // IN_TIME(1:1) // ':00' ELSE IF (LEN.EQ.2) THEN ! 12 -> 12:00 IN_TIME = IN_TIME(1:2) // ':00' ELSE IF (LEN.EQ.3) THEN ! 915 -> 09:15 IN_TIME = '0' // IN_TIME(1:1) // ':' // IN_TIME(2:3) ELSE IF (LEN.EQ.4) THEN ! 1245 or 9:15 IF (IN_TIME(2:2).NE.':') THEN ! 1245 -> 12:45 IN_TIME = IN_TIME(1:2) // ':' // IN_TIME(3:4) ELSE ! 9:15 -> 09:15 IN_TIME = '0' // IN_TIME(1:4) ENDIF ENDIF IF (.NOT.SYS$BINTIM('-- '//IN_TIME,ITIME)) 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