PROC ;PROCEDURES & FUNCTIES ;PROC; Beschrijving zie PROCBES [ 12/22/2003  4:51 PM ]
 Q
INIT(sLijst,sLocal,sTaal) 
 New Ref,R
 Set:'$L($G(sLocal)) sLocal=$E(sLijst,1,8)
 Kill @sLocal,DL
 Set R=^LD("D",sLijst)
 X "Set Ref="_$P(R,"`",8)
 If $E(Ref,$L(Ref))=")" Set $E(Ref,$L(Ref))=","
 Set @sLocal@(1)=Ref ; Global of local refrence
 Set @sLocal@(3)=$P(R,"`",9) ; Begin schermlijn
 Set @sLocal@(4)=$P(R,"`",10) ; Aantal schermlijnen
 Set:'@sLocal@(4) @sLocal@(4)=24-$P(R,"`",9)+1 ; Aantal schermlijnen
 Set @sLocal@(5)=$P(R,"`",4) ; Aantal karakters per lijn
 Set @sLocal@(6)=$P(R,"`",7) ; Select 
 Set @sLocal@(7)=0 ; Offset
 Set @sLocal@(2)=^LD("L",sLijst) ; Format Definitie
 Set @sLocal@(10)=$P(R,"`",11) ; Callback \ FetchMore
 Set @sLocal@(11)=$P(R,"`",1) ; Titel
 If $D(^LD("L",sLijst,"H")) Do  ; Header
 .If $L($G(sTaal)),$D(^LD("L",sLijst,"H",sTaal)) Set @sLocal@(8)=^LD("L",sLijst,"H",sTaal)
 .Else  Set @sLocal@(8)=^LD("L",sLijst,"H")
 .Set @sLocal@(8)=$$FLATASCI(@sLocal@(8))
 Set:+$P(R,"`",3)<0 $P(@sLocal@(8),"`",2)=$P(R,"`",3) ; Afstand header
 Set:$D(^LD("L",sLijst,"E")) @sLocal@(12)=^LD("L",sLijst,"E") ; Execute
 Set @sLocal@(13)=sLijst
 Set DL(1)=sLocal
 Quit
 ;
 ; sLocal wordt opgeroepen via .sLocal
REFRESH(sLocal) ; Refresh and draw lijst
 New BeginPos,EndPos,Place,DL
 Set BeginPos=sLocal(3),EndPos=BeginPos+sLocal(4)-1
 If $L(sLocal(11)) Set Place=$P(sLocal(11),"`",2),BeginPos=BeginPos+$S('Place:-1,1:Place)
 Quit:sRB<BeginPos  Quit:sRT>EndPos
 Set DL(1)="sLocal",DL(2)=$S(sRT>BeginPos:sRT,1:BeginPos),DL(3)=$S(sRB<EndPos:sRB,1:EndPos)
 Do WL
 Quit
 ;
 ; Inkey
IK G IK^PROC1
 ;
 ;
 ; Cusor vertaallist
CVL S R="\21;FI\20;UP\19;DO\"
 I $P($G(^cLOG(boot,"DEV",$$IO^cQ5)),"\",1)="MC" S R="\24;FI\20;UP\19;DO\"
 I $E($P($G(^cLOG(boot,"DEV",$$IO^cQ5)),"\",1))="O" S R="\24;FI\20;UP\19;DO\"
 Q
 ;
 ;
 ; Format number
FN S:'$D(FN(3)) FN(3)=0 S:'$D(FN(4)) FN(4)="N" S R=FN(1)
 I FN(4)["C",'R,"0"'[R S R=$E(R,1,FN(2)) G FN2
 S:FN(4)["$" FN(3)=0,FN(2)=FN(2)-2
 S R=$J(R,0,FN(3)) I 'R,$P(FN(4),"N",2)'[0 S R="" G FN3
 S FNt=" ",FNd="" S:FN(3) FNd=","_$P(R,".",2) S:R<0 FNt="-",R=-R S R=$P(R,".",1)
 S:$P(FN(4),"N",2)["+" FNt="" S:FNt=" "&($P(FN(4),"N",1)["-") FNt="" G FN1:'FN(2),FN1:$P(FN(4),"N",1)'[0
 S FNz="",$P(FNz,0,FN(2)-$L(FNt))=0,FNz=1_FNz S:FN(3) FNz=$E(FNz,1,$L(FNz)-(FN(3)+1)) S:$L(R)<$L(FNz) R=$E(FNz+R,2,99)
FN1 I FN(4)'["." F FNp=3,7,11 S FNe=$L(R) Q:FNe'>FNp  S R=$E(R,1,FNe-FNp)_"."_$E(R,FNe-FNp+1,FNe)
 S R=R_FNd I FN(2),$P(FN(4),"N",1)[0 F FNz=1:1 Q:$L(R)=(FN(2)-$L(FNt))!("0."'[$E(R,1))  S R=$E(R,2,99)
 S R=$S($P(FN(4),"N",1)["-":FNt,1:"")_R_$S($P(FN(4),"N",1)["-":"",1:FNt)
FN2 I FN(2),$L(R)>FN(2) S R="",$P(R,"#",FN(2))="#"
 S:FN(4)["$" R=R_",-"
FN3 S R=$$FLATASCI(R)
 Q
 ;
 ;
 ; Format line
FL 
 NEW OX,RZonderTAGS
 SET (FormattedLine,FieldNbr)="" IF '$DATA(FL(2)) SET FL(2)=""
 IF FL(2) SET FP=FL(2) WRITE @F
 If $PIECE(FL(1),"\")?1.2N New D SET D=$CHAR($PIECE(FL(1),"\")),FieldNbr=1
 If FL(1)?1.U SET OX=FL(1),FL(1)=^LD("L",FL(1)) IF $DATA(^LD("L",OX,"E")) write *7 XECUTE ^("E")_" D FL1" Quit
 IF $DATA(FL(5)) XECUTE FL(5)_" D FL1" Quit
FL1 
 SET FieldNbr=FieldNbr+1,FieldParameters=$PIECE(FL(1),"\",FieldNbr),FieldLength=$PIECE(FieldParameters,U,4) GOTO FL7:FieldParameters="" SET R="" GOTO FL2:'$LENGTH($PIECE(FieldParameters,U,1)) ;ophalen data
 IF $PIECE(FieldParameters,U,1)?.N SET R=$PIECE(FL(3),D,$PIECE(FieldParameters,U,1))
 ELSE  IF $PIECE(FieldParameters,U,1)?1.E1"."1.N SET R=$PIECE(FL(3,$PIECE($PIECE(FieldParameters,U,1),".",1)),D,$PIECE($PIECE(FieldParameters,U,1),".",2))
 ELSE  XECUTE "S R="_$PIECE(FieldParameters,U,1)
 IF $PIECE(FieldParameters,U,8)'="" SET OX=$GET(X),X=R XECUTE "S R="_$PIECE(FieldParameters,U,8) SET X=OX
 IF (((R["ŞB")||(R["Şb")) && FieldLength) {
	 Set RZonderTAGS=R,RZonderTAGS=$Replace(RZonderTAGS,"ŞB",""),RZonderTAGS=$Replace(RZonderTAGS,"Şb","")
	 Set FieldLength = FieldLength + ($Length(R) - $Length(RZonderTAGS))
 }
FL2 
 GOTO FL3:$PIECE(FieldParameters,U,2)'["N" SET FN(1)=R,FN(2)=$PIECE(FieldParameters,U,4),FN(3)=$PIECE(FieldParameters,U,5),FN(4)=$PIECE(FieldParameters,U,2) ;verwerking numerieke data
 DO FN
FL3 
 If "\DN\DC\MN\MC\DM\DW\W\J\DKP\DK\DL\"[("\"_$PIECE(FieldParameters,U,2)_"\") SET R=$$EXTDATE^vhLib.DataTypes(R,$PIECE(FieldParameters,U,2))
 If $PIECE(FieldParameters,U,2)="T" SET R=$$EXTTIME^vhLib.DataTypes(R)
 If $PIECE(FieldParameters,U,2)="F" Set R=$TRANSLATE($JUSTIFY("",$PIECE(FieldParameters,U,4))," ",R)
 GOTO FL4:'FieldLength 
 SET R=$EXTRACT(R,1,FieldLength)
 IF $PIECE(FieldParameters,U,3)="L" SET R=R_$JUSTIFY("",FieldLength-$LENGTH(R)) ;alignering
 ELSE  IF $PIECE(FieldParameters,U,3)="R" SET R=$JUSTIFY(R,FieldLength)
 ELSE  IF $PIECE(FieldParameters,U,3)="C" SET R=$JUSTIFY("",(FieldLength-$LENGTH(R))\2)_R_$JUSTIFY("",FieldLength-$LENGTH(R)-((FieldLength-$LENGTH(R))\2))
 ELSE  SET R="",$PIECE(R,"#",FieldLength)="#"
FL4 
 GOTO FL6:'$LENGTH(FL(2)),FL5:'$LENGTH($PIECE(FieldParameters,U,7)) ;print
 IF $PIECE(FieldParameters,U,7)?.N SET FLb=$PIECE(FL(3),"\",$PIECE(FieldParameters,U,7))
 ELSE  XECUTE "S FLb="_$PIECE(FieldParameters,U,7) // N.B. Variabelen zoals FLs zijn hernoemd naar leesbaardere vormen, zie revisie 56936.
 IF '$GET(FL(4)),FLb WRITE @FMTB,$$FLATASCI(R),@FMTb,$PIECE(FieldParameters,U,6) GOTO FL6
FL5 
 Set Positie = 1
 Set Tekst = ""
 While Positie <= $Length(R)
 {
	 If ($Extract(R,Positie,Positie+1) = "ŞB") {
		 WRITE @FMTB
		 Set Positie = Positie + 2
	 } ElseIf ($Extract(R,Positie,Positie+1) = "Şb") {
		 WRITE @FMTb
		 Set Positie = Positie + 2
	 } Else {
		 WRITE $Extract(R,Positie,Positie)
		 Set Positie = Positie + 1
	 }
 }
 WRITE $PIECE(FieldParameters,U,6)
FL6 
 SET FormattedLine=FormattedLine_R_$PIECE(FieldParameters,U,6) 
 GOTO FL1 ;concatinering
FL7 
 SET R=$$FLATASCI(FormattedLine)
 QUIT
 ;
 ;
FLATASCI(R) 
 IF $LENGTH(R),$GET(sScr("VT"))=1 SET R=$$FLATASCI^vhRtn1(R)
 QUIT R
 ;
 ; sLijst parameters
LPar S DLt=@DL(1)@(1) F DLi=$L(DLt):-1 Q:" ,)"'[$E(DLt,DLi)  ; instellen van de referenties
 S DLt=$E(DLt,1,DLi) S:DLt'["(" DLt=DLt_"(" S:$E(DLt,$L(DLt))'="(" DLt=DLt_","
 S @DL(1)@(1)=DLt,DLt=DLt_"DLv)"
 D IPar
 Q
 ;
 ; Write list
WL New DLInc,DLad,DLal,DLb,DLbl,DLc,DLcb,DLcm,DLe,DLf,DLfe,DLfn,DLfx
 New DLi,DLll,DLo,DLse,DLsl,DLsw,DLt,DLti,DLv,DLvx,DLwp,IK,DLn
 
 D LPar S DLse=0,DLvx=DLv S:'$D(@DL(1)@(8)) @DL(1)@(8)=""
 I @DL(1)@(8)[D K FL S FL(1)=@DL(1)@(8),FL(2)="" D FL S @DL(1)@(8)=R
 G WL2:$D(@DL(1)@(9)) S @DL(1)@(9)=0
WL1 S DLv=DLv+10 G WL1:$D(@DLt) F DLv=DLv-1:-1:1 I $D(@DLt) S @DL(1)@(9)=DLv Q
WL2 S DLv=DLvx,@DL(1)@(4)=DLal,@DL(1)@(5)=DLll,DLti=1 D STi
 S DLi=DLbl-1 S:$D(DL(2)) DLb=DL(2) S:$D(DL(3)) DLe=DL(3) D WP K DL(2),DL(3),DLn S $P(DLse,"\",1)=@DL(1)@(9)
 Q
 ;
 ; Init parameters
IPar S:@DL(1)@(2)?.U @DL(1)@(2)=^LD("L",@DL(1)@(2))
 S DLInc=1 S:@DL(1)@(2)?1N1"F" DLInc=+@DL(1)@(2)
 S DLbl=@DL(1)@(3),DLal=25-DLbl\DLInc*DLInc I $D(@DL(1)@(4)),@DL(1)@(4) S DLal=@DL(1)@(4)
 S DLll=80 I $D(@DL(1)@(5)),@DL(1)@(5) S DLll=@DL(1)@(5)
 S DLsl=0
 I $D(@DL(1)@(6)),@DL(1)@(6) D
 .S (DLsl,DLv)=@DL(1)@(6)
 .I '$D(@DLt) F DLv=DLv:-1:1 Quit:$D(@DLt)
 .S (DLsl,@DL(1)@(6))=DLv
 S DLo=1 S:DLal<DLsl DLo=DLsl-DLal+1 I $D(@DL(1)@(7)),@DL(1)@(7) S DLo=@DL(1)@(7)
 S DLse=0 I $D(@DL(1)@(9)),@DL(1)@(9) S DLse=@DL(1)@(9)_D_DLo S:DLsl $P(DLse,"\",2)=DLsl
 S DLc=$P($G(@DL(1)@(10)),"\")
 S DLcm=$P($G(@DL(1)@(10)),"\",2)
 S DLv=DLo+DLal,DLb=1,DLe=24
 S DLsw=""
 Q
 ;
 ; Write page
WP S DLv=DLo-1 ; verwerken van de data
WP1 S DLv=DLv+1 I '$D(@DLt) G WP2
 G WP3:(DLv-DLo+1)>DLal D WLn G WP1
WP2 F DLi=DLi+1:1:(DLbl+DLal-1) S FP=DLi*100+1 W @F,@F2  ; resterende lijnen wissen
WP3 D Par
 Q
 ;
  ; Enable line
EL New DLInc,DLad,DLal,DLb,DLbl,DLc,DLcb,DLcm,DLe,DLf,DLfe,DLfn,DLfx
 New DLi,DLll,DLo,DLse,DLsl,DLsw,DLt,DLti,DLv,DLvx,DLwp,DLn,IK
 
 I $D(@DL(1)@(7)) D
 .I @DL(1)@(6)>(@DL(1)@(7)+@DL(1)@(4)-1) S @DL(1)@(7)=@DL(1)@(6)-@DL(1)@(4)+1 D WL Q
 .I @DL(1)@(6)<@DL(1)@(7) Set @DL(1)@(7)=@DL(1)@(6) D WL
 S DLt=@DL(1)@(1)_"DLv)" D IPar S DLvx=DLv,DLv=DLsl D:$D(@DLt)#10 WLn S DLv=DLvx
 Q
 ;
 ; Disable line
DL New DLInc,DLad,DLal,DLb,DLbl,DLc,DLcb,DLcm,DLe,DLf,DLfe,DLfn,DLfx
 New DLi,DLll,DLo,DLse,DLsl,DLsw,DLt,DLti,DLv,DLvx,DLwp,DLn,IK
 
 I $D(@DL(1)@(7)) D
 .I @DL(1)@(6)>(@DL(1)@(7)+@DL(1)@(4)-1) S @DL(1)@(7)=@DL(1)@(6)-@DL(1)@(4)+1 D WL Q
 .I @DL(1)@(6)<@DL(1)@(7) Set @DL(1)@(7)=@DL(1)@(6) D WL
 S DLt=@DL(1)@(1)_"DLv)" D IPar S DLvx=DLv,DLv=DLsl,DLsl=0 D:$D(@DLt)#10 WLn S DLv=DLvx
 Q
 ;
 ; Write line
WLn New FL,FN
 I '$D(@DLt) D
 .F DLv=DLv:-1:1 Q:$D(@DLt)
 S DLi=DLbl+DLv-DLo Q:DLi<DLb!(DLi>DLe)  Q:'($D(@DLt)#10)
 S FL(2)=DLi*100+1,FL(3)=@DLt
 S DLcb=""
 I $L(DLc) X "S DLcb=$$"_DLc_"(DLv,FL(3))"
 S FL(1)=@(DL(1)_"(2"_$S(DLcb="":"",1:",DLcb")_")")
 S:$D(@DL(1)@(12)) FL(5)=@DL(1)@(12)
 I DLsl=DLv W @FMTU,@FMTB S FL(4)=1 Do FL W $J("",@DL(1)@(5)-$L(R)),@FMTb,@FMTu
 I DLsl'=DLv D FL W @FMTb,@FMTu I $L(R)<@DL(1)@(5) W @F2
 S $P(DLse,"\",2)=$S(DLsl:DLsl,1:DLo)
 I $D(DLf),DLf="FI",DLv=DLn D WFi
 Q
 ;
 ; Write find
WFi I R[DLz S FP=FP+$L($P(R,DLz,1)),R=$P(R,DLz,2,999) W @F,@FMTI,DLz,@FMTi S FP=FP+$L(DLz) G WFi
 Q
 ;
 ; Parameters invullen
Par S @DL(1)@(6)=DLsl,@DL(1)@(7)=DLo
 Q
 ;
 ; Scroll area bepalen
SCa S FP=DLbl_$E(100+DLbl+DLal-1,2,3) W @FSC
 Q
 ;
 ; Page parameters
PPar S:DLo<1 DLo=1 I DLsl S DLsl=DLo I DLf="EN" S DLsl=DLv
 I DLo'=@DL(1)@(7) D WP
 Q
 ;
 ; Opzoeken laatste lijn
LLn F DLv=DLv-1:-1:1 I $D(@DLt) S DLo=DLv-DLal+1 Q
 S DLv=DLv-DLInc+1
 Q
 ;
 ; Show selected line
SSl I $D(DLse),DLse,$L(@DL(1)@(8)) D
 .I '$P(@DL(1)@(8),"`",2) S $P(@DL(1)@(8),"`",2)=-1
 .S DLti=1,FP=DLbl+$P(@DL(1)@(8),"`",2)
 .S:FP<1 FP=1 S:FP>24 FP=24
 .S FP=FP*1000+DLll-8
 .W @FE,@FMTI,@FMTB,$J($P(DLse,"\",2)-1\DLInc+1_"/"_(+DLse-1\DLInc+1),8)," ",@FMTb,@FMTi
 Q
 ;
 ; Show titel
STi I $D(DLti),DLti,$L(@DL(1)@(8)) D
 .I '$P(@DL(1)@(8),"`",2) S $P(@DL(1)@(8),"`",2)=-1
 .S DLti=0,FP=DLbl+$P(@DL(1)@(8),"`",2)
 .S:FP<1 FP=1 S:FP>24 FP=24
 .S FP=FP*100+1
 .W @F,@FMTI,$P(@DL(1)@(8),"`"),$J("",DLll-$L($P(@DL(1)@(8),"`"))),@FMTi
 Q
 ;
 ; Line up
LUp D SCa I 'DLsl G LUp3:DLo=1 S DLv=DLo-DLInc G LUp2
 I DLsl=1 S DLf="" G LUp3
 S DLvx=DLv,DLv=DLsl,DLsl=DLsl-DLInc I $D(DLml),DLml D WLn:DLal>1 G LUp1
 D WLn:DLal>1&'DLfe
 S IK(2)=0 D IK K IK(2) S (DLf,DLfx)=R,DLfe=1
LUp1 S DLv=DLv-DLInc I DLv'<DLo G LUp3:'$D(DLml),LUp3:'DLml D WLn G LUp3
LUp2 S DLv=DLv+DLInc F DLtt=1:1:DLInc S (DLv,DLo)=DLo-1,FP=DLbl*100+1 W @F W:DLal>1 @FIN D WLn S DLfe=0 I 'DLsw S DLsw=""
 I $D(DL(3)) S DLsw=0
LUp3 S DLv=DLo+DLal D Par S FP=124 W @FSC
 Q
 ;
 ; Line down
LDo D SCa I 'DLsl G LDo3:'$D(@DLt),LDo2
 S DLvx=DLv,DLv=DLsl+DLInc I '$D(@DLt) S DLf="" G LDo3
 S DLv=DLsl,DLsl=DLsl+DLInc I $D(DLml),DLml D WLn:DLal>1 G LDo1
 D WLn:DLal>1&'DLfe
 S IK(2)=0 D IK K IK(2) S (DLf,DLfx)=R,DLfe=1
LDo1 S DLv=DLv+DLInc I DLv<DLvx G LDo3:'$D(DLml),LDo3:'DLml D WLn G LDo3
LDo2 F DLtt=1:1:DLInc S DLo=DLo+1,FP=DLbl*100+1 W @F W:DLal>1 @FDL D WLn S DLv=DLv+1,DLfe=0 I 'DLsw S DLsw=""
 I $D(DL(3)) S DLsw=0
LDo3 S:DLsl DLv=DLvx D Par S FP=124 W @FSC
 Q
 ;
 ; First page
FPag S DLfe=0,DLo=1 I DLsl>1,DLo=@DL(1)@(7) S DLvx=DLv,DLv=DLsl,DLsl=1 D WLn S DLv=1 D WLn,Par S DLv=DLvx G FPag1
 S:DLsl DLsl=1 D PPar
FPag1 Q
 ;
 ; Last page
LPag S DLfe=0,DLv=DLv+10 G LPag:$D(@DLt) D LLn S:DLo<1 DLo=1
 I DLsl,DLsl'=DLv,DLo=@DL(1)@(7) S DLvx=DLv,DLv=DLsl,DLsl=DLvx D WLn S DLv=DLsl D WLn,Par G LPag1
 D PPar
LPag1 Q
 ;
 ; Prev Page
PPag S DLfe=0,DLo=DLo-DLal D PPar
 Q
 ;
 ; Next page
NPag S DLfe=0,DLo=DLo+DLal,DLv=DLo+DLal I '$D(@DLt) D LLn G NPag1:DLv=1 S:DLsl DLf="EN" S:'DLsl DLv=DLv+1
 D PPar
NPag1 Q
 ;
 ; Selecteer procedure
 
Select I $D(DL(3)) S DLsw=1
 D @$S(DLf="UP":"LUp",DLf="DO":"LDo",DLf="PP":"PPag",DLf="NP":"NPag",DLf="HO":"FPag",DLf="EN":"LPag",DLf="FI":"Find^PROC1($G(DLTaal))",1:"DLfcl")
 Q
 ;
 ; Dummy
DLfcl S DLf="" I DLfe D EL S DLfe=0
 Q
 ;
 ; Move list
ML New DLInc,DLad,DLal,DLb,DLbl,DLc,DLcb,DLcm,DLe,DLf,DLfe,DLfn,DLfx
 New DLi,DLll,DLo,DLse,DLsl,DLsw,DLt,DLti,DLv,DLvx,DLwp,DLn,IK,DLTaal
 
 S DLfe=0,DLt=@DL(1)@(1)_"DLv)",DLf=DL(2),DLml=1,DLTaal=$G(DL(3)) S:DLTaal'="F" DLTaal="N"
 D IPar,Select K DLml
 Q
 ;
 ; Scroll list
SL New DLInc,DLad,DLal,DLb,DLbl,DLc,DLcb,DLcm,DLe,DLf,DLfe,DLfn,DLfx
 New DLi,DLll,DLo,DLse,DLsl,DLsw,DLt,DLti,DLv,DLvx,DLwp,DLn,IK,DLTaal
 S DLTaal=$G(DL(4)) S:DLTaal'="F" DLTaal="N"
 
 S DLfe=0,DLt=@DL(1)@(1)_"DLv)" D IPar,CVL K IK S:$D(DL(2)) R=R_DL(2) S IK(1)=R,DLsw=0
 I $D(DL(3)),DL(3)<0 S (IK(2),DL(3))=-DL(3)
SL1 I DLfe D EL,SSl S DLfe=0
 D IK S (DLf,DLfx)=R
 I "DO,NP"[R,DLcm'="",DLsl+DLal>+DLse X "S $P(DLse,""\"",1)=$$"_DLcm_"(+DLse,DLal)" S @DL(1)@(9)=$P(DLse,"\",1)
 I "EN"=R,DLcm'="" X "S $P(DLse,""\"",1)=$$"_DLcm_"(+DLse,9999)" S @DL(1)@(9)=$P(DLse,"\",1)
SL2 Do Select S IK(2)=3 S:$D(DL(3)) IK(2)=DL(3) I 'DLsw S DLsw=$S(DLsw=0:"",1:0)
 I DLfe S:'DLsw DLsw=0 G SL2:$L(DLf),SL1
 I $L(DLf) D SSl G SL1
 I DLfx="",'DLsw,'$D(DL(3)) D:$L(DLsw) SSl G SL1:$L(DLsw) D STi K IK(2) G SL1
 I DLfx="",'DLsw S DLsw=1 d SSl G SL1
 D STi S R=DLfx
 Q
 ;
 ; Position list
PL New DLInc,DLad,DLal,DLb,DLbl,DLc,DLcb,DLcm,DLe,DLf,DLfe,DLfn,DLfx
 New DLi,DLll,DLo,DLse,DLsl,DLsw,DLt,DLti,DLv,DLvx,DLwp,DLn,IK
 
 D LPar G PL1:DL(2)=DLbl D CL^PROC1 I DLsl>(DL(3)+DLo-1) S DLo=DLsl-DL(3)+1 D Par
 D Pba K DL(2),DL(3) D WL G PL4
PL1 G PL3:DL(3)>DLal I DL(3)=DLal K DL(2),DL(3) G PL4
 D SCa G PL2:DLsl'>(DL(3)+DLo-1)
 S FP=DLbl*100+1 W @F F DLi=1:1:DLal-DL(3)-(DLal-(DLsl-DLo+1)) W @FDL
 S DLo=DLo+DLi D Par
PL2 S FP=DLbl+DL(3)*100+1 W @F F DLi=1:1:DLal-DL(3) W @FDL
 S FP=124 W @FSC D Pba K DL(2),DL(3) G PL4
PL3 D Pba S DL(2)=DLbl+DLal,DL(3)=DLbl+DL(3)-1 D WL
 S DLv=DLo+DLal-1 G PL4:$D(@DLt) D SCa,LLn S:DLo<1 DLo=1 S DLb=1,DLe=24
 S FP=DLbl*100+1 W @F F DLv=@DL(1)@(7)-1:-1:DLo S DLo=DLv W @FIN D WLn Q:DLv=1
 D Par S FP=124 W @FSC
PL4 Q
 ;
 ; Nieuwe begin- en aantal lijnen
Pba S @DL(1)@(3)=DL(2),@DL(1)@(4)=DL(3)
 Q
 ;
YZ Q
 Q
Z X ^cZ Q
ZZ ; 09.12.91 -  8 u 50