Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FAQ-S.ZIP/MAINMENU.PAS

Pascal/Delphi Source File | 1991-05-04 | 75.3 KB | 2,732 lines

{$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
{$M 65500,0,0 }

unit mainmenu;

interface

uses crt,dos,
     gentypes,configrt,statret,textret,userret,mailret,modem,
     gensubs,subs1,subs2,subs3,windows,chatstuf,mainr1,mainr2,overret1;

var userqr,userlistqr:integer;
    u,uu:userrec;
    totalused,totalidle,totalup,totaldown,totalmins,callsday,
    totaldisk,totalfree,filesizes,x,y,z:real;
    a,b,c:integer;
    totalfiles:integer;
    dofiles:boolean;

function ansiyn (str:string):boolean;
procedure calcuserqr;
procedure calcuserlistqr;
procedure editusers;
procedure zapspecifiedusers;
procedure summonsysop;
procedure offfaq;
procedure listusers;
procedure transfername;
procedure editnews;
procedure delerrlog;
procedure feedback;
procedure settime;
procedure changepwd;
procedure requestraise;
procedure makeuser;
procedure infoformhunt;
procedure donations;
procedure viewsyslog;
procedure delsyslog;
procedure changecon (con:char);
procedure showsystemstatus;
procedure showallforms;
procedure showallsysops;
procedure bbslist;
procedure searchphone;
procedure timebank;
{procedure modifycon;}
procedure readerrlog;
procedure showad;
procedure setlastcall;
procedure removeallforms;
procedure readfeedback;
procedure yourstatus;
procedure topposter;
procedure spacespace (i:integer);

implementation

function ansiyn (str:string):boolean;
var b:boolean;
    c:char;
    str2:string;
    i,ii:integer;

begin
ii:=wherey;
i:=2;
repeat
str2:=str+'? ';
printxy2 (1,ii,^P+str2);
printxy2 (length(str2)+1,ii,^R+'Yes');
printxy2 (length(str2)+6,ii,^R+'No');
if i=1 then begin
ansicolor (31);
printxy2 (length(str2)+1,ii,'Yes');
end;
if i=2 then begin
ansicolor (31);
printxy2 (length(str2)+6,ii,'No');
end;
c:=upcase(readkey);
if c='Y' then i:=1;
if c='N' then i:=2;
if c=#13 then begin
case i of
  1:b:=true;
  2:b:=false;
 end;
end;
until (c=#13);
ansiyn:=b;
end;

procedure calcuserqr;
begin
 with u do begin
  userqr := qrmultifactor*(u.uploads+u.nbu)-u.downloads;
 end;
end;

procedure calcuserlistqr;
begin
 with uu do begin
  userlistqr := qrmultifactor*(uu.uploads+uu.nbu)-uu.downloads;
 end;
end;

procedure editusers;
var eunum:integer;
    matched:boolean;

  procedure elistusers (getspecs:boolean);
  var cnt,f,l:integer;
      us:userspecsrec;

    procedure listuser;
    begin
      write (cnt:4,' ');
      tab (u.handle,31);
      write (u.level:6,' ');
      if useqr then begin
       calcuserqr;
       tab (strr(userqr),8);
      end;
      writeln (u.nbu:6,u.numon:6,postcallratio(u):7:2)
    end;

  begin
    if getspecs
      then if selectspecs(us)
        then exit
        else
          begin
            f:=1;
            l:=numusers
          end
      else parserange (numusers,f,l);
    seek (ufile,f);
    matched:=false;
    write (^B^M^M' ID# Name                            Level ');
    if useqr then write ('QR         ');
    writeln ('Posts Calls PCR');
    for cnt:=f to l do begin
      read (ufile,u);
      if (not getspecs) or fitsspecs(u,us) then begin
        listuser;
        matched:=true
      end;
      handleincoming;
      if break then exit
    end;
    if not matched then
      if getspecs
        then writeln (^B^M'No users match specifications!')
        else writeln (^B^M'No users found in that range!')
  end;

begin
  repeat
    writestr (^M'[User to Edit] [?,??/List]:');
    if (length(input)=0) or (match(input,'Q')) then exit;
    if input[1]='?'
      then elistusers (input='??')
      else begin
        eunum:=lookupuser (input);
        if eunum=0
          then writestr ('User not found!')
          else edituser (eunum)
      end
  until hungupon
end;

procedure zapspecifiedusers;
var us:userspecsrec;
    confirm:boolean;
    u:userrec;
    cnt:integer;
    done:boolean;
begin
  if selectspecs (us) then exit;
  writestr ('Confirm each deletion individually? [y/n]: *');
  if length(input)=0 then exit;
  confirm:=yes;
  if not confirm then begin
    writestr (^M'Confirm each users? [y/n]: *');
    if not yes then exit
  end;
  for cnt:=1 to numusers do begin
    seek (ufile,cnt);
    read (ufile,u);
    if (length(u.handle)>0) and fitsspecs (u,us) then begin
      if confirm
        then
          begin
            done:=false;
            repeat
              writestr ('Delete '+u.handle+' [Y/N/X/E]: ');
              if length(input)>0 then case upcase(input[1]) of
                'Y':begin
                      done:=true;
                      writeln ('[Deleting '+u.handle+']');
                      deleteuser (cnt)
                    end;
                'N':done:=true;
                'X':exit;
                'E':begin
                      edituser(cnt);
                      writeln;
                      writeln
                    end
              end
            until done
          end
        else
          begin
            writeln ('[Deleting '+u.handle+']');
            if break then begin
              writestr ('Aborted!');
              exit
            end;
            deleteuser (cnt)
          end
    end
  end
end;

procedure summonsysop;
var tf:text;
   cnt:integer;
     k:char;
begin
  chatmode:=not chatmode;
  bottomline;
  if chatmode
    then
      if sysopisavail
        then
          begin
            writehdr ('Page '+sysopname);
            writestr ('Enter a reason to chat: &');
            chatreason:=input;
            if length(input)=0 then begin
              chatmode:=false;
              exit
            end;
            writelog (1,3,chatreason);
            if not sblaster then begin
            assign (tf,textfiledir+'Chatcall');
            reset (tf);
            if ioresult=0 then begin
              while (not (eof(tf) or hungupon)) and chatmode do
                begin
                  read (tf,k);
                  nobreak:=true;
                  if ord(k)=7 then summonbeep else writechar (k);
                  if keyhit then begin
                    k:=bioskey;
                    clearbreak;
                    chat1 (false)
                  end
                end;
              textclose (tf)
            end;
           end else begin
  soundblaster ('CHATCALL.VOC');
  end;
  {nosound;
  write (^P'[');
  for cnt:=1 to 25 do begin
  write(^G^G^G^G^G^G^G^G^S'.'); delay (50);
  if keyhit then begin
     k:=bioskey;
     clearbreak;
     chat1 (false);
     end end; writeln(^P']');
  nosound; end;}
            if chatmode
              then writestr ('Use [C] again to turn off page.')
              else unsplit
          end
        else
          begin
            if length(notavailstr)=0 then
            writestr ('Sorry, '+sysopname+
                      ' isn''t available right now!') else
            writeln (notavailstr);
            chatmode:=false;
            writelog (1,2,'')
          end
    else writestr ('Page off.  Use [C] to turn it back on.');
  clearbreak
end;

{procedure offfaq;
var q,n:integer;
    tn:file of integer;
    yesno:boolean;
    m:message;
begin
  writehdr ('Log off BBS');
  yesno:=ansiyn (^P'Log off '^R+longname+^P);
  if yesno then begin
    if ulvl<msgnextlvl then begin
      if exist (textfiledir+'GoodBye') then;
      printfile (textfiledir+'GoodBye');
     disconnect;
     end;
    yesno:=ansiyn (^P'Leave a message to the next user');
    if yesno then begin
      titlestr:='Auto-Message';
      sendstr:='Next User';
      q:=editor(m,false,'Auto-Message');
      sendstr:='';
      if q>=0 then begin
        if tonext>=0 then deletetext (tonext);
        tonext:=q;
        writestatus
      end
    end;
    printfile (textfiledir+'Goodbye');
    disconnect;
  end
end;}

procedure offfaq;
var q,n:integer;
    tn:file of integer;
    m:message;
begin
  writehdr ('Log off BBS');
  writestr ('Log off '^R+longname+^P'? [y/n]: *');
  if yes then begin
    if ulvl<msgnextlvl then begin
      if exist (textfiledir+'GoodBye') then;
      printfile (textfiledir+'GoodBye');
     disconnect;
     end;
    writestr (^S'Leave a message to the next user? *');
    if yes then begin
      titlestr:='Auto-Message';
      sendstr:='Next User';
      q:=editor(m,false,'Auto-Message');
      sendstr:='';
      if q>=0 then begin
        if tonext>=0 then deletetext (tonext);
        tonext:=q;
        writestatus
      end
    end;
    printfile (textfiledir+'Goodbye');
    disconnect;
  end
end;

procedure listusers;
var cnt,u1,u2:integer;
begin
  if ulvl<listuserlvl then begin
   reqlevel (listuserlvl);
   exit;
  end;
  writehdr ('List Users');
  parserange (numusers,u1,u2);
  if u1=0 then exit;
  write (^B^P'['^S'Name'^P']                           ['^S'Level'^P'] ['^S'Note'^P']');
  if useqr then writeln (^P'                          ['^S'QR'^P']  ')
  else writeln;
  if break then exit;
  if asciigraphics in urec.config then
   write (^B^R'───────────────────────────────────────────────') else
   write (^B^R'-----------------------------------------------');
  if (useqr) then begin
   if asciigraphics in urec.config then
    write (^B^R'────────────────────────────────') else
    write (^B^R'--------------------------------');
  end;
  writeln;
  if break then exit;
  for cnt:=u1 to u2 do
    begin
      seek (ufile,cnt);
      read (ufile,uu);
      che;
      if length(uu.handle)>0 then begin
        periods:=false;
        write (^P'['^S);
        tab (uu.handle,30);
        if break then exit;
        write (^P'] ['^S);
        periods:=false;
        tab (strr(uu.level),5);
        if break then exit;
        write (^P'] ['^S);
        periods:=false;
        tab (uu.note,29);
        write (^P']');
        if break then exit;
        if useqr then begin
         calcuserlistqr;
         write (^P' ['^S);
         tab (strr(userlistqr),4);
         write (^P']');
         if break then exit;
        end;
       writeln;
      end
    end
end;

procedure transfername;
var un,nlvl,ntime,tmp:integer;
    u:userrec;
    qaz:lstr;
begin
  writehdr ('Transfer User');
  if tempsysop then begin
    writeln (usr,'(Disabling Temporary Sysop Access)');
    ulvl:=regularlevel;
    tempsysop:=false
  end;
  writestr ('User to transfer to:');
  if length(input)=0 then exit;
  un:=lookupuser(input);
  if unum=un then begin
    writestr ('That would be a waste of CPU time...');
    exit;
   end;
  if un=0 then begin
    writestr ('No such user.');
    exit
  end;
  seek (ufile,un);
  read (ufile,u);
  if ulvl<sysoplevel then if not checkpassword(u) then begin
    writelog (1,5,u.handle);
    exit
  end;
  writelog (1,4,u.handle);
  updateuserstats (false);
  ntime:=0;
  if datepart(u.laston)<>datepart(now) then begin
    tmp:=ulvl;
    if tmp<1 then tmp:=1;
    if tmp>100 then tmp:=100;
    ntime:=usertime[tmp]
  end;
  if u.timetoday<10
    then if issysop or (u.level>=sysoplevel)
      then
        begin
          writestr ('The user has '+strr(u.timetoday)+' min(s) left!');
          writestr ('New time left:');
          ntime:=valu(input)
        end
      else
        if u.timetoday>0
      then writeln (^P'WARNING:'^R' You have ',u.timetoday,' minutes left!')
          else
            begin
              writestr ('Sorry, that user doesn''t have any time left!');
              exit
            end;
  unum:=un;
  readurec;
  if ntime<>0 then begin
    urec.timetoday:=ntime;
    writeurec
  end;
end;


Procedure editnews;
  Var nn,numnews:Integer;
    nf:File Of newsrec;
    News:newsrec;
  Procedure getnn(txt:mstr);
    Begin
      writestr(^S+'News number to '+^R+txt+^S+':');
      nn:=valu(Input);
      If (nn<1) Or (nn>numnews) Then nn:=0
    End;

  Procedure delnews;
    Var cnt:Integer;
      r:Integer;
      NTmp:newsrec;
    Begin
      If nn=0 Then getnn('delete');
      If nn<>0 Then Begin
        Seek(nf,nn-1);
        Read(nf,Ntmp);che;
        deletetext(Ntmp.Location);
        numnews:=FileSize(nf)-1;
        For cnt:=nn To numnews Do
          Begin
            Seek(nf,cnt);
            Read(nf,nTmp);
            Seek(nf,cnt-1);
            Write(nf,Ntmp)
          End;
        Seek(nf,numnews);
        Truncate(nf)
      End
    End;

  Procedure listnews;
    Var cnt:Integer;
      r,sector:Integer;
      q:buffer;
      l:anystr;
      k:Char;
      Ntmp:newsrec;
    Begin
      clearbreak;
      WriteLn (^S'  News    Min    Max          Title ');
      WriteLn (^S' Number  Level  Level');
      WriteLn;

      For cnt:=1 To numnews Do Begin
        Seek(nf,cnt-1);
        Read(nf,ntmp);
        r:=ntmp.location;
        Seek(tfile,r);
        Read(tfile,q);

        Write( Cnt:5 , '    ' , ntmp.level:5,'  ',ntmp.maxlevel:5, ' ');
        r:=1;
        k:=' ';
        l:='';
        Writeln (ntmp.title);
{        While (Ord(k)<>13) And Not hungupon Do Begin
          k:=q[r];
          r:=r+1;
          If (k=#0) Or (r>sectorsize) Then k:=Chr(13);
          l:=l+k
        End;
        Write(l);}
        If break Then exit
      End;
{      WriteLn                }
    End;

  Procedure viewnews;
    Var r:Integer;
      Ntmp:newsrec;
    Begin
      If nn=0 Then getnn('view');
      If nn<>0 Then Begin
        Seek(nf,nn-1);
        Read(nf,nTmp);che;
        r:=ntmp.location;
        WriteLn(^M'News #',nn,' ''',ntmp.title,''' From :',ntmp.from);
        WriteLn('Date: ',Datestr(ntmp.when),' Level [',ntmp.level,'-',ntmp.maxlevel,']');
        printtext(r)
      End
    End;


  Procedure adddnews;
    Begin
      Close(nf);
      addnews;
      Assign(nf,bbsdatadir+'News.dat');
      Reset(nf)
    End;

  Var q:Integer;
  Begin
    Assign(nf,bbsdatadir+'News.dat');
    Reset(nf);
    writehdr ('New Edit');
    If IOResult<>0 Then writestr('No news!  Use [A] to add some!') Else Begin
      Repeat
        numnews:=FileSize(nf);
        Write(^B^M'News entries: ',numnews);
        q:=menu ('News Edit','NEWS','ADLVQ?');
        nn:=valu(Copy(Input,2,255));
        If (nn<1) Or (nn>numnews) Then nn:=0;
        Case q Of
          1:adddnews;
          2:delnews;
          3:listnews;
          4:viewnews;
          6:begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ News Section                        ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [A]  s');
writeln ('uAdd News                       ║HC║ [Ds');
writeln ('u]  Delete News                    ║HC║ [s');
writeln ('uL]  List News                      ║Hs');
writeln ('uC║ [Q]  Quit                           s');
writeln ('u║HC║ [V]  View News               s');
writeln ('u       ║HC║ [?]  View This Menu   s');
writeln ('u              ║HC╚═══════════════════════════════A');
writeln ('C══════╝');
writeln;
pause;
           end;
        End;
        If numnews=0 Then Begin
          Close(nf);
          Erase(nf);
          q:=5
        End
      Until (q=5) Or hungupon
    End;
    Close(nf)
  End;


{procedure editnews;
var nn,numnews:integer;
    nf:file of integer;

  procedure getnn (txt:mstr);
  begin
    writestr ('News number to '+txt+':');
    nn:=valu(input);
    if (nn<1) or (nn>numnews) then nn:=0
  end;

  procedure delnews;
  var cnt:integer;
      r:integer;
  begin
    if nn=0 then getnn ('delete');
    if nn<>0 then begin
      seek (nf,nn-1);
      read (nf,r); che;
      deletetext (r);
      numnews:=filesize(nf)-1;
      for cnt:=nn to numnews do
        begin
          seek (nf,cnt);
          read (nf,r);
          seek (nf,cnt-1);
          write (nf,r)
        end;
      seek (nf,numnews);
      truncate (nf)
    end
  end;

  procedure listnews;
  var cnt:integer;
      r,sector:integer;
      q:buffer;
      l:anystr;
      k:char;
  begin
    clearbreak;
    for cnt:=1 to numnews do begin
      seek (nf,cnt-1);
      read (nf,r);
      seek (tfile,r);
      read (tfile,q);
      write (strr(cnt)+'. ');
      r:=1;
      k:=' ';
      l:='';
      while (ord(k)<>13) and not hungupon do begin
        k:=q[r];
        r:=r+1;
        if (k=#0) or (r>sectorsize) then k:=chr(13);
        l:=l+k
      end;
      writeln (l);
      if break then exit
    end;
    writeln
  end;

  procedure viewnews;
  var r:integer;
  begin
    if nn=0 then getnn ('view');
    if nn<>0 then begin
      seek (nf,nn-1);
      read (nf,r); che;
      printtext (r)
    end
  end;

  procedure adddnews;
  begin
    addnews;
    assign (nf,bbsdatadir+'News.dat');
    close (nf);
    reset (nf)
  end;

var q:integer;
begin
  assign (nf,bbsdatadir+'News.dat');
  reset (nf);
  if ioresult<>0 then writestr ('No news!  Use [A] to add some!') else begin
    repeat
      numnews:=filesize(nf);
      write (^B^M'News entries: ',numnews);
      q:=menu ('News Edit','NEWS','ADLVQ?');
      nn:=valu(copy(input,2,255));
      if (nn<1) or (nn>numnews) then nn:=0;
      case q of
        1:adddnews;
        2:delnews;
        3:listnews;
        4:viewnews
        6:begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ News Section                        ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [A]  s');
writeln ('uAdd News                       ║HC║ [Ds');
writeln ('u]  Delete News                    ║HC║ [s');
writeln ('uL]  List News                      ║Hs');
writeln ('uC║ [Q]  Quit                           s');
writeln ('u║HC║ [V]  View News               s');
writeln ('u       ║HC║ [?]  View This Menu   s');
writeln ('u              ║HC╚═══════════════════════════════A');
writeln ('C══════╝');
writeln;
pause;
           end;
      end;
      if numnews=0 then begin
        close (nf);
        erase (nf);
        writestr ('No more news!  Use [A] to add some.');
        q:=5
      end
    until (q=5) or hungupon
  end;
  close (nf)
end; }

procedure delerrlog;
var e:text;
    i:integer;
begin
  writehdr ('Delete Error Log');
  writestr ('Delete Error Log [y/n]:');
  if not yes then exit;
  assign (e,bbsdatadir+'errlog.dat');
  reset (e);
  i:=ioresult;
  if ioresult=1
    then writeln (^M'No error log!')
    else begin
      textclose (e);
      erase (e);
      writestr ('Error log deleted.');
      if ioresult>1
        then writeln ('I/O error ',i,' deleting error log!');
      writelog (2,2,'')
    end
end;

procedure feedback;
var m:mailrec;
    me:message;
begin
  writehdr ('Feedback');
  writestr ('Leave Feedback to '+sysopname+' [y/n]: *');
  if not yes then exit;
  sendstr:='Sysop';
  m.line:=editor(me,false,'Feedback');
  if m.line<0 then exit;
  m.title:=me.title;
  m.sentby:=unam;
  m.anon:=false;
  m.when:=now;
  addfeedback (m);
  writestr ('Feedback sent.')
end;

procedure settime;
var t:integer;
    n:longint;
    r:registers;
    d:datetime;
begin
  writehdr ('Set Date/Time');
  writestr ('Current Time: '+timestr(now));
  writestr ('Current Date: '+datestr(now));
  writestr ('Enter new time:');
  if length(input)<>0
    then begin
      t:=timeleft;
      unpacktime (timeval(input),d);
      r.ch:=d.hour;
      r.cl:=d.min;
      r.dh:=0;
      r.dl:=0;
      r.ah:=$2d;
      intr ($21,r);
      if r.al=$ff then writestr ('Invalid time!');
      settimeleft (t)
    end;
  writestr ('Enter new date:');
  if length(input)<>0
    then begin
      unpacktime (dateval(input),d);
      r.dl:=d.day;
      r.dh:=d.month;
      r.cx:=d.year;
      r.ah:=$2b;
      intr ($21,r);
      if r.al=$ff then writestr ('Invalid date!')
    end;
  writelog (2,4,'')
end;

procedure changepwd;
var t:sstr;
begin
  buflen:=15;
  echodot:=true;
  write ('Choose your new password now - Return/have one generated: ');
  if getpassword
    then begin
      echodot:=false;
      writeurec;
      writestr ('Password changed.');
      writelog (1,1,'')
    end else begin
      echodot:=false;
      writestr ('No change.');
 end;
end;

procedure requestraise;
var t:text;
    q:lstr;
    p,l1,l2:integer;
    s1,s2:sstr;
    me:message;
    m:mailrec;
label nope,found;
begin
  assign (t,textfiledir+'Raisereq');
  reset (t);
  if ioresult<>0 then goto nope;
  printtexttopoint (t);
  while not eof(t) do begin
    readln (t,q);
    p:=pos('-',q);
    if p>0
      then
        begin
          s1:=copy(q,1,p-1);
          s2:=copy(q,p+1,255)
        end
      else
        begin
          s1:=copy(q,1,15);
          s2:=s1
        end;
    val (s1,l1,p);
    if p=0 then val (s2,l2,p);
    if p<>0 then begin
      textclose (t);
      error ('Invalid range in RAISEREQ: %1','',q);
      exit
    end;
    if (ulvl>=l1) and (ulvl<=l2) then goto found;
    skiptopoint (t)
  end;
  nope:
  error ('No text for level %1','',strr(ulvl));
  textclose (t);
  p:=ioresult;
  exit;
  found:
  printtexttopoint (t);
  textclose (t);
  if hungupon then exit;
  titlestr:='Raise Request';
  pause;
  sendstr:='Sysop';
  m.line:=editor (me,false,'Raise Request');
  sendstr:='';
  if m.line<0 then exit;
  m.anon:=false;
  m.title:='Raise Request (Now Level '+strr(ulvl)+')';
  m.sentby:=unam;
  m.when:=now;
  addfeedback (m);
end;

procedure makeuser;
var u:userrec;
    i,un,ln:integer;
begin
  writehdr ('Add a User');
  writestr ('Name:');
  if length(input)=0 then exit;
  if lookupuser(input)<>0 then begin
    writestr ('Sorry!  Already exists!');
    exit
  end;
  u.handle:=input;
  writestr ('Password:');
  u.password:=input;
  writestr ('Level:');
  if length(input)=0 then exit;
  u.level:=valu(input);
  u.note:=newusernote;
  for i:=1 to 5 do begin
  u.defcon[i]:=defconfm[i];
  u.defcon[i+5]:=defconfx[i];
  end;
  un:=adduser(u);
  if un=-1 then begin
    writestr ('Sorry, no room for new users!');
    exit
  end;
  ln:=u.level;
  if ln<1 then ln:=1;
  if ln>100 then ln:=100;
  u.timetoday:=usertime[ln];
  writeufile (u,un);
  writestr ('User added as #'+strr(un)+'.');
  writelog (2,8,u.handle)
end;

procedure infoformhunt;
begin
  writestr ('User to search for [CR/All users]:');
  writeln (^M);
  showinfoforms (input)
end;

procedure donations;
var fn:lstr;
begin
  writehdr ('Donations');
  fn:=textfiledir+'Donation';
  if exist (fn)
    then printfile (fn)
    else begin
      writestr ('I''m sorry, no information is currently available.');
      if issysop
        then writestr (
'Sysop:  To create donation information text, make a file called '+fn)
    end
end;

procedure viewsyslog;
var n:integer;
    l:logrec;

  function lookupsyslogdat (m,s:integer):integer;
  var cnt:integer;
  begin
    for cnt:=1 to numsyslogdat do with syslogdat[cnt] do
      if (menu=m) and (subcommand=s) then begin
        lookupsyslogdat:=cnt;
        exit
      end;
    lookupsyslogdat:=0
  end;

  function firstentry:boolean;
  begin
    firstentry:=(l.menu=0) and (l.subcommand in [1..2])
  end;

  procedure backup;
  begin
    while n<>0 do begin
      n:=n-1;
      seek (logfile,n);
      read (logfile,l);
      if firstentry then exit
    end;
    n:=-1
  end;

  procedure showentry (includedate:boolean);
  var q:lstr;
      p:integer;
  begin
    q:=syslogdat[lookupsyslogdat(l.menu,l.subcommand)].text;
    p:=pos('%',q);
    if p<>0 then q:=copy(q,1,p-1)+l.param+copy(q,p+1,255);
    if includedate then q:=q+' on '+datestr(l.when);

    q:=timestr(l.when)+' - '+q;
    writeln (q)
  end;

var b:boolean;
begin
  writehdr ('View System Log');
  writeln ('Press [Space] to advance to the previous caller, [X] to abort.');
  writeln;
  writelog (2,6,'');
  n:=filesize(logfile);
  repeat
    clearbreak;
    writeln (^M);
    backup;
    if n=-1 then exit;
    seek (logfile,n);
    read (logfile,l);
    showentry (true);
    b:=false;
    while not (eof(logfile) or break or xpressed or b) do begin
      read (logfile,l);
      b:=firstentry;
      if not b then showentry (false);
    end
  until xpressed
end;

procedure delsyslog;
begin
  writehdr ('Delete System Log');
  writestr ('Delete the System Log [y/n]:');
  if not yes then exit;
  close (logfile);
  rewrite (logfile);
  writeln (^M'Deleted.');
  writelog (2,7,unam)
end;

procedure changecon (con:char);

procedure listcon (k:char);
var i:integer;
begin
writehdr ('Conference List');
  if ascii then begin
  writeln (^R'┌───┬───────────────────────────────────────────────────────────┐');
  writeln (^R'│ '^S'# '^R'│ '^S'Conference Name                                           '^R'│');
  writeln (^R'├───┼───────────────────────────────────────────────────────────┤');
  end else begin
  writeln (^R'+---+-----------------------------------------------------------+');
  writeln (^R'| '^S'# '^R'| '^S'Conference Name                                           '^R'|');
  writeln (^R'|---|-----------------------------------------------------------|');
  end;
  for i:=1 to 5 do begin
  if (k='M') then if (urec.defcon[i]) and (length(confm[i])>0) then begin
  if ascii then write (^R'│ ') else write (^R'| ');
  tab (^S+strr(i),3);
  if ascii then write (^R'│ ') else write (^R'| ');
  tab (^S+confm[i],59);
  if ascii then writeln (^R'│') else writeln (^R'|');
  end;
  if (k='X') then if (urec.defcon[i+5]) and (length(confx[i])>0) then begin
  if ascii then write (^R'│ ') else write (^R'| ');
  tab (^S+strr(i),3);
  if ascii then write (^R'│ ') else write (^R'| ');
  tab (^S+confx[i],59);
  if ascii then writeln (^R'│') else writeln (^R'|');
  end;
  end;
  if ascii then
  writeln (^R'└───┴───────────────────────────────────────────────────────────┘')
  else writeln (^R'+---+-----------------------------------------------------------+');
  writeln;
end;

var n:char;
    c:byte;
begin
if (conn<0) or (conn>5) then conn:=1;
if (useconf) then begin
c:=conn;
repeat
buflen:=1;
writestr (^R'Enter Conference # '^P'['^S'?'^P'/'^R'List'^P']'^S': *');
n:=upcase(input[1]);
case n of
'?':listcon (con);
'1':if con='M' then
    if (not urec.defcon[1]) or (length(confm[1])<1)
    then writeln (^R^M'No Such Conference!') else begin
    conn:=1; exit; end else
    if con='X' then
    if (not urec.defcon[6]) or (length(confx[1])<1)
    then writeln (^R^M'No Such Conference!') else begin
    conn:=1; exit; end;
'2':if con='M' then
    if (not urec.defcon[2]) or (length(confm[2])<1)
    then writeln (^R^M'No Such Conference!') else begin
    conn:=2; exit; end else
    if con='X' then
    if (not urec.defcon[7]) or (length(confx[2])<1)
    then writeln (^R^M'No Such Conference!') else begin
    conn:=2; exit; end;
'3':if con='M' then
    if (not urec.defcon[3]) or (length(confm[3])<1)
    then writeln (^R^M'No Such Conference!') else begin
    conn:=3; exit; end else
    if con='X' then
    if (not urec.defcon[8]) or (length(confx[3])<1)
    then writeln (^R^M'No Such Conference!') else begin
    conn:=3; exit; end;
'4':if con='M' then
    if (not urec.defcon[4]) or (length(confm[4])<1)
    then writeln (^R^M'No Such Conference!') else begin
    conn:=4; exit; end else
    if con='X' then
    if (not urec.defcon[9]) or (length(confx[4])<1)
    then writeln (^R^M'No Such Conference!') else begin
    conn:=4; exit; end;
'5':if con='M' then
    if (not urec.defcon[5]) or (length(confm[5])<1)
    then writeln (^R^M'No Such Conference!') else begin
    conn:=5; exit; end else
    if con='X' then
    if (not urec.defcon[10]) or (length(confx[5])<1)
    then writeln (^R^M'No Such Conference!') else begin
    conn:=5; exit; end;
end;
until ((n='1') and (length(confm[1])>0) and (urec.defcon[1])) or
      ((n='1') and (length(confx[1])>0) and (urec.defcon[6])) or
      ((n='2') and (length(confm[2])>0) and (urec.defcon[2])) or
      ((n='2') and (length(confx[2])>0) and (urec.defcon[7])) or
      ((n='3') and (length(confm[3])>0) and (urec.defcon[3])) or
      ((n='3') and (length(confx[3])>0) and (urec.defcon[8])) or
      ((n='4') and (length(confm[4])>0) and (urec.defcon[4])) or
      ((n='4') and (length(confx[4])>0) and (urec.defcon[9])) or
      ((n='5') and (length(confm[5])>0) and (urec.defcon[5])) or
      ((n='5') and (length(confx[5])>0) and (urec.defcon[10]));
 end else begin conn:=0; exit; end;
end;

procedure showsystemstatus;
var totalused,totalidle,totalup,totaldown,totalmins,callsday:real;
    yiyiyi:integer;
    drv:array [1..15] of boolean;

  procedure diskcalcs;
  var cnt,cnt2,curarea:integer;
      ar,area:arearec;
      ud:udrec;
      inscan,showit,fast:boolean;

  procedure assignud;
  var con1:byte;
  begin
    for con1:=1 to 5 do
    assign (udfile,datadir+'AREA'+strr(curarea)+'.'+strr(con1))
  end;

  const beenaborted:boolean=false;

  function aborted:boolean;
  begin
    if beenaborted then begin
      aborted:=true;
      exit
    end;
    aborted:=xpressed or hungupon;
    if xpressed then begin
      beenaborted:=true;
      writeln (^B'Aborted!')
    end
  end;

  procedure setarea (n:integer);
  begin
    curarea:=n;
    seek (afile,n-1);
    read (afile,area);
    close (udfile);
    assignud;
    close (udfile);
    reset (udfile);
    if ioresult<>0 then rewrite (udfile);
  end;

  procedure checkdrive (dv:char);
  var n:byte;
      tempdisk,tempfree:real;

    procedure writefreespace (dr:byte);
    var r:registers;
        csize:real;

      function unsigned (i:integer):real;
      begin
        if i>=0 then unsigned:=i else unsigned:=65536.0+i
      end;

    begin
      r.ah:=$36;
      r.dl:=dr;
      intr ($21,r);
      if r.ax=-1 then exit;
      csize:=unsigned(r.ax)*unsigned(r.cx);
      tempfree:=(csize*unsigned(r.bx))/1000;
      tempdisk:=(csize*unsigned(r.dx))/1000;
    end;


  begin
    if (ord(dv)<65) or (ord(dv)>79) then exit;
    n:=ord(dv)-64;
    writefreespace(n);
    if not drv[n] then begin
      drv[n]:=true;
      totaldisk:=totaldisk+tempdisk;
      totalfree:=totalfree+tempfree;
    end;
  end;

  function getfname (path:lstr; name:mstr):lstr;
  var l:lstr;
  begin
    l:=path;
    if length(l)<>0 then if not (upcase(l[length(l)]) in [':','\'])
      then l:=l+'\';
    l:=l+name;
    getfname:=l
  end;

  var con1:byte;
  begin
    totalfiles:=0;
    filesizes:=0;
    totaldisk:=0;
    totalFree:=0;
    for cnt:=1 to 15 do drv[cnt]:=false;
    for con1:=1 to 5 do begin
    assign (afile,datadir+'Areadir.'+strr(con1));
    if exist (datadir+'Areadir.'+strr(con1)) then begin
     reset (afile);
     if filesize (afile)<0 then exit
    end
    else rewrite (afile);
    end;
    cnt:=1;
    while (cnt<=filesize(afile)) do begin
      seek (afile,cnt-1);
      read (afile,ar);
      checkdrive (upcase(ar.xmodemdir[1]));
      setarea (cnt);
      for cnt2:=filesize (udfile) downto 1 do begin
        seek (udfile,cnt2-1);
        read (udfile,ud);
        checkdrive (upcase(ud.path[1]));
        if aborted then begin
          totalfiles:=0;
          filesizes:=0;
          totaldisk:=0;
          totalfree:=0;
          exit;
        end;
        if exist (getfname(ud.path,ud.filename)) then begin
          totalfiles:=totalfiles+1;
          filesizes:=filesizes+ud.filesize;
        end;
      end;
      cnt:=cnt+1;
    end;
    filesizes:=filesizes/1000;
  end;

  procedure percent (prompt:mstr; top,bot:real);
  var p:real;
  begin
    write (prompt);
    if bot<1 then begin
      writeln ('N/A');
      exit
    end;
    p:=round(1000*top/bot)/10;
    writeln (p:0:1,'%')
  end;

procedure modemstatus;

function getbaudstr (var q:baudset):lstr;
var w:lstr;
    cnt:baudratetype;
begin
  w[0]:=chr(0);
  for cnt:=firstbaud to lastbaud do
    if cnt in q then w:=w+strlong(baudarray[cnt])+' ';
  if length(w)=0 then w:='None';
  getbaudstr:=w
end;

  begin
  writehdr ('Modem Status');
  writeln (^R'COM Port'^P':               '^S+strr(usecom));
  writeln (^R'Characters Sent'^P':        '^S+strlong(bsent));
  writeln (^R'Characters Received'^P':    '^S+strlong(brecv));
  writeln (^R'Current Baud Rate'^P':      '^S+strlong(baudrate));
  writeln (^R'Default Baud Rate'^P':      '^S+strlong(defbaudrate));
  writeln (^R'Supported Baud Rates'^P':   '^S+getbaudstr(supportedrates));
  writeln (^R'Downloaded Baud Rates'^P':  '^S+getbaudstr(downloadrates));
  write   (^R'Connected with MNP/ARQ'^P': ');
  if arq then writeln (^S'Yes') else writeln (^S'No');
  writeln (^R'Modem Routines/Version'^P': '^S'FAQ/PibaSync Version '+ver);
  writeln (^R);
  end;

label last;
var ozzy,anarky:anystr;
    c:char;
    metallica:integer;
begin
  writehdr ('BBS Statistics');
  repeat
  writestr (^S'M'^R'odem Status  '^S'S'^R'ystem Status  '^S'Q'^R'uit'^P': '^U'*');
  c:=upcase(input[1]);
  case c of
  'M':begin modemstatus; c:=#0; end;
  'S':begin
  writehdr ('System Status');
  dofiles:=false;
  totalused:=numminsused.total+elapsedtime(numminsused);
  totalidle:=numminsidle.total;
  totalup:=totalidle+numminsused.total;
  totalmins:=1440.0*(numdaysup-1.0)+timer;
  totaldown:=totalmins-totalup;
  callsday:=round(10*numcallers/numdaysup)/10;
  {writestr ('Calculate Disk Storages & File Area Stats? [y/n]: *');
  writeln;
  if yes then begin
   writeln ('Calculating.');
   dofiles:=true;
   diskcalcs;
  end;}
  ozzy:=ver+' - '+parsedate(date);
  writeln ('[FAQ Version]:       '^S,ozzy);
  writeln ('[Time & Date]:       '^S,timestr(now),', ',datestr(now));
  writeln ('[Calls today]:       '^S,callstoday);
  writeln ('[Total callers]:     '^S,numcallers:0:0);
  writeln ('[Total days up]:     '^S,numdaysup);
  writeln ('[Calls per day]:     '^S,callsday:0:1);
  writeln ('[Total mins in use]: '^S,numminsused.total:0:0);
  writeln ('[Total mins idle]:   '^S,totalidle:0:0);
  writeln ('[Mins file xfer]:    '^S,numminsxfer.total:0:0);
  writeln ('[Total mins up]:     '^S,totalup:0:0);
  writeln ('[Total mins down]:   '^S,totaldown:0:0);
  percent ('[% BBS is in use]:   '^S,totalused,totalmins);
  percent ('[% BBS is idle]:     '^S,totalidle,totalmins);
  percent ('[% BBS is up]:       '^S,totalup,totalmins);
  percent ('[% BBS is down]:     '^S,totaldown,totalmins);
  {if dofiles then begin
  percent ('[% Space Unused]:    '^S,totalfree,totaldisk);
  percent ('[% Space Used]:      '^S,(totaldisk-totalfree),totaldisk);
  percent ('[% Storage Online]:  '^S,filesizes,totaldisk);
  writeln ('[Files Online]:      '^S,totalfiles);
  writeln ('[Files Storage]:     '^S,streal (filesizes/1000),' Megabytes');
  writeln ('[Total Storage]:     '^S,streal (totaldisk/1000),' Megabytes');
  writeln ('[Upload Space]:      '^S,streal (totalfree/1000),' Megabytes');
  write   ('[Drives Online]:     '^S);
  for yiyiyi:=1 to 15 do
   if drv[yiyiyi] then write ('['+chr(yiyiyi+64),']: ');
  end;
  writeln (^R);}
  c:=#0;
  end;
  end;
  until (c='Q') or (c='q');
end;

procedure showallforms;
begin
  showinfoforms ('')
end;

procedure showallsysops;
var n:integer;
    u:userrec;
    q:set of configtype;
    s:configtype;

  procedure showuser;
  const sectionnames:array [udsysop..databasesysop] of string[20]=
         ('File transfer','Bulletin section','Voting booths',
          'E-mail section','Doors','Main Menu','Databases');
  var s:configtype;
  begin
    writeln (#27'[2J');
    writeln (^R'┌─────────┬──────────────────────────────┐');
    writeln ('│'^P'Name'^R'     │                              │');
    Writeln ('│'^P'Level'^R'    │                              │');
    Writeln ('│'^P'Password'^R' │                              │');
    writeln (^R'└─────────┴──────────────────────────────┘');
    printxy (12,3,^S+u.handle);
    printxy (12,4,strr(u.level));
    printxy (12,5,u.password);

    writestr (^M'Edit user? [y/n]: *');
    if yes then edituser (n)
  end;

begin
  q:=[];
  for s:=udsysop to databasesysop do q:=q+[s];
  for n:=1 to numusers do begin
    seek (ufile,n);
    read (ufile,u);
    if (u.level>=sysoplevel) or (q*u.config<>[]) then showuser
  end
end;

procedure bbslist;
var card,ugbot,p:lstr;
    b:bbsrec;

   function numbbses:integer;
   begin
     numbbses:=filesize(blfile)
   end;

   procedure seekblfile (n:integer);
   begin
     seek (blfile,n-1);
   end;

   function numbbs:integer;
   begin
    numbbs:=filesize (blfile);
   end;

   procedure getstring (t:lstr; var m; buf:integer);
   var q:lstr absolute m;
       mm:lstr;
   begin
     writeln (^R'Old ',t,': '^S,q,^R);
     buflen:=buf;
     writestr ('Enter new '+t+' [CR/no change]:');
     mm:=input;
     if length(mm)<>0 then q:=mm;
     writeln
   end;

    procedure listbbs;
    var cnt,b1,b2:integer;
        showedz:boolean;
    begin
     writehdr ('BBS List');
     reset (blfile);
     if ioresult<>0 then begin
      writeln ('There are no BBS''s in the list.  Add one!');
      exit;
     end
     else begin
     parserange (numbbs,b1,b2);
     writestr ('Show Extended BBS Descriptions? [Y/n]: *');
     writeln;
     showedz:=true;
     if (upcase(input[1])='N') then showedz:=false;
     if b1>0 then
     for cnt:=b1 to b2 do
     begin
      seekblfile (cnt);
      read (blfile,b);
      write (^R'['^S);
      tab (b.number,12);
      write (^R' '^P);
      tab (b.name,48);
      write (^R' '^U);
      tab (b.maxbaud,4);
      write (^R' '^P);
      tab (b.ware,8);
      writeln (^R']');
      if showedz then
      begin
       write (^R':'^U);
       tab (b.extdesc,77);
       writeln (^R'');
      end;
     end;
    end;
    end;

  function getbnum (txt:mstr):integer;
  var n:integer;
  begin
    getbnum:=0;
    repeat
      writeln;
      writestr ('BBS Number to '+txt+' [?/List]:');
      if length(input)=0 then exit;
      if upcase(input[1])='?'
        then listbbs
        else begin
          n:=valu(input);
          if (n<1) or (n>numbbs) then begin
            writestr (^M'Number out of range!');
            exit
          end;
          seekblfile (n);
          read (blfile,b);
          getbnum:=n;
          exit
        end
    until hungupon
  end;

    procedure addbbs;
    begin
     writehdr ('Add a BBS');
     writeln (^R'Phone Number [12 Characters Max]');
     writeln (^R' [------------]');
     buflen:=12;
     writestr (': &');
     b.number:=input;
     writeln;
     writeln (^R'Enter BBS Name [48 Characters Max]');
     writeln (^R' [------------------------------------------------]');
     buflen:=48;
     writestr (': &');
     b.name:=input;
     writeln;
     writeln (^R'Maximum Baud [4 Digits] (ie 2400,4800,9600,19.2)');
     writeln (^R' [----]');
     buflen:=4;
     writestr (': &');
     b.maxbaud:=input;
     writeln;
     writeln (^R'BBS Software [8 Characters Max] (ie FAQ,TCS,Celerity)');
     writeln (^R' [--------]');
     buflen:=8;
     writestr (': &');
     b.ware:=input;
     writeln;
     writeln (^R'Extended BBS Description [77 Characters Max - CR for none]');
     writeln(^R' [-------------------------------------------------------------------------]');
     buflen:=77;
     writestr (': &');
     b.extdesc:=input;
     b.leftby:=unam;
     b.when:=now;
     if (length(b.number)>0) and (length(b.name)>0) and (length(b.maxbaud)>0)
     and (length(b.ware)>0) then begin
      if not exist (bbsdatadir+'BBSList.dat') then rewrite (blfile);
      seekblfile (numbbses+1);
      write (blfile,b);
      writeln (^M^S'Entry Added!'^R^M);
      writelog (6,1,b.name);
     end else
     writeln (^M^S'Entry incomplete!'^R^M);
     end;

  procedure changebbs;
  var q,spock:integer;
      doodzdomain:char;
      phortune:boolean;

   procedure showbbs (b:bbsrec);
   begin
   writeln (^M^R'['^S'1'^R'] BBS Name:     '^S,b.name,
            ^M^R'['^S'2'^R'] BBS Number:   '^S,b.number,
            ^M^R'['^S'3'^R'] Max Baud:     '^S,b.maxbaud,
            ^M^R'['^S'4'^R'] BBS Software: '^S,b.ware,
            ^M^R'['^S'5'^R'] Extended BBS Description:',
            ^M^R': '^S,b.extdesc,
            ^M^R'['^S'Q'^R'] Quit');
   end;

   begin
       reset (blfile);
       if ioresult<>0 then begin
       writeln ('There are no BBS''s in the list.  Add one!');
       exit;
       end;
       writehdr ('Change an Entry');
       phortune:=false;
       repeat
       writestr (^M'Entry to Change [?/List]: &');
       if input[1]='?' then listbbs else begin
       spock:=valu(input);
       if spock<1 then exit;
       if spock>numbbs then exit;
       seekblfile (spock);
       read (blfile,b);
       if (not (match (b.leftby,unam))) and (ulvl<sysoplevel) then begin
        writeln (^M'You didn''t post that entry!'^M);
        exit;
       end;
       phortune:=true;
       writelog (16,3,b.name);
       repeat
       showbbs (b);
       writestr ('[Edit BBS List Command] [?/Help]: *');
       doodzdomain:=upcase(input[1]);
       case doodzdomain of
        '1':getstring ('BBS Name',b.name,48);
        '2':getstring ('BBS Number',b.number,12);
        '3':getstring ('Maximum Baud',b.maxbaud,4);
        '4':getstring ('BBS Software',b.ware,8);
        '5':begin
             writeln ('Old Extended BBS Description:');
             writeln (': ',b.extdesc);
             writeln ('Enter new Extended BBS Description [CR/no change]:');
             buflen:=77;
             writestr (': &');
             if length(input)<>0 then b.extdesc:=input;
             writeln
            end;
        'Q':;
       end;
       until doodzdomain='Q';
       seekblfile (spock);
       write (blfile,b);
       end;
       until phortune;
      end;

  procedure deletebbs;
  var i,n,cnt:integer;
      c:char;
      maniaclame:boolean;
  begin
   reset (blfile);
   if ioresult<>0 then begin
   writeln ('There are no BBS''s in the list.  Add one!');
   exit;
   end;
   writehdr ('Delete an Entry');
   n:=getbnum ('Delete');
   if n=0 then exit;
   seekblfile (n);
   read (blfile,b);
   if not issysop then
   if not match(b.leftby,unam) then begin
    writeln;
    writeln ('You didn''t enter that!');
    writeln;
    exit;
   end;
   writeln;
   writeln (^R'['^S,b.name,^R'] ['^S,b.number,^R']');
   writeln;
   writestr ('Delete this entry? [y/n]: *');
   if not yes then exit;
   writelog (6,2,b.name);
    for cnt:=n to numbbs-1 do begin
      seekblfile (cnt+1);
      read (blfile,b);
      seekblfile (cnt);
      write (blfile,b)
    end;
    seekblfile (numbbs);
    truncate (blfile);
   { writelog ('Deleted BBS Entry "',b.leftby,'"'); }
  end;

  procedure searchbbstext;
  var x:integer;
      ariescool:boolean;
      s:anystr;
      bb:bbsrec;
  begin
   reset (blfile);
   if ioresult<>0 then begin
   writeln ('There are no BBS''s in the list.  Add one!');
   exit;
   end;
   writehdr ('Search for Text in BBS List');
   writeln ('Enter text to search for:');
   writestr (': &');
   writeln;
   if length(input)=0 then exit;
   s:=input;
   s:=upstring(s);
   for x:=1 to numbbs do begin
    ariescool:=false;
    seekblfile (x);
    read (blfile,bb);
    if pos(s,upstring(bb.number))<>0 then ariescool:=true;
    if pos(s,upstring(bb.name))<>0 then ariescool:=true;
    if pos(s,upstring(bb.maxbaud))<>0 then ariescool:=true;
    if pos(s,upstring(bb.ware))<>0 then ariescool:=true;
    if pos(s,upstring(bb.extdesc))<>0 then ariescool:=true;
    if ariescool=true then begin
     write (^R'['^S);
     tab (bb.number,12);
     write (^R' '^P);
     tab (bb.name,48);
     write (^R' '^U);
     tab (bb.maxbaud,4);
     write (^R' '^P);
     tab (bb.ware,8);
     writeln (^R']');
     write (^R':'^U);
     tab (bb.extdesc,77);
     writeln (^R'');
    end;
   end;
  end;

  procedure newscanbbs;
  var cnt:integer;
      bb:bbsrec;
  begin
    reset (blfile);
    if ioresult<>0 then begin
    writeln ('There are no BBS''s in the list.  Add one!');
    exit;
    end;
    writehdr ('BBS List Newscan');
    for cnt:=1 to numbbs do begin
     seekblfile (cnt);
     read (blfile,bb);
     if (bb.when>laston) then begin
      write (^R'['^S);
      tab (bb.number,12);
      write (^R' '^P);
      tab (bb.name,48);
      write (^R' '^U);
      tab (bb.maxbaud,4);
      write (^R' '^P);
      tab (bb.ware,8);
      writeln (^R']');
      write (^R':'^U);
      tab (bb.extdesc,77);
      writeln (^R'');
    end;
  end;
  end;

  procedure sortbbs;
  begin
    reset (blfile);
    if ioresult<>0 then begin
    writeln ('There are no BBS''s in the list.  Add one!');
    exit;
    end
  end;

  procedure converttextfile;
  var x:integer;
      t:text;
  begin
      reset (blfile);
      if ioresult<>0 then begin
      writeln ('There are no BBS''s in the list.  Add one!');
      exit;
      end;
      assign (t,bbsdatadir+'BBSLIST.TXT');
      rewrite (t);
      textclose (t);
  end;

  procedure bbslistsysop;
  begin
     if ulvl<sysoplevel then begin
      reqlevel (sysoplevel);
      exit;
     end;
     writelog (6,4,unam);
     writeln;
     repeat
      ugbot:=' ';
      writeln  (^R'['^S'D'^R'] Delete an Entry');
      writeln  (^R'['^S'C'^R'] Change an Entry');
      writeln  (^R'['^S'S'^R'] Sort Entries');
      writeln  (^R'['^S'Q'^R'] Quit');
      writeln;
      writestr ('[BBS List Sysop Command]: *');
      ugbot:=upstring(input);
      case ugbot[1] of
       'D':deletebbs;
       'C':changebbs;
       'S':sortbbs;
      end;
     until (ugbot[1]='Q');
    end;

label exit;
var q:integer;
begin
    assign (blfile,bbsdatadir+'BBSList.dat');
    if exist (bbsdatadir+'BBSList.dat') then reset (blfile);
    writehdr ('BBS List');
    repeat
     q:=menu ('BBS List','BBSLIST','LADC%QNS?');
     writeln;
     case q of
      1:listbbs;
      2:addbbs;
      3:deletebbs;
      4:changebbs;
      5:bbslistsysop;
      6:goto exit;
      7:newscanbbs;
      8:searchbbstext;
      9:begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ BBS List Section                    ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [A]  s');
writeln ('uAdd BBS Entry to List          ║HC║ [Cs');
writeln ('u]  Change BBS Entry               ║HC║ [s');
writeln ('uD]  Delete BBS Entry from List     ║Hs');
writeln ('uC║ [L]  List BBS Entries               s');
writeln ('u║HC║ [N]  Newscan BBS Entries     s');
writeln ('u       ║HC║ [Q]  Quit             s');
writeln ('u              ║HC║ [S]  Search BBSs');
writeln ('u Entries for Text    ║HC║ [%]  BBSs');
writeln ('u List Sysop Section         ║HC║ [?]  s');
writeln ('uView This Menu                 ║HC╚═════════A');
writeln ('C════════════════════════════╝');
write (^B^R' '^M);
pause;
           end;
      end;
     until (hungupon) or (q=6);
    exit:
    close (blfile);
end;

procedure searchphone;
var temp:sstr;
    user:userrec;
    cnt,int:integer;
begin
int:=0;
writeln (^R'Phone Number without dashes'^P', '^R'slashes'^P', '^R'etc'^P'.');
buflen:=15;
writestr (^P': '^U'*');
if length(input)<10 then exit;
temp:=input;
writeln;
for cnt:=1 to numusers do begin
seek (ufile,cnt);
read (ufile,user);
if match(temp,user.phonenum) then begin
writeln (^R'User with #'^S+user.phonenum+^P': '^R'#'^S,cnt,' '+user.handle,^M);
int:=int+1;
end; end;
writeln (^R'# of Users found with Phone Number'^P': '^S,int);
write (^B^R);
end;

procedure timebank;
var q:char;

  procedure setuplocal;
  var i:integer;
  begin
    assign(bnkfile,bbsdatadir+'TIMEBANK.DAT');
    if not exist(bbsdatadir+'timebank.dat') then begin
                    rewrite(bnkfile);
                    acct.balance:=0;
                    acct.lastw:=0;
                    acct.lastt:=' ';
                    acct.lasta:=0;
                    for i:=1 to 1200 do write(bnkfile,acct);
                    end;
    reset(bnkfile); seek(bnkfile,unum-1);
    read(bnkfile,acct);
end;

procedure writebank;
begin
    seek(bnkfile,unum-1); write(bnkfile,acct);
end;

procedure showbalance;
begin
    writeln('Account #'+strr(unum)+' - '+unam); writeln;
    writeln('Current balance : '^S,acct.balance,^R' minutes.');
        writeln('Maximum deposit : '^S,strr(maxdeposit));
      write('Last Transaction: '^S);
      case acct.lastt of
        'W'    : write('Withdrawal');
        'D'    : write('Deposit');
        else begin
            writeln('None');
            writeln;
            exit;
            end;
        end;
writeln(^R' of '^P,acct.lasta,^R' minutes on '^P,datestr(acct.lastw),^R);
    writeln;
end;

procedure deposit;
var amt:integer;
begin
    writeln;
    if urec.timetoday <= 5 then begin
        writeln('You have only ',urec.timetoday,' now!');
        exit;
        end;

    if acct.balance = maxdeposit then begin
    writeln('The time bank only insures you up to '+strr(maxdeposit)+' minutes!');
                exit;
                end;
    showbalance;
    writestr('Deposit how many minutes? &');
    amt:=valu(input); writeln;
    if amt <= 0 then exit;
    if amt > urec.timetoday then begin
            writeln('You haven''t got that much left!');
            exit;
            end;
    if amt+acct.balance > maxdeposit then begin
writeln('The time bank will only insure up to '+strr(maxdeposit)+' minutes, would you settle for');
 write ('depositing only '+strr(maxdeposit-acct.balance)+' minutes instead? ');
 writestr('&');

      if upcase(input[1])<>'Y' then exit;
      amt:=maxdeposit-acct.balance;
      end;
    acct.lasta:=amt;
    acct.lastw:=now;
    acct.lastt:='D';
    acct.balance:=acct.balance+amt;
    urec.timetoday:=urec.timetoday-amt;
    writebank;
    writeln(^S,amt,^R' minutes added to your account.');
end;

procedure withdraw;
var amt:integer;
begin
    writeln;
    if acct.balance <= 0 then acct.balance:=0;
    if acct.balance = 0 then begin
    writeln('You have nothing to withdraw!');
                exit;
                end;
    showbalance;
    writestr('Withdraw how many minutes? &');
    amt:=valu(input); writeln;
    if amt <= 0 then exit;
    if amt > acct.balance then begin
        writeln('You haven''t got that much in your account.');
            exit;
            end;

    acct.lasta:=amt;
    acct.lastw:=now;
    acct.lastt:='W';
    acct.balance:=acct.balance-amt;
    urec.timetoday:=urec.timetoday+amt;
    writebank;
    writeln(^S,amt,^R' minutes added to today''s time.');
end;

begin
  if (usetimebank) then begin
  setuplocal;
  repeat
        showbalance;
        writeln (^P'['^S'D'^P'] '^R'Deposit Time');
        writeln (^P'['^S'W'^P'] '^R'Withdraw Time');
        writeln (^P'['^S'Q'^P'] '^R'Quit');
    writestr(^M^P'['^R'Time Bank Menu'^P']'^S': '^U'*');
        q:=upcase(input[1]);
    case q of
        'W': withdraw;
        'D': deposit;
        end
      until (q='q') or (q='Q') or (hungupon)
  end else begin writeln ('Timebank is not configured.'); exit; end;
end;

{procedure modifycon;
var choice:char;
choice1,choice2,choice3,choice4,choice5:char;

procedure writeconfig;
var q:file of configsettype;
begin
  assign (q,'SETUP.CFG');
  rewrite (q);
  write (q,configset);
  close (q)
end;

begin
repeat
writehdr ('Modify Conferences');
writeln (^R'['^S'A'^R'] Conference #1: '^S+conf1);
writeln (^R'['^S'B'^R'] Conference #2: '^S+conf2);
writeln (^R'['^S'C'^R'] Conference #3: '^S+conf3);
writeln (^R'['^S'D'^R'] Conference #4: '^S+conf4);
writeln (^R'['^S'E'^R'] Conference #5: '^S+conf5);
writeln (^R'['^S'Q'^R'] Quit:');
writestr (^M^P'['^R'Conference Sysop Command'^P']'^S': *');
 choice:=upcase(input[1]);
 if choice='A' then begin
repeat
writeln (^M^R'['^S'A'^R'] Conference #1 Name    : '^S+conf1);
writeln (^R'['^S'B'^R'] Conference #1 Sponsor : '^S+con1spon);
writeln (^R'['^S'C'^R'] Conference #1 Entry PW: '^S+con1pw);
writeln (^R'['^S'Q'^R'] Quit:');
writestr (^M^P'['^R'Conference Modify Command'^P']'^S': *');
 choice1:=upcase(input[1]);
if choice1='A' then begin writestr ('Input: *'); conf1:=input; end;
if choice1='B' then begin writestr ('Input: *'); con1spon:=input; end;
if choice1='C' then begin writestr ('Input: *'); con1pw:=input; end;
until (choice1='Q');
writeconfig;
end;
 if choice='B' then begin
repeat
writeln (^M^R'['^S'A'^R'] Conference #2 Name    : '^S+conf2);
writeln (^R'['^S'B'^R'] Conference #2 Sponsor : '^S+con2spon);
writeln (^R'['^S'C'^R'] Conference #2 Entry PW: '^S+con2pw);
writeln (^R'['^S'Q'^R'] Quit:');
writestr (^M^P'['^R'Conference Modify Command'^P']'^S': *');
 choice2:=upcase(input[1]);
if choice2='A' then begin writestr ('Input: *'); conf2:=input; end;
if choice2='B' then begin writestr ('Input: *'); con2spon:=input; end;
if choice2='C' then begin writestr ('Input: *'); con2pw:=input; end;
until (choice2='Q');
writeconfig;
end;
 if choice='C' then begin
repeat
writeln (^M^R'['^S'A'^R'] Conference #3 Name    : '^S+conf3);
writeln (^R'['^S'B'^R'] Conference #3 Sponsor : '^S+con3spon);
writeln (^R'['^S'C'^R'] Conference #3 Entry PW: '^S+con3pw);
writeln (^R'['^S'Q'^R'] Quit:');
writestr (^M^P'['^R'Conference Modify Command'^P']'^S': *');
 choice3:=upcase(input[1]);
if choice3='A' then begin writestr ('Input: *'); conf3:=input; end;
if choice3='B' then begin writestr ('Input: *'); con3spon:=input; end;
if choice3='C' then begin writestr ('Input: *'); con3pw:=input; end;
until (choice3='Q');
writeconfig;
end;
 if choice='D' then begin
repeat
writeln (^M^R'['^S'A'^R'] Conference #4 Name    : '^S+conf4);
writeln (^R'['^S'B'^R'] Conference #4 Sponsor : '^S+con4spon);
writeln (^R'['^S'C'^R'] Conference #4 Entry PW: '^S+con4pw);
writeln (^R'['^S'Q'^R'] Quit:');
writestr (^M^P'['^R'Conference Modify Command'^P']'^S': *');
 choice4:=upcase(input[1]);
if choice4='A' then begin writestr ('Input: *'); conf4:=input; end;
if choice4='B' then begin writestr ('Input: *'); con4spon:=input; end;
if choice4='C' then begin writestr ('Input: *'); con4pw:=input; end;
until (choice4='Q');
writeconfig;
end;
 if choice='E' then begin
repeat
writeln (^M^R'['^S'A'^R'] Conference #5 Name    : '^S+conf5);
writeln (^R'['^S'B'^R'] Conference #5 Sponsor : '^S+con5spon);
writeln (^R'['^S'C'^R'] Conference #5 Entry PW: '^S+con5pw);
writeln (^R'['^S'Q'^R'] Quit:');
writestr (^M^P'['^R'Conference Modify Command'^P']'^S': *');
choice5:=upcase(input[1]);
if choice5='A' then begin writestr ('Input: *'); conf5:=input; end;
if choice5='B' then begin writestr ('Input: *'); con5spon:=input; end;
if choice5='C' then begin writestr ('Input: *'); con5pw:=input; end;
until (choice5='Q');
writeconfig;
end;
until (choice='Q');
writeconfig;
end;}

procedure readerrlog;
begin
  writehdr ('Read Error Log');
  if exist (bbsdatadir+'Errlog.dat')
    then printfile (bbsdatadir+'Errlog.dat')
    else writestr ('No error file!')
end;

procedure showad;
var fn:lstr;
begin
  writehdr ('Advertisement');
  fn:=textfiledir+'FAQ.Ad';
  if exist (fn) then printfile (fn) else begin
  writeln (^M'No Advertisement.'^M);
  writeln (usr,'Sysop: To make one, create a file called FAQ.AD in your Menus Directory.'^M);
  end;
end;

procedure setlastcall;

  function digit (k:char):boolean;
  begin
    digit:=ord(k) in [48..57]
  end;

  function validtime (inp:sstr):boolean;
  var c,s,l:integer;
      d1,d2,d3,d4:char;
      ap,m:char;
  begin
    validtime:=false;
    l:=length(inp);
    if (l<7) or (l>8) then exit;
    c:=pos(':',inp);
    if c<>l-5 then exit;
    s:=pos(' ',inp);
    if s<>l-2 then exit;
    d2:=inp[c-1];
    if l=7
      then d1:='0'
      else d1:=inp[1];
    d3:=inp[c+1];
    d4:=inp[c+2];
    ap:=upcase(inp[s+1]);
    m:=upcase(inp[s+2]);
    if d1='1' then if d2>'2' then d2:='!';
    if (d1>='0') and (d1<='1') and digit(d2) and (d3>='0') and (d3<='5')
       and digit(d4) and ((ap='A') or (ap='P')) and (m='M')
         then validtime:=true
  end;

  function validdate (inp:sstr):boolean;
  var k,l:char;

    function gchar:char;
    begin
      if length(inp)=0 then begin
        gchar:='?';
        exit
      end;
      gchar:=inp[1];
      delete (inp,1,1)
    end;

  begin
    validdate:=false;
    k:=gchar;
    l:=gchar;
    if not digit(k) then exit;
    if l='/'
      then if k='0'
        then exit
        else
      else begin
        if k>'1' then exit;
        if not digit(l) then exit;
        if (l>'2') and (k='1') then exit;
        l:=gchar;
        if l<>'/' then exit
      end;
    k:=gchar;
    l:=gchar;
    if l='/'
      then if k='0'
        then exit
        else
      else begin
        if k>'3' then exit;
        if not digit(l) then exit;
        if (k='3') and (l>'1') then exit;
        l:=gchar;
        if l<>'/' then exit
      end;
    if digit(gchar) and digit(gchar) then validdate:=true
  end;

begin
  writehdr ('Set Last Call');
  writeln (^M'Your last call was: '^S+datestr(laston),' at '+timestr(laston));
  writestr (^M'Enter new date [mm/dd/yy]:');
  if length(input)>0
    then if validdate (input)
      then laston:=dateval(input)+timepart(laston)
      else writestr ('Invalid date!');
  writestr (^M'Enter new time [hh:mm am/pm]:');
  if length(input)>0
    then if validtime(input)
      then laston:=timeval(input)+datepart(laston)
      else writestr ('Invalid time!')
end;

procedure removeallforms;
var ndel,cygnus:integer;
    u:userrec;

procedure eraseinfo1;
var cnt:integer;
begin
  ndel:=0;
  for cnt:=1 to numusers do begin
   if (cnt mod 10)=0 then write (cnt,', ');
   seek (ufile,cnt);
   read (ufile,u);
   if u.infoform1>=0 then begin
     deletetext (u.infoform1);
     u.infoform1:=-1;
     seek (ufile,cnt);
     write (ufile,u);
     ndel:=ndel+1
   end
  end;
end;

procedure eraseinfo2;
var cnt:integer;
begin
  ndel:=0;
  for cnt:=1 to numusers do begin
   if (cnt mod 10)=0 then write (cnt,', ');
   seek (ufile,cnt);
   read (ufile,u);
   if u.infoform2>=0 then begin
     deletetext (u.infoform2);
     u.infoform2:=-1;
     seek (ufile,cnt);
     write (ufile,u);
     ndel:=ndel+1
   end
  end;
end;

procedure eraseinfo3;
var cnt:integer;
begin
  ndel:=0;
  for cnt:=1 to numusers do begin
   if (cnt mod 10)=0 then write (cnt,', ');
   seek (ufile,cnt);
   read (ufile,u);
   if u.infoform3>=0 then begin
     deletetext (u.infoform3);
     u.infoform3:=-1;
     seek (ufile,cnt);
     write (ufile,u);
     ndel:=ndel+1
   end
  end;
end;

procedure eraseinfo4;
var cnt:integer;
begin
  ndel:=0;
  for cnt:=1 to numusers do begin
   if (cnt mod 10)=0 then write (cnt,', ');
   seek (ufile,cnt);
   read (ufile,u);
   if u.infoform4>=0 then begin
     deletetext (u.infoform4);
     u.infoform4:=-1;
     seek (ufile,cnt);
     write (ufile,u);
     ndel:=ndel+1
   end
  end;
end;

procedure eraseinfo5;
var cnt:integer;
begin
  ndel:=0;
  for cnt:=1 to numusers do begin
   if (cnt mod 10)=0 then write (cnt,', ');
   seek (ufile,cnt);
   read (ufile,u);
   if u.infoform5>=0 then begin
     deletetext (u.infoform5);
     u.infoform5:=-1;
     seek (ufile,cnt);
     write (ufile,u);
     ndel:=ndel+1
   end
  end;
end;

begin
  writehdr ('Erase Infoform[s]');
  writestr ('Erase ALL of which Info-Form? [#1-5]: *');
  if (valu(input)<1) or (valu(input)>5) then exit;
  cygnus:=valu(input);
  writestr ('Erase ALL # '+strr(valu(input))+' Info-Forms -- Are you sure [y/n]? *');
  if not yes then exit;
  writeurec;
  writestr (^M'Erasing.  please stand by.');
  ndel:=0;
  case cygnus of
   1:eraseinfo1;
   2:eraseinfo2;
   3:eraseinfo3;
   4:eraseinfo4;
   5:eraseinfo5;
  end;
  writeln ('Done.');
  writestr (^M'All # '+strr(cygnus)+' Infoforms erased.');
  writestr (strr(ndel)+' Users Processed.');
  readurec
end;

procedure readfeedback;
var ffile:file of mailrec;
    m:mailrec;
    me:message;
    cur:integer;

  function nummessages:integer;
  begin
    nummessages:=filesize(ffile)
  end;

  function checkcur:boolean;
  begin
    if length(input)>1 then cur:=valu(copy(input,2,255));
    if (cur<1) or (cur>nummessages) then begin
      writestr (^M'Message out of range!');
      cur:=0;
      checkcur:=true
    end else begin
      checkcur:=false;
      seek (ffile,cur-1);
      read (ffile,m)
    end
  end;

  procedure readnum (n:integer);
  begin
    cur:=n;
    input:='';
    if checkcur then exit;
    writeln (^B^M'Message: '^S,cur,
               ^M'Title:   '^S,m.title,
               ^M'Sent by: '^S,m.sentby,
               ^M'Sent on: '^S,datestr(m.when),' at ',timestr(m.when),^M);
    if break then exit;
    printtext (m.line)
  end;

  procedure writecurmsg;
  begin
    if (cur<1) or (cur>nummessages) then cur:=0;
    write (^B^R^M'Current msg: '^S);
    if cur=0 then write ('None') else begin
      seek (ffile,cur-1);
      read (ffile,m);
      write (m.title,' by ',m.sentby)
    end
  end;

  procedure delfeedback;
  var cnt:integer;
  begin
    if checkcur then exit;
    deletetext (m.line);
    for cnt:=cur to nummessages-1 do begin
      seek (ffile,cnt);
      read (ffile,m);
      seek (ffile,cnt-1);
      write (ffile,m)
    end;
    seek (ffile,nummessages-1);
    truncate (ffile);
    cur:=cur-1
  end;

  procedure editusr;
  var n:integer;
  begin
    if checkcur then exit;
    n:=lookupuser (m.sentby);
    if n=0
      then writestr ('User disappeared!')
      else edituser (n)
  end;

  procedure infoform;
  begin
    if checkcur then exit;
    showinfoforms (m.sentby)
  end;

  procedure nextfeedback;
  begin
    cur:=cur+1;
    if cur>nummessages then begin
      writestr (^M'Sorry, no more feedback!');
      cur:=0;
      exit
    end;
    readnum (cur)
  end;

  procedure readagain;
  begin
    if checkcur then exit;
    readnum (cur)
  end;

  procedure replyfeedback;
  begin
    if checkcur then exit;
    sendmailto (m.sentby,false)
  end;

  procedure listfeedback;
  var cnt:integer;
  begin
    if nummessages=0 then exit;
    thereare (nummessages,'piece of feedback','pieces of feedback');
    if break then exit;
    writeln (^M'Num Title                          Left by'^M);
    seek (ffile,0);
    for cnt:=1 to nummessages do begin
      read (ffile,m);
      tab (strr(cnt),4);
      if break then exit;
      tab (m.title,31);
      writeln (m.sentby);
      if break then exit
    end
  end;

  Var q:Integer;
  Label exit;
  Begin
    Assign(ffile,bbsdatadir+'Feedback.dat');
    Reset(ffile);
    If IOResult<>0 Then Rewrite(ffile);
    cur:=0;
    Repeat
      If nummessages=0 Then Begin
        writestr('Sorry, no feedback!');
        GoTo exit
      End;{listfeed}
      writecurmsg;

      q:=menu ('Feedback','FEED','Q#DEIR_AL?');
      If q<0
      Then readnum(-q)
      Else Case q Of
        3:delfeedback;
        4:editusr;
        5:infoform;
        6:replyfeedback;
        7:nextfeedback;
        8:readagain;
        9:listfeedback;
       10:begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ Feedback Section                    ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [A]  s');
writeln ('uRead Feedback Again            ║HC║ [Ds');
writeln ('u]  Delete Feedback                ║HC║ [s');
writeln ('uE]  Edit User                      ║Hs');
writeln ('uC║ [I]  Infoforms                      s');
writeln ('u║HC║ [L]  List Feedback           s');
writeln ('u       ║HC║ [Q]  Quit             s');
writeln ('u              ║HC║ [R]  Reply to Fs');
writeln ('ueedback              ║HC║ [#]  Reas');
writeln ('ud Feedback File             ║HC║ [CR] s');
writeln ('uRead Next Feedback             ║HC║ [?s');
writeln ('u]  View This Menu                 ║HC╚═A');
writeln ('C════════════════════════════════════╝');
write (^B^R' '^M);
pause;
           end;

      End
    Until (q=1) Or hungupon;
exit:
    Close(ffile)
  End;

     procedure stat;
     begin
     ansicolor (urec.statcolor)
     end;

     procedure prompt;
     begin
     ansicolor (urec.promptcolor)
     end;

     procedure yourstatus;
  var cnt,gnumsgs,gnufiles,gnugfiles,gnudbases,clicheline:integer;
     var u:userrec;
     begin
  if ansigraphics in urec.config
    then write (direct,#27'[2J');
     gnumsgs:=(messages-urec.lastmessages);
     gnufiles:=(ups-urec.lastups);
     gnugfiles:=(gfilez-urec.lastgfiles);
     gnudbases:=(dbases-urec.lastdbases);
     if gnumsgs<1 then gnumsgs:=0;
     if gnufiles<1 then gnufiles:=0;
     if gnugfiles<1 then gnugfiles:=0;
     if gnudbases<1 then gnudbases:=0;
     urec.lastmessages:=messages;
     urec.lastups:=ups;
     urec.lastgfiles:=gfilez;
     urec.lastdbases:=dbases;
     ansicolor (urec.promptcolor);
     writeln ('                         ╒═════════════════════╕');
     write ('                    ╒════╡ ');
     ansicolor (urec.statcolor);
     write ('FAQ '+ver+'/ '+date+'');
     ansicolor (urec.promptcolor);
     writeln (' ╞════╕');
     writeln (^P'                    │    ╘═════════════════════╛    │');
     write (^P'                    │ '^R'User Name  : '); ansicolor (urec.statcolor); tab (unam,17);
     ansicolor (urec.promptcolor); writeln (^P'│');
     write (^P' ┌─┤ '^R'New Status '^P'├─┐ │ '^R'User Level : ');
     ansicolor (urec.statcolor); tab (strr(ulvl),17);
     ansicolor (urec.promptcolor); writeln (^P'│');
     write (^P' │'^R'Messages : '); stat; if gnumsgs<1 then tab ('None',5) else tab (strr(gnumsgs),5);
     write (^P'│ │ '^R'Xfer Level : ');
     stat; tab (strr(urec.udlevel),17); prompt; writeln ('│ ┌─┤ '^R'File  Xfer '^P'├─┐');
     write (^P' │'^R'Databases: '); stat; if gnudbases<1 then tab ('None',5) else tab (strr(gnudbases),5);
     write (^P'│ │ '^R'Time Today : ');
     stat; tab (strr(urec.timetoday),17); prompt; write (^P'│ │'^R'Num U/Ls : '^S); if urec.uploads<1 then tab ('None',5)
     else tab (strr(urec.uploads),5);
     writeln (^P'│');
     write (^P' │'^R'Files    : '); stat; if gnufiles<1 then tab ('None',5) else tab (strr(gnufiles),5);
     write (^P'│ │ '^R'# of Calls : ');
     stat; tab (strr(urec.numon),17); prompt; write (^P'│ │'^R'Num D/Ls : '^S); if urec.downloads<1 then tab ('None',5)
     else tab (strr(urec.uploads),5);
     writeln (^P'│');
     write (^P' │'^R'G-Files  : '); stat; if gnugfiles<1 then tab ('None',5) else tab (strr(gnugfiles),5);
     write (^P'│ │ '^R'Mail Status: ');
     stat;
     cnt:=getnummail (unum);
     if cnt<1 then tab ('None',17) else tab (strr(cnt),17);
     prompt; write (^P'│ │'^R'F. Points: '^S); if urec.udpoints<1 then tab ('None',5) else tab (strr(urec.udpoints),5);
     writeln (^P'│');
     write (^P' │'^R'Hack A.  : '); stat; if urec.hack=0 then tab ('None',5) else tab (strr(urec.hack),5);
     write (^P'│ │ '^R'Last On    : ');
     stat;
          if laston<>0 then
     tab (datestr(laston),17) else
     tab ('None ',17);
     subs1.laston:=laston;
     laston:=now;
     prompt;
     writeln (^P'│ └────────────────┘');
     write (^P' └────────────────┘ │ '^R'Last Caller: '); stat; tab (getlastcaller,17); prompt; writeln ('│');
   { if useqr then begin }
     calcqr;
     write (^P'                    │ '^R'Rating     : '); stat; tab (strr(qr),17); prompt; writeln ('│');
   { end; }
     write (^P'                    │ '^R'Comments   : '); stat; tab (urec.note,17); prompt; writeln ('│');
     writeln (^P'                    ╘═══════════════════════════════╛');
     writeln;
   end;

procedure topposter;
      type HighestPCR=record
             Name:mstr;
             PCR:longint;
             end;
  var a,b,c,d,e,cnt,UptoDown:longint;
  done:boolean;
      TMPrec:userrec;
      Posters:array [1..5] of highestpcr;
      LamePosters:array [1..5] of highestpcr;
      Uploaders:array [1..5] of highestpcr;
      LameUploaders:array [1..5] of highestpcr;
      Downloaders:array [1..5] of highestpcr;
      LameDownloaders:array [1..5] of highestpcr;

      TmpPost:highestpcr;


     begin
     Writehdr ('Calculating Statistics');

       for cnt:=1 to 5 do begin
        Posters[cnt].pcr:=maxint;
        posters[cnt].name:='';
        lamePosters[cnt].pcr:=0;
        lameposters[cnt].name:='';
        Downloaders[cnt].pcr:=maxint;
        downloaders[cnt].name:='';
        lamedownloaders[cnt].pcr:=0;
        lamedownloaders[cnt].name:='';
               uploaders[cnt].pcr:=maxint;
        uploaders[cnt].name:='';
        lameuploaders[cnt].pcr:=0;
        lameuploaders[cnt].name:='';

       end;
     for cnt:=1 to numusers do begin
      seek(ufile,cnt);
      read(ufile,TmpRec);

        if tmprec.numon>1 then begin

        if tmprec.numon>0 then  d:=(tmprec.nbu*100) div tmprec.numon else d:=0;



      if d>0 then  begin
                          done:=false;
                for e:=1 to 5 do begin
                 if (done=false) and (posters[e].pcr<d) then begin  { sort }
                    if e<5 then begin
                      for a:=4 downto e do begin
                        posters[a+1]:=posters[a];
                      end;
                    end;
                   posters[e].pcr:=d;
                   posters[e].name:=tmprec.handle;
                  Done:=true;
                 end;
         end;
       end;

        begin
                          done:=false;
                for e:=1 to 5 do begin
                 if (done=false) and (lameposters[e].pcr>d) then begin  { sort }
                    if e>1 then begin
                      for a:=4 downto e do begin
                        lameposters[a+1]:=lameposters[a];
                      end;
                    end;
                   lameposters[e].pcr:=d;
                   lameposters[e].name:=tmprec.handle;
                  Done:=true;
                 end;
         end;
       end;

d:=tmprec.upk;

      if d>0 then  begin
                          done:=false;
                for e:=1 to 5 do begin
                 if (done=false) and (Uploaders[e].pcr<d) then begin  { sort }
                    if e<5 then begin
                      for a:=4 downto e do begin
                        Uploaders[a+1]:=uploaders[a];
                      end;
                    end;
                   uploaders[e].pcr:=d;
                   uploaders[e].name:=tmprec.handle;
                  Done:=true;
                 end;
         end;
       end;

        begin
                          done:=false;
                for e:=1 to 5 do begin
                 if (done=false) and (lameuploaders[e].pcr>d) then begin  { sort }
                    if e>1 then begin
                      for a:=4 downto e do begin
                        lameuploaders[a+1]:=lameuploaders[a];
                      end;
                    end;
                   lameuploaders[e].pcr:=d;
                   lameuploaders[e].name:=tmprec.handle;
                  Done:=true;
                 end;
         end;
       end;
d:=tmprec.downk;

      if d>0 then  begin
                          done:=false;
                for e:=1 to 5 do begin
                 if (done=false) and (downloaders[e].pcr<d) then begin  { sort }
                    if e<5 then begin
                      for a:=4 downto e do begin
                        downloaders[a+1]:=downloaders[a];
                      end;
                    end;
                   downloaders[e].pcr:=d;
                   downloaders[e].name:=tmprec.handle;
                  Done:=true;
                 end;
         end;
       end;

        begin
                          done:=false;
                for e:=1 to 5 do begin
                 if (done=false) and (lamedownloaders[e].pcr>d) then begin  { sort }
                    if e>1 then begin
                      for a:=4 downto e do begin
                        lamedownloaders[a+1]:=lamedownloaders[a];
                      end;
                    end;
                   lamedownloaders[e].pcr:=d;
                   lamedownloaders[e].name:=tmprec.handle;
                  Done:=true;
                 end;
         end;
       end;

      end;
     end;
clearscr;
writeln(^R'┌─'^P'['^S' Top Five Posters'^P' ]'^R'────────────────┐┌─'^P'['^S' Top Five Lowest Posters'^P' ]'^R'─────────┐');
writeln(^R'│'^S'User Name             Post Call Ratio'^S'││'^S'User Name             Post Call Ratio'^S'│');
writeln(^R'│'^S'1.                           '^P'[      ]'^R'││'^S'1.                           '^P'[      ]'^R'│');
writeln(^R'│'^S'2.                           '^P'[      ]'^R'││'^S'2.                           '^P'[      ]'^R'│');
writeln(^R'│'^S'3.                           '^P'[      ]'^R'││'^S'3.                           '^P'[      ]'^R'│');
writeln(^R'│'^S'4.                           '^P'[      ]'^R'││'^S'4.                           '^P'[      ]'^R'│');
writeln(^R'│'^S'5.                           '^P'[      ]'^R'││'^S'5.                           '^P'[      ]'^R'│');
writeln(^R'└─────────────────────────────────────┘└─────────────────────────────────────┘');
   movexy(4,3);write(posters[1].name);
   movexy(4,4);write(posters[2].name);
   movexy(4,5);write(posters[3].name);
   movexy(4,6);write(posters[4].name);
   movexy(4,7);write(posters[5].name);
   movexy(32,3);write(posters[1].pcr:5,'%');
   movexy(32,4);write(posters[2].pcr:5,'%');
   movexy(32,5);write(posters[3].pcr:5,'%');
   movexy(32,6);write(posters[4].pcr:5,'%');
   movexy(32,7);write(posters[5].pcr:5,'%');
   movexy(43,3);write (lameposters[1].name);
   movexy(43,4);write (lameposters[2].name);
   movexy(43,5);write (lameposters[3].name);
   movexy(43,6);write (lameposters[4].name);
   movexy(43,7);write (lameposters[5].name);
   movexy(71,3);write (lameposters[1].pcr:5,'%');
   movexy(71,4);write (lameposters[2].pcr:5,'%');
   movexy(71,5);write (lameposters[3].pcr:5,'%');
   movexy(71,6);write (lameposters[4].pcr:5,'%');
   movexy(71,7);write (lameposters[5].pcr:5,'%');
  movexy(1,14);writestr(^R'Press '^P'['^S'Return'^P']'^S': '^U'*');
  end;

procedure spacespace (i:integer);
var ii:integer;
begin
for ii:=1 to i do write (' ');
end;

end.