summaryrefslogtreecommitdiff
path: root/app/baisy/2.2.1-schulis/src/isp.masken
blob: 12d5ef23a28b698c68ce4afbf0a0c90f8dc13ba1 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
PACKET textalsrowDEFINES ins,del,CAT ,ipos,dump,replaceiac,VSUB ,VISUB :LET 
nil13byte="�������������",nil4byte="����",nilbyte="�";TEXT VAR g1,code2:="��"
;PROC ins(TEXT VAR row,INT CONST wo,was):replace(code2,1,was);g1:=subtext(row
,2*wo-1);row:=subtext(row,1,2*wo-2);rowCAT code2;rowCAT g1END PROC ins;PROC 
del(TEXT VAR row,INT CONST wo):g1:=subtext(row,2*wo+1);row:=subtext(row,1,2*
wo-2);rowCAT g1END PROC del;OP CAT (TEXT VAR row,INT CONST was):replace(code2
,1,was);rowCAT code2END OP CAT ;INT PROC ipos(TEXT CONST row,INT CONST was):
INT VAR start:=0;replace(code2,1,was);REP start:=pos(row,code2,start+1)UNTIL 
startMOD 2=1OR start=0PER ;(start+1)DIV 2END PROC ipos;PROC dump(TEXT VAR row
):INT VAR i;FOR iFROM 1UPTO length(row)DIV 2REP put(rowISUB i)PER END PROC 
dump;PROC replaceiac(TEXT VAR string,INT CONST wo,TEXT CONST was):IF LENGTH 
string<=LENGTH was+wo-1THEN stretch(string,LENGTH was+wo-1)FI ;replace(string
,wo,was)END PROC replaceiac;PROC stretch(TEXT VAR t,INT CONST wo):WHILE 
LENGTH t<=wo-13REP tCAT nil13bytePER ;WHILE LENGTH t<=wo-4REP tCAT nil4byte
PER ;WHILE LENGTH t<woREP tCAT nilbytePER END PROC stretch;PROC replaceiac(
TEXT VAR string,INT CONST wo,INT CONST was):IF LENGTH string<=2*(wo+1)THEN 
stretch(string,2*(wo+1))FI ;replace(string,wo,was)END PROC replaceiac;INT OP 
VSUB (TEXT CONST string,INT CONST pos):code(stringSUB pos)END OP VSUB ;INT 
OP VISUB (TEXT CONST string,INT CONST pos):IF pos*2<=LENGTH stringTHEN string
ISUB posELSE 0FI END OP VISUB ;END PACKET textalsrow;#-S tand: 09.10.8617:45'
10398-7873997831794-186313620-87233256154684296-17369#PACKET screenservice
DEFINES screencursor,screenput,screenpage,screenline,screenout,screenbs,
screencopy,checkscreen,screenreorganized,screendirty,screenok,
reorganizescreen:#L screenlets#LET zeilen=24,spalten=80,ganzrichtig=0,
ganzfalsch=1,teilweisefalsch=3;LET emptyline="�
";TEXT CONST blankline:=
spalten*" ";ROW zeilenTEXT VAR screen;TEXT VAR buffer;INT VAR screenstatus:=
ganzfalsch;ROW zeilenBOOL VAR lineok;INT VAR zeile;INT VAR curx,cury,pbegin,
pend;.allesrichtig:ROW zeilenBOOL :(TRUE ,TRUE ,TRUE ,TRUE ,TRUE ,TRUE ,TRUE 
,TRUE ,TRUE ,TRUE ,TRUE ,TRUE ,TRUE ,TRUE ,TRUE ,TRUE ,TRUE ,TRUE ,TRUE ,
TRUE ,TRUE ,TRUE ,TRUE ,TRUE ).allesfalsch:ROW zeilenBOOL :(FALSE ,FALSE ,
FALSE ,FALSE ,FALSE ,FALSE ,FALSE ,FALSE ,FALSE ,FALSE ,FALSE ,FALSE ,FALSE ,
FALSE ,FALSE ,FALSE ,FALSE ,FALSE ,FALSE ,FALSE ,FALSE ,FALSE ,FALSE ,FALSE )
.;BOOL PROC screenreorganized:screenstatus=ganzrichtigEND PROC 
screenreorganized;PROC screendirty:screenstatus:=ganzfalsch;END PROC 
screendirty;PROC screenok:screenstatus:=ganzrichtig;END PROC screenok;PROC 
screenok(BOOL CONST wie,INT CONST von,bis):IF screenstatus=ganzfalschCAND wie
THEN lineok:=allesfalsch;screenstatus:=teilweisefalschELIF screenstatus=
ganzrichtigCAND NOT wieTHEN lineok:=allesrichtig;screenstatus:=
teilweisefalschFI ;IF screenstatus=teilweisefalschTHEN FOR zeileFROM vonUPTO 
bisREPEAT lineok(zeile):=wiePER FI END PROC screenok;PROC checkscreen:IF 
screenstatus<>ganzrichtigTHEN reorganizescreenFI END PROC checkscreen;
screenpage;PROC screencursor(INT CONST x,y):curx:=x;cury:=yEND PROC 
screencursor;PROC screenpage:FOR curyFROM 1UPTO zeilen-1REPEAT screen(cury):=
emptylinePER ;screen(zeilen):=blankline;cury:=1;curx:=1END PROC screenpage;
PROC screenbs:curxDECR 1END PROC screenbs;PROC screenline:curyINCR 1;curx:=1;
END PROC screenline;PROC screenput(TEXT CONST was):IF was>""THEN 
checkworkline;getfirstparttoput;WHILE theremaybearestREP replacepart;
getnextparttoputPER ;replacerestFI .getfirstparttoput:pbegin:=pos(was," ","�"
,1);pend:=pos(was,"�","�",pbegin)-1.theremaybearest:pend>0.replacepart:buffer
:=subtext(was,pbegin,pend);replace(workline,pbegin+curx-1,buffer).
getnextparttoput:pbegin:=pos(was," ","�",pend+2);IF pbegin>0THEN pend:=pos(
was,"�","�",pbegin)-1;ELSE pend:=0FI .replacerest:IF pbegin>0THEN IF pbegin=1
THEN replace(workline,curx,was)ELSE buffer:=subtext(was,pbegin,LENGTH was);
replace(workline,pbegin+curx-1,buffer)FI ;curxINCR LENGTH was;IF curx>spalten
THEN curyINCR 1;curxDECR spaltenFI ;FI .END PROC screenput;PROC screenout(
TEXT CONST was,INT CONST von,bis):buffer:=subtext(was,von,bis);checkscreen;
IF buffer>""THEN checkworkline;replace(workline,curx,buffer);curxINCR ((bis-
von)+1);IF curx>spaltenTHEN curyINCR 1;curxDECR spaltenFI FI .workline:screen
(cury).END PROC screenout;PROC screenout(TEXT CONST was):checkscreen;IF was>
""THEN checkworkline;replace(workline,curx,was);curxINCR LENGTH was;IF curx>
spaltenTHEN curyINCR 1;curxDECR spaltenFI FI .END PROC screenout;PROC 
reorganizescreen:out("�");IF screenstatus=teilweisefalschTHEN FOR zeileFROM 1
UPTO zeilen-1REPEAT IF lineok(zeile)THEN out("
")ELSE out(screen(zeile))FI 
PER ;IF NOT lineok(zeilen)THEN outsubtext(screen(zeilen),1,spalten-1);FI 
ELSE FOR zeileFROM 1UPTO zeilen-1REPEAT out(screen(zeile))PER ;outsubtext(
screen(zeilen),1,spalten-1);FI ;cursor(curx,cury);screenok;END PROC 
reorganizescreen;PROC screencopy(FILE VAR f):putline(f,"#page#");INT VAR 
zeile;FOR zeileFROM 1UPTO zeilenREPEAT TEXT VAR t:=screen(zeile);changeall(t,
"�"," ");changeall(t,"�"," ");putline(f,t)PER ;END PROC screencopy;PROC 
reorganizescreen(INT CONST zeile,von,bis):cursor(von,zeile);IF LENGTH screen(
zeile)<vonTHEN outsubtext(blankline,von,bis)ELSE outsubtext(screen(zeile),von
,bis)FI END PROC reorganizescreen;.checkworkline:IF LENGTH (workline)<3THEN 
workline:=blankline;FI .workline:screen(cury).END PACKET screenservice;
PACKET maskDEFINES TAG ,:=,nil,show,put,get,putget,leavingcode,xsize,ysize,
fields,fieldexists,formline,setautoesc,executecommandcode,length,cursor,
clearfield,definefield,setlasteditvalues,setneweditvalues,searchfield,
firstfield,nextfield,priorfield,fieldinfos,setfieldinfos,symbolicname,
auskunftsnr,fieldwithname,store,storefalse,page,SCROLL ,design,designfields,
designfield,designform,trans,TO ,transform,#V alt#fill,CLEARBY :#V std##L 
eumelcodes##L codeintlets#LET invers="",endinvers="",left="�",right="�",
home="�";LET chop=1,chome=1,cvor=2,cfeldende=18,crueck=8,cfeldanf=20,choch=3,
cfeldrueck=19,crunter=10,causkunft=0,ctab=9,csettab=21,ceinf=11,caufbrech=22,
causf=12,clearn=26,cfeldvor=13,cloeschende=24,cmark=16,cneu=17,cesc=27,
cseiterueck=15,centry=6,cseitevor=14;LET hoptasten="?aouAOUBb§</>(!)-k'= #",
hopcodes="�äöüÄÖÜßßß[\]{|}­k^~ \#";LET niltext="";#L maskenlets#LET tagtypenr=
999,filetypenr=1003,taglines=24,maxfields=100;#boardlines=2000,##boardtype=
777;#TEXT VAR cat;BOOL VAR beimletztenrausfallen:=FALSE ,prot:=FALSE ,
outputallowed:=TRUE ;BOOL VAR closedbit,protectbit,darstbit,tabbit,leftbit,
exitbit,rollbit,normal:=TRUE ;INT VAR workint,ausnr;PROC store(BOOL CONST ein
):prot:=ein;IF NOT einTHEN screendirty;outputallowed:=TRUE FI END PROC store;
PROC storefalse(INT CONST von,bis):prot:=FALSE ;screenok(FALSE ,von,bis);
outputallowed:=TRUE END PROC storefalse;BOOL PROC store:protEND PROC store;
PROC page:IF protTHEN screenpage;screenokFI ;IF outputallowedTHEN out("��")
FI END PROC page;PROC xoutsubtext(TEXT CONST was,INT CONST von,bis):IF prot
THEN screenout(was,von,bis)FI ;IF outputallowedTHEN outsubtext(was,von,bis)
FI END PROC xoutsubtext;TYPE TAG =STRUCT (TEXT erstel,darst,diainfo,dbnam,
ausknam,feld,x,y,len,tab,ROW taglinesTEXT formblatt,INT xmax,ymax,xs,ys,dbp,
ver,durchs,art);OP :=(TAG VAR a,TAG CONST b):CONCR (a):=CONCR (b)END OP :=;
PROC nil(TAG VAR t):t.formblatt:=ROW taglinesTEXT :("","","","","","","","",
"","","","","","","","","","","","","","","","");t.xmax:=0;t.ymax:=0;t.xs:=1;
t.ys:=1;t.dbp:=0;t.ver:=1;t.durchs:=0;t.art:=0;t.darst:="";t.erstel:="";t.
diainfo:="";t.dbnam:="";t.ausknam:="";t.feld:="";t.x:="";t.y:="";t.tab:="";t.
len:="";END PROC nil;INT PROC fields(TAG CONST a):LENGTH a.erstelEND PROC 
fields;BOOL PROC fieldexists(TAG CONST a,INT CONST feldnr):(a.erstelVSUB 
feldnr)>0END PROC fieldexists;INT PROC xsize(TAG CONST a):a.xmaxEND PROC 
xsize;INT PROC ysize(TAG CONST a):a.ymaxEND PROC ysize;TEXT PROC formline(
TAG CONST a,INT CONST l):a.formblatt(l)END PROC formline;PROC setinfo(TEXT 
CONST string,INT CONST pos):workint:=stringVSUB pos;IF workint>0THEN 
setallvaluesELSE normal:=TRUE FI .setallvalues:closedbit:=hbit;protectbit:=
hbit;darstbit:=hbit;tabbit:=hbit;leftbit:=hbit;exitbit:=hbit;rollbit:=hbit;
normal:=FALSE .hbit:workint:=workint*2;IF workint>255THEN workintDECR 256;
TRUE ELSE FALSE FI .END PROC setinfo;PROC clearfield(TAG VAR a,INT CONST feld
):sucheanfangdesfeldelementstring;sucheendedesfeldelementstring;
loeschefeldelementeintraege;korrigiereerstelverweise;loeschefeldeintraege.
sucheanfangdesfeldelementstring:INT VAR anf:=pos(a.feld,code(feld)).
sucheendedesfeldelementstring:INT VAR ende:=anf;WHILE (a.feldVSUB ende)=feld
REP endeINCR 1PER ;endeDECR 1.loeschefeldelementeintraege:change(a.feld,anf,
ende,"");change(a.x,anf,ende,"");change(a.y,anf,ende,"");change(a.len,anf,
ende,"");change(a.tab,anf,ende,"").korrigiereerstelverweise:INT VAR feldnr;
FOR feldnrFROM 1UPTO LENGTH a.erstelREP IF code(a.erstelSUB feldnr)>endeTHEN 
replace(a.erstel,feldnr,code(decrementierterwert))FI ;PER .
decrementierterwert:code(a.erstelSUB feldnr)-(ende-anf+1).
loeschefeldeintraege:replace(a.erstel,feld,"�");replace(a.darst,feld,"�");
replace(a.diainfo,feld,"�");IF LENGTH a.dbnam>=2*feldTHEN replace(a.dbnam,
feld,0)FI ;IF LENGTH a.ausknam>=2*feldTHEN replace(a.ausknam,feld,0)FI .END 
PROC clearfield;PROC definefield(TAG VAR t,TEXT CONST xb,yb,lenb,tabb,INT 
CONST dbnam,auskinfo,feldnr,TEXT CONST darst,diainfo):IF fieldexists(t,feldnr
)THEN clearfield(t,feldnr)FI ;elementarfeldpossuchen;elementarfeldereinfuegen
;erstelverweisekorrigieren;feldeintragen.elementarfeldpossuchen:
zumerstenelfeld;WHILE elfelddaCAND (liegtvorneuemCOR NOT isterstel)REP 
oldnumber:=feld;elementarfeldposINCR 1PER .elementarfeldereinfuegen:
insertchar(t.y,yb,elementarfeldpos);insertchar(t.x,xb,elementarfeldpos);
insertchar(t.tab,tabb,elementarfeldpos);insertchar(t.len,lenb,
elementarfeldpos);insertchar(t.feld,LENGTH xb*code(feldnr),elementarfeldpos).
erstelverweisekorrigieren:INT VAR fnr;FOR fnrFROM 1UPTO LENGTH t.erstelREP 
IF code(t.erstelSUB fnr)>=elementarfeldposTHEN replace(t.erstel,fnr,code(
incrementierterwert))FI ;PER .incrementierterwert:code(t.erstelSUB fnr)+
LENGTH xb.feldeintragen:replaceiac(t.erstel,feldnr,code(elementarfeldpos));
replaceiac(t.diainfo,feldnr,diainfo);replaceiac(t.darst,feldnr,darst);IF 
dbnam<>0THEN replaceiac(t.dbnam,feldnr,dbnam)FI ;IF auskinfo<>0THEN 
replaceiac(t.ausknam,feldnr,auskinfo)FI .zumerstenelfeld:INT VAR oldnumber:=0
;INT VAR elementarfeldpos:=1.liegtvorneuem:y<(ybSUB 1)OR (y=(ybSUB 1)AND x<(
xbSUB 1)).isterstel:oldnumber<>feld.elfeldda:elementarfeldpos<=LENGTH t.x.y:t
.ySUB elementarfeldpos.x:t.xSUB elementarfeldpos.feld:code(t.feldSUB 
elementarfeldpos).END PROC definefield;OP SCROLL (TAG VAR t,INT CONST lines):
cat:="";INT VAR i;FOR iFROM 1UPTO LENGTH (t.y)REP INT VAR v:=code(t.ySUB i)+
lines;IF v<1OR v>taglinesTHEN errorstop(
"Feld ausserhalb Bildschirm durch SCROLL")FI ;catCAT code(v)PER ;t.y:=cat;IF 
lines>0THEN FOR iFROM min(taglines-lines,t.ymax)DOWNTO 1REP t.formblatt(i+
lines):=t.formblatt(i)PER ;FOR iFROM linesDOWNTO 1REP t.formblatt(i):=""PER ;
t.ymaxINCR lines;t.ymax:=min(taglines,t.ymax)ELSE FOR iFROM 1-linesUPTO min(t
.ymax-lines,taglines)REP t.formblatt(i+lines):=t.formblatt(i)PER ;FOR iFROM t
.ymax+lines+1UPTO t.ymaxREP t.formblatt(i):=""PER ;t.ymaxINCR lines;t.ymax:=
max(t.ymax,1);FI .END OP SCROLL ;INT PROC fieldwithname(TAG CONST t,INT 
CONST name):ipos(t.dbnam,name)END PROC fieldwithname;INT PROC symbolicname(
TAG CONST t,INT CONST feld):t.dbnamVISUB feldEND PROC symbolicname;PROC 
symbolicname(TAG VAR t,INT CONST feld,symbol):replaceiac(t.dbnam,feld,symbol)
END PROC symbolicname;INT PROC auskunftsnr(TAG CONST t,INT CONST feld):t.
ausknamVISUB feldEND PROC auskunftsnr;INT PROC auskunftsnr:ausnrEND PROC 
auskunftsnr;PROC auskunftsnr(TAG VAR t,INT CONST feld,ausknr):replaceiac(t.
ausknam,feld,ausknr)END PROC auskunftsnr;PROC fieldinfos(TAG CONST t,INT 
CONST feld,INT VAR geheimcode,BOOL VAR closed,protected,secret,special,left):
geheimcode:=code(t.darstSUB feld);setinfo(t.diainfo,feld);IF normalTHEN 
closed:=FALSE ;protected:=FALSE ;secret:=FALSE ;special:=FALSE ;left:=FALSE ;
ELSE closed:=closedbit;protected:=protectbit;secret:=darstbit;special:=tabbit
;left:=leftbit;FI END PROC fieldinfos;PROC setfieldinfos(TAG VAR t,INT CONST 
feld,BOOL CONST closed,protected,secret):INT VAR cd:=(t.diainfoVSUB feld)MOD 
32;IF secretTHEN cdINCR 32FI ;IF protectedTHEN cdINCR 64FI ;IF closedTHEN cd
INCR 128FI ;replaceiac(t.diainfo,feld,code(cd))END PROC setfieldinfos;PROC 
transform(TAG CONST t,FILE VAR o):enablestop;buffer:="";bufferCAT t.xmax;
bufferCAT t.ymax;bufferCAT t.xs;bufferCAT t.ys;bufferCAT t.dbp;bufferCAT t.
ver;bufferCAT t.durchs;bufferCAT t.art;putline(o,buffer);putline(o,t.darst);
putline(o,t.erstel);putline(o,t.diainfo);putline(o,t.dbnam);putline(o,t.
ausknam);putline(o,t.feld);putline(o,t.x);putline(o,t.y);putline(o,t.tab);
putline(o,t.len);putline(o,trtab);tTO o.END PROC transform;PROC transform(
FILE VAR i,TAG VAR t):enablestop;TEXT VAR oldtrtab:=trtab;getline(i,buffer);t
.xmax:=bufferISUB 1;IF t.xmax<>12336THEN t.ymax:=bufferISUB 2;t.xs:=buffer
ISUB 3;t.ys:=bufferISUB 4;t.dbp:=bufferISUB 5;t.ver:=bufferISUB 6;t.durchs:=
bufferISUB 7;t.art:=bufferISUB 8;getline(i,t.darst);getline(i,t.erstel);
getline(i,t.diainfo);getline(i,t.dbnam);getline(i,t.ausknam);getline(i,t.feld
);getline(i,t.x);getline(i,t.y);getline(i,t.tab);getline(i,t.len);getline(i,
trtab);ELSE nil(t);FI ;iTO t;trtab:=oldtrtab;IF t.ver<>1THEN errorstop(
"Datei enth�lt kein TAG")FI .END PROC transform;PROC filetotag(DATASPACE 
CONST ei):type(ei,tagtypenr)END PROC filetotag;PROC tagtofile(DATASPACE 
CONST ei):IF type(ei)=tagtypenrTHEN type(ei,filetypenr)ELSE errorstop(
"TYPE nicht TAG")FI END PROC tagtofile;PROC efill(TAG VAR ff,TEXT CONST t,
INT CONST elfeld):INT CONST abwo:=1;zumerstenelementarfeld;WHILE 
nochgenugtextdaREP fuelleelementarfeld;elementarfeldweiterzaehlen;IF 
gehoertzumnaechstenfeldTHEN markiereueberlauf;LEAVE efillFI ;zumelementarfeld
;PER ;gibrestaus.zumerstenelementarfeld:tlen:=LENGTH t;tout:=abwo-1;afeld:=ff
.feldVSUB elfeld;ael:=elfeld;zumelementarfeld.fuelleelementarfeld:cat:=
subtext(t,tout+1,tout+al);replace(ff.formblatt(ay),ax,cat);toutINCR al.
nochgenugtextda:tout+al<tlen.elementarfeldweiterzaehlen:aelINCR 1.
zumelementarfeld:al:=ff.lenVSUB ael;ax:=ff.xVSUB ael;ay:=ff.yVSUB ael.
gehoertzumnaechstenfeld:(ff.feldVSUB ael)<>afeld.gibrestaus:cat:=subtext(t,
tout+1,tlen);replace(ff.formblatt(ay),ax,cat).markiereueberlauf:replace(ff.
formblatt(ay),ax+al-1,"<").END PROC efill;PROC fill(TAG VAR t,TEXT CONST 
inhalt,INT CONST feld):setinfo(t.diainfo,feld);INT VAR erstelem:=t.erstel
VSUB feld;IF erstelem>0THEN IF normalCOR NOT closedbitTHEN efill(t,inhalt,
erstelem)FI FI END PROC fill;OP CLEARBY (TAG VAR u,TAG CONST u1):INT VAR i;
FOR iFROM 1UPTO u.ymaxREP u.formblatt(i):=u1.formblatt(i)PER ;END OP CLEARBY 
;INT VAR afeld,ax,ay,al,ael,tlen,tout;PROC eput(TAG CONST ff,TEXT CONST t,
INT CONST elfeld):eput(ff,t,elfeld,1)END PROC eput;PROC eput(TAG CONST ff,
TEXT CONST t,INT CONST elfeld,INT CONST abwo):zumerstenelementarfeld;WHILE 
nochgenugtextdaREP fuelleelementarfeld;elementarfeldweiterzaehlen;IF 
gehoertzumnaechstenfeldTHEN markiereueberlauf;LEAVE eputFI ;zumelementarfeld;
PER ;gibrestaus;REP elementarfeldweiterzaehlen;IF gehoertzumnaechstenfeld
THEN LEAVE eputFI ;zumelementarfeld;gibhintergrundausPER .
zumerstenelementarfeld:tlen:=LENGTH t;tout:=abwo-1;afeld:=ff.feldVSUB elfeld;
ael:=elfeld;positionieren(ff).fuelleelementarfeld:xoutsubtext(t,tout+1,tout+
al);toutINCR al.nochgenugtextda:tout+al<tlen.elementarfeldweiterzaehlen:ael
INCR 1.zumelementarfeld:positionieren(ff).gehoertzumnaechstenfeld:(ff.feld
VSUB ael)<>afeld.gibrestaus:xoutsubtext(t,tout+1,tlen);IF tout+al>tlenTHEN 
xoutsubtext(grund,ax+tlen-tout,ax+al-1)FI .gibhintergrundaus:xoutsubtext(
grund,ax,ax+al-1).grund:ff.formblatt(ay).markiereueberlauf:IF outputallowed
THEN out("�<")FI ;IF protTHEN screenbs;screenout("<")FI .END PROC eput;PROC 
positionieren(TAG CONST ff):al:=ff.lenVSUB ael;ax:=ff.xVSUB ael;ay:=ff.yVSUB 
ael;IF protTHEN screencursor(ax,ay)FI ;IF outputallowedTHEN cursor(ax,ay)FI .
END PROC positionieren;PROC cursor(TAG CONST ff,INT CONST feld):ael:=ff.
erstelVSUB feld;positionieren(ff)END PROC cursor;INT PROC length(TAG CONST ff
,INT CONST feld):zumerstenelementarfeld;IF ael<1THEN LEAVE lengthWITH 0FI ;
INT VAR len:=0;REP lenINCR feldlaenge;zumnaechstenelementarfeld;UNTIL 
gehoertzumnaechstenfeldPER ;len.zumerstenelementarfeld:ael:=ff.erstelVSUB 
feld.zumnaechstenelementarfeld:aelINCR 1.gehoertzumnaechstenfeld:(ff.feld
VSUB ael)<>feld.feldlaenge:ff.lenVSUB ael.END PROC length;PROC show(TAG 
CONST ff):INT VAR i;IF protTHEN IF screenreorganizedTHEN FOR iFROM 1UPTO ff.
ymaxREP screencursor(1,i);screenput(ff.formblatt(i))PER ;ELSE FOR iFROM 1
UPTO ff.ymaxREP IF ff.formblatt(i)>""THEN screencursor(1,i);screenok(FALSE ,i
,i);screenput(ff.formblatt(i))FI PER ;IF outputallowedTHEN reorganizescreen
FI ;LEAVE showFI FI ;IF outputallowedTHEN out(home);out(ff.formblatt(1));FOR 
iFROM 2UPTO ff.ymaxREP line;out(ff.formblatt(i))PER FI .END PROC show;INT 
VAR charcode:=0,lastx,lasty;PROC translatecode:charcode:=code(char);SELECT 
charcodeOF CASE chop:charcode:=chomeCASE cvor:charcode:=cfeldendeCASE crueck:
charcode:=cfeldanfCASE choch:charcode:=cseiterueckCASE crunter:charcode:=
cseitevorCASE ctab:charcode:=csettabCASE ceinf:charcode:=caufbrechCASE causf:
charcode:=cloeschendeCASE cfeldvor:charcode:=cfeldrueckCASE cmark:charcode:=
cneuCASE cesc:charcode:=clearnOTHERWISE charcode:=pos(hoptasten,char);IF 
charcode=0THEN IF ischarTHEN FI ELSE char:=hopcodesSUB charcode;charcode:=
code(char)FI END SELECT END PROC translatecode;TEXT VAR char,pseudochar;BOOL 
PROC ischar:inchar(char);charcode:=code(char);IF charcode>31THEN TRUE ELIF 
charcode=chopTHEN inchar(char);translatecode;charcode>31ELSE FALSE FI END 
PROC ischar;INT VAR aktlimit,aktbegin,aktfeld,aktline,aktlen,aktanf,aktel,wo;
PROC setfieldvalues(TAG CONST ta):aktlen:=ta.lenVSUB aktel;aktanf:=ta.xVSUB 
aktel;aktline:=ta.yVSUB aktelEND PROC setfieldvalues;INT VAR nextfeld,nextel,
nextwo,nextbegin;PROC setlasteditvalues:preset:=TRUE END PROC 
setlasteditvalues;PROC setneweditvalues:aktfeld:=nextfeld;aktbegin:=nextbegin
;aktel:=nextel;wo:=nextwo;preset:=TRUE END PROC setneweditvalues;BOOL VAR 
preset:=FALSE ,feldda;PROC searchfield(TAG CONST t,INT CONST x,y,BOOL VAR 
erfolg):erfolg:=FALSE ;nextel:=0;REP sucheelementinrichtigerzeileUNTIL 
keinsmehrdaCOR xposstimmtPER ;IF erfolgTHEN nextfeld:=t.feldVSUB nextel;
nextbegin:=1;INT VAR i:=t.erstelVSUB nextfeld;WHILE i<nextelREP nextbegin
INCR (t.lenVSUB i);iINCR 1PER ;nextwo:=nextbegin+x-anfangFI .
sucheelementinrichtigerzeile:nextel:=pos(t.y,code(y),nextel+1).keinsmehrda:
nextel=0.xposstimmt:erfolg:=anfang<=xAND ende>x;erfolg.anfang:t.xVSUB nextel.
ende:(t.xVSUB nextel)+(t.lenVSUB nextel).END PROC searchfield;PROC editieren(
TAG CONST ff,TEXT VAR eing,INT CONST feld):IF fieldexists(ff,feld)THEN 
bestimmeeinstieg;REPEAT REPEAT wertesteuerzeichenausUNTIL ischarPER ;REPEAT 
schreibezeichen;UNTIL wo>aktlimitCOR NOT ischarPER PER FI .bestimmeeinstieg:
IF presetAND (feld=0COR feld=aktfeld)THEN ELSE aktfeld:=feld;aktel:=ff.erstel
VSUB aktfeld;aktbegin:=1;wo:=1FI ;charcode:=centry;preset:=FALSE ;IF NOT 
normalTHEN preparespecialeditingFI .preparespecialediting:IF darstbitTHEN 
pseudochar:=ff.darstSUB feldFI .schreibezeichen:IF wo<=LENGTH eingTHEN 
replace(eing,wo,char)ELSE eingCAT char;IF wo>LENGTH eing+1THEN 
normalizepositionFI FI ;IF normalCOR NOT darstbitTHEN out(char)ELSE out(
pseudochar)FI ;woINCR 1.wertesteuerzeichenaus:SELECT charcodeOF CASE cneu:
neuschreibenCASE centry:setfieldvalues(ff);positionieren;aktlimit:=aktbegin+
aktlen-1CASE cvor:IF wo<=LENGTH eingTHEN woINCR 1;out(right);forwardFI CASE 
cfeldende:zumfeldendeCASE crueck:woDECR 1;out(left);backwardCASE cfeldanf:wo
:=1;backwardtoendCASE ceinf:insertchar(eing," ",wo);restneuschreibenCASE 
causf:IF LENGTH eing>0THEN IF wo>LENGTH eingTHEN woDECR 1;out(left);backward
FI ;deletechar(eing,wo);restneuschreibenFI ;CASE cloeschende:eing:=subtext(
eing,1,wo-1);restneuschreibenCASE choch:gouporleaveCASE crunter:godownorleave
OTHERWISE :IF charcode>31THEN forwardELSE leaveFI END SELECT .zumfeldende:wo
:=LENGTH eing+1;forward;positionieren.positionieren:cursor(aktanf+(wo-
aktbegin),aktline).forward:WHILE wo>aktlimitREPEAT aktelINCR 1;IF 
gehoertzumfeldTHEN aktbegin:=aktlimit+1;decodefieldlen;aktlimitINCR aktlen
ELSE aktelDECR 1;wo:=aktlimitFI ;positionierenPER .leave:getcursor(lastx,
lasty);LEAVE editieren.godownorleave:getcursor(lastx,lasty);searchfield(ff,
lastx,lasty+1,feldda);IF felddaCAND nextfeld=aktfeldTHEN wo:=nextwo;aktel:=
nextel;setfieldvalues(ff);aktbegin:=nextbegin;aktlimit:=aktbegin-1+aktlen;
positionierenELSE LEAVE editierenFI .gouporleave:getcursor(lastx,lasty);
searchfield(ff,lastx,lasty-1,feldda);IF felddaCAND nextfeld=aktfeldTHEN wo:=
nextwo;aktel:=nextel;setfieldvalues(ff);aktbegin:=nextbegin;aktlimit:=
aktbegin-1+aktlen;positionierenELSE LEAVE editierenFI .backward:IF wo<
aktbeginTHEN IF wo<1THEN wo:=1ELSE aktelDECR 1;decodefieldlen;aktlimit:=
aktbegin-1;aktbeginDECR aktlen;FI ;positionierenFI .backwardtoend:aktel:=ff.
erstelVSUB aktfeld;decodefieldlen;aktbegin:=1;aktlimit:=aktlen;positionieren.
normalizeposition:wo:=LENGTH eing;WHILE wo<aktbeginREP aktelDECR 1;
decodefieldlen;aktlimit:=aktbegin-1;aktbeginDECR aktlenPER ;positionieren.
decodefieldlen:setfieldvalues(ff).restneuschreiben:neuschreiben.neuschreiben:
eput(ff,darstellstring,ff.erstelVSUB aktfeld);positionieren.darstellstring:
IF normalCOR NOT darstbitTHEN eingELSE LENGTH (eing)*pseudocharFI .
gehoertzumfeld:(ff.feldVSUB aktel)=aktfeld.END PROC editieren;TEXT PROC get(
TAG CONST ff,INT CONST feld):TEXT VAR a:=niltext;get(ff,a,feld);aEND PROC get
;PROC get(TAG CONST ff,TEXT VAR eingabe,INT CONST feld):IF protTHEN 
checkscreenFI ;BOOL VAR p:=prot;prot:=FALSE ;setinfo(ff.diainfo,feld);
editieren(ff,eingabe,feld);IF pTHEN prot:=TRUE ;outputallowed:=FALSE ;put(ff,
eingabe,feld);outputallowed:=TRUE FI END PROC get;PROC putget(TAG CONST ff,
TEXT VAR value,INT CONST feld):BOOL VAR p:=prot;prot:=FALSE ;outputallowed:=
TRUE ;put(ff,value,feld);editieren(ff,value,feld);IF pTHEN prot:=TRUE ;
outputallowed:=FALSE ;put(ff,value,feld);outputallowed:=TRUE FI END PROC 
putget;PROC put(TAG CONST ff,TEXT CONST v,INT CONST feld):setinfo(ff.diainfo,
feld);INT VAR erstelem:=ff.erstelVSUB feld;IF erstelem>0THEN IF normalCOR 
NOT darstbitTHEN eput(ff,v,erstelem)ELSE eput(ff,LENGTH v*(ff.darstSUB feld),
erstelem)FI FI END PROC put;INT PROC leavingcode:charcodeEND PROC leavingcode
;PROC putget(TAG CONST ff,ROW maxfieldsTEXT VAR v,INT VAR einstieg):put(ff,v)
;get(ff,v,einstieg)END PROC putget;PROC put(TAG CONST ff,ROW maxfieldsTEXT 
VAR fieldvalues):INT VAR iFOR iFROM 1UPTO LENGTH ff.erstelREP IF fieldexists(
ff,i)THEN put(ff,fieldvalues(i),i)FI PER END PROC put;PROC get(TAG CONST ff,
ROW maxfieldsTEXT VAR fieldvalues,INT VAR feld):INT VAR felder:=LENGTH ff.
erstel;IF NOT fieldexists(ff,feld)THEN errorstop("startfeld nicht im tag")
ELSE WHILE feld<=felderREPEAT get(ff,fieldvalues(feld),feld);
executecommandcode(ff,feld)UNTIL charcode=cescPER FI END PROC get;PROC 
executecommandcode(TAG CONST ff,INT VAR feld):SELECT charcodeOF CASE 
cfeldrueck:topriorfieldCASE cfeldvor:tonextfieldCASE choch:goupifpossible
CASE crunter:godownifpossibleCASE chome:tohomefieldCASE ctab:IF protTHEN 
reorganizescreenFI ;setlasteditvaluesCASE cesc:ausnr:=auskunftsnr(ff,feld)
END SELECT .topriorfield:REPEAT feld:=priorfield(ff,feld)UNTIL warerstesCOR 
nichtgesperrtPER ;IF warerstesTHEN tohomefieldFI .tonextfield:INT VAR oldfeld
:=feld;REP feld:=nextfield(ff,feld)UNTIL warletztesCOR nichtgesperrtPER ;IF 
warletztesTHEN feld:=oldfeld;IF beimletztenrausfallenTHEN charcode:=cesc;
beimletztenrausfallen:=FALSE FI FI .tohomefield:feld:=firstfield(ff);WHILE 
gesperrtREP feld:=nextfield(ff,feld)PER .goupifpossible:BOOL VAR erfolg;
searchfield(ff,lastx,lasty-1,erfolg);IF erfolgAND nextnichtgesperrtTHEN 
setneweditvalues;feld:=nextfeldELSE setlasteditvaluesFI .godownifpossible:
searchfield(ff,lastx,lasty+1,erfolg);IF erfolgAND nextnichtgesperrtTHEN 
setneweditvalues;feld:=nextfeldELSE setlasteditvaluesFI .nichtgesperrt:(ff.
diainfoVSUB feld)<64.nextnichtgesperrt:(ff.diainfoVSUB nextfeld)<64.gesperrt:
NOT nichtgesperrt.warletztes:feld<1.warerstes:feld<1.END PROC 
executecommandcode;PROC setautoesc:beimletztenrausfallen:=TRUE END PROC 
setautoesc;INT PROC firstfield(TAG CONST t):t.feldVSUB 1END PROC firstfield;
INT PROC nextfield(TAG CONST t,INT CONST feld):INT VAR el:=(t.erstelVSUB feld
)+1;WHILE (t.feldVSUB el)=feldREP elINCR 1PER ;t.feldVSUB elEND PROC 
nextfield;INT PROC priorfield(TAG CONST t,INT CONST feld):t.feldVSUB ((t.
erstelVSUB feld)-1)END PROC priorfield;TEXT VAR buffer,blinkan,blinkaus;TEXT 
VAR trtab:="!<> ",tr;TAG VAR hilfstag;nil(hilfstag);hilfstag.formblatt(
taglines):="                                      Feldnummer : __ ";
definefield(hilfstag,code(pos(hilfstag.formblatt(taglines),"_")),code(
taglines),"�",".",0,0,1,"�","�");OP TO (FILE VAR a,TAG VAR t):INT VAR i,j;
TEXT VAR char;t.xmax:=0;FOR jFROM 1UPTO taglinesREP IF NOT eof(a)THEN getline
(a,buffer);transform;IF length(buffer)>t.xmaxTHEN t.xmax:=length(buffer)FI ;t
.ymax:=jELSE tr:=niltext;FI ;t.formblatt(j):=tr;PER .transform:tr:=niltext;
FOR iFROM 1UPTO LENGTH bufferREP char:=bufferSUB i;SELECT pos(trtab,char)OF 
CASE 2:trCAT inversCASE 3:trCAT endinversCASE 1:trCAT " "CASE 4:trCAT right
OTHERWISE :trCAT charEND SELECT PER .END OP TO ;OP TO (TAG CONST t,FILE VAR f
):INT VAR i,j;TEXT VAR pseudoblank:=trtabSUB 1,char;FOR jFROM 1UPTO t.ymax
REP buffer:=t.formblatt(j);retransform;putline(f,tr)PER .retransform:tr:=
niltext;FOR iFROM 1UPTO LENGTH bufferREP char:=bufferSUB i;SELECT code(char)
OF CASE 32:trCAT pseudoblankCASE 15:trCAT (trtabSUB 2)CASE 14:trCAT (trtab
SUB 3)CASE cvor:trCAT " "OTHERWISE :trCAT charEND SELECT PER ;buffer:=tr.END 
OP TO ;PROC trans(TEXT CONST x):IF LENGTH x=3THEN trtab:=x;trtabCAT " "ELSE 
errorstop("falsche Umsetztabelle")FI END PROC trans;TEXT PROC blink(TAG 
CONST t,INT VAR feld):blinkan:=length(t,feld)*"#";blinkaus:=LENGTH blinkan*
"!";INT VAR i;FOR iFROM 1UPTO 20REP IF (iMOD 2)=0THEN put(t,blinkan,feld);
ELSE put(t,blinkaus,feld);FI ;buffer:=incharety(3)UNTIL buffer<>""PER ;buffer
END PROC blink;PROC findchar(TAG CONST f,TEXT CONST eingabe,INT VAR posx,posy
):INT VAR posxn:=posx,posyn:=posy;WHILE (f.formblatt(posy)SUB posxn)=eingabe
REP posxnINCR 1PER ;posxn:=pos(f.formblatt(posy),eingabe,posxn+1);WHILE posxn
=0REP posynINCR 1;IF posyn>f.ymaxTHEN LEAVE findcharFI ;posxn:=pos(f.
formblatt(posyn),eingabe)PER ;posx:=posxn;posy:=posyn.END PROC findchar;PROC 
designelfield(TAG CONST t,INT CONST xm,ym,INT VAR x,y,l):cursortostartpos;
cursortoendpos.cursortostartpos:TEXT VAR storage:="_";REP cursor(x,y);IF 
ischarTHEN findchar(t,char,x,y);storage:=charELSE SELECT charcodeOF CASE 
chome:x:=1;y:=1CASE cvor:x:=xMOD xm;xINCR 1CASE crueck:IF x=1THEN x:=xmELSE x
DECR 1FI CASE cfeldanf:x:=1CASE cfeldende:x:=xmCASE choch:IF y=1THEN y:=ym
ELSE yDECR 1FI CASE crunter:y:=yMOD ym;yINCR 1CASE causkunft:cursor(1,24);out
("X=");put(text(x,2));out(" Y=");put(text(y,2))CASE cesc:LEAVE designelfield
CASE ctab:findchar(t,storage,x,y)CASE cfeldvor:LEAVE cursortostartpos
OTHERWISE :out("�")END SELECT FI PER .cursortoendpos:TEXT VAR aktchar:=t.
formblatt(y)SUB x;IF aktchar>" "AND (t.formblatt(y)SUB x-1)<>aktcharTHEN l:=1
;WHILE (t.formblatt(y)SUB (x+l))=aktcharREP lINCR 1PER ;FI ;markiere;REP 
WHILE ischarREP out("�")PER ;IF charcode=cvorAND x+l<xm+1THEN lINCR 1;out(
right);out(">");out(left);ELIF charcode=crueckAND l>1THEN 
originalzeichenausgeben;lDECR 1ELIF charcode=cescTHEN LEAVE designelfield
ELIF charcode=cfeldvorTHEN LEAVE cursortoendposFI PER .
originalzeichenausgeben:out(" �");out(t.formblatt(y)SUB (x+l-1));out("��").
markiere:cursor(x,y);lTIMESOUT ">";out(left).END PROC designelfield;INT VAR 
el;PROC designfield(TAG CONST t,INT CONST feld,TEXT VAR x,y,l,ta):IF NOT 
varsinitializedTHEN initializeFI ;REP designelement;elINCR 1PER .
varsinitialized:LENGTH x=LENGTH yAND LENGTH y=LENGTH lAND LENGTH l=LENGTH ta
AND LENGTH x>0.initialize:IF NOT fieldexists(t,feld)THEN x:="";y:="";l:="";ta
:=""ELSE INT VAR begin:=t.erstelVSUB feld,end:=begin;WHILE (t.feldVSUB end)=
feldREP endINCR 1PER ;endDECR 1;x:=subtext(t.x,begin,end);y:=subtext(t.y,
begin,end);l:=subtext(t.len,begin,end);ta:=subtext(t.tab,begin,end);FI ;el:=1
.designelement:INT VAR xb,yb,lb;cursor(1,24);out(text(el));out(
". Teilfeld                 ");IF LENGTH x<elTHEN xb:=1;yb:=1;lb:=1ELSE xb:=x
VSUB el;yb:=yVSUB el;lb:=lVSUB elFI ;designelfield(t,t.xmax,t.ymax,xb,yb,lb);
IF charcode=cescTHEN LEAVE designfieldFI ;IF LENGTH x<elTHEN xCAT code(xb);y
CAT code(yb);lCAT code(lb);taCAT "�"ELSE replace(x,el,code(xb));replace(y,el,
code(yb));replace(l,el,code(lb));FI .END PROC designfield;PROC design(TAG 
VAR todesign):REP designform(todesign);designfields(todesign);UNTIL 
leavingcode<>cescCOR no("
�Formulardarstellung veraendern")PER END PROC 
design;PROC designform(TAG VAR f):taginitialisieren;formulareditieren.
formulareditieren:DATASPACE VAR wds:=nilspace;FILE VAR in:=sequentialfile(
output,wds);fTO in;modify(in);headline(in,"Formular eingeben !");edit(in);
page;input(in);reset(in);inTO f;forget(wds).taginitialisieren:IF f.ver<>1
THEN nil(f)FI .END PROC designform;PROC dummie(INT VAR a,b,TEXT VAR c,BOOL 
VAR d,e):LEAVE dummie;a:=b;d:=e;c:="";END PROC dummie;PROC designfields(TAG 
VAR f):designfields(f,PROC dummie)END PROC designfields;PROC designfields(
TAG VAR f,PROC (INT VAR ,INT VAR ,TEXT VAR ,BOOL VAR ,BOOL VAR )setparam):
show(f);INT VAR feld:=2;TEXT VAR xrow,yrow,lrow,trow;REPEAT 
feldnummereinlesen;benutzerwunscherfragen;benutzerwunschauswertenEND REP .
benutzerwunscherfragen:IF fieldexists(f,feld)THEN REP cursor(1,24);out(
"a(endern) ,l(oeschen), i(rrtum) ?");TEXT VAR ein:=blink(f,feld);IF ein="�"
THEN charcode:=cesc;LEAVE designfieldsFI UNTIL pos("aAäÄlLiI",ein)>0PER ;
ELSE REP cursor(1,24);out("     n(eu einrichten), (i)rrtum ?");inchar(ein);
IF ein="�"THEN charcode:=cesc;LEAVE designfieldsFI UNTIL pos("nNiI",ein)>0
PER ;FI ;cursor(1,24);out("                                 ").
benutzerwunschauswerten:IF pos("lL",ein)>0THEN put(f,"",feld);clearfield(f,
feld)ELSE IF fieldexists(f,feld)THEN put(f,"",feld);FI ;IF pos("iI",ein)=0
THEN xrow:="";yrow:=" ";lrow:="";trow:="";designfield(f,feld,xrow,yrow,lrow,
trow);parametersetzen;definefield(f,xrow,yrow,lrow,trow,sym,aus,feld,dar,dia)
;feldINCR 1;FI FI .feldnummereinlesen:TEXT VAR itext:=text(feld);REPEAT 
cursor(1,24);out("�");out(hilfstag.formblatt(taglines));putget(hilfstag,itext
,1);IF leavingcode=cescTHEN LEAVE designfieldsFI ;feld:=int(itext);IF feld<1
OR leavingcode=causkunftOR NOT lastconversionokTHEN dialogueELSE LEAVE 
feldnummereinlesen;FI ;PER .dialogue:REP cursor(1,24);out(
"q(uit), i(rrtum), m(aske neu zeigen), f(eldnummern)  �");inchar(ein);IF ein=
"�"THEN charcode:=cesc;LEAVE designfieldsFI UNTIL pos("qQiImMfF",ein)>0PER ;
SELECT (pos("qQiImMfF",ein)-1)DIV 2OF CASE 0:LEAVE designfieldsCASE 1:LEAVE 
dialogueCASE 2:show(f)CASE 3:INT VAR i;FOR iFROM 1UPTO fields(f)REP TEXT VAR 
buf:=text(i);bufCAT "*";put(f,((length(f,i)-1)DIV LENGTH (buf)+1)*buf,i)PER 
END SELECT .parametersetzen:INT VAR aus:=auskunftsnr(f,feld),sym:=
symbolicname(f,feld);TEXT VAR dar:=f.darstSUB feld,dia;setinfo(f.diainfo,feld
);BOOL VAR a:=closedbit,b:=protectbit,c:=darstbit;setparam(sym,aus,dar,b,c);
setfieldinfos(f,feld,a,b,c);dia:=f.diainfoSUB feld;dar:=text(dar,1).END PROC 
designfields;END PACKET mask;PACKET dateDEFINES monat,jahr,tag,datum,tmj,
datumjh,nildatum,jahrestag,wochentag:LET seperatorzeichen=":./ ",
seperatorzeichen1=".";INT CONST beforefirstday:=-(22*vierjahre)-1;TEXT VAR b;
BOOL VAR conversionerror:=FALSE ;INT PROC nildatum:beforefirstdayEND PROC 
nildatum;#L datumslets#LET letzterjanuar=31,letzterfebruar=59,letztermaerz=90
,letzterapril=120,letztermai=151,letzterjuni=181,letzterjuli=212,
letzteraugust=243,letzterseptember=273,letzteroktober=304,letzternovember=334
,#letzterdezember=365,#vierjahre=1461;PROC tmj(INT CONST d,INT VAR t,m,j):
INT VAR a;IF d<=beforefirstdayTHEN t:=-1;m:=-1;j:=-1;LEAVE tmjFI ;a:=d;IF a>0
THEN j:=88ELSE j:=0;aINCR (-(beforefirstday+1))FI ;jINCR 4*(aDIV vierjahre);a
:=aMOD vierjahre;IF a=letzterfebruarTHEN t:=29;m:=2;LEAVE tmjELIF a>
letzterfebruarTHEN aDECR 1FI ;jINCR aDIV 365;a:=(aMOD 365)+1;IF a<=
letzterjuniTHEN januarbisjuniELSE julibisdezemberFI .januarbisjuni:IF a<=
letztermaerzTHEN januarbismaerzELSE aprilbisjuniFI .julibisdezember:IF a<=
letzterseptemberTHEN julibisseptemberELSE oktoberbisdezemberFI .
januarbismaerz:IF a<=letzterjanuarTHEN m:=1;t:=aELIF a<=letzterfebruarTHEN m
:=2;t:=a-letzterjanuarELSE m:=3;t:=a-letzterfebruarFI .aprilbisjuni:IF a<=
letzteraprilTHEN m:=4;t:=a-letztermaerzELIF a<=letztermaiTHEN m:=5;t:=a-
letzteraprilELSE m:=6;t:=a-letztermaiFI .julibisseptember:IF a<=letzterjuli
THEN m:=7;t:=a-letzterjuniELIF a<=letzteraugustTHEN m:=8;t:=a-letzterjuli
ELSE m:=9;t:=a-letzteraugustFI .oktoberbisdezember:IF a<=letzteroktoberTHEN m
:=10;t:=a-letzterseptemberELIF a<=letzternovemberTHEN m:=11;t:=a-
letzteroktoberELSE m:=12;t:=a-letzternovemberFI .END PROC tmj;INT PROC datum(
TEXT CONST a):b:=a;conversionerror:=FALSE ;INT VAR seperator:=seppos,t,m,j;
IF seperator=0THEN IF length(b)=6THEN t:=z(1)*10+z(2);m:=z(3)*10+z(4);j:=z(5)
*10+z(6);INT VAR dummy:=datum(t,m,j);IF conversionerrorTHEN dummy:=nildatum
FI ;LEAVE datumWITH dummyELSE leaveFI ELIF seperator=2THEN t:=z(1);ELIF 
seperator=3THEN t:=10*z(1)+z(2);ELSE leaveFI ;b:=subtext(b,seperator+1);
seperator:=seppos;IF seperator=3THEN m:=z(1)*10+z(2);ELIF seperator=2THEN m:=
z(1)ELSE leaveFI ;b:=subtext(b,seperator+1);IF length(b)=2THEN j:=z(1)*10+z(2
)ELIF length(b)=4THEN j:=z(1)*1000+z(2)*100+z(3)*10+z(4)-1900;ELSE leaveFI ;
IF conversionerrorTHEN nildatumELSE datum(t,m,j)FI .leave:LEAVE datumWITH 
nildatum.seppos:INT VAR q;FOR qFROM 2UPTO 3REP IF pos(seperatorzeichen,bSUB q
)>0THEN LEAVE sepposWITH q;FI PER ;0.END PROC datum;INT PROC z(INT CONST wo):
INT VAR e:=code(bSUB wo)-48;IF e<0OR e>9THEN conversionerror:=TRUE ;0ELSE e
FI END PROC z;INT PROC datum(INT CONST t,m,jc):INT VAR j:=jc-1900IF j<0THEN j
INCR 1900FI ;IF (j+160)DIV 160<>1THEN nildatumELIF t<0THEN nildatumELSE 
SELECT mOF CASE 1,3,5,7,8,10,12:IF t>31THEN nildatumELSE erg(t,m,j)FI CASE 4,
6,9,11:IF t>30THEN nildatumELSE erg(t,m,j)FI CASE 2:IF t<29THEN erg(t,m,j)
ELIF t=29AND jMOD 4=0THEN erg(t,m,j)ELSE nildatumFI OTHERWISE nildatumEND 
SELECT FI END PROC datum;INT PROC wochentag(INT CONST d):INT CONST x:=d-1;IF 
x<0THEN 6-(-xMOD 7)ELSE xMOD 7FI END PROC wochentag;INT PROC jahrestag(INT 
CONST d):INT VAR a;IF d<=beforefirstdayTHEN LEAVE jahrestagWITH -1FI ;a:=d;
IF a<=0THEN aINCR (-(beforefirstday+1))FI ;a:=aMOD vierjahre;IF a>365THEN a
DECR 366;a:=aMOD 365FI ;a+1END PROC jahrestag;INT PROC erg(INT CONST t,m,jc):
INT VAR j:=jc;INT VAR result:=beforefirstday,tagimzyklus;IF j>=88THEN jDECR 
88;result:=-1FI ;resultINCR ((jDIV 4)*vierjahre);j:=jMOD 4;tagimzyklus:=
tagundmonat+365*j;IF tagimzyklus>erstermaerzimschaltjahrTHEN tagimzyklusINCR 
1ELIF tagimzyklus=erstermaerzimschaltjahrAND m=3THEN tagimzyklusINCR 1FI ;
result+tagimzyklus.erstermaerzimschaltjahr:60.tagundmonat:SELECT mOF CASE 1:t
CASE 2:t+letzterjanuarCASE 3:t+letzterfebruarCASE 4:t+letztermaerzCASE 5:t+
letzteraprilCASE 6:t+letztermaiCASE 7:t+letzterjuniCASE 8:t+letzterjuliCASE 9
:t+letzteraugustCASE 10:t+letzterseptemberCASE 11:t+letzteroktoberCASE 12:t+
letzternovemberOTHERWISE errorstop("monat > 12 oder < 0");0END SELECT .END 
PROC erg;INT PROC tag(INT CONST d):INT VAR t,m,j;tmj(d,t,m,j);tEND PROC tag;
INT PROC jahr(INT CONST d):INT VAR t,m,j;tmj(d,t,m,j);j+1900END PROC jahr;
INT PROC monat(INT CONST d):INT VAR t,m,j;tmj(d,t,m,j);mEND PROC monat;TEXT 
PROC datumjh(INT CONST d):INT VAR t,m,j;TEXT VAR e;tmj(d,t,m,j);IF t<0THEN 
LEAVE datumjhWITH ""FI ;e:=code(tDIV 10+48);eCAT code(tMOD 10+48);eCAT 
seperatorzeichen1;eCAT code(mDIV 10+48);eCAT code(mMOD 10+48);eCAT 
seperatorzeichen1;IF j<100THEN eCAT "19"ELSE eCAT "20";jDECR 100FI ;eCAT code
(jDIV 10+48);eCAT code(jMOD 10+48);eEND PROC datumjh;TEXT PROC datum(INT 
CONST d):INT VAR t,m,j;TEXT VAR e;tmj(d,t,m,j);IF t<0THEN LEAVE datumWITH ""
FI ;e:=code(tDIV 10+48);eCAT code(tMOD 10+48);eCAT seperatorzeichen1;eCAT 
code(mDIV 10+48);eCAT code(mMOD 10+48);eCAT seperatorzeichen1;eCAT code((j
MOD 100)DIV 10+48);eCAT code(jMOD 10+48);eEND PROC datum;END PACKET date;