PRKLEUR ;Beheer kleurkodes [ 01/13/2003  1:37 PM ]
 ;
VERWERK 
 New %TC
 Do
 .New %SC
 .Do DISPLAY^vhScherm("PRKLEUR")
 Do ADD^vhLock("^KCOL")
 If '%TC Do LDISP^vhLock("^KCOL","Kleurenkodes") Quit
 Do FETCH,INIT^vhLIST("PRKLEUR","KLEUR",.KLEUR),WRITE^vhLIST(.KLEUR)
 For  Do COMMAND Quit:Input="CANC"  If Input="SAVE" Do  Quit:$L(Input)
 .Set Input=$$^vhTXTPOP("FILE",$S($G(%SC):"SAVE",1:"EXIT"))
 .If Input="J",$G(%SC) Do SAVE
 Do REMOVE^vhLock("^KCOL")
 Quit
 ;
COMMAND Set Input=$$SCROLL^vhLIST(.KLEUR)
 If Input="COM" Set Input="" Do CALL^vhMenu("PRKLEUR")
 If Input="SPEC" Set Input="" Do CALLSPEC^vhMenu(KLEUR("POS")+KLEUR("SELECT")_";80","PRKLEURS","E")
 Quit:Input=""
 Do EXEC^vhMenu("PRKLEUR",.Input)
 Quit
 ;
LNIEUW  
 New sFL,Kode New:$G(%SC) %SC
 Do STORE^vhTERMINA(),NIEUW^vhScherm("PRKLEURD"),REFRESH^vhTERMINA()
 If %SC Do NIEUW^vhLISTE(.KLEUR,sFL(1)) Set Kode=$P(sFL(1),D),Kleur("I",Kode)=""
 Quit
 ;
LWIJZIG(Ref) 
 New sFL,Kode
 Set sFL(1)=Kleur("D",Ref),Kode=$P(sFL(1),D)
 Do STORE^vhTERMINA(),EDIT^vhScherm("PRKLEURD"),REFRESH^vhTERMINA()
 Set Kleur("D",Ref)=sFL(1)
 If Kode'=$P(sFL(1),D) Kill Kleur("I",Kode) Set Kode=$P(sFL(1),D),Kleur("I",Kode)=""
 Do LINE^vhLIST(.KLEUR,Ref)
 Quit
 ;
LDELETE(Ref) 
 New R,Kode
 Set R=Kleur("D",Ref),Kode=$P(R,D)
 Do DELETE^vhLISTE(.KLEUR)
 Kill Kleur("I",Kode)
 Set %SC=1
 Quit
 ;
LEXTERN(Kode,Vertalingen...) 
 New sFL,%SC,%TC,Count,Kleur,Extern
 Do ADD^vhLock("^KCOL")
 If '%TC Do LDISP^vhLock("^KCOL","Kleurenkodes") Quit
 Set Extern=1,sFL(1)=$G(Kode)_"\"_##class(TECH.MultiDimUtils).OneDimValuesToString(.Vertalingen,"\")
  Do FETCH,STORE^vhTERMINA(),NIEUW^vhScherm("PRKLEURD"),REFRESH^vhTERMINA()
 If %SC Set Count=$O(Kleur("D",""),-1)+1,Kleur("D",Count)=sFL(1) Do SAVE
 Do REMOVE^vhLock("^KCOL")
 Quit
 ;
FETCH 
 New R,Kode,Count,FieldIndex
 Set Kode="",Count=0
 For  Set Kode=$O(^KCOL(Kode)) Quit:Kode=""  Do
 .Set R=$TR(Kode," ","")_D
 .Set FieldIndex=1
 .For  Set FieldIndex=$order(^SD("D","PRKLEURD","F",FieldIndex)) Quit:FieldIndex=""  set R = R _ $G(^KCOL(Kode,$classmethod("DOM.enu.Taal",$piece(^SD("D","PRKLEURD","F",FieldIndex),"`",3))))_"\"
 .Set Count=Count+1,Kleur("D",Count)=R,Kleur("I",Kode)=""
 Quit
 ;
SAVE 
 New R,Kode,Count,FieldIndex
 Set Kode=""
 For  Set Kode=$O(^KCOL(Kode)) Quit:Kode=""  Kill ^KCOL(Kode)
 For Count=1:1 Quit:'$D(Kleur("D",Count))  Do
 .Set R=Kleur("D",Count),Kode=$J($P(R,D),4)_" "
 .set FieldIndex=1
 .For  Set FieldIndex=$order(^SD("D","PRKLEURD","F",FieldIndex)) Quit:FieldIndex=""  set ^KCOL(Kode,$classmethod("DOM.enu.Taal",$piece(^SD("D","PRKLEURD","F",FieldIndex),"`",3)))=$piece(R,"\",FieldIndex) 
 Quit
 ;
PRINT 
 New DL,LD
 Do LDCONV
 Do STORE^vhTERMINA(),^OUTPUT("P","","S"),REFRESH^vhTERMINA()
 Quit
 ;
LDCONV 
 Set DL(1)="LD"
 Set LD(1)=KLEUR("F")
 Set LD(2)=$TR(KLEUR("FMT","S",1),"`§",";\")
 Set LD(5)=80
 Set LD(8)=$P(^RES($P(KLEUR("ID"),"`"),"LD",$P(KLEUR("ID"),"`",2),"HO",1),"`",3),LD(8)=LD(8)_$J("",80-$L(LD(8)))
 Set LD(11)="Kleurenkodes"
 Quit
 ;
OMSCHR(PRNr,Taal) 
 New I,KortTxt,Kode,Kleur New:PRNr?4.7N B
 Set Taal=$G(Taal,"N")
 If PRNr For I=0:1 Quit:'$D(^KPR(PRNr,I))  Set B(I+1)=^KPR(PRNr,I)
 Set KortTxt=$P(B(1),"\"),Kode=$E(KortTxt,22,25)
 Set:$L(Kode) Kleur=$G(^KCOL(Kode_" ",Taal))
 Quit $G(Kleur)
 ;