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----------------------------------------------------------------------- C c Modified 850314 to write day-of-week to daily-appointment screen, c and note current time if current day displayed (reverse video) c CG c SUBROUTINE day ! (line) c c Declarations: c include 'comdtc.inc/nolist' include 'escdtc.inc/nolist' c c byte line(1) ! input line byte appoin(icmln) ! appointment string byte work(icmln) ! scratch array for handling scheduling byte temp(2), ll, ln1, ! temporary string converting array 1 ap1 c byte esc/"033/ ! escape character byte blot/26/ ! ^Z, for entry from display c integer iterm/6/ ! Terminal unit # integer id, idr ! Julian Day integer im, imr ! Julian Month integer iye, iyr ! Julian Year integer idx, imx, iyx, isx ! copies for calling DANY c real*8 daylist(7) / ' Sun', ' Mon', ' Tues', ! uses A6 fmt 1 'Wednes', ' Thurs', ' Fri', ' Satur' / ! 'day' is in format c equivalence (line, ln1), (appoin, ap1) include 'stmtfunc.for/nolist' c Initialize: c c iterm = 6 ! Output terminal unit number c esc = "033 ! Escape character if ((ln1 .and. ucmask) .eq. 'D') 1 call shrink(1, ifnb, lnb) call dtcdatcvt(3) ! Pick off a date value c c ************************** Move the cursor to top of screen and clear it, c ************************** set up appointments display: c call idate(imr, idr, iyr) ! Get today's date c im=idmo id=iddy iye=idyr iyx = iye ! Can be modified c if ((im .eq. imr) .and. 1 (id .eq. idr) .and. 2 (iye .eq. iyr)) then ! Displaying current day c scnds = amax1(secnds(0.), 28801.) ! Get current time (>8 AM) ihalf = mod(ifix(scnds/1800.), 48) ! current half-hour (orig 0) ihour = ihalf/2 ! Current hour ihalf = ihalf - (ihour*2) ! 0 or 1 for half-hour c else ihour = 0 ! Set non-match value endif c call dany (isx, imx, im, iyx) ! Get day-of-week c idx = mod (id + isx - 2, 7) + 1 ! Calc current d/o/w c write(iterm,4) esc,homescrn, esc,clrscrn 4 format('+', 4a, $) write(iterm,5) '+', esc,dhdw1, daylist(idx),im,id,iye 5 format(3a,' Appointments for ', a6,'day, ', 1 i2,'/',i2.2,'/',i2.2) write(iterm,5) ' ', esc,dhdw2, daylist(idx),im,id,iye Do 8 i=8,16 If ( i .gt. 12 ) then j = i - 12 Else j = i End If c if (i .ne. ihour) then ! Check for highlighting write(iterm,6) j 6 format(x,i2,':00 -') write(iterm,7) j 7 format(x,i2,':30 -') else ! must be current hour if (ihalf .eq. 0) then ! Check which half write(iterm,96), esc,revattr, j, esc,resetvattr write(iterm,7) j else write(iterm,6) j write(iterm,97), esc,revattr, j, esc,resetvattr endif c 96 format (x, 2a, i2,':00 -', 2a) 97 format (x, 2a, i2,':30 -', 2a) c endif 8 Continue if (ihour .ge. 17) then ! Highlight 'Evening' line write(iterm,98), esc,revattr, esc,resetvattr else ! Includes display other than today write(iterm,9) end if 9 format(x, 'Evening:', /, x, 78('=')) 98 format(x, 2a, 'Evening: ', 2a, /, x, 78('=')) c ******************* Screen has now been displayed, c ******************* now check rest of line for time and appointment if (ln1 .ne. 0) then ! More characters available? call dtctimcvt(iht, ihmx) ! & a time value ihh1 = (iht+2)/5 ! Adds 1 if trailing 3 ihh2 = (ihmx+2)/5 ! Result is 16 to 35 idmx = max0(ihh2-ihh1, 1) ! 8:00>5:30 c Note: range of h1:00>h1:30 is considered only one scheduling interval, c similarly h(1)>h(2) is an even number, ending just before h(2), c computation forces at least one for interval h1:00>h1:00 ifnb = 0 lnb = 0 ivx = 0 ap1 = 0 ! Clear appointment string do i = 1, icmln c ll = line(i) appoin(i) = ll c if (ll .eq. 0) go to 6789 ! done ivx = i ! Save current length end do 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 and when the band you're in starts playing different tunes, c I'll see you on the dark side of the moon. c 6789 If (ap1 .eq. 0) then ! Empty appointment string c iy = ihh1 - 13 ! Vertical position for half hour ix = 11 call dtcat(ix,iy) write(iterm, 987) blot, esc,'[D' ! write, backspace 987 format ('+', 3a, $) c c !!! close(iterm) c read(5,13,END=914) lapp, work 13 format(q,100a1) c c copy appointment for use later... c ifnb = 0 lnb = 0 ivx = 0 Do i = 1, lapp c ll = work(i) ! fetch character c if (ll .gt. ' ') then if (ifnb .eq. 0) ifnb = i ! Flag first non-blank lnb = i ! Flag last non-blank end if if (ifnb .ne. 0) then ! Copy after first n/b ivx = ivx + 1 appoin(ivx) = ll end if c end do if (ifnb .eq. 0) go to 914 ! Nothing on read either c End If c ivx = min0(ivx, iaptlim) ! ivx = length of string iwy=iye iwm=im iwd=id iwht=iht c close(1) ! add close to guarantee no failures... c 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', 1 carriagecontrol='LIST', access='APPEND') ihtxx=iht do 3005 ixx = 1, idmx write(1,14) iye,im,id,ihtxx,(appoin(i),i=1, ivx) if ((ihtxx/10)*10 .eq. ihtxx) then ihtxx=ihtxx+3 ! IHT is even hour, go to next half hour else ihtxx=ihtxx+7 ! IHT is a half hour ... make up to next hour end if 3005 continue 14 format(3i2.2,i3.3,x,100a1) close(1) End If else ! Empty line (no appointment to add) 914 idmx = 0 ! Use as flag for display only end if c 9876 nunit=1 Open (unit=nunit,file=FNAME ,status='OLD' ,form='FORMATTED', 1 err=99) 100 continue ! loop back up here to continue reading and ! processing input file: read(nunit,200,end=400) ihy, ihm, ihd, iht, iwkln, work 200 format(3i2, i3, q, 100a1) c if ((ihm .eq. 99) .and. (nunit .eq. 1)) then nunit=2 c null terminate the filename somewhere c lines with 99 in 2nd 2 cols are filenames only... c use = as delimiter of filename work(59)=0 ij = 0 do ii=1, iwkln iq=iwkln-ii+1 c go from end of line back to beginning and null trailing blanks c this works even if filename contains spaces in specs. somehow. ll = work(iq) if (ll.eq.'=')work(iq)=0 ! null out any = signs if (ll.gt.' ')goto 5678 end do 5678 continue if (ctlfg .ne. 0) then c on scheduling multiple dates via the S function, use this occasion to c add the record to everyone's calendar file. c close(2) Open (unit=2, file=work, status='OLD', 1 form='FORMATTED', carriagecontrol='LIST', 2 access='APPEND', err=1119) ihtxx=iwht do ixx = 1, idmx write(2,14) iwy,iwm,iwd,ihtxx,(appoin(i),i=1,ivx) if ((ihtxx/10)*10 .eq. ihtxx) then ihtxx=ihtxx+3 ! iht is an even hour ... add the half hour else ihtxx=ihtxx+7 ! iht is a half hour ... make up to next hour end if end do close(2) end if 1119 Open(unit=nunit,file=work,status='old',form='formatted', 1 carriagecontrol='LIST', err=1067) go to 100 c Display appointment if it matches current date else If ((iye .eq. ihy) .and. (im .eq. ihm) 1 .and. (id .eq. ihd)) then iy = min0(max0((((iht+2) / 5) - 13), 3), 22) ! Compute vertical posn c do kk = iaptlim + 1, 1, -1 ! Trim trailing blanks and nulls if (work(kk) .gt. ' ') go to 1066 ! and all that end do kk = 1 ! Line was empty work(1) = blot 1066 ix = 10 if (work(1) .ne. ' ') then ix = 11 ! '12:00 - Appointment' kk = min0(kk, iaptlim) end if call dtcat(ix,iy) write(iterm,300) (work(k),k=1,kk), esc,'[K' ! Erase EOL 300 format('+', a1, 2a, $) End If go to 100 400 continue ! no more appointments left in file. if (nunit .ne. 1) then c 1067 continue close(2) nunit=1 go to 100 c end if c go to 101 ! Common exit code c 99 continue ! Error opening, create empty open(unit=1, file=FNAME, status='NEW', form='FORMATTED', 1 carriagecontrol='LIST') c 101 close(1) call dtcat(1,22) return end