|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 17280 (0x4380)
Types: TextFile
Names: »TELEPROC.PAS«
└─⟦6032ef8bc⟧ Bits:30003298 Turbo Pascal 3.01A og diverse programmer til RC700
└─⟦this⟧ »TELEPROC.PAS«
PROCEDURE break_olp;
BEGIN
READ(KBD,ch);
IF ch='/' THEN
BEGIN
WRITE('Break Printer,j/n '); READ(KBD,ch);
IF ch IN Æ'J','j'Å THEN
BEGIN
WRITELN(ch,'a.'); ok:=FALSE;
END ELSE BEGIN WRITE(@13); cleol; END;
END;
END;
PROCEDURE lineform(verdi: INTEGER);
BEGIN
IF verdi=12 THEN WRITE(prn,CHR(verdi))
ELSE FOR i:=1 TO verdi DO WRITELN(prn);
END;
PROCEDURE hoved;
BEGIN
IF olp THEN
BEGIN
IF NOT lp_on THEN (* start printer *)
BEGIN
WRITELN('Printer Listning./.':44);
IF skrift=3 THEN nyside:=255 ELSE nyside:=lintop;
lp_on:=TRUE;
ASSIGN(prn,'LST:'); REWRITE(prn);
END;
IF side>1 THEN lineform(form); (* Form-/Line-Feed *)
WRITELN(UP,'Side ',side); (* consol-mess. *)
IF skrift<3 THEN
BEGIN
IF norm>0 THEN WRITE(prn,CHR(norm));
WRITE(prn,'Udskrift fra ':28,filnavn);
WRITELN(prn,' * Side ',side,'.'); WRITELN(prn);
END; (* quick *)
END ELSE WRITELN(CLRHOM);
IF skrift=1 THEN
BEGIN
WRITE(prn,' NAVN Telf.Nr ');
WRITELN(prn,' Initialer Post-Distrikt');
WRITELN(prn);
END; (* quick *)
nohead:=FALSE; side:=side+1;
END;
PROCEDURE vent;
BEGIN
nohead:=TRUE; (* Flere data? - Nyt Hoved *)
IF NOT lp_on THEN
BEGIN
WRITE('<',line,'>,flere linier./.');
READ(KBD,ch); WRITE(@13); cleol; (* Vent her *)
IF ch IN Æ'/','3'Å THEN ok:=FALSE; (* Abort readout *)
END;
END;
PROCEDURE udskriv;
BEGIN
IF fpo.flag='s' THEN EXIT; (* slettet post *)
IF nohead THEN hoved;
line:=line+1;
WITH fpo DO BEGIN
CASE skrift OF
1: WRITELN(prn,navn,' ',telf,' ',idnt,' ',byno);
2: IF lp_on THEN
BEGIN (* Print-Total: 123char+spacer *)
IF komp>0 THEN WRITE(prn,CHR(komp));
WRITE(prn,navn,' ',telf,' ',j:3,flag);
WRITELN(prn,' ',idnt,' ',stil,' ',addr,' ',byno);
END ELSE
BEGIN
WRITE(@10,navn,' - Nr',flag,j,'/Grup.',grup);
WRITELN(': ',grup_kodeÆORD(grup)-48Å);
WRITELN(idnt,' ',stil);
WRITELN(telf,', ',addr,' ',byno,@10);
END;
3: IF lp_on THEN
BEGIN (* Labels *)
IF nlqon>0 THEN WRITE(prn,CHR(27),CHR(nlqon)); (* Set NLQ *)
WRITELN(prn,sp,navn);
WRITELN(prn,sp,addr);
WRITELN(prn,sp,byno);
FOR i:=1 TO labfed DO WRITELN(prn);
IF nlqoff>0 THEN WRITE(prn,CHR(27),CHR(nlqoff)); (* NLQ=off *)
END ELSE
BEGIN (* Skaerm-Labels *)
WRITELN(sp,navn); WRITELN(sp,addr);
WRITELN(sp,byno);
FOR i:=1 TO labfed DO WRITELN;
END;
END; (* case *)
END; (* fpo *)
IF lp_on THEN IF KEYPRESS THEN break_olp;
IF line MOD nyside=0 THEN vent;
END;
PROCEDURE printer_off;
BEGIN
IF lp_on AND (line>0) THEN (* stop *)
BEGIN
IF skrift<>3 THEN (* Antal udskrevne navne *)
WRITELN(prn,'<',line,'>');
IF norm>0 THEN WRITE(prn,CHR(norm));
lineform(linfed);
ASSIGN(prn,'CON:');
REWRITE(prn);
END;
WRITE('<',line,'>03'); (* vent her hvis ej /3 *)
IF (ch<>'/') AND (ch<>'3') THEN READ(KBD,ch);
IF ch='3' THEN modul:=ch;
END;
PROCEDURE readout(start: INTEGER);
BEGIN
ok:=TRUE; lp_on:=FALSE; nohead:=TRUE; ch:=' ';
IF skrift=1 THEN nyside:=20 ELSE nyside:=4; (* Skaerm *)
line:=start-(offset+1); nul:=line; j:=line; sp:='';
side:=1+(line-1) DIV nyside; (* Find side-No. *)
FOR i:=1 TO inryk DO sp:=sp+' '; (* Label-margin *)
SEEK(fv,start);
WHILE ok AND NOT EOF(fv) DO
BEGIN
READ(fv,fpo); j:=j+1;
IF modul='4' THEN
udskriv
ELSE BEGIN
CASE nr OF
'1': IF lede=fpo.grup THEN udskriv;
'2': IF POS(lede,fpo.navn)>0 THEN udskriv;
'3': IF POS(lede,fpo.idnt)>0 THEN udskriv;
'4': IF POS(lede,fpo.stil)>0 THEN udskriv;
'5': IF POS(lede,fpo.addr)>0 THEN udskriv;
'6': IF POS(lede,fpo.byno)>0 THEN udskriv;
'7': IF POS(lede,fpo.telf)>0 THEN udskriv;
END;
END;
END;
IF line=0 THEN BEGIN
WRITE(UP,nr:24,'. ',lede,' findes ikke'); cleol; WRITELN;
END;
printer_off;
END;
PROCEDURE viskode(yin,xout,yout: BYTE);
BEGIN
cursor(0,yin);
IF modul3 THEN WRITELN('Gruppekoder:',@10);
FOR i:=0 TO 9 DO WRITELN(i,': ',grup_kodeÆiÅ);
cursor(xout,yout);
END;
PROCEDURE holdt;
BEGIN
REPEAT
WRITE(@7); READ(KBD,ch);
i:=ORD(ch); IF i>96 THEN i:=i-32;
IF i>94 THEN i:=8;
UNTIL i<21;
END;
PROCEDURE copytxt;
BEGIN
IF i=11 THEN
BEGIN
txtcopy:=txt; gempy:=py; indset:=TRUE;
END ELSE
IF indset AND ((plx=1) AND (py=gempy)) THEN
BEGIN
txt:=txtcopy; WRITELN(txt); i:=13;
END;
END;
PROCEDURE back(space: BYTE);
BEGIN
plx:=plx-1; WRITE(@8);
IF space=8 THEN
BEGIN
WRITE(' ',@8); txtÆplxÅ:=' ';
END;
END;
PROCEDURE stopmark(pxind,pxud: INTEGER);
BEGIN
cursor(pxind+px,py);
WRITE('<<');
cursor(pxud,py);
END; (* stopmark *)
PROCEDURE slet_linie;
BEGIN
cursor(8,23); WRITE(txt);
cleol; txt:=fyld; plx:=1;
cursor(px,py); cleol;
END;
PROCEDURE delin(txlen: INTEGER);
VAR tx1,tx2: str26;
BEGIN
IF plx>=txlen THEN EXIT; (* Illegal *)
tx1:=COPY(txt,1,plx-1);
IF i=7 THEN
BEGIN
tx2:=COPY(txt,plx+1,txlen-plx);
txt:=tx1+tx2+' ';
END ELSE
BEGIN
tx2:=COPY(txt,plx,txlen-plx);
txt:=tx1+' '+tx2;
END; (* i *)
cursor(px,py); WRITE(txt);
cursor(px-1+plx,py);
END;
PROCEDURE nytext(lgd: INTEGER);
BEGIN
plx:=1; (* Relativ Cursor X-pos(1) *)
IF oprette THEN BEGIN
stopmark(lgd,px); txt:=fyld (* 26 spacer *)
END ELSE cursor(px,py);
REPEAT
REPEAT
READ(KBD,ch); i:=ORD(ch); IF i>96 THEN i:=i-32;
IF i>94 THEN i:=8;
IF (i=4) AND (plx<lgd) THEN BEGIN
WRITE(@24); plx:=plx+1;
END;
IF (plx=lgd+1) AND ((i>31) AND (i<95)) THEN holdt;
IF ((i=8) OR (i=19)) AND (plx>1) THEN back(i);
IF i=20 THEN BEGIN slet_linie; stopmark(lgd,px); END;
IF i=18 THEN stopmark(lgd,px-1+plx);
IF (i=7) OR (i=22) THEN delin(lgd);
IF (i=9) OR (i=11) THEN copytxt;
UNTIL (i=13) OR ((i>31) AND (i<95));
IF i>31 THEN
BEGIN
WRITE(CHR(i)); (* skriv og *)
txtÆplxÅ:=CHR(i); (* gem tegn *)
END;
plx:=plx+1;
UNTIL i=13;
py:=py+1;
END;
PROCEDURE printtxt;
BEGIN
menu;
py:=ypos; (* Cursor *)
cursor(0,py);
WITH fpo DO BEGIN
WRITE(' No: ',nummer-offset);
cursor(px-2,py); WRITELN(flag);
WRITE(' Gruppe-kode 0..9 / ........ : ',grup);
WRITELN(' ',grup_kodeÆORD(grup)-48Å);
py:=py+1;
WRITELN(' Efternavn, Fornavn(e) ..... : ',navn);
WRITELN(' Initialer/afd./call........ : ',idnt);
WRITELN(' Stilling/suppl.oplysninger. : ',stil);
WRITELN(' Gade/Vej-Navn og Hus-No.... : ',addr);
WRITELN(' Postnummer og Bynavn ...... : ',byno);
WRITELN(' Telefon-nummer ............ : ',telf);
IF modul='2' THEN IF cont THEN
WRITE(' C-on ') ELSE WRITE(' C-off');
WRITELN;
END;
END;
PROCEDURE skrivtxt;
BEGIN
WITH fpo DO BEGIN
txt:=navn; nytext(24); navn:=txt;
txt:=idnt; nytext(12); idnt:=txt;
txt:=stil; nytext(26); stil:=txt;
txt:=addr; nytext(24); addr:=txt;
txt:=byno; nytext(21); byno:=txt;
txt:=telf; nytext(12); telf:=txt;
END;
END;
PROCEDURE kodning;
BEGIN
REPEAT
cursor(px,py); READ(KBD,ch);
IF ch='/' THEN viskode(0,px,py);
IF ch IN Æ'0'..'9'Å THEN
BEGIN
fpo.grup:=ch;
WRITE(ch,' ',grup_kodeÆORD(ch)-48Å); cleol;
END;
UNTIL ORD(ch)=13;
py:=py+1;
END;
PROCEDURE inddata;
BEGIN
REPEAT
oprette:=TRUE;
IF (svar='N') OR (modul='2') THEN oprette:=FALSE;
IF oprette THEN (* clear tekst *)
BEGIN
fpo.flag:='u'; (* fpo.frik:='F' (not used) *)
fpo.grup:='9'; fpo.navn:=''; fpo.idnt:='';
fpo.stil:=''; fpo.addr:='';
fpo.byno:=''; fpo.telf:='';
printtxt;
END ELSE py:=ypos+1;
kodning;
skrivtxt;
cursor(0,py+1);
WRITE(' Er data ok, - J(a N(ej ? '); cleol;
janej;
UNTIL svar='J';
oprette:=FALSE;
END;
PROCEDURE nyopret;
BEGIN
IF no<=max THEN (* plads endnu *)
BEGIN
SEEK(fv,no);
REPEAT
nummer:=no;
inddata;
WRITE(fv,fpo);
no:=no+1;
WRITE(' Flere oprettelser, j/n ? ');
janej;
UNTIL (svar='N') OR (no>=max);
END ELSE BEGIN
WRITE(@7,@13,'Filen er fyldt op.! - Return.');
READ(KBD,ch);
END;
END;
PROCEDURE vejledn;
BEGIN
menu; modul3:=TRUE;
WRITELN(listdev:39);
WRITELN('Der kan søges på følgende:':50,@10);
WRITELN('0,1.) Gruppe-kode 0..9':48);
WRITELN('2.) Navn/Firma':40);
WRITELN('3.) Initialer':39);
WRITELN('4.) Stilling':38);
WRITELN('5.) Adresse':37);
WRITELN('6.) PostNr/BY':39);
WRITELN('7.) Telf.Nr':37,@10,nr:11,'.< ',lede,' >',UP);
WRITE('Hvad ønskes : ':40);
REPEAT
READ(KBD,nr); IF nr='1' THEN viskode(6,40,17);
UNTIL nr IN Æ'0'..'7'Å;
WRITELN(nr,@10);
IF nr='0' THEN nr:='1';
IF nr>'1' THEN BEGIN
WRITE(' Søgekriteriet kan ');
WRITELN('blot være dele af det søgte.',@10);
WRITE('/':22,' Skriv søgekriteriet : ');
END ELSE WRITE('/':21,' Angiv Gruppe-kode 0..9: ');
READLN(intxt);
FOR i:=1 TO LEN(intxt) DO IF intxtÆiÅ>='a'
THEN intxtÆiÅ:=CHR(ORD(intxtÆiÅ)-32);
IF intxt>'' THEN lede:=intxt;
modul3:=FALSE;
END;
PROCEDURE kig_efter;
BEGIN
REPEAT
vejledn; ch:=' ';
if ledeÆ1Å<>'/' THEN readout(1+offset);
IF ch='3' THEN svar:='J';
IF ch='0' THEN svar:='N';
IF (ch<>'0') AND (ch<>'3') THEN BEGIN
cursor(0,23);
WRITE('Flere søgninger, j/n ? '); cleol;
janej;
END;
UNTIL svar='N';
END;
PROCEDURE post_index;
BEGIN
CASE nr OF
'1': sbuf:=fpo.grup;
'2': sbuf:=fpo.navn;
'3': sbuf:=fpo.idnt;
'4': sbuf:=fpo.stil;
'5': sbuf:=fpo.addr;
'6': sbuf:=fpo.byno;
'7': sbuf:=fpo.telf;
END;
END;
PROCEDURE slettxt;
BEGIN
WRITE(@7,UP,' SKAL VEDKOMMENE SLETTES ? '); cleol;
clear:=FALSE;
janej;
IF svar='J' THEN fpo.flag:='s';
END;
PROCEDURE retpost(num: INTEGER);
BEGIN
SEEK(fv,num); fundet:=FALSE;
WHILE NOT fundet AND NOT EOF(fv) DO BEGIN
READ(fv,fpo);
post_index;
IF (POS(lede,sbuf)>0) OR (p_num='/') THEN
BEGIN
nummer:=(POSITION(fv))-1;
fundet:=TRUE;
printtxt;
IF fpo.flag<>'s' THEN BEGIN
WRITE(' Denne person: j/n, S(let ? ');
clr:=TRUE; janej; clr:=FALSE;
END ELSE BEGIN
WRITE(' Slettet post. - RETURN ');
READ(KBD,svar); svar:='N';
END;
IF clear THEN slettxt;
IF svar='J' THEN BEGIN
IF fpo.flag<>'s' THEN inddata;
BEGIN SEEK(fv,nummer); WRITE(fv,fpo); END;
END; (* svar *)
IF cont THEN FUNDET:=FALSE;
END;
END;
END;
PROCEDURE convert;
VAR n: INTEGER;
BEGIN
p_num:='*'; post:=0; n:=1;
IF (LEN(lede)>1) AND (ledeÆ1Å='/') THEN
BEGIN
p_num:='/';
FOR i:=LEN(lede) DOWNTO 2 DO
BEGIN
post:=post+(ORD(ledeÆiÅ)-48)*n; n:=n*10;
END;
post:=post+offset;
IF (post<3) OR (post>=no) THEN post:=-1;
(* Illegal Fil-post Nr *)
END;
END;
PROCEDURE rettelse;
BEGIN
cont:=FALSE;
REPEAT
modul2:=TRUE; nummer:=0;
vejledn;
convert;
IF (p_num='/') AND (post>0) THEN
retpost(post)
ELSE
IF ledeÆ1Å<>'/' THEN retpost(1+offset);
IF post<0 THEN
WRITELN('Galt søgekriterie : ':46,lede);
IF (lede<>'/') AND (nummer=0) AND (post>=0) THEN
BEGIN
WRITE(UP,nr:24,'. ',lede,' findes ikke'); cleol; WRITELN;
END;
modul2:=FALSE;
cursor(5,23); WRITE(' Flere rettelser, j/n ? '); cleol;
janej;
UNTIL svar='N';
END;
PROCEDURE print_gruppekoder;
BEGIN
WRITE(' Printer listning...',@13);
WRITELN(LST);
WRITELN(LST,' Gruppekoder for ',filnavn);
FOR i:=0 TO 9 DO WRITELN(LST,i:5,': ',grup_kodeÆiÅ);
WRITELN(LST,@10);
END;
PROCEDURE read_gruppekoder;
BEGIN
WRITE(' checkes... ');
no:=LENGTH(fv);
SEEK(fv,0);
i:=0; pass_ok:=TRUE;
FOR j:=0 TO 2 DO
BEGIN
READ(fv,fpo);
(* evnt.IF j=0 THEN prot_level:=fpo.grup; *)
IF j=0 THEN BEGIN
olpok:=fpo.flag;
password:=fpo.idnt;
setolp:=fpo.byno;
fil_dato:=fpo.telf;
END;
IF j=1 THEN BEGIN
pennword:=fpo.idnt;
setlab:=fpo.byno;
END;
grup_kodeÆj+iÅ:=fpo.navn;
i:=i+1;
grup_kodeÆj+iÅ:=fpo.stil;
i:=i+1;
grup_kodeÆj+iÅ:=fpo.addr;
END;
IF filnum>level THEN tilladelse;
(* only olpsetup on P-modified files.! *)
IF olpok='P' THEN make_olp_setup;
END;
PROCEDURE write_gruppekoder;
BEGIN
SEEK(fv,0);
i:=0; dato_ok:=TRUE;
fpo.grup:='9';
fpo.frik:='F'; (* future use *)
FOR j:=0 TO 2 DO BEGIN
fpo.flag:='u';
fpo.telf:='=Telefon-Nr.'; (* Orig *)
fpo.byno:='=Postnummer,/By-Navn.'; (* Orig *)
IF j=0 THEN BEGIN
fpo.flag:='P'; (* for olp-setup ok *)
fpo.idnt:=password+'.........';
fpo.byno:=setolp;
fpo.telf:=fil_dato;
END;
IF j=1 THEN BEGIN
fpo.idnt:=pennword+'.........'; (* Skriv *)
fpo.byno:=setlab;
END;
IF j=2 THEN fpo.idnt:='Identifier.2';
fpo.navn:=grup_kodeÆj+iÅ;
i:=i+1;
fpo.stil:=grup_kodeÆj+iÅ;
i:=i+1;
fpo.addr:=grup_kodeÆj+iÅ;
WRITE(fv,fpo);
END;
END;
PROCEDURE opret_gruppekoder;
BEGIN
menu;
cursor(0,0); WRITE(' ');
viskode(1,0,10);
cleol; WRITELN;
WRITELN('Max 20 tegn/Grp.<<-------------------->)');
WRITELN;
FOR j:=0 TO 8 DO BEGIN
REPEAT
WRITE(UP,'Indtast gruppe ',j,': '); cleol;
READLN(txt);
UNTIL LEN(txt)<=20;
WRITELN(@10,' << >>',UP);
IF txt>'' THEN grup_kodeÆjÅ:=txt
ELSE
WRITELN(' ':16,UP,UP,': ',grup_kodeÆjÅ,@10);
END;
WRITE(UP); cleol; WRITELN; cleol;
(* Evnt. protection-level input *)
WRITE('Nyt Password, FIL-Acces:(',maxpas,' tegn):=');
READLN(txt);
IF LEN(txt)=maxpas THEN password:=txt;
WRITE('Nyt Password, Skrivning:(',maxpen,' tegn):=');
READLN(txt);
IF LEN(txt)=maxpen THEN pennword:=txt;
END; (* opret gruppekoder / passwords. *)
(* end INCLUDE-FIL: 'TELEPROC.PAS', 6/11-87, (C) JFP *)
«eof»