
c
c	Daily Print Appointment subroutine
c
c
c	Input: 
c       Command - 84 characters;  Format: PR [mmddyy>MMDDYY [Outdevice]]
c
c	Output:
c		appointments are output on the specified output manner.
C		If no output is specified, it is directed to SYS$PRINT.
C		Allowed output keywords include
C
C					LQ        DTC$PRINT_LQ (SYS$PRINT)
C					PRint     DTC$PRINT (SYS$PRINT)
c					SCratch   SCRATCH.FIL 
C					TErminal  Current terminal
C					TT:	  Current terminal
C
C		Only the first two letters of any keyword are required.
C		If DTC$PRINT does not exist, the output is directed to 
C		SYS$PRINT.
C
C	James G. Downward
C	KMS Fusion, Inc
C	P.O. Box 1567
C	Ann Arbor, Mich. 48196
C	(313)-769-8500
C	15-Jul-1984
c-----------------------------------------------------------------------
c
	OPTIONS/NOI4

	SUBROUTINE DTC_PRINT(Command)

c
c	Declarations:
c
	CHARACTER*1 	Cesc,Cnull,Cbell
	CHARACTER*4 	Cbold, Cnorm
	CHARACTER*6	Cfile_Date		!
	CHARACTER*9	Cdate1			! First date (if present)
	CHARACTER*9	Cdate2			! 2nd date if present
	CHARACTER*10 	Cbuf			!
	CHARACTER*20	Cout_File
	CHARACTER*60	Cinrec			!
	CHARACTER*60	Coutput			! to direct output 
	CHARACTER*84	Command			!
	CHARACTER*80 	Cline
	
	BYTE		FNAME(60)
	BYTE		Ldate1(9),Ldate2(9)	! The two dates
	LOGICAL*1	Lterm			! If output to terminal is true
	LOGICAL*1	Ldelete			! If file deleted on output
	INTEGER*2	FNSZ
	INTEGER*2	ID			!	Julian Day
	INTEGER*2	IM			!	Julian Month
	INTEGER*2	IYE			!	Julian Year
	INTEGER*2	RDSPFG          ! flag to rev sense of dsply of time
	INTEGER*2	CTLFG           !  misc control flags here
	INTEGER*2	IDYR,IDMO,IDDY	
	INTEGER*4	Ilength			!
	COMMON/DEFDAT/	IDYR,IDMO,IDDY
	common/ctls/	rdspfg,ctlfg,Check_Type
	COMMON  /Constants/	Cesc,Cbell,Cnull,Cbold,Cnorm
	COMMON/FN/	FNSZ,FNAME		! Pass file name

c
c	Initialize:
c

	IM=IDMO					! Set current dflt month
	ID=IDDY					! day
	IYE=IDYR				! and year

	Cdate1= ' '				! be sure we always start
	Cdate2= ' '				! off with a clean slate
	Coutput = ' '				!
	READ(Cdate1,'(9A1)')Ldate1		!
	READ(Cdate1,'(9A1)')Ldate2		!

c
c		Parse that line!
c
C    Erase any error messages on line 24
C
	WRITE(*,9998)Cnull//Cesc//'[24;1H'//Cesc//'[K'//Cesc//'[23;1H'

	Cline=Command(1:80)			! Grab/shorten command line
	CALL DTC_Clean_Up_Line(Cline)		! remove mult spaces, etc
	CALL String_Length(Cline,Ilength)	!


	Ispc=INDEX(Cline(1:Ilength),' ')	! Find first space
 	IF(Ispc .EQ.0)		THEN		! If for some reason no command
	  Ilength=0				!   on line here (there should
	  GOTO 5				!   but who cares), use default
	END IF					!   date and print
	Cline=Cline(Ispc+1:)			! Remove the 'Print' command
	CALL String_Length(Cline,Ilength)	! Find new length
5	IF(Ilength.EQ.0)	THEN		! No command on line so set in
	  WRITE(Cdate1,10)  Idyr,Idmo,Iddy	!   the default date for both
10	  FORMAT(I2.2,I2.2,I2.2)		!
	  WRITE(Cdate2,10)  Idyr,Idmo,iddy	!   both hi and low dates
	  Coutput=' '				!
	  GOTO 100				!   Go print dates
	END IF


	Isplt=INDEX(Cline(1:Ilength),'>')
	IF(Isplt.EQ.Ilength)	      GOTO 8050 ! Date missing, warn user
	IF(Isplt.GT.0)			THEN	! If '>' present then two dates
	  Cdate1=Cline(1:Isplt-1)		!   Got first date
  	  IF(Cdate1(1:1).LT.'0'  .OR.		!   If date does not start with
     -	       Cdate1(1:1).GT.'9')     GOTO 8070!   Warn if invalid date format
	  IF(Cline(Isplt+1:Isplt+1).NE. ' ') THEN!  If no space after the '>'
	    Cline=Cline(Isplt+1:)		!     use 2nd half of line
	    Ilength=Ilength-Isplt+1		!     xfer the correct length
	  ELSE					!   Else If spc follows the '>'
	    Cline=Cline(Isplt+2:)		!   We striped mult spaces
	    Ilength=Ilength-Isplt		!   so this is safe operation
	  END IF				! Now have first date if any
	  IF(Ilength.EQ.0)	      GOTO 8050 ! Date missing, warn user

	  Ispc=INDEX(Cline(1:Ilength),' ')	! Find next seperator
	  IF(Ispc.EQ.0) Ispc=Ilength+1		! If missing, use dnd of lne
	  Cdate2=Cline(1:Ispc-1)		! Now have second date
  	  IF(Cdate2(1:1).LT.'0'  .OR.		!   or do we?, Check to see if 
     -	     Cdate2(1:1).GT.'9')       GOTO 8070!   its legal
	  IF(Ispc.LT.Ilength)		THEN	!  also may have output string
	    Coutput = Cline(Ispc+1:)		!
	  END IF
	ELSE					! Else just one date and output
	  Ispc=INDEX(Cline(1:Ilength),' ')	! Find space seperator
	  IF(Ispc.EQ.0) Ispc=Ilength+1		! If missing, use end of lne
	  IF(Ispc-1.GT.LEN(Cdate1))	THEN	! If date string too long
	    Coutput=Cline(1:Ispc-1)		!   must be output data
	  ELSE					! Else assume is date string
	    Cdate1=Cline(1:Ispc-1)		!   Just one date, the first
	    IF(Ispc.LT.Ilength)		THEN	!   and if stuff still on the 
	      Coutput = Cline(Ispc+1:)		!   line, use it as output param
	    END IF				!
	    IF(Cdate1(1:1).LT.'0'  .OR.		!   If date does not start with
     -	       Cdate1(1:1).GT.'9')	THEN	!     a number, it is not a date
	       Coutput=Cdate1(1:Ispc-1)		!     so make it the output parm
	       WRITE(Cdate1,10)  Idyr,Idmo,Iddy	!     & set dflt date
	       WRITE(Cdate2,10)  Idyr,Idmo,Iddy	!     & set dflt date
	       GOTO 100				!     and go off to print
	    END IF				!   End if
	 END IF					!  End if
	 Cdate2=Cdate1				!  Set default date if only one

	END IF					! End if


	CALL String_Length(Cdate1,Ilen1)	! Now convert date strings
	Call String_Length(Cdate2,Ilen2)	! to valid logicals for
	READ(Cdate1(1:Ilen1),'(<Ilen1>A1)')(Ldate1(I),I=1,Ilen1) ! cnvt to general
	READ(Cdate2(1:Ilen2),'(<Ilen2>A1)')(Ldate2(I),I=1,Ilen2) ! string
	CALL Cnvt_To_MMDDYY(Ldate1,Ier)
	IF(Ier.NE.0)		      GOTO 8090	! Bad date formats
	CALL Cnvt_to_MMDDYY(Ldate2,Ier)
	IF(Ier.NE.0)		      GOTO 8090	! Bad date format
	WRITE(Cdate1(1:6),'(6a1)')(Ldate1(I),I=1,6)
	WRITE(Cdate2(1:6),'(6a1)')(Ldate2(I),I=1,6)

	Cdate1=Cdate1(5:6)//Cdate1(1:4)		! Transpose to YYMMDD format
	Cdate2=Cdate2(5:6)//Cdate2(1:4)		!
100	Continue

c	write(*,50) Cdate1,Cdate2,Coutput
c50	format(' *',A,'*',/,' *',A,'*',/,' *',A,'*',/,/)



C  Now we have starting and stopping dates, lets open the file
C  and print out any dates there
c



	Open (unit	=1,
     -	      file	=FNAME,
     -	      status	='OLD',
     -        form	='FORMATTED',
     -	      READONLY,
     -	      ERR=8020)

	   Lterm=.FALSE.				! Assume writing to file
	   Cout_file='LP.LIS'				!
	IF(Coutput(1:2) .EQ. '  ')		THEN 	! If null, dflt to PRINT
	   CONTINUE					!
	ELSE IF(Coutput(1:2) .EQ. 'TT')		THEN	! Do not open file 
	   Lterm=.TRUE.					!
	ELSE IF(Coutput(1:2) .EQ. 'TE')		THEN	!
	   Lterm=.TRUE.					!
	ELSE IF(Coutput(1:2) .EQ. 'SC')		THEN	! Use scratch file
	  Cout_File='SCRATCH.FIL'			!  with this name
	  Ldelete=.FALSE.				!  do not delete 
	ELSE IF(Coutput(1:2) .EQ. 'PR')		THEN 	! Output to SYS$PRINT
	  CONTINUE					!
	ELSE IF(Coutput(1:2) .EQ. 'LQ')		THEN	! Use letter Qual pntr
	  CONTINUE					!
	ELSE						!
	  GOTO	8110					! If bad choice
	END IF

	IF (.NOT. Lterm)			THEN	! if output not to term
	  OPEN(Unit	=2,
     -	       File	=Cout_File,
     -	       Status	='Unknown',
     -	       Carriagecontrol='LIST',
     -         ERR	=8150)
	  WRITE(2,200) Cdate1(3:4),Cdate1(5:6),Cdate1(1:2),
     -                 Cdate2(3:4),Cdate2(5:6),Cdate2(1:2)
200	  FORMAT(' ',T30,'DTC Appointment List',/,
     -	         ' ',T30,A,'/',A,'/',A,'/',' - ',A,'/',A,'/',A,/,/)
	ELSE						! Else if to a terminal
	  CALL PAGE
	  WRITE(*,200) Cdate1(3:4),Cdate1(5:6),Cdate1(1:2),
     -                 Cdate2(3:4),Cdate2(5:6),Cdate2(1:2)	
	END IF

1000	read(1,1200,end=1400) ihy,ihm,ihd,iht,Cinrec
1200	format(3i2,i3,A)
	WRITE(Cfile_Date,'(3I2.2)')Ihy,Ihm,Ihd
c	WRITE(Cbuf(1:3),'(I3.3)')Iht
c	WRITE(*,1201)Ihd,ihm,ihy,Cbuf(1:2),Cbuf(3:3),Cinrec
c1201	FORMAT('  *'I2.2,'/',I2.2,'/',I2.2,2X,A,':',A,'0',2X,A)
c	WRITE(*,1202)CFILE_DATE,CDate1(1:6),Cdate2(1:6)
c1202	format(' **',a,3x,a,3x,a)
	IF(Cfile_Date.LT.Cdate1(1:6)  .OR.		! Only print if in range
     -     Cfile_date.GT.Cdate2(1:6))	       GOTO 1000!
	WRITE(Cbuf(1:3),'(I3.3)')Iht
	CALL String_Length(Cinrec,J)
	IF(Lterm)				THEN	! If output to terminal
	  WRITE(*,1210)Ihm,ihd,ihy,Cbuf(1:2),Cbuf(3:3),Cinrec(1:J)
1210	  FORMAT(' 'I2.2,'/',I2.2,'/',I2.2,2X,A,':',A,'0',2X,A)
	ELSE
	   WRITE(2,1210)Ihm,ihd,ihy,Cbuf(1:2),Cbuf(3:3),Cinrec(1:J)	
	END IF

	goto 1000

1400	continue	! no more appointments left in file.
	IF(Lterm) WRITE(*,1410)Cesc,Cbold,Cnorm,Cesc
1410	FORMAT(' ',/,' ',A,'[24;1HPress ',A,'RETURN',A,' to continue',
     -	        A,'[23;1H')
	CLOSE(1)
	IF(.NOT. Lterm)				THEN	! If output not to term
	  IF(Coutput(1:2) .EQ. 'SC')		THEN
	     CLOSE(Unit=2,DISPOSE='KEEP')
	   ELSE IF(Coutput(1:2) .EQ. 'PR'  .OR.		!
     -             Coutput(1:2) .EQ. '  ')	THEN	!
	     CLOSE(Unit=2,DISPOSE='PRINT/DELETE')	! PRINT/DELETE file
	   ELSE IF(Coutput(1:2) .EQ. 'LQ')	THEN	! If LQ, ask system to
	     CLOSE(Unit=2,DISPOSE='KEEP')		!
	     CALL LIB$SPAWN('$LQ/DEL '//Cout_File)	!  print/delete it
	   END IF
	END IF

	GOTO 9999


8000	WRITE(*,8010)Cnull,Cesc,Cesc
8010	FORMAT(A,A,'[24;1HDTC -- Invalid date format, Try again',
     -         A,'[23;1H',$)
	GOTO 9999
8020	WRITE(*,8025)Cnull,Cesc,(Fname(I),I=1,fnsz),Cesc
8025	FORMAT(A,A,'[24;1HDTC -- Appointment file can not be read: ',
     -	       <Fnsz>A1,A,'[23;1H',$)
	RETURN
8030	WRITE(*,8040)Cnull,Cesc,Cesc
8040	FORMAT(A,A,'[24;1HDTC -- Invalid print command format',
     -         A,'[23;1H',$)
	GOTO 9999

8050	WRITE(*,8060)Cnull,Cesc,Cesc
8060	FORMAT(A,A,'[24;1HDTC -- Expected second date is missing',
     -         A,'[23;1H',$)
	GOTO 9999
8070	WRITE(*,8080)Cnull,Cesc,Cesc
8080	FORMAT(A,A,'[24;1HDTC -- Invalid date format. ',
     -             'Dates must start with numbers',A,'[23;1H',$)
	GOTO 9999
8090	WRITE(*,8100)Cnull,Cesc,Cesc
8100	FORMAT(A,A,'[24;1HDTC -- Invalid month name. ',
     -             'Use Jan, Feb, Mar, ... Dec.',A,'[23;1H',$)
	GOTO 9999

8110	WRITE(*,8120)Cnull,Cesc,Cesc
8120	FORMAT(A,A,'[24;1HDTC -- Invalid print choice. ',
     -             'Use TT:, TERM, PRINT, or LQ',A,'[23;1H',$)
	GOTO 9999

8150	WRITE(*,8160)Cnull,Cesc,Cesc
8160	FORMAT(A,A,'[24;1HDTC -- Error opening output print file',
     -             '[23;1H',$)
	GOTO 9999

	
9999	WRITE(*,9998)Cnull//Cesc//'[23;10H'//Cesc//'[K'
9998	FORMAT(A,$)
	RETURN
	end


C Cnvt_to_MMDDYY
C
c Function:  Edit a line starting with a date of form
c 			mm/dd/yy, mmddyy, or dd-MMM-yy
c into one with a date of form
c 			mmddyy
c
C
C		CALL Cnvt_To_MMDDYY(Line)
C
C		Where 	BYTE	Line(9)
C
C Line servers both as input and output
C Converted from G. Everhart's DTC version
C-

	OPTIONS /NOI4
	Subroutine Cnvt_to_MMDDYY(line,Ier)
	Byte line(9),work(9)
	byte l1,l2,l3

	Ier=0					! assume success
	do 1 n=1,6
	   if(line(n).eq.'/')	goto 100	! If in mm/dd/yy form
	   if(line(n).eq.'-')	goto 200	! If in dd-mmm-yy form
1	continue
	Return					! Format Ok, Return leaving
						!  the line alone
C ------------------------------
100	continue				! convert mm/dd/yy  into mmddyy
	if(line(2).eq.'/') then
	work(1)='0'
	work(2)=line(1)
	k=3
	else
	work(1)=line(1)
	work(2)=line(2)
	k=4
	end if
	if(line(k+1).eq.'/')then
	work(3)='0'
	work(4)=line(k)
	kk=k+2
	else
	work(3)=line(k)
	work(4)=line(k+1)
	kk=k+3
	end if
	work(5)=line(kk)
	work(6)=line(kk+1)
c set up pointers to next element of line (i.e., kkk)
c for copy of rest of stuff.
	kkk=kk+2
	goto 300
C ----------------------------
200	continue				! Convert dd-mmm-yy into mmddyy
	if(line(2).eq.'-')then
	work(3)='0'
	work(4)=line(1)
	k=3
	else
	work(3)=line(1)
	work(4)=line(2)
	k=4
	end if
	work(5)=line(k+4)
	work(6)=line(k+5)
	kkk=k+6
c now have pointers, but month needs to be filled in.
c note we assume year always is entered as 2 digits
c and month is 3 chars...
	if(line(k+3).ne.'-')then
	work(1)=0
c zero stuff to pass if not 3 char month
	work(2)=0
	goto 300
	end if
	kk=k+3
	do 220 n=k,kk
	nn=line(n)
c mask off 32 (dec) bit to
c make letters uppercase
	nn=nn.and.223
	line(n)=nn
220	continue
	l1=line(k)
	l2=line(k+1)
	l3=line(k+2)
c decode months the hard way
	work(1)='0'
	work(2)='0'
	IF(L1.EQ.'J'.AND.L2.EQ.'A')THEN
		WORK(2)='1'
		GOTO 300
	ELSE IF(L1.EQ.'F')THEN
		WORK(2)='2'
		GOTO 300
	ELSE IF(L1.EQ.'M'.AND.L2.EQ.'A'.AND.L3.EQ.'R')THEN
		WORK(2)='3'
		GOTO 300
	ELSE IF(L1.EQ.'A'.AND.L2.EQ.'P')THEN
		WORK(2)='4'
		GOTO 300
	ELSE IF(L1.EQ.'M'.AND.L2.EQ.'A'.AND.L3.EQ.'Y')THEN
		WORK(2)='5'
		GOTO 300
	ELSE IF(L1.EQ.'J'.AND.L2.EQ.'U'.AND.L3.EQ.'N')THEN
		WORK(2)='6'
		GOTO 300
	ELSE IF(L1.EQ.'J'.AND.L2.EQ.'U'.AND.L3.EQ.'L')THEN
		WORK(2)='7'
		GOTO 300
	ELSE IF(L1.EQ.'A'.AND.L2.EQ.'U')THEN
		WORK(2)='8'
		GOTO 300
	ELSE IF(L1.EQ.'S')THEN
		WORK(2)='9'
		GOTO 300
	ELSE IF(L1.EQ.'O')THEN
		WORK(1)='1'
		GOTO 300
	ELSE IF(L1.EQ.'N')THEN
		WORK(1)='1'
		WORK(2)='1'
		GOTO 300
	ELSE IF(L1.EQ.'D')THEN
		WORK(1)='1'
		WORK(2)='2'
		GOTO 300
	ELSE
		Ier=-1				! Unrecognized month, warn user
c		WORK(1)=0
c		WORK(2)=0
	END IF
	goto 300
300	continue
c common clean-up & return
	do 320 n=1,6		! Copy edited string back for further work
320	line(n)=work(n)
	Line(7)=' '
	Line(8)=' '
	Line(9)=' '
	return
	end
