vhINP ;Input veld [ 11/08/2003  3:54 PM ]
 Goto ctl
 ;
 ;  **** Oproep van teksten op geslagen in ^ASK
 ; Vraagstelling met input door gebruiker
ASKL(sProgNm,sLabel) 
 New sValue,prompt,ln,X,sT1,sT2,%C,sAftPrmp,sTimeOut,sSetting,sTest,sExitKey,sCVL,IsCVL
 Do FETCH("A")
 New X Set X=$G(sValue)
 Goto ASK1
 ; Vraagstelling met keypress door gebruiker
KEYL(sProgNm,sLabel) 
 New sValue,prompt,ln,X,sT1,sT2,%C,sAftPrmp,sTimeOut,sSetting,sTest,sExitKey,sCVL,IsCVL
 Do FETCH("K")
 Goto KEY1
 ; Tonen van tekst aan de gebruiker
TXTL(sProgNm,sLabel) 
 New IK,sValue,prompt,ln,X,sT1,sT2,%C,sAftPrmp,sTimeOut,sSetting,sTest,sExitKey,sCVL,IsCVL
 Do FETCH("T")
 Goto TXT1
 
 ; Lowlevel routine voor ophalen van gegevens uit de ^ASK global
FETCH(Mode) 
 New sRec
 If '$D(^ASK("D",sProgNm,sLabel)) Do TXT(sProgNm_","_sLabel_" bestaat niet") Quit
 Set sRec=^(sLabel)
 Set sTest=$G(^(sLabel,"V"))
 Set sCVL=$G(^("L"))
 Set sT1=$G(^("T"))
 Set sT2=$P(sT1,"`",2)
 Set sT1=$P(sT1,"`")
 If Mode'="T" Do
 .Set prompt=$P(sRec,"`",1)
 .X:$E(prompt)="""" "S prompt="_prompt
 .Set prompt=prompt_" : "
 .If Mode="A",$L($P(sRec,"`",2)) X "S sValue="_$P(sRec,"`",2)
 .Set ln=$P(sRec,"`",3)
 .S:Mode="A" sAftPrmp=$P(sRec,"`",5)
 .S %C=$P(sRec,"`",6)
 .S sSetting=$P(sRec,"`",7)
 .S sExitKey=$P(sRec,"`",8)
 S sTimeOut=$P(sRec,"`",9)
 Quit
 
 ; **** Directe oproep van teksten
 ; 
 ;sSetting = U=Forced upper, L=Forced lower, B=Both Upper and lower
 ;           Leeg = instelling van het programma 
ASK(prompt,ln,X,sT1,sT2,%CO,sAftPrmp,sTimeOut,sSetting,sTest,sExitKey) 
 Set sSetting=$G(sSetting)
 Set sT1=$G(sT1)
 Set sT2=$G(sT2)
 Set sAftPrmp=$G(sAftPrmp)
ASK1 Set X=$E(X,1,ln)
 Set FP=2101 Write @F,@F2
 Set FP=2300+$G(%CO,1)
 If $L(sT1),"""@$"[$E(sT1) Write @F,@sT1,@F2
 Else  Write @F,sT1,@F2
 Set FP=2400+$G(%CO,1)
 If $L(sT2),"""@$"[$E(sT2) Write @F,@sT2,@F2
 Else  Write @F,sT2,@F2
 Set:'$G(%CO) %CO=1
 Set %R=22,FP=%R*100+ln+$L(prompt)+%CO
 If $L(sAftPrmp),"""@"[$E(sAftPrmp) Write @F,@sAftPrmp,@F2
 Else  Write @F,sAftPrmp,@F2
ASK2 Set %C=%CO
 Do vhINP
 If sSetting["U" Set X=$$UPCASE^vhRtn1(X)
 If sSetting["L" Set X=$$LOCASE^vhRtn1(X)
 
 Set:'$L($G(sTest)) sTest="X'["";"",X'[""\"""
 I $L(X)=1,sExitKey[X Goto ASK3
 I @sTest
 Else  W *7 Goto ASK2 
ASK3 Do ADD^vhScherm(21,24)
 Quit X
 
 
 ; Vraagstelling met input door 1 toets
KEY(prompt,sT1,sT2,%C,sTimeOut,sSetting,sTest,sExitKey) 
 New IK,R
 Set sT1=$G(sT1),sT2=$G(sT2),sSetting=$G(sSetting),sTimeOut=$G(sTimeOut),sExitKey=$G(sExitKey)
KEY1 Set FP=2101 Write @F,@F2
 Set FP=2301
 If $L(sT1),"""@$"[$E(sT1) Write @F,@sT1,@F2
 Else  Write @F,sT1,@F2
 Set FP=2401
 If $L(sT2),"""@$"[$E(sT2) Write @F,@sT2,@F2
 Else  Write @F,sT2,@F2
 Set:'$G(%C) %C=1
KEY2 Set %R=22,FP=%R*100+%C Write @F,prompt,@F2
 If $ZV["MSM" Use 0:(::::65)
 Else  Use 0:(:"+S")
 If sTimeOut R X#1:sTimeOut Else  Set zb=-1 Goto KEY4
 If 'sTimeOut R X#1
 Set zb=$$TRANSZB
 I $L($G(sCVL)) Do CVL Goto:$G(IsCVL) KEY4
 If sSetting["U" Set X=$$UPCASE^vhRtn1(X)
 If sSetting["L" Set X=$$LOCASE^vhRtn1(X)
 I $L(sExitKey),$L(X)!(sExitKey["*"),sExitKey[X Goto KEY3
 Set:'$L($G(sTest)) sTest=1
 I @sTest
 Else  W *7 Goto KEY2
KEY3 Set zb=1
KEY4 Do ADD^vhScherm(21,24)
 If $ZV["MSM" Use 0:(:::::65)
 Else  Use 0:(:"-S")
 Quit X
 
 ; Tonen van tekst en wachten op indruk van een toets
TXT(sT1,sT2,sTimeOut,Nok) 
 New ln,R,IK,%R,Ok
 Set sT1=$G(sT1),sT2=$G(sT2),sTimeOut=$G(sTimeOut)
TXT1 If sT2="" Set sT2=sT1,sT1=""
 If $L(sT1) Do
 .Set FP=2300
 .Write @F,@FMTI,$J("",80),@F," "
 .If """@$"[$E(sT1) Write @sT1
 .Else  Write sT1
 Set Ok='$G(Nok),FP=2400 Write @F,@FMTI,$J("",80),@F," "
 If """@$"[$E(sT2) Write @sT2 Write:Ok "  []=ok" Write @FMTi
 Else  Write sT2 Write:Ok "  []=ok" Write @FMTi
 Set:sTimeOut IK(2)=sTimeOut Do IK^PROC1
 Do ADD^vhScherm(23+'$L(sT1),24)
 Quit
 
 ;sSetting = U=Forced upper, L=Forced lower, B=Both Upper and lower
 ;           Leeg = instelling van het programma 
MASK(prompt,ln,sT1,sT2,%R,%C,sAftPrmp,sTimeOut,sSetting,sTest,sExitKey) 
 New X
 Set prompt=$G(prompt),ln=$G(ln),sT1=$G(sT1),sT2=$G(sT2),%R=$G(%R),%C=$G(%C)
 Set sAftPrmp=$G(sAftPrmp),sSetting=$G(sSetting),sExitKey=$G(sExitKey)
 S:$G(sExitKey)="" sExitKey=",.-()"
 If sT1="",$L(sT2) Set sT1=sT2,sT2=""
 Xecute:$E(prompt)="""" "S prompt="_prompt
 Set:$L(prompt) prompt=prompt_" : "
 Set:'ln ln="" Set:'%R %R=22 Set:'%C %C=1
 Set FP=%R*100+%C
 Write @F,prompt,$TR($J("",ln)," ",".")
 Set FP=%R*100+ln+$L(prompt)+%C
 If $L(sAftPrmp),"""@"[$E(sAftPrmp) Write @F,@sAftPrmp,@F2
 Else  Write @F,sAftPrmp,@F2
 If $L(sT1) Do
 .Set FP=%R*100+%C+100
 .If """@$"[$E(sT1) Write @F,@sT1,@F2
 .Else  Write @F,sT1,@F2
 If $L(sT2) Do
 .Set FP=%R*100+%C+200
 .If """@$"[$E(sT2) Write @F,@sT2,@F2
 .Else  Write @F,sT2,@F2
 Set FP=%R*100+%C+$L(prompt)
MASK2 Write @F,$TR($J("",ln)," ","."),@F
 Do mread
 If sSetting["U" Set X=$$UPCASE^vhRtn1(X)
 If sSetting["L" Set X=$$LOCASE^vhRtn1(X)
 
 Set:'$L($G(sTest)) sTest="X'["";"",X'[""\"""
 I $L(X)=1,sExitKey[X Goto MASK3
 I @sTest
 Else  W *7 Goto MASK2 
MASK3 Do ADD^vhScherm(%R,%R+$S($L(sT2):2,$L(sT1):1,1:0))
 Quit X
 
 ; **** Verlaten van een programma  ****
 
 ; NotSave = 1 : De gebruiker krijgt de mogelijkheid op NIET te bewaren
 ;           0 : De gebruiker krijgt de NIET de mogelijkheid om NIET te bewaren
 ; Changed = 1 : Al dan niet bewaren
 ;           0 : Exit (zonder vraagstelling van bewaren)
SAVE(NotSave,Changed,NoExit) 
 New Input
 If $D(Changed),'Changed Goto:'$G(NoExit) EXIT1 Quit "."
SAVE1 Set Input=$$^vhTXTPOP("FILE","SAVE")
 ;Set Input=$$ASK^vhINP("Wenst U de gewijzigde gegeven te bewaren : ",1,"","J[] = Bewaren, "_$S(NotSave:"N[] = Niet bewaren, ",1:"")_"[] = Hernemen","","","","","U")
 Quit:'$L(Input) ""
 If $S(NotSave:"JN",1:"J")'[Input W *7 Goto SAVE1
 Quit $S(Input="J":"-",Input="N":".",1:"")
 
 ; Verlaten van een programma waarbij de gegevens niet gewijzigd werden
EXIT New Input
EXIT1 Set Input=$$^vhTXTPOP("FILE","EXIT")
 ;Set Input=$$UPCASE^vhRtn1($$ASK^vhINP("Wenst U het programma te verlaten : ",1,"","-[] = Verlaten,  [] = Hernemen"))
 If "-"'[Input W *7 Goto EXIT1
 Quit Input
 
EDITBIG(X,prompt,ln,Pos) 
 New sSetting,sExitKey,%R,%C
 Set ln=ln\80*80
 Set Pos=Pos-(ln\80)-1
 Do STORE^vhTERMINA(Pos,24)
 Set FP=Pos*100+1 Write @F,@F1,!,prompt
 Set prompt="",%C=1,%R=Pos+2,sExitKey="-."
 Do ctl
 Do REFRESH^vhTERMINA(Pos,24)
 Quit X
 
 ; **** LowLevel read (overgenomen van ^cyur) ****
 
ctl ;N:$D(urv) urv D ^cyu:'$D(cu) I cu("~") S urv="00"
 S urv=10 ;D on^cyuos
 New ZMode
 Set ZMode=$ZMODE ; Huidige input settings onthouden
 Use 0:(::$C(13,8,9))
 If $L($G(sSetting)) Xecute:sSetting["U" FUP Xecute:$G(sSetting)["L"!($G(sSetting)["B") FLO
 S EOL=$G(sSetting)["E"
 S:$L($G(sCVL)) EOL=1
 D init
ctl1 D read,ST:X[" "
 Use 0:(:$S($P(ZMode,"\")["U":"+",1:"-")_"U":$C(13)) ; herzetten uppercase
 s:zb'=1&(zb'=-1) zb=""
 D kill Q
 
init Set FP=%R*100+%C W @F,@FMTCL
 I $D(prompt) D
 .W prompt
 .Set FP=%R*100+ln+$L(prompt)+%C
 .If $L($G(sAftPrmp)),"""@"[$E(sAftPrmp) Write @F,@sAftPrmp,@F2
 .Else  Write @F,$G(sAftPrmp),@F2
 .S %C=%C+$L(prompt),FP=%R*100+%C
 .W @F
 S:$G(sExitKey)="" sExitKey=",.-()"
 S X=$E(X,1,ln)
 S:'$D(X) X="" S:'$D(ln) ln=80-%C W @FMTI
 I ln'>80 W X_$J("",ln-$L(X))
 Else  Do
 .Do FILL^vhTERMINA(%R,1,%R+(ln/80)-1,80)
 .Set FP=%R*100+%C W @F
 .W X_$J("",ln-$L(X))
init1 S xc=1,urv=$C(%R,%C)_1_(ln>80)_urv_$D(uno)_$C(ln/256)_$C(ln#256) K uno
 I $G(sSetting)["A",$L(X) S xc=$L(X)+1 S:xc>ln xc=ln S FP=FP+xc-1
 W @F
 s zb=""
 ;row_col_true_long_on_cysr_no_ln opts
 ; 1   2   3    4   5   6   7  8
 Q
 ;
1 W *7
read Set:X=""&$L($G(sCVL)) EOL=1
 ; Lijn 3 bijgevoegd voor Cache weet niet of dit correct is  ?????
3 If 'EOL Do 
 .I $G(sTimeOut) R in#ln-xc+1:sTimeOut else  S zb=-1 Q
 .E  R in#ln-xc+1
 Else  Do
 .I $G(sTimeOut) R in#1:sTimeOut else  S zb=-1 Q
 .E  R in#1
 Quit:zb=-1
 If $ZV'["MSM",$E(in,$L(in))=$zb Set zb=0
 Else  Set zb=$$TRANSZB
 I in]"" S X=$E(X,1,xc-1)_$J("",xc-$L(X)-1)_in_$E(X,xc+$L(in),999),xc=xc+$L(in) I $E(urv,4) D coor W @F
 I EOL,$L(in) S X=$E(X,1,xc-1) D coor W @F,$J("",ln-xc+1),@F 
 I $L($G(sCVL)) Do CVL Goto B13:IsCVL
 I xc=2,zb=13,$L(in)=1,sExitKey[in S zb=99 Goto B99 ; "-"+ENTER input
 If zb>20,zb<27 Set:$P(^cLOG(boot,"DEV",$$IO^cQ5),"\")="MC" zb=$P("22;25;24;23;26;21",";",zb-20) goto @("B"_zb)
 If zb>16,zb<21 goto @("B"_zb)
 If zb=13!(zb=8)!(zb=9)!(zb=127) goto @("B"_zb)
 If zb=0,'EOL!(ln=1) goto B20
readEOL S EOL=0
 G read
 ;
coor I '$E(urv,4) S %R=$A(urv),%C=$A(urv,2)-1+xc,FP=%R*100+%C
 E  S %C=$A(urv,2)-1+xc#80 S:'%C %C=80 S %R=xc\80-(%C=80)+$A(urv),FP=%R*100+%C
 Q
CVL Set:$E(sCVL)'="\" sCVL="\"_sCVL_"\"
 Set IsCVL=""
 Set:sCVL[("\"_zb_";") IsCVL=zb
 Set:sCVL[("\"_X_";") IsCVL=X
 Quit:IsCVL=""
 Set IsCVL=$P($P(sCVL,"\"_IsCVL_";",2),"\") 
 Set X=$S($L(IsCVL):IsCVL,1:X)
 Set IsCVL=1
 Quit
 ;
B13 Q
B17 I '$E(urv,4) G 1
 I %R=$A(urv) G:$E(urv,6) 3 S %C=$A(urv,2),xc=1 W @F 
 E  S xc=xc-80 D coor W $C(27,91,65)
 G readEOL ; Cursor up
B18 G:'$E(urv,4) 1
 I xc+80>ln G:$E(urv,6) 3 W *7
 E  S xc=xc+80 D coor G:xc>ln B22 W $C(27,91,66) ; lijn 22 omgevormd naar B22 ?????
 G readEOL ; Cursor down
B19 I xc'<ln G 1
 S xc=xc+1 I '$E(urv,4) W $C(27,91,67)
 E  D coor W @F
 G readEOL ; Cursor right
B20 G:xc'>1 1
 S xc=xc-1 I '$E(urv,4) W $C(27,91,68)
 E  D coor W @F
 G:zb=20!(zb=0) readEOL Q  ; Cursor LEFT
B25 S xc=1 D coor W @F G readEOL ; Cursor Begin
B26 S xc=$L(X) S:xc<ln xc=xc+1 D coor W @F G readEOL ; Cursor End
B9 S xc=$S(xc+8'>$L(X):xc+8,$L(X)=ln:$L(X),1:$L(X)+1) D coor W @F G readEOL ; Tab
B22 G:$L(X)'<ln 1 S X=$E(X,1,xc-1)_" "_$E(X,xc,999) D coor
 W @F,$E(X,xc,999),@F
 G readEOL ; Insert
B23 G:$L(X)=0 1 S X=$E(X,1,xc-1)_$E(X,xc+1,999) D coor
 W @F,$E(X,xc,999)_$J("",ln-$L(X)),@F
 G readEOL ; Remove
B127 ; Ook backspace
B8 G:xc=1 1 ;I '$E(urv,4) D B24 W " ",cu("l") I 1
 S xc=xc-1 D coor W @F," ",@F
 S X=$E(X,1,xc-1)_" "_$E(X,xc+1,999) G readEOL ; Backspace
B24 S X="",zb=1 Q  ;Select    
B21 S X=$E(X,1,xc-1) D coor W @F,$J("",ln-xc+1),@F G read ; Erase EOL
82 I $E(X,xc)?1A S a=$A(X,xc),X=$E(X,1,xc-1)_$C(a+$S(a>90:-32,1:32))_$E(X,xc+1,999) W $E(X,xc)
 I xc<ln S xc=xc+1 D coor
 W @F G read
B99 ;Input "-"+Enter
 S X=$E(X,1,xc-1) D coor W @F,$J("",ln-xc+1),@F
 S zb=13
 G B13
ST F a=0:0 Q:$E(X,$L(X)\2,999)'?1." "  S X=$E(X,1,$L(X)\2-1)
 F a=$L(X):-1:1 I $E(X,a)]" " S X=$E(X,1,a) Q
 Q
 
kill K char,if,in,urv,xc,EOL,IsCVL w @FMTCL Q
 
mread   
 New Y,BackSp,DelChar
 If $ZV["MSM" Use 0:(::::1) ; echo off
 Else  Use 0:(:"+S")
 Write @FCH
 Set DelChar=$V(126,-4,1),BackSp=$V(127,-4,1)
 Set X=""
 Read "" ; flush type-ahead
 For  Do  Quit:Y=13!($G(zb)=-1)  ; zb set here, not modified hereafter
 .I $G(sTimeOut) Read *Y:sTimeOut Else  Set zb=-1 Quit
 .Else  Read *Y
 .Quit:Y=13!($G(zb)=-1)
 .If (Y=8!(Y=127)&'BackSp)!(Y=BackSp) Do  Quit  ; process backspace
 ..Quit:X=""
 ..If $L(prompt)!ln Write $C(8,$S(ln:46,1:32),8) ; erase #
 ..Else  Do
 ...Set FP=%R*100+%C-($L(X)\2)
 ...Write @F Write:'($L(X)#2) " " Write $TR($J("",$L(X)-1)," ","*") Write:($L(X)#2) " "
 ..Set X=$E(X,1,$L(X)-1) ; remove last char
 .If (Y=21!(Y=24)&'DelChar)!(Y=DelChar) Do  Quit  ; line delete
 ..Quit:X=""
 ..For Y=1:1:$L(X) Write $C(8,32,8) ; erase the line
 ..Set X="" Q
 .If $L(X)=ln&ln Do  ; process maxlength
 ..Quit:X=""  Write $C(8,$S(ln:46,1:32),8) ; erase #
 ..Set X=$E(X,1,$L(X)-1) ; remove last char
 .Set X=X_$C(Y)
 .If $L(prompt)!ln Write "*" ; echo * for each char
 .Else  Set FP=%R*100+%C-($L(X)\2) Write @F,$TR($J("",$L(X))," ","*")
 If $ZV["MSM" Use 0:(:::::1) ; echo on
 Else  Use 0:(:"-S")
 Write @FCS
 Quit
TRANSZB() 
 New K1,K,zb
 If $ZV["MSM" Quit $S($zb>256:$zb\256,1:$zb)
 Set K1=$A($Key,1)
 Set K=$E($Key,2,5)
 If K1=27 Do  ; Escape sequentie
 . Set Def="OP;32\OQ;33\OR;34\OS;35\[17~;37\[18~;38\[19~;39\[20~;40\[21~;41\[23~;43\[24~;44\[25~;45\[26~;46\[28~;48\[29~;49\[31~;51\[32~;52\[33~;53\[34~;54\[A;17\[B;18\[C;19\[D;20\[1~;21\[2~;22\[3~;23\[4~;24\[5~;25\[6~;26\Ok;59\Ol;60\Om;61\On;62\Oo;63\Op;27\Oq;1\Or;2\Os;3\Ot;4\Ou;5\Ov;7\Ow;7\Ox;8\Oy;10"
 . Set Str=$P(Def,K,2)
 . Set zb=+$E(Str,2,4)
 Else  Do
 . Set zb=K1
 Quit zb

YesNoCancel(Tekst)
	new Answer
	set Answer=$$ASK(Tekst_" ? ",1,""," [] = Ja  .[] = Nee  -[] = Annuleer",,,,,,""".-""[X")
	quit $select( Answer="":1 , Answer=".":0 , 1:"-" )