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<Iwdth>)')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: ',
     -	       <Fnsz>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: ',
     -	       <Fnsz>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,<Fnsz>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
