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. * * * Alan L. Zirkle Naval Surface Weapons Center * Code K105 * 5 December 1983 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*128 FILE LOGICAL ADD,DEL,CLI$PRESENT CALL GET_USERNAME IF (CLI$PRESENT('LOGIN')) CALL LOGIN ADD = CLI$PRESENT('ADD') DEL = CLI$PRESENT('DELETE') IF (ADD.AND.DEL) THEN PRINT 1000 CALL EXIT ENDIF CALL CLI$GET_VALUE('FILE',FILE) OPEN (1,FILE=FILE,STATUS='OLD',SHARED,ACCESS='KEYED', 1 FORM='FORMATTED',ERR=100) IF (ADD) THEN CALL ADD_ENTRY ELSE IF (DEL) THEN CALL DELETE_ENTRY ELSE CALL SHOW ENDIF CALL EXIT 100 PRINT 1001 1000 FORMAT ('0You can''t do both!'/) 1001 FORMAT ('0Cannot open Reminder Event File -', 1 '- notify System Manager'/) END SUBROUTINE ADD_ENTRY IMPLICIT INTEGER (A-Z) CHARACTER*9 DATE CHARACTER*5 TIME CHARACTER*48 APPOINTMENT CHARACTER*15 USER COMMON /USERNAME/ USER 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*15 USER COMMON /USERNAME/ USER CHARACTER*80 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 ASSIGN 105 TO NOTFOUND 20 READ (1,1001,KEY=USER,ERR=110,IOSTAT=ERR) LEV,EVENT ASSIGN 40 TO LOCK 30 IF ( EVENT(17:31) .EQ. DATE//' '//TIME ) THEN DELETE (1,ERR=110,IOSTAT=ERR) CALL COMMUNICATE RETURN ENDIF 40 READ (1,1001,END=105,ERR=110,IOSTAT=ERR) LEV,EVENT IF (EVENT(1:15).EQ.USER) GO TO 30 UNLOCK (1) 100 PRINT 1002,'You have no appointments.' RETURN 105 PRINT 1002,'You have no such appointment.' 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 NOTFOUND,(100,105) PRINT 1003,ERR CALL EXIT ENDIF 1000 FORMAT (' ') 1001 FORMAT (Q,A) 1002 FORMAT (' ',A/) 1003 FORMAT ('0Error',I3,' on the Reminder Event File.'/) END SUBROUTINE SHOW IMPLICIT INTEGER (A-Z) CHARACTER*80 EVENT COMMON /EVENT_/ LEV,EVENT CHARACTER*15 USER COMMON /USERNAME/ USER 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 - 16 EVENTS(APPTS)(1:LEV-16) = EVENT(17: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:15).EQ.USER) GO TO 20 100 CLOSE (1) IF (APPTS.EQ.0) THEN PRINT 1002,BUFFER(1:BLEN)//'. You have no appointments.' PRINT 1001 RETURN ELSE IF (APPTS.EQ.1) THEN PRINT 1002,BUFFER(1:BLEN)//'. You have one appointment:' ELSE IF (APPTS.GT.1) THEN CALL SYS$FAO('. You have !SL appointments:', 1 BLEN2,BUFFER(BLEN+1:),%VAL(APPTS)) BLEN = BLEN + BLEN2 PRINT 1002,BUFFER(1:BLEN) CALL SORT_EVENTS ENDIF DO I=1,APPTS CALL SHOW_2(EVENTS(I)(1:LEVS(I)),TIMES(I)/10000) ENDDO PRINT 1000 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,ERR CALL EXIT ENDIF 1000 FORMAT (Q,A) 1001 FORMAT (1X,A) 1002 FORMAT ('0 ',A) 1003 FORMAT ('0Error',I3,' 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*6 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)) D = INDEX(DAY,' ') - 1 CALL SHOW_3(DAY(:D),EVENT) ELSE DATE(5:6) = EVENT(1:2) DATE(4:4) = ' ' DATE(1:1) = EVENT(4:4) DATE(2:2) = CHAR(ICHAR(EVENT(5:5))+32) DATE(3:3) = CHAR(ICHAR(EVENT(6:6))+32) 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' ) COL = 16 - LEN(TEXT) IF (EVENT(16:16).EQ.' ') THEN IF (LEN(EVENT).LE.16) THEN PRINT 1000,TEXT,EVENT(11:15) ELSE PRINT 1000,TEXT,EVENT(11:15),EVENT(17:) ENDIF ELSE IF (LEN(EVENT).LE.16) THEN PRINT 1000,ON//TEXT,EVENT(11:15)//OFF ELSE PRINT 1000,ON//TEXT,EVENT(11:15),EVENT(17:)//OFF ENDIF ENDIF 1000 FORMAT ('0',T,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*80 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 STATUS = SYS$BINTIM(EVENT(17:23)//'19'//EVENT(24:31),TIME) 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 IMPLICIT INTEGER (A-Z) PARAMETER ( CLI$_DEFAULTED = '3FD21'X ) 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*15 USER COMMON /USERNAME/ USER LOGICAL USER_IS_SCHEDULER CALL USER_HAS_PRIV(' ') USER = USERNAME(1:UNLEN) IF (.NOT.CLI$PRESENT('LOGIN')) THEN IF (CLI$PRESENT('SCHEDULER').EQ.CLI$_DEFAULTED) THEN IF (USER_IS_SCHEDULER(USERNAME(1:UNLEN))) THEN PRINT 1000 READ 1001,UNLEN,USERNAME IF (UNLEN.GT.0) THEN CALL STR$UPCASE(USERNAME,USERNAME) USER = USERNAME(1:UNLEN) ENDIF ENDIF ENDIF ENDIF 1000 FORMAT (/'$ User: ') 1001 FORMAT (Q,A) END LOGICAL FUNCTION USER_IS_SCHEDULER(USERNAME) IMPLICIT INTEGER (A-Z) CHARACTER*(*) USERNAME CHARACTER*128 SCHEDULER USER_IS_SCHEDULER = .FALSE. CALL CLI$GET_VALUE('SCHEDULER',SCHEDULER) COL = INDEX(SCHEDULER,' '//USERNAME//' ') USER_IS_SCHEDULER = COL .NE. 0 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_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 COMMON /SYSTIME_/ DATE,SYSTIME(2) IF (LEGAL_INTEGER(FIELD1)) THEN DATE = FIELD1 // '-' // FIELD2 // '-19' // FIELD3 ! 10 DEC 83 ELSE DATE = FIELD2 // '-' // FIELD1 // '-19' // 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 = INDEX(DAY,' ') - 1 CALL IDATE(M,D,Y) MONTH = MONTHS(M) LM = INDEX(MONTH,' ') - 1 STATUS = SYS$FAO('It is !AS, !AS !SL at !AS',BLEN,BUFFER, 1 DAY(:LD),MONTH(:LM),%VAL(D),NOW) 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 CALL EXIT END