vhRtn1 ;Routine library 1 [ 03/28/2003 10:27 AM ] %J() ; Nieuw index voor ^HULP Set sJC=$G(sJC)+1 If sJC>990 Set sJC=1 Set:$O(^HULP($J+1*1000),-1)\100=$J sJC=$O(^HULP($J+1*1000),-1)#1000+1 Quit $J*1000+sJC %JDECR(%J,HulpRef) ; Vrijgeven van %J ; of te wel %J of te wel HulpRef meegeven als parameter If $G(%J) Quit:$J*1000+sJC'=%J If $L($G(HulpRef)) Quit:$NAME(^HULP($J*1000+sJC))'=HulpRef Set sJC=sJC-1 Kill:$G(%J) ^HULP(%J) Kill:$L($G(HulpRef)) @HulpRef Quit ; Vervangen of verwijderen van verschillende substrings ; Eerst wordt alle occurences van string F1 vervangen door T1 ; daarna van F2, ... REPLACE5(String,F1,T1,F2,T2,F3,T3,F4,T4,F5,T5) New I,P For I=1:1:5 Quit:'$D(@("F"_I)) Do .Set P=1 .For Set P=$F(String,@("F"_I),P) Quit:'P Do ..Set $E(String,P-$L(@("F"_I)),P-1)=@("T"_I) ..Set P=P-$L(@("F"_I))+$L(@("T"_I)) Quit String ; Vervangen of verwijderen van een substring in een string ; Indien From gedefinieerd is dan wordt pas na de From-de occurence van de substring F de string vervangen ; Indien Cnt is ingevuld dan worden er slecht Cnt vervangingen uitgevoerd REPLACE(String,F,T,From,Cnt) New P,I Set P=1 For I=1:1:$G(From) Set P=$F(String,F,P) Quit:'P Quit:'P Set:'$G(Cnt) Cnt=9999 For Quit:'Cnt Set P=$F(String,F,P) Quit:'P Do .Set $E(String,P-$L(F),P-1)=T .Set P=P-$L(F)+$L(T) .Set Cnt=Cnt-1 Quit String ; Extractie van de keywords uit een string ; Return : Keywords gescheiden door "\" KEYLIST(String,BBExcl) New S,R,I Set:'$D(BBExcl) BBExcl="EXCLKEY" Set S="",String=$$UPTRIMA(String) For I=1:1:$L(String," ") S R=$P(String," ",I) If $L(R)>2,'$D(^BB("D",BBExcl,R)) Set S=S_"\"_R Quit $P(S,"\",2,99) ;Omzetten van de karakters naar UpperCase UPCASE(String) Quit $TR(String,"azertyuiopqsdfghjklmwxcvbnéàèçë","AZERTYUIOPQSDFGHJKLMWXCVBNEAECE") ;Omzetten van de karakters naar LowerCase LOCASE(String) Quit $TR(String,"AZERTYUIOPQSDFGHJKLMWXCVBN","azertyuiopqsdfghjklmwxcvbn") ; De eerste letters van een woord behouden ; De volgende letters van een woord in lowercase zetten ; Woorden worden gescheiden door een leesteken zoals : Blanko, Komma,Punt,Dubbel punt, Punt-Komma, Slash, Uitroepteken, Vraagteken, Koppelteken. INITCAP(S) New N,R,U ; Set U=1 For N=1:1:$L(S) Do .Set $E(S,N)=$S(U:$E(S,N),1:$TR($E(S,N),"AZERTYUIOPQSDFGHJKLMWXCVBN","azertyuiopqsdfghjklmwxcvbn")) .Set U=0 S:" . /:\?!,-"[$E(S,N) U=1 Quit S ;Omzetten naar UpperCase en trimmen van niet ALPHA/SPATIE karakters UPTRIMA(String) Set String=$$UPCASE(String) Quit:String?1.U String New S,I Set S="" For I=1:1:$L(String) Set:$E(String,I)?1U!($E(String,I)=" ") S=S_$E(String,I) Quit S ;Omzetten naar UpperCase en trimmen van niet ALPHA/NUMERIEKE karakters UPTRIMAN(String) Set String=$$UPCASE(String) Quit:String?.U String New S,I Set S="" For I=1:1:$L(String) Set:$E(String,I)?1U!($E(String,I)?1N) S=S_$E(String,I) Quit S ;Extractie van de numerieke karakters TRIMN(String) Quit:String?.N String New S,I Set S="" For I=1:1:$L(String) Set:$E(String,I)?1N S=S_$E(String,I) Quit S #define UCase(%v) $ZCVT(%v,"U") ;Identnummer trimmen tot numeriek + 1e char mag een letter zijn. ;Is gewoon een uitbreiding op TRIMN() . Een meer specifieke implementatie is ook mogelijk. TRIMIDENT(String) ; [IDENT] Added by WimV on 11/02/2011 New S,I Set S="" Set:($E(String,1)?1AN) S=S_$$$UCase($E(String,1)) Set S=S_$$TRIMN($E(String,2,99)) Quit S ;Extractie van de initialen INITIAL(String) New S,I Set String=$$UPTRIMA(String),S="" For I=1:1:$L(String," ") Set S=S_$E($P(String," ",I),1) Quit S ;Lijst verwerking ;Verwijderen van een waarde uit een lijst REMLIST(List,Ref,Delim) Quit:List'[Ref List S:'$D(Delim) Delim=";" New J For J=1:1:$L(List,Delim)+1 Quit:$P(List,Delim,J)=Ref Quit $P(List,Delim,1,J-1)_$S($P(List,Delim,J+1,999)'=""&($P(List,Delim,1,J-1)'=""):Delim,1:"")_$P(List,Delim,J+1,999) ; Verwijderen van een local of global Ref met verschillende sleutel waarden uit list KILL(Ref,List) New X,Y Quit:'$L(List) Set List=$TR(List,"\",";") For Y=1:1:$L(List,";") Set X=$P(List,";",Y) Kill @Ref Quit ; Invullen van de local of global definitie Ref met verschillende sleutelwaarden uit list SET(Ref,List,Val) New X,Y Set:'$D(Val) Val="""""" Quit:'$L(List) Set List=$TR(List,"\",";") For Y=1:1:$L(List,";") Set X=$P(List,";",Y) X "Set "_Ref_"="_Val Quit ; Copieren van een deelboom in een global of local COPYTREE(sFromNr,sToNr,sRef) New sRF,sRT,sKey Set:$E(sRef,$L(sRef))'="(" $E(sRef,$L(sRef))="" Set sRF=sRef_$S($E(sRef,$L(sRef))="(":"",1:",")_"sFromNr)" Set sRT=sRef_$S($E(sRef,$L(sRef))="(":"",1:",")_"sToNr)" Merge @sRT=@sRF Quit COPYBOOM(sRF,sRT) Merge @sRT=@sRF Quit COPYREC(sRF,sRT,sNiv) ;Recursieve copy Merge @sRT=@sRF Quit WARN w *7 Quit LINE(Type,Len,Vert) New L,I,V,C Set:'$D(Vert) Vert="" Set L=$J("",Len) Set:Type'="B" L=$TR(L," ",$$C(9)) If Vert="" Quit L If Type="" For I=1:1:$L(Vert,";") Do VERT($P(Vert,";",I)) Set $E(L,V)=C If Type="B" Do .For I=1:1:$L(Vert,";") Do ..Do VERT($P(Vert,";",I)) ..Set $E(L,V)=$S(C="":$$C(10),1:C) If Type="S" Do .For I=1:1:$L(Vert,";") Do ..Do VERT($P(Vert,";",I)) ..Xecute "For V="_V_" Set $E(L,V)=$S(C="""":$S(V=1:$$C(7),V=Len:$$C(6),1:$$C(11)),1:C)" If Type="F" Do .For I=1:1:$L(Vert,";") Do ..Do VERT($P(Vert,";",I)) ..Xecute "For V="_V_" Set $E(L,V)=$S(C="""":$S(V=1:$$C(1),V=Len:$$C(2),1:$$C(5)),1:C)" If Type="L" Do .For I=1:1:$L(Vert,";") Do ..Do VERT($P(Vert,";",I)) ..Xecute "For V="_V_" Set $E(L,V)=$S(C="""":$S(V=1:$$C(3),V=Len:$$C(4),1:$$C(8)),1:C)" Quit L VERT(v) If v["$" Set V=$P(v,"$") Else Set V=+v Set C=$E(v,$L(V)+1,$L(v)) If $L(C) Xecute "Set C="_C Quit C(Piece) New C Xecute "Set C=$C("_$P($P(FG,D,Piece),"*",2)_")" Quit C ; ; Wrappen van text binnen kantlijnen ; sLen : Afstand kantlijn ; sRef : Bevat naam van een local of global ref ; sRec : Bevat paste-gegevens met D gescheiden ; .sWrap : Local waarin de verschillende tekstlijnen gestoken worden ; .sWrap = Aantal lijnen ; .sWrap(n) = Tekstlijn ; Indent : Empty : Automatische indent met 1. of - * of blanko's ; 0 : Geen indent ; n : Indent van n op de 2de en volgende lijnen ; Opmerking : Met ~ in de tekst wordt er een nieuwe lijn genomen. WRAP(sLen,sRef,sRec,sWrap,sIndent) New sTxt,sI,sJ,sS,sT,sO,sMem Set sRec=$G(sRec) Set (sMemInd,sIndent)=$G(sIndent) Set sTxt="" If ",("[$E(sRef,$L(sRef)) Set sI="",sRef=sRef_"sI)" For Set sI=$O(@sRef) Quit:sI="" Set sTxt=sTxt+1,sTxt(sTxt)=@sRef Else Set sTxt=1,sTxt(1)=@sRef Kill sWrap Set sWrap=0 Set sS="" For sJ=1:1:sTxt Do .For Set sI=$P(sTxt(sJ),"@",2) Quit:sI'?1.2N Do ..Set sTxt(sJ)=$P(sTxt(sJ),"@")_$P(sRec,D,sI)_$P(sTxt(sJ),"@",3,99) .Set sOMem=1 .If $L(sTxt(sJ)) For sO=1:1:$L(sTxt(sJ),"~") Do ..Set sT=$P(sTxt(sJ),"~",sO) ..If sLen,$L(sT)!(sOMem'=sO) For sI=1:1:$L(sT," ") Do ...If $L(sS)+$L($P(sT," ",sI))+sIndent>sLen!(sOMem'=sO) Do ....Set sWrap=sWrap+1,sWrap(sWrap)=$J("",sIndent)_$E(sS,1,$L(sS)-1) ....If sIndent="" Set sIndent=0 If sS?1.2N1"."1" "1.E!("- ~* ~ "[$E(sS,1,2)) Set sIndent=$L($P(sS," ",1))+1 For sIndent=sIndent:1:99 Quit:$E(sS,sIndent+1)'=" " ....Set sS="" ....Set:sO'=sOMem sIndent=sMemInd ....Set sOMem=sO ...Set sS=sS_$P(sT," ",sI)_" " ..Set:'sLen sWrap=sWrap+1,sWrap(sWrap)=sT Set:$L(sS)>1 sWrap=sWrap+1,sWrap(sWrap)=$J("",sIndent)_$E(sS,1,$L(sS)-1) Quit:sLen If sWrap For Quit:sWrap(sWrap)'=""!'sWrap Kill sWrap(sWrap) Set sWrap=sWrap-1 Quit ISEURO() Quit ''$$FADEF(11,1) EURO(Bedrag,Munt,NoSa,NoRound) New Euro,FaMunt If '$D(Q) New Q Set Q="K" If '$D(D) New D Set D="\" Set Munt=$G(Munt),Bedrag=$G(Bedrag),NoSa=$G(NoSa),NoRound=$G(NoRound) Set FaMunt=$$FADEF() Set:Munt="" Munt=FaMunt Set Euro=Bedrag*$$MUNT("EUR",,,NoSa,Munt) Set:'NoRound Euro=$J(Euro,0,$$MUNT("EUR",4,,NoSa)) Quit Euro MUNT(Munt,Par1,Par2,NoSa,ToMunt) ; Par1 1 = Afkorting ; Par2 = 0 Oude ; = 1 Nieuwe ; Anders default ; 2 = Omschrijving ; 3 = Pariteit ; Par2 = 1 Aankoop ; = 2 Verkoop ; = 3 financieel ; = 11 Aankoop (invers) ; = 12 Verkoop (invers) ; = 13 financieel (invers) ; 4 = Afronding ; 5 = Omrekenen ; Par2 = om te rekenen bedrag (Bedrag#Round) ; Round = 1 : afronden volgens ToMunt If $G(Munt)="?" Do HELPFUNC($ZN,"MUNT") Quit "" New R,FaMunt Set FaMunt=$$FADEF() Set Munt=$G(Munt) Set:Munt="" Munt=FaMunt Set ToMunt=$G(ToMunt) Set:ToMunt="" ToMunt=FaMunt Set Munt=$$MUNTKODE(Munt),ToMunt=$$MUNTKODE(ToMunt) Set Par1=$G(Par1,3),Par2=$G(Par2,2),NoSa=$G(NoSa),R=@("^"_Q_"BA(11,Munt)") If NoSa="S",$D(@("^"_Q_"BA(NoSa,11,Munt)")) Set R=@("^"_Q_"BA(NoSa,11,Munt)") If NoSa="E",$D(@("^"_Q_"BA(NoSa,11,Munt)")) Set R=@("^"_Q_"BA(NoSa,11,Munt)") If Par1=1 Do .Set R=$P(R,D) .If Par2'=0,Par2'=1 .Else Set R=$$MUNTKODE(R,Par2) Else If Par1=2 Set R=$P(R,D,2) Else If Par1=3 Set R=$$MUNTPAR(Munt,Par2,NoSa,ToMunt) Else If Par1=4 Set R=$P(R,D,7) Else If Par1=5 Do .New Round .Set Round=$P(Par2,"#",2),Par2=$P(Par2,"#") .Set R=Par2/$$MUNT(Munt,,,NoSa,ToMunt) Set:Round R=$J(R,0,$$MUNT(ToMunt,4)) Else Do .Set R="" .For Par1=1:1:4 Set R=R_D_$$MUNT(Munt,Par1,Par2) .Set $E(R)="" Quit R MUNTPAR(Munt,Type,NoSa,ToMunt) ; Type 1 = Aankoop ; Type 2 = Verkoop ; Type 3 = Financieel ; Type 11 = Aankoop (invers) ; Type 12 = Verkoop (invers) ; Type 13 = Financieel (invers) If $G(Munt)="?" Do HELPFUNC($ZN,"MUNTPAR") Quit "" New MuntPar,FaMunt Set FaMunt=$$FADEF() Set Munt=$G(Munt) Set:Munt="" Munt=FaMunt Set Munt=$$MUNTKODE(Munt) Set Type=$G(Type,2),NoSa=$G(NoSa) Set MuntPar=$P(@("^"_Q_"BA(11,Munt)"),D,3,6) If $G(NoSa)="S",$D(@("^"_Q_"BA(NoSa,11,Munt)")) Set MuntPar=$P(@("^"_Q_"BA(NoSa,11,Munt)"),D,3,6) If $G(NoSa)="E",$D(@("^"_Q_"BA(NoSa,11,Munt)")) Set MuntPar=$P(@("^"_Q_"BA(NoSa,11,Munt)"),D,3,6) If Type\10 Set MuntPar=$P(MuntPar,D,Type#10+1)/$P(MuntPar,D) Else Set MuntPar=1/($P(MuntPar,D,Type+1)/$P(MuntPar,D)) If $D(ToMunt) Do .Set:ToMunt="" ToMunt=FaMunt .Set ToMunt=$$MUNTKODE(ToMunt) .Set MuntPar=MuntPar/$$MUNTPAR(ToMunt,Type,NoSa) Quit MuntPar MUNTKODE(Munt,OldNew) ; OldNew = 0 Oude ; = 1 Nieuwe New R,Versie6 Set Munt=$G(Munt),OldNew=$G(OldNew),Versie6=$$ISVERS6 Set:Munt="" Munt=$$FADEF() If OldNew'=0,OldNew'=1 Set OldNew="" Set:OldNew Versie6=1 If OldNew=0 Do .Set:Munt="BEF" Munt="BF" .Set:Munt="DEM" Munt="DM" .Set:Munt="FRF" Munt="FF" .Set:Munt="CHF" Munt="FS" .Set:Munt="NLG" Munt="HFL" .Set:Munt="ITL" Munt="LIT" .Set:Munt="ATS" Munt="OSH" .Set:Munt="ESP" Munt="PTS" Else If Versie6 Do .Set:Munt="BF" Munt="BEF" .Set:Munt="DM" Munt="DEM" .Set:Munt="FF" Munt="FRF" .Set:Munt="FS" Munt="CHF" .Set:Munt="HFL" Munt="NLG" .Set:Munt="LIT" Munt="ITL" .Set:Munt="OSH" Munt="ATS" .Set:Munt="PTS" Munt="ESP" Else Do .If Munt="BEF",$D(^KBA(11,"BF")) Set Munt="BF" .Else If Munt="BF",$D(^KBA(11,"BEF")) Set Munt="BEF" .Else If Munt="DEM",$D(^KBA(11,"DM")) Set Munt="DM" .Else If Munt="DM",$D(^KBA(11,"DEM")) Set Munt="DEM" .Else If Munt="FRF",$D(^KBA(11,"FF")) Set Munt="FF" .Else If Munt="FF",$D(^KBA(11,"FRF")) Set Munt="FRF" .Else If Munt="CHF",$D(^KBA(11,"FS")) Set Munt="FS" .Else If Munt="FS",$D(^KBA(11,"CHF")) Set Munt="CHF" .Else If Munt="NLG",$D(^KBA(11,"HFL")) Set Munt="HFL" .Else If Munt="HFL",$D(^KBA(11,"NLG")) Set Munt="NLG" .Else If Munt="ITL",$D(^KBA(11,"LIT")) Set Munt="LIT" .Else If Munt="LIT",$D(^KBA(11,"ITL")) Set Munt="ITL" .Else If Munt="ATS",$D(^KBA(11,"OSH")) Set Munt="OSH" .Else If Munt="OSH",$D(^KBA(11,"ATS")) Set Munt="ATS" .Else If Munt="EST",$D(^KBA(11,"PTS")) Set Munt="PTS" .Else If Munt="PTS",$D(^KBA(11,"EST")) Set Munt="EST" Quit Munt LAND(Key,Par1,Par2,Par3,Par4) ; Par1 1 = Afkorting ; Par2 1 = eventueel vertaling naar nieuwe kode ; Par2 2 = eventueel vertaling naar oude kode ; 2 = Omschrijving ; Par2 = Taalkode (N,F,D,E - default N) ; Par3 = Omzetten naar upcase (dafault 1 = ja) ; I = Invers (Key is de landkode oude of nieuwe) ; L = Leverancier ; Key = LEVNr ; Par2 1 = Afkorting ; Par3 1 = eventueel vertaling naar nieuwe kode ; Par3 2 = eventueel vertaling naar oude kode ; Par2 2 = Omschrijving ; Par3 = Taalkode (N,F,D,E - default leverancier) ; Par4 = Omzetten naar upcase (dafault 1 = ja) ; K = Klant ; Key = KLNr ; Par2 1 = Afkorting ; Par3 1 = eventueel vertaling naar nieuwe kode ; Par3 2 = eventueel vertaling naar oude kode ; Par2 2 = Omschrijving ; Par3 = Taalkode (N,F,D,E - default klant) ; Par4 = Omzetten naar upcase (dafault 1 = ja) If $G(Key)="?" Do HELPFUNC($ZN,"LAND") Quit "" New R,FaLand,Invers Set Key=$G(Key),Par1=$G(Par1,1),Par2=$G(Par2),Par3=$G(Par3),Par4=$G(Par4) Set:Key="" FaLand=$$FADEF(3),Key=$$LAND(FaLand,"I") Set Key=$$UPCASE(Key) If 'Key,Par1'="I",'Par2 Set Key=$$LAND(Key,"I") Else Set R=Key If Par1=1 Do .Set R="" Set:$L(Key) R=$G(^ISO(0,"ISO.LAND",Key,0)),R=$P(R,D) Set:R="" R=Key .Set:Par2=1 R=$S(R="B":"BE",R="L":"LU",R="D":"DE",R="F":"FR",R="I":"IT",R="A":"AT",R="S":"SE",R="M":"MA",R="EGY":"EG",1:R) .Set:Par2=2 R=$S(R="BE":"B",R="LU":"L",R="DE":"D",R="FR":"F",R="IT":"I",R="AT":"A",R="SE":"S",R="MA":"M",R="EG":"EGY",1:R) Else If Par1=2 Do .Set:Par2="" Par2="N" Set:Par3="" Par3=1 .Set R="" Set:$L(Key) R=$G(^ISO(0,"ISO.LAND",Key,0)) .Set R=$P(R,D,$F("NFDE",Par2)-2*10+2) .Set:Par3 R=$$UPCASE(R) Else If Par1="I" Do .Set R="" .For Set R=$O(^ISO(0,"ISO.LAND",R)) Quit:R="" If $P(^ISO(0,"ISO.LAND",R,0),D)=Key Quit .Quit:$L(R) .Set R=$$LAND(Key,1,1) .If R=Key Set R="" .Else Set R=$$LAND(R,"I") Else If Par1="K" Do .Set:Par2="" Par2=1 .If Par2=2,Par3="" Set Par3=$P(^KKL(^KK1(Key),0),D,9) Set:Par3="" Par3="N" .Set Key=$P(^KKL(^KK1(Key),0),D,8),Invers='Key Set:Invers Key=$$LAND(Key,"I") .Set R=$$LAND(Key,Par2,Par3,Par4) .If Invers,Par2=1,Par3'=1 Set R=$$LAND(R,1,2) Else If Par1="L" Do .Set:Par2="" Par2=1 .If Par2=2,Par3="" Set Par3=$P(^KLE(^KL1(Key),0),D,9) Set:Par3="" Par3="N" .Set Key=$P(^KLE(^KL1(Key),0),D,8),Invers='Key Set:Invers Key=$$LAND(Key,"I") .Set R=$$LAND(Key,Par2,Par3,Par4) .If Invers,Par2=1,Par3'=1 Set R=$$LAND(R,1,2) Quit R BTWPERC(Kode) Quit $S(Kode="":"",'$D(@("^"_Q_"BA(18,Kode)")):"",1:+@("^"_Q_"BA(18,Kode)")) ; Omzetting van $I naar het normale $I voor LAT-poorten die voor een tweede keer ingelogd zijn. NORMDEV(%I) New CFG,Vol,I,ZD Set CFG=$$CONFIG^cQ9(),Vol="MGR" If %I?1.N,%I>0,%I<11 Do .Set ZD=$ZDEV(%I) .Quit:ZD=%I .Set I="" .For Set I=$O(^[Vol]SYS(CFG,"DDB",I)) Quit:I="" Do ..Set:$P(^(I),",",2)=ZD %I=I Quit %I ; Opvragen van de USER record in %LOG("DDB") USER(%I) New User Set %I=$$NORMDEV(%I) Set (%I,User)=$$IO^cQ5(%I) Set User=$$USERNAME^vhUSER($$DEVUSER^vhUSER(%I)) If User="",$D(^cLOG(boot,"DDB",$$CONFIG^cQ9(),%I)) Set User=^(%I) Quit User ; FLATASCI(R) New FVAN,FNAAR Do VANNAAR^vhTERMINA("") Quit $TR(R,FVAN,FNAAR) ; HEX(From) New I,To Set To="" For I=1:1:$L(From,",") Set To=To_$C($ZH($P(From,",",I))) Quit To ; GETWW(Type,MinLen,MaxLen) ;Type="AaNS" New String,WachtW,Rnd Set String="" Set:Type["N" String=String_"1234567890" Set:Type["A" String=String_"ABCDEFGHIJKLMNOPQRSTUVWXYZ" Set:Type["a" String=String_"abcdefghijklmnopqrstuvwxyz" Set:Type["S" String=String_"@&$àèé#""!?+=[]()<:/;>" For I=1:1:$P($H,",",1) Set Rnd=$R($P($H,",",1)) For I=1:1:$P($H,",",2) Set Rnd=$R($P($H,",",1)) Set WachtW="" For Do Quit:$L(WachtW)'50 .Set Rnd=$R($L(String))+1 .Set WachtW=WachtW_$E(String,Rnd) Quit WachtW ; ALFAKEY(NKey,Type) ;Type="AaNS" Opgegeven volgorde is belangrijk ; Deze routine is niet geschikt om bv. HEXADECIMAAL omzettingen te doen New I,String,AKey,Val Set String="" For I=1:1 Quit:$E(Type,I)="" Do .Set:$E(Type,I)="N" String=String_"1234567890" .Set:$E(Type,I)="A" String=String_"ABCDEFGHIJKLMNOPQRSTUVWXYZ" .Set:$E(Type,I)="a" String=String_"abcdefghijklmnopqrstuvwxyz" .Set:$E(Type,I)="S" String=String_"@&$àèé#""!?+=[]()<:/;>" Set AKey="" For Quit:NKey=0 Do .Set Val=NKey#$L(String) .Set:Val=0 Val=$L(String) .Set NKey=NKey-Val\$L(String) .Set AKey=$E(String,Val)_AKey Quit AKey ; FADEF(Piece,IntForm) ;Piece 1 = Munt boekhouding ; 2 = Taalkode firma ; 3 = Landkode firma ; 4 = Kenletters BTW nummers Belgie ; 5 = Telefoonzone firma ; 6 = Boekjaar overgang Euro ; 7 = Muntkode Euro ; 8 = Decimalen Euro ; 9 = Munt voor de overgang naar Euro ; 10 = Decimalen van de munt voor de overgang naar Euro ; 11 = Conversiedatum ; IntForm = 1 intern formaat ; 12 = BEF n.v.t. If $G(Piece)="?" Do HELPFUNC($ZN,"FADEF") Quit "" New R Set Piece=$G(Piece,1),IntForm=$G(IntForm),R=^KBA(39) Do:IntForm .If Piece=11,$L($P(R,D,Piece)) Set $P(R,D,Piece)=$$INTDATE^vhDTyp($P(R,D,Piece)) Quit $P(R,D,Piece) ; CALCKORT(Bedrag,Korting1,Korting2) Quit Bedrag*(100-$G(Korting1)/100)*(100-$G(Korting2)/100) ; TRIMNAAM(Naam) New NaamOut,tmpNaam Set tmpNaam=$$UPCASE(Naam) Quit:($$TRMNM2("VAN DE ","VD ")) NaamOut Quit:($$TRMNM2("VANDE ","VD ")) NaamOut Quit:($$TRMNM2("VAN DER ","VD ")) NaamOut Quit:($$TRMNM2("VANDER ","VD ")) NaamOut Quit:($$TRMNM2("VAN DEN ","VD ")) NaamOut Quit:($$TRMNM2("VANDEN ","VD ")) NaamOut Quit:($$TRMNM2("VAN HET ","VH ")) NaamOut Quit:($$TRMNM2("VANHET ","VH ")) NaamOut Quit:($$TRMNM2("OP DE ","OD ")) NaamOut Quit:($$TRMNM2("OPDE ","OD ")) NaamOut Quit:($$TRMNM2("OP DEN ","OD ")) NaamOut Quit:($$TRMNM2("OPDEN ","OD ")) NaamOut Quit:($$TRMNM2("VAN ","V ")) NaamOut Quit:($$TRMNM2("DE ","D ")) NaamOut Quit:($$TRMNM2("DER ","D ")) NaamOut Quit:($$TRMNM2("DEN ","D ")) NaamOut Quit:($$TRMNM2("B.V. ","")) NaamOut Quit Naam TRMNM2(Lang,Kort) Quit:(Lang="") 0 Set Lang=$$UPCASE(Lang) If $E(tmpNaam,1,$L(Lang))=Lang Do Quit 1 . Set NaamOut=Kort_$E(Naam,$L(Lang)+1,999) Quit 0 HELPFUNC(Routine,Label) New I,R,V Xecute "Set R=$T("_Label_"^"_Routine_")" Do:$L(R) .Write !,R .Set V=$L($P(R,"(")) .For I=1:1 Xecute "Set R=$T("_Label_"+"_I_"^"_Routine_")" Set R=$P(R," ",2,999) Quit:$E(R)'=";" Write !?V,$P(R,";",2,99) Quit ; ISVERS6() Quit ''$D(^DMS) ; ConvertToHTML(str) ;Quit $ZCVT(str,"O","HTML") ; Previous method New MyStr,sFind,sRepl,I,J,strLen ; Replace '&' Set MyStr=$$REPLACE(str,"&","&") ; Replace all characters with ASCII-value 128 or above by &#xxx; (xxx represents the ASCII-value) Set strLen=$L(MyStr) Set I=0 For Quit:($INCREMENT(I)>strLen) Do:($ASCII($E(MyStr,I))>127) . Set $E(MyStr,I,I)="&#"_$ASCII($E(MyStr,I))_";" . Set strLen=$L(MyStr) ; Replace some other characters Set sFind="'""<>" Set sRepl="'/"/</>" For I=1:1:$L(sFind) Do . For Quit:(MyStr'[$E(sFind,I)) Do .. Set J=$F(MyStr,$E(sFind,I))-1 .. Set $E(MyStr,J,J)=$P(sRepl,"/",I) Set MyStr=$$REPLACE(MyStr,$C(13,10),"
") Quit MyStr /* ConvertToHTMLprev(str) ;Quit $ZCVT(str,"O","HTML") ; Previous method New MyStr,sFind,sRepl,I,J Set MyStr=$$REPLACE(str,"&","&") Set sFind="'""<>àâäçèéêëÈÉËôöü€£§°±ØÅ" ;Set sRepl="′/&qout;/</>/à/â/ä/ç/è/é/ê/ë/È/É/Ë/ô/ö/ü/€/£/§/°/±/Ø/Å" Set sRepl="'/"/</>/à/â/ä/ç/è/é/ê/ë/È/É/Ë/ô/ö/ü/∈/£/§/°/±/Ø/Å" For I=1:1:$L(sFind) Do . For Quit:(MyStr'[$E(sFind,I)) Do .. Set J=$F(MyStr,$E(sFind,I))-1 .. Set $E(MyStr,J,J)=$P(sRepl,"/",I) Quit MyStr */