byte line(84) call dtc_Print(Line) end c----------------------------------------------------------------------- c c Daily Print Appointment subroutine c c c Input: c line - 72 bytes; Format: PR [mmddyy>MMDDYY [Outdevice]] c c Output: c appointments are output on the specified output C device or to DTC$PRINT if non specified. If DTC$PRINT C does not exist, the output is directed to 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(line) 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*60 Coutput ! to direct output CHARACTER*84 Cbuf CHARACTER*80 Cline BYTE LINE(1) ! input line BYTE TEMP(2) ! tmp string converting array BYTE FNAME(60) BYTE Ldate1(9),Ldate2(9) ! The two dates 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 WRITE(Cline,'(80A1)')Line ! Convert to a string ISTATUS=LIB$GET_FOREIGN(Cline,,Nchar) CBUF='DTC.DAT' READ(CBUF(1:7),'(7A1)')(FNAME(I),I=1,7) Fnsz=7 CALL DTC_Clean_Up_Line(Cline) ! 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,Iddy,Idmo ! the default date for both 10 FORMAT(I2.2,I2.2,I2.2) ! WRITE(Cdate2,10) Idyr,Iddy,idmo ! 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,Iddy,Idmo ! & set dflt date END IF ! End if END IF ! End if Cdate2=Cdate1 ! Set default date END IF ! End if 100 continue CALL String_Length(Cdate1,Ilen1) ! Now convert date strings Call String_Length(Cdate2,Ilen2) ! to valid logicals for READ(Cdate1(1:Ilen1),'(A1)')(Ldate1(I),I=1,Ilen1) ! cnvt to general READ(Cdate2(1: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) Cdate2=Cdate2(5:6)//Cdate2(1:4) 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 c IF (Idummy.eq.0) call exit !***** Open (unit=1,file=FNAME,status='OLD',form='FORMATTED', - READONLY,ERR=8020) 1000 read(1,1200,end=1400) ihy,ihm,ihd,iht,(line(k),k=1,60) 1200 format(3i2,i3,60a1) 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),(line(k),K=1,60) c1201 FORMAT(' *'I2.2,'/',I2.2,'/',I2.2,2X,A,':',A,'0',2X,60A1) c WRITE(*,1202)CFILE_DATE,CDate1(1:6),Cdate2(1:6) 1202 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 WRITE(*,1210)Ihm,ihd,ihy,Cbuf(1:2),Cbuf(3:3),(line(k),K=1,60) 1210 FORMAT(' 'I2.2,'/',I2.2,'/',I2.2,2X,A,':',A,'0',2X,60A1) goto 1000 1400 continue ! no more appointments left in file. CLOSE(1) 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: ', - 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 9999 WRITE(*,9998)Cnull//Cesc//'[23;10H' 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