c----------------------------------------------------------------------- c c Daily Appointment subroutine c c part of Mitch Wyle's DTC program c c Input: c line - 72 bytes; Format: D [mmddyy [hh:mm>HH:MM [appointment]]] c c Output: c display screen (see below) C C Modified: 10-Jun-1984 Extensive modifications to C 1. improve parsing and C error handling C 2. Allow more ROBUST time C handling C 3. Keep display on the VMS C terminal screen C 4. Use CHARACTER data where C it simplifies life C 5. Fix up screen pointing C 6. Special treatment for C 'TODAY' and 'CHECK' C 7. Handle ^Z correctly c c----------------------------------------------------------------------- c OPTIONS/NOI4 SUBROUTINE day(line) c c Declarations: c CHARACTER*1 Cesc,Cnull,Cbell CHARACTER*4 Cbold, Cnorm CHARACTER*84 Cbuf CHARACTER*80 Cline byte line(1) ! input line byte temp(2) ! temporary string converting array byte appoin(60) ! appointment string byte work(60) ! scratch array for handling scheduling byte esc ! escape character LOGICAL*1 Lsort_Flag integer id ! Julian Day integer im ! Julian Month integer iye ! Julian Year integer rdspfg ! flag to rev sense of display of time integer ctlfg ! misc control flags here INTEGER*2 Check_Type ! Control special checks ! =0 No action ! =1 'TODAY' Limit display & exit ! =2 'CHECK' No display, prnt msg ! =3 'QCHECK' Set Symbol DTC_Apmt ! to apmt number for VPW INTEGER IDYR,IDMO,IDDY ! INTEGER*2 Number_of_Appt ! Number of 1/2 hour slots reserved COMMON/DEFDAT/IDYR,IDMO,IDDY common/ctls/rdspfg,ctlfg,Check_Type COMMON /Sort/ Lsort_Flag COMMON /Constants/ Cesc,Cbell,Cnull,Cbold,Cnorm byte fname(60) integer fnsz common/fn/fnsz,fname c c Initialize: c c iterm = 6 ! Output terminal unit number esc = "033 ! Escape character IM=IDMO ID=IDDY IYE=IDYR c c Parse that line! c c c Was there a D on the front? If so, trim it off: c C Should we do a prescan of file to see how many (if any) appointments C (1/2 hour time slots) for the current date? IF (Check_Type.GE.0) THEN CALL PRE_SCAN(Id,Im,IYE,Number_Of_Appt,Check_type) IF(Number_Of_Appt.EQ.0 .AND. ! Tell user nothing going - Check_Type.EQ.1) GOTO 8100 ! on on this date IF(Check_Type.EQ.2) GOTO 8200 ! Tell user the bad news IF(Check_Type.EQ.3) THEN ! Just set symbol/exit IF(Number_Of_Appt.LT.0) THEN ! Compute width of string Iwdth=2 ! to output ELSE IF(Number_Of_Appt .GT.-1 .AND. ! - Number_Of_Appt .LT.10) THEN ! Iwdth=1 ! ELSE IF(Number_Of_Appt .GE.10 .AND. ! - Number_Of_Appt .LT.100) THEN ! Iwdth=2 ! ELSE IF(Number_Of_Appt .GE.100 .AND. ! - Number_Of_Appt .LT.1000) THEN ! Iwdth=3 ! ELSE IF(Number_Of_Appt .GE.1000.AND. ! - Number_Of_Appt.LT.10000) THEN ! Iwdth=4 ! ELSE ! Iwdth=5 ! END IF ! WRITE(Cbuf(1:Iwdth),'(I)')Number_Of_Appt! Encode the number Istatus=LIB$SET_SYMBOL('DTC_APMT',Cbuf(1:Iwdth),1) RETURN ! All done END IF END IF IDMX=0 If ( line(1) .eq. 'D' .or.line(1).eq.'d') then Do i=1,70 line(i) = line(i+2) END DO End If c c If the date was specified in command line then c set id, im and iye to the right values: c IDL=0 CALL DATMUN(LINE) Do i=1,6 IDL=I If ( ( line(i) .gt. '9' ) .or. - ( line(i) .lt. '0' ) ) goto 33 END DO c Six numbers in a row, so decode into numeric date: temp(1) = line(1) temp(2) = line(2) decode ( 2 , 2 , temp ,ERR=8000) im temp(1) = line(3) temp(2) = line(4) decode ( 2 , 2 , temp,ERR=8000) id temp(1) = line(5) temp(2) = line(6) decode ( 2 , 2 , temp,ERR=8000) iye IDDY=ID ! Set new default date IDYR=IYE IDMO=IM 2 Format(i2) c c Now discard the date part from line string: c Do I=1,63 line(i) = line(i+7) END DO GOTO 40 33 continue IF(IDL.LE.0.OR.IDL.GT.6)GOTO 40 ! If have date first IF(Line(IDL) .EQ. ':') GOTO 40 ! Most likely its a time C Well we have a non-numeric character in the first 6 collums. Clearly C it isn't a date, and since it is not a ':' it isn't the start of a C time string. So make the delimeter position the start of the line C by chopping all that came earlier (and pray..) C DO I=1,63 ! Chop, chop LINE(I)=LINE(I+IDL) END DO C Now with a modicum of luck we have the date set, and have stripped the C line back to include only the time and the appointment string. 40 CONTINUE WRITE(Cline,'(84a1)')Line c c Clear the screen, move the cursor to the top part, c set up appointments screen: c Cbuf=Cesc//'<'//Cesc//'[2J'//Cesc//'[1;1H' write(*,5) Cbuf(1:12),esc,'#','3',im,id,iye 5 format(x,A,3a1,10X,'Appointments For ',i2.2,'/',i2.2,'/',i2.2) Cbuf=Cesc//'[2;1H' write(*,5) Cbuf(1:6),esc,'#','4',im,id,iye Do i=8,16 If ( i .gt. 12 ) then j = i - 12 Else j = i End If write(*,6) j 6 format(x,i2.2,':00 -') write(*,7) j 7 format(x,i2.2,':30 -') END DO IF(Check_Type.EQ.0) write(*,9)Cesc 9 format(x,'Evening:',/,79('='),/,' Command: ',A,'[3;10H') IF(Check_Type.EQ.1) write(*,10) 10 FORMAT(x,'Evening:') c c Was a time input? Did it accompany an appointment string? c Why do fools fall in love? c IDMX=0 if(line(1).eq.'e')LINE(1)='E' If (((line(1).le.'9') .and. - (line(1).ge.'0')) .OR. - LINE(1).EQ.'E') THEN c c Parse the time string, rock the Casbah: c Iangle_loc=6 ! We might find one here IF(LINE(1).NE.'E') THEN ! If not 'EV' command If ( line(2) .eq. ':' ) then ! Short hour form Iangle_Loc=5 ! if short look sooner temp(1) = '0' temp(2) = line(1) decode ( 2 , 2 , temp,ERR=8000 ) iht if ( iht .lt. 5 ) THEN ! If from 1-5 iht = iht + 12 ! make pm ELSE IF(iht .GE. 5 .AND. - iht .LT. 8) THEN iht=17 ! Force 5 pm END IF IHHR=IHT iht = iht * 10 If ( line(3) .eq. '3' ) iht = iht + 3 Else If ( line(3) .eq. ':' ) then temp(1) = line(1) temp(2) = line(2) decode ( 2 , 2 , temp,ERR=8000) iht if ( iht .lt. 5 ) THEN ! If from 1-5 iht = iht + 12 ! make pm ELSE IF(iht .GE. 5 .AND. - iht .LT. 8) THEN iht=17 ! Force 5 pm END IF IHHR=IHT iht = iht * 10 If ( line(4) .eq. '3' ) iht = iht + 3 End If END IF C HANDLE "EV" MODIFIER FOR EVENING APPOINTMENTS IF(LINE(1).EQ.'E') THEN ! If 'Evening' cmd IHT=170 ! 170 corresponds to 5pm Iangle_Loc=1 ! Can't have '>' after 5 END IF ! IHMX=1 IDHR=0 IOMX=6 IF (LINE(Iangle_Loc).EQ.'>') THEN C IF(Line(Iangle_Loc+2).EQ.':') THEN ! If 2 ranges exist dup Line(Iangle_Loc)='0' ! msg after extracting Iangle_loc=Iangle_Loc-1 ! 2nd range of HH:MM END IF DECODE(2,2,LINE(Iangle_Loc+1),ERR=8000)IHMX IF(IHMX.LT.5)IHMX=IHMX+12 DECODE(2,2,LINE(Iangle_Loc+4),ERR=8000)IMMX IF(IMMX.NE.30)IMMX=0 IDHR=(IHMX-IHHR)*2 ! COUNT HALF HOURS IN GIVEN INTERVAL ... IF(IMMX.NE.0)IDHR=IDHR+1! FIND NUMBER ENTRIES TO SHOVE OUT... IF(IHT.NE.(10*IHHR))IDHR=IDHR-1 IDHR=MAX0(1,IDHR) IDMX=IDHR IOMX=12 ! ABOVE CLAMPS POS... NO INVALID ENTRIES PLEASE... END IF c c Now look for space delimiter to trim off the time c of day part, and then extract the appointment: c C USE IOMX SO WE SCAN PAST 2ND RANGE IF ANY... Do io=1,IOMX If ( line(1) .eq. ' ' .OR. ! If found space or null - line(1) .EQ. 0) goto 12 ! exit loop Do i=1,71 line(i) = line(i+1) End Do END DO 12 Continue ! Label to Exit loop c c Was there an appointment string input? c If so, put it in file, and display it on screen. c If not, move cursor to correct time on screen, c then input the appointment, put in file and re-display it. c If ( line(1) .lt. ' ' ) then itemp = iht / 10 if ( itemp .gt. 7 ) itemp = itemp - 7 iy = 2 * itemp + 1 If ( ( ( iht/10 ) * 10 ) .ne. iht ) iy = iy + 1 IF (IY.LE.2) GOTO 914 ix = 11 IF(Iy.GT.21) Iy= 21 call dtcat(ix,iy) Line(1)=' ' ! Make as in cmd mode read(*,13,END=9999) (line(i),i=2,60) c13 format('+',60a1) 13 format(59a1) 914 CONTINUE End If c copy appointment for use later... Do ivx=1,60 work(ivx)=line(ivx) END DO iwy=iye iwm=im iwd=id iwht=iht If ( line(1) .ge. ' ' ) then CLOSE(1) ! GUARANTEE NO FAILURES... C If we are using the 'S' command, ONLY add meetings to the indirected C files, not to the current (control) file. IF(CTLFG.NE.1) THEN Open ( unit=1,file=FNAME,status='UNKNOWN',form='FORMATTED', - ACCESS='APPEND',ERR=8020) IHTSV=IHT IF(IDMX.LT.1)IDMX=1 DO IVX=1,IDMX Isum=Iye+im+id+iht IF(Isum.GT.0) THEN Lsort_Flag=.TRUE. ! Show must sort on exit write(1,14,ERR=15) iye,im,id,iht,(line(i),i=1,60) END IF GOTO 16 ! 15 WRITE(*,8025)Cnull,Cesc,(Fname(I),I=1,fnsz),Cesc 16 IF((IHT/10)*10.EQ.IHT)THEN ! If IHT is even hour, add in IHT=IHT+3 ! the half hour. ELSE ! else, if it is a half hour, IHT=IHT+7 ! round up to next hour END IF END DO IHT=IHTSV 14 format(3i2.2,i3.3,60a1) close(1) END IF End If End If nunit=1 Open (unit=nunit,file=FNAME ,status='OLD' ,form='FORMATTED', - err=99) 100 continue ! loop back up here to continue reading and ! processing input file: read(nunit,200,end=400) ihy,ihm,ihd,iht,(line(k),k=1,60) 200 format(3i2,i3,60a1) if(ihy.eq.99.and.nunit.eq.1)then nunit=2 c null terminate the filename somewhere c lines with 99 in 1st 2 cols are filenames only... c use = as delimiter of filename line(59)=0 do ii=1,59 if(line(ii).eq.'=')line(ii)=0 END DO if(CTLFG.eq.0) goto 1119 c **** c on scheduling multiple dates via the S function, use this occasion to c add the record to everyone's calendar file. CLOSE(2) Open ( unit=2,file=line,status='OLD',form='FORMATTED', - ACCESS='APPEND',err=1119) IHTSV=IHT iht=iwht IF(IDMX.LT.1)IDMX=1 DO IVX=1,IDMX Isum=Iwy+iwm+iwd+iht IF(Isum.GT.0) THEN Lsort_Flag=.TRUE. write(2,14,ERR=210) iwy,iwm,iwd,iht,(work(i),i=1,60) END IF GOTO 220 210 WRITE(*,8025)Cnull,Cesc,(Fname(I),I=1,fnsz),Cesc 220 IF((IHT/10)*10.EQ.IHT)THEN C IHT IS AN EVEN HOUR ... AD THE HALF HOUR IHT=IHT+3 ELSE C IHT IS A HALF HOUR ... MAKE UP TO NEXT HOUR IHT=IHT+7 END IF END DO IHT=IHTSV close(2) c **** 1119 continue Open(unit=nunit,file=line,status='old',form='formatted', - err=1067) goto 100 end if If ((iye .eq. ihy) .and. (im .eq. ihm) .and. (id .eq. ihd)) then itemp = iht / 10 if ( itemp .gt. 7 ) itemp = itemp - 7 iy = 2 * itemp + 1 If (((iht/10)*10) .ne. iht) iy = iy + 1 IF(IY.LE.2) GOTO 100 !*** ix = 10 IF(Iy.GT.21) Iy = 21 call dtcat(ix,iy) write(*,300) (line(k),k=1,60) 300 format('+',60a1) c call dtcat(1,22) c WRITE(*,305)Cnull,Cesc//'[22;1H' c305 FORMAT(A,A,$) End If goto 100 400 continue ! no more appointments left in file. if(nunit.ne.1)then 1067 continue close(2) nunit=1 goto 100 end if close(1) GOTO 9999 99 CONTINUE OPEN(UNIT =1, - FILE =FNAME, - STATUS ='NEW', - FORM ='FORMATTED', - ERR =8050) CLOSE(1) GOTO 9999 8000 WRITE(*,8010)Cnull,Cesc,Cesc,Cbell 8010 FORMAT(A,A,'[24;1HDTC -- Invalid time format, Try again', - A,'[23;1H',A,$) GOTO 9999 8020 WRITE(*,8025)Cnull,Cesc,(Fname(I),I=1,fnsz),Cesc,Cbell 8025 FORMAT(A,A,'[24;1HDTC -- Appointment file can not be written to: ', - A1,A,'[23;1H',A,$) c RETURN GOTO 9999 8050 WRITE(*,8060)Cnull,Cesc,(Fname(I),I=1,fnsz),Cesc,Cbell 8060 FORMAT(A,A,'[24;1HDTC -- Appointment file can not be created: ', - A1,A,'[23;1H',A,$) GOTO 9999 8100 WRITE(*,8110) Im,Id,Iye 8110 FORMAT(' DTC -- No appointments are scheduled for ', - I2.2,'/',I2.2,'/',I2.2) CALL EXIT c GOTO 9999 8200 WRITE(*,8210)Cbold,Number_of_Appt,Cnorm,Im,Id,Iye,Cbell 8210 FORMAT(' DTC -- You have ',A,I2,A, - ' appointments scheduled for ',I2.2,'/',I2.2,'/',I2.2,A) CALL EXIT c GOTO 9999 9999 IF(Check_Type.EQ.0) THEN WRITE(*,9998)Cnull//Cesc//'[23;10H' ELSE WRITE(*,9998)Cnull//Cesc//'[22;0H' ! Move out of harms way END IF 9998 FORMAT(A,$) RETURN end OPTIONS/NOI4 C C Subroutine Pre-Scan C C This subroutine opens the data file, and counts the number of entries C occurring in the file for a given Day, Month and Year. C C- SUBROUTINE Pre_Scan(Iday,Imonth,Iyear,Number_of_Appt,Check_Type) CHARACTER*1 Cesc,Cnull,Cbell CHARACTER*4 Cbold, Cnorm CHARACTER*6 Cdate CHARACTER*69 Cbuffer BYTE Fname(60) INTEGER*2 Iday,Imonth,Iyear INTEGER*2 Number_of_Appt ! Number of 1/2 hour slots reserved INTEGER*2 Fnsz ! INTEGER*2 Check_Type ! Control special checks ! =0 No action ! =1 'TODAY' Limit display & exit ! =2 'CHECK' No display, prnt msg ! =3 'QCHECK' Set Symbol DTC_Apmt ! to apmt number for VPW COMMON /Constants/ Cesc,Cbell,Cnull,Cbold,Cnorm common/fn/ fnsz,fname WRITE(Cdate,10)Iyear,Imonth,Iday ! Set date string to match 10 FORMAT(3(I2.2)) ! Number_Of_Appt=0 ! Initialize Open (unit =1, ! - file =FNAME, ! - status ='OLD', ! - form ='FORMATTED', ! - READONLY, ! - err =8000) ! 20 READ(1,22,END=7000)Cbuffer ! 22 FORMAT(A) ! IF(Cbuffer(1:6).EQ.Cdate(1:6)) Number_of_Appt=Number_of_Appt+1 GOTO 20 ! 7000 CLOSE(Unit=1) ! RETURN ! 8000 IF(Check_Type.EQ.1) THEN ! If TODAY WRITE(*,8010) Cbold,(Fname(i), i=1,Fnsz),Cnorm 8010 FORMAT(' DTC -- Your appointment file ',A,A1,A,/, - ' does not exist or can not be read') CALL EXIT ELSE IF(Check_Type.EQ.2) THEN ! If CHECK Number_of_Appt=-1 ! very quietly RETURN ELSE IF(Check_Type.EQ.3) THEN ! Show file does not exist Number_of_Appt=-1 ! very quietly RETURN ELSE RETURN END IF END