PVB ;Importen van BURBIDGE produkten [ 10/30/2001  5:00 PM ]
 ;
 Quit
 ; Exporting vertaal elementen
EXPTAAL Set Dev=0
 Set Dev=$$OPEN^vhDEV($$DIRUSER^vhDEV,"BURBVERT.TXT","W")
 Use Dev
 Write $TR("Groep;Kode;Sort;LevTrm;KatalN1;KatalN2;KatalF1;KatalF2;ProdN1;ProdN2;ProdF1;ProdF2;ProdLev1;ProdLev2",";",$C(9)),!
 Set Reeks=""
 For  Set Reeks=$O(^BURBID("EXPORT",Reeks)) Quit:Reeks=""  Do
 .Set Kode=""
 .For  Set Kode=$O(^BURBID("EXPORT",Reeks,Kode)) Quit:Kode=""  Do
 ..Write Reeks,*9,$S($E(Kode)="0":"_"_$E(Kode,2,99),1:Kode),*9,$TR(^BURBID("EXPORT",Reeks,Kode),"\",$C(9)),!
 Close:Dev Dev
 Quit
 
 ; Importing vertaal elementen
IMPTAAL Set Dev=0
 Kill ^BURBID("EXPORT") ;Verwijder
 Do READ^vhDEV(,"*.TXT","D`CBTAAL^"_$ZN,"TD")
 Quit
CBTAAL(Rec) ; Callback van READ
 Set Reeks=$P(Rec,D)
 Set Kode=$P(Rec,D,2)
 Set:$E(Kode)="_" $E(Kode)="0"
 Set ^BURBID("EXPORT",Reeks,Kode)=$P(Rec,D,3,99)
 Quit
 
IMPORT Set Dev=0
 Kill ^BURBID("D") ;Verwijder
 Set VolgNr=0
 Do READ^vhDEV(,"*.TXT","D`CBTAAL^"_$ZN,"TD")
 Quit
CBIMPORT(Rec) ; Callback van READ
 Set VolgNr=VolgNr+1
 Set ^BURBID("D",VolgNr)=Rec
 Quit
 
KREATIE Goto KREA  ; Oproepen na IMPKREA
 ; Vergelijken oude produkten en de prijzen
IMPCOMP Do IMPORT("C") Quit 
COMPARE Goto COMP0 ; Oproepen na IMPCOMP
 
DELETE Goto DELETE2 ; Verschillend in prijs
 
TRANS Kill ^BURBID("C"),^BURBID("L")
 Set Tab=$C(9)
 Set D="\",U=";"
 Set Cnt=0
 For RecNr=1:1:$O(^BURBID("D",""),-1) Do
 .Set Rec=$TR(^BURBID("D",RecNr),Tab,D)
 .If $$UPTRIMAN^vhRtn1($P(Rec,D))="" Do HOOFD Quit
 .Do PRODS
 Quit
HOOFD Kill Fam 
 Set FamL=$TR(Rec,"""","")
 Quit
PRODS Set Rec=$TR(Rec,"""","")
 Set Oms=$P(Rec,D,1,3)
 Set:$E($P(Oms,D))=" " $P(Oms,D)=$E($P(Oms,D),2,99) ; Spatie voor oms
 Set $P(Oms,D,3)=$TR($P(Oms,D,3)," ","")
 Set KlasAllS=$P(FamL,D,3)
 ; Aflopen van de verschillende families van een bepaald artikel
 For I=4:2:$L(Rec,D) Do
 .Set Prod=$P(Rec,D,I)
 .Set Optie=$P(Rec,D,I+1)
 .Set NS=0 ; NietStock
 .If $P(Optie,U)="*" Set NS=4
 .If $P(Optie,U)="#" Set NS=4 
 .Set Kort=42.50,Winst=44
 .If $P(Optie,U,2) Set Kort=$P(Optie,U,2)
 .Quit:Prod=""
 .Quit:Prod="NA"
 .Quit:'$TR($P(Prod,U,$L(Prod,U)),", ",".")  ; Spaties weg en ',' -> '.'
 .Set Fam=$P(FamL,D,I)
 .Set KlasS=$P(FamL,D,I+1)
 .Set KlasS=$S($L(KlasS):KlasS,$L(KlasAllS):KlasAllS,1:$E(Fam,1,3))
 .If $P(Prod,U,3,99)'="" Set Fam=$P(Prod,U,1,$L(Prod,U)-1),Prod=$P(Prod,U,$L(Prod,U)-1,99)
 .;Aflopen van de verschillende kleuren in een familie
 .For J=1:1:$L(Fam,U) Do
 ..Quit:$P(Fam,U,J)=""
 ..Set Cnt=Cnt+1
 ..Set Prod=$TR(Prod,", ",".") ; Spaties weg en ',' -> '.'
 ..Set:$L(Prod,U)=1 Prod=U_Prod
 ..Set RecP=$P(Fam,U,J)_D_Oms_D_$P(Prod,U,1)_D_$TR($P(Prod,U,2)," ","")_D_NS_D_Kort_D_Winst_D_KlasS
 ..Set ^BURBID("C",Cnt)=RecP
 ..Set LevRef=$P(RecP,D,1)_"-"_$S($P(RecP,D,4)?1N:"0",1:"")_$P(RecP,D,4)
 ..If $D(^BURBID("C",LevRef)) Write "DUBBEL ",Cnt," & "_^(LevRef)_" = "_LevRef
 ..Set ^BURBID("L",LevRef)=Cnt
 Quit
 
 ; Kreatie van nieuwe Burbidge produkten
 ; Oproepen na IMPORT
KREA 
 d ^cA604 S Tab=$C(9),D="\",Tab=D
 S DupPrd=8358
 u 0:(::::4096+262144)
 ; Opzoeken van de klassificatie
 ; De subgroepen beginnen met de nummers van prod families
 s SG=""
 f  s SG=$O(^KPSG1(SG)) Q:SG=""  I $E(SG,$L(SG)-2,$L(SG))="BU " s Klas($E(SG,12,14))=$P(^KPSG1(SG),D,6)
 w !,"Kreatie Produkten"
 Set Key=""
 For  Set Key=$O(^BURBID("ADD",Key)) Quit:Key=""  D
 .Set Cnt=^BURBID("ADD",Key)
 .Set Rec=^BURBID("C",Cnt)
 .Do FETCH,GROEP,EXTRACT,SAVE:Prijs
 Quit
 
COMP0 d ^cA604 S Tab=$C(9),D="\",Tab=D
 w !,"Conversie prijslijst"
 K ^BURBID("P"),^BURBID("ADD"),^BURBID("ADD1"),^BURBID("ADD2")
 K ^BURBID("DEL"),^BURBID("DEL1"),^BURBID("DEL2"),^BURBID("MOD")
 Set LEVNr=5810
 s SG=""
 f  s SG=$O(^KPSG1(SG)) Q:SG=""  I $E(SG,$L(SG)-2,$L(SG))="BU " s Klas($E(SG,12,14))=$P(^KPSG1(SG),D,6)
 ; Opzoeken prijsverschillen
 F Cnt=1:1:$O(^BURBID("C",""),-1) D
 .S K=^BURBID("C",Cnt)
 .Quit:K=""
 .Set LevRef=$TR($P(K,Tab,4)," ","")
 .Set LevRef=$P(K,Tab)_"-"_$S(LevRef?1N:"0",1:"")_LevRef
 .Set PrijsB=+$P(K,Tab,6)
 .Set Kort=$P(K,Tab,8)
 .Set Winst=$P(K,Tab,9)
 .Set NS=$P(K,Tab,7)
 .Set KlasS=$P(K,Tab,10)
 .B:$TR($P(K,Tab,4)," ","")="088"
 .Set LevR=""
 .Set:$D(^KPL(LEVNr_" ","  ",LevRef_" ")) LevR=LevRef_" "
 .Goto WFBF:$E(LevRef,$L(LevRef)-2,$L(LevRef))="-WF"!($E(LevRef,$L(LevRef)-2,$L(LevRef))="-BF")!($E(LevRef,$L(LevRef)-2,$L(LevRef))="-PR")
 .If $E(LevRef,$L(LevRef)-2,$L(LevRef))="EXC" Do
 ..If LevR="",$O(^KPL(LEVNr_" ","  ",LevRef_" "))=(LevRef_" ") Set LevR=$O(^KPL(LEVNr_" ","  ",LevRef_" "))
 .Else  Do
 ..If LevR="",$E($O(^KPL(LEVNr_" ","  ",LevRef_" ")),1,$L(LevRef))=LevRef Set LevR=$O(^KPL(LEVNr_" ","  ",LevRef_" "))
 .If LevR="" Do
 ..Set (Key,LevB)=$P(LevRef,"-",2)
 ..For  Set Key=$O(^KPL(LEVNr_" ","  ",Key)) Quit:Key=""  Quit:$E(Key,1,$L(LevB))'=LevB  If $$UPTRIMAN^vhRtn1(Key)=$$UPTRIMAN^vhRtn1(LevRef) Set LevR=Key Quit
WFBF .If LevR="" Quit 
 .Set CKT=""
 .Set PCnt=0
 .For  Set CKT=$O(^KPL(LEVNr_" ","  ",LevR,CKT)) Quit:CKT=""  Set PCnt=PCnt+1,PRNr=^(CKT),^BURBID("P",PRNr)=K Do COMPCOMP
 ; Nakijken of er produkten moeten bijgevoegd worden
 F Cnt=1:1:$O(^BURBID("C",""),-1) D
 .S K=^BURBID("C",Cnt)
 .Quit:K=""
 .Set LevRef=$TR($P(K,Tab,4)," ","")
 .Set LevRef=$P(K,Tab)_"-"_$S(LevRef?1N:"0",1:"")_LevRef
 .Set PrijsB=+$P(K,Tab,6)
 .Set Kort=$P(K,Tab,8)
 .Set Winst=$P(K,Tab,9)
 .Set NS=$P(K,Tab,7)
 .Set LevR=""
 .Set:$D(^KPL(LEVNr_" ","  ",LevRef_" ")) LevR=LevRef_" "
 .Goto WFBF2:$E(LevRef,$L(LevRef)-2,$L(LevRef))="-WF"!($E(LevRef,$L(LevRef)-2,$L(LevRef))="-BF")!($E(LevRef,$L(LevRef)-2,$L(LevRef))="-PR")
 .If $E(LevRef,$L(LevRef)-2,$L(LevRef))="EXC" Do
 ..If LevR="",$O(^KPL(LEVNr_" ","  ",LevRef_" "))=(LevRef_" ") Set LevR=$O(^KPL(LEVNr_" ","  ",LevRef_" "))
 .Else  Do
 ..If LevR="",$E($O(^KPL(LEVNr_" ","  ",LevRef_" ")),1,$L(LevRef))=LevRef Set LevR=$O(^KPL(LEVNr_" ","  ",LevRef_" "))
 .If LevR="" Do
 ..Set LevB=$P(LevRef,"-",2)_"-",Key=LevB_" "
 ..For  Set Key=$O(^KPL(LEVNr_" ","  ",Key)) Quit:Key=""  Quit:$E(Key,1,$L(LevB))'=LevB  If $$UPTRIMAN^vhRtn1(Key)=$$UPTRIMAN^vhRtn1(LevRef) Set LevR=Key Quit
 .If 
WFBF2 .If LevR="" Do COMPADD Quit 
 ;Nakijken of er Produkten moeten verwijderd worden
 Set PRNr=1 
 For  Set PRNr=$O(^KPR(PRNr)) Quit:PRNr=""  Do
 .Quit:'$D(^KPR(PRNr,"J"_LEVNr))
 .Quit:$D(^BURBID("P",PRNr))
 .Quit:$P(^KPR(PRNr,$O(^KPR(PRNr,"I"))),D)'["DE"  ; Alleen deuren, geen knoppen of grepen
 .Do COMPDEL
 Quit
 
COMPDEL Set Res=""
 Set Res=$$CHECKDEL(PRNr)
 ;Quit:Res=""
 Write !,$P(^KPR(PRNr,"J"_LEVNr),D,3),*9,PRNr,*9,"DEL:",Res
 ;Set $P(^KPR(PRNr,1),D,25)=1 ; Non aktief
 Set Delete=$G(Delete)+1
 Set LevRef=$P(^KPR(PRNr,"J"_LEVNr),D,3)
 Set:$$UPTRIMAN^vhRtn1(LevRef)="" LevRef=$P(^KPR(PRNr,0),D)
 Set ^BURBID("DEL",PRNr)=Res_D_LevRef
 Set ^BURBID("DEL1",LevRef)=PRNr_D_Res
 Set ^BURBID("DEL2",$$TRANSREF(LevRef))=PRNr_D_Res
 Quit
 
TRANSREF(LevRef) 
 Set LevRef=$P(LevRef,"-",3,99)_"-"_$P(LevRef,"-",1,2)
 Quit LevRef
 
COMPADD Write !,LevRef,*9,*9,"ADD",*9,$J(PrijsB,10,2),*9,$P(K,Tab,2)
 Set Add=$G(Add)+1
 Set ^BURBID("ADD",LevRef)=Cnt
 Set ^BURBID("ADD1",$$TRANSREF(LevRef))=Cnt
 Quit
COMPCOMP 
 Set ^BURBID("MOD",LevRef)=Cnt
 s Comp=$G(Comp)+1
 Set PrijsR=^KPR(PRNr,"J"_LEVNr)
 Set PrijsVH=+$P(PrijsR,D,19)
 Set $P(^KPR(PRNr,2),D,3)=+$J(PrijsB,0,2) ; Nieuwe schaduw prijs
 Set $P(^KPR(PRNr,1),D,25)="" ; Aktief
 Set LR=$E($$TRIMN^vhRtn1(LevRef),1,5)
 Set $P(^KPR(PRNr,2),D,4)=Kort
 Set $P(^KPR(PRNr,2),D,6)=Winst
 Set $P(^KPR(PRNr,"J"_LEVNr),D,7)=$S(NS:NS,1:2)
 Set KKey=Klas(KlasS)
 Set IKey=$O(^KPR(PRNr,"I")) Set:$E(IKey)'="I" ^KPR(PRNr,"I")="",IKey="I1"
 If $P($G(^KPR(PRNr,IKey)),D,4)'=KKey Do  ; Foutieve klassificatie
 .Write !,"KLAS ",LevRef
 .S KHS=$$GETSORT^KLASS(KKey,1)
 .S KGS=$$GETSORT^KLASS(KKey,2)
 .S KSS=$$GETSORT^KLASS(KKey,3)
 .Do DELIND^PRODUKT2(PRNr)
 .S ^KPR(PRNr,IKey)=KHS_D_KGS_D_KSS_D_KKey
 .Do BLDIND^PRODUKT2(PRNr)
 ;Quit:PrijsVH=PrijsR
 Write !,LevRef,"  ",$P(^KPR(PRNr,"J"_LEVNr),D,3),"  ",$J(PrijsVH,10,2),"  ",$J(PrijsB,10,2)
 ;Write *9 Write:PrijsB $J(PrijsB-PrijsVH/PrijsVH*100,5,2)
 ;Write " " Write:PCnt>1 "*"_PCnt
 ;Write " ",$P(K,Tab,2)
 Quit
 
import(Node) ; Importeren van de gegevens in het BURBID bestand
 Set Dev=$$OPEN^vhDEV($$DIRUSER^vhDEV,$$ASKFILE^vhDEV("PRODUKT.TXT"),"R")
 Quit:'Dev
 Use Dev
 S Cnt=0
 Kill ^BURBID(Node)
 F  Use Dev Read K Quit:$ZC=-1  D
 .Set Cnt=Cnt+1,^BURBID(Node,Cnt)=K
 Quit
GROEP 
 Set Grp=$P(Rec,Tab,10)
 S KKey=Klas(Grp)
 S KHS=$$GETSORT^KLASS(KKey,1)
 S KGS=$$GETSORT^KLASS(KKey,2)
 S KSS=$$GETSORT^KLASS(KKey,3)
 Quit
FETCH New Key,PRNr
 s PRNr=DupPrd
 k A
 f I=0,1,2,3,4,5 s TT(I)=^KPR(PRNr,I)
 f I="I","J" s Key=$O(^KPR(PRNr,I)) I $E(Key)=I s TT(I)=^KPR(PRNr,Key)
 ; Leeg maken van bep. velden
 F I=3:1:7 S $P(TT(2),D,I)="" ; Schaduw leeg maken
 S $P(TT(0),D,14)=0 ; Voorraad
 S $P(TT(0),D,12)="" ; Beginstock
 S $P(TT(0),D,17)="" ; Toelevering
 S $P(TT(0),D,24)="" ; Limiet stockbeheer = ""
 S $P(TT(2),D,9)="" ; Reservatie
 
 Q   
SAVE    
 W !!,"New : ",$P(TT(0),D,1)
 ;zw TT
 ;Read K
 ;Quit:$L(K)
 ; Produktnummer en identnr
 S NewPRNr=$$NEXTID^PRODUKT()
 Set X=100000+NewPRNr
 Set Som=$E(X,2)*6+($E(X,3)*5)+($E(X,4)*4)+($E(X,5)*3)+($E(X,6)*2)#11
 Set Som=$S(Som=0:1,Som=1:0,1:11-Som)
 Set IdentNr="9."_$E(X,2,4)_"."_$E(X,5,6)_Som_".0"
 Set $P(TT(2),D,25)=IdentNr
 s PRNr=NewPRNr    
 f I=0,1,2,3,4,5 s ^KPR(PRNr,I)=TT(I)
 s ^KPR(PRNr,"I")="",^KPR(PRNr,"I1")=TT("I")
 d RECALC^PRODUKT2(PRNr,TT("J"))
 D BLDIND^PRODUKT2(PRNr)
 Do Gemaakt^PRODUKT2(PRNr)
 Quit
 
EXTRACT S OmschE=$P(Rec,Tab,2)
 S FAMNr=$P(Rec,Tab,1)
 S Kleur=$P(FAMNr,"-",2)
 S FAMNr=$P(FAMNr,"-")
 S AltFAM=$P(Rec,Tab,5)
 S AfmE=$P(Rec,Tab,3)
 S Nr=$P(Rec,Tab,4)
 S Kort=$P(Rec,Tab,8)
 S Winst=$P(Rec,Tab,9)
 S LevTrm=$S($P(Rec,Tab,7):$P(Rec,Tab,7),1:2)
 S Prijs=$TR($P(Rec,Tab,6),",",".") Quit:'Prijs
 Set KleurT=$P($G(^BURBID("T",Kleur),Kleur),D,1)
 ; *** Korttekst
 Set KortNr=Nr
 Set:$L(KortNr)=1 KortNr=$TR($J(Nr,2)," ",0)
 If $L(KortNr)>4 Do  ; Omvormen LANGE kode voor korttekst     
 .Set KortNr=$$UPTRIMAN^vhRtn1(KortNr)
 .Set:$L(KortNr)>4&($E(KortNr,$L(KortNr))="0") $E(KortNr,$L(KortNr))=""
 .Set:$L(KortNr)>4&($E(KortNr,$L(KortNr))="0") $E(KortNr,$L(KortNr))=""
 .Set:$E(KortNr,1,3)="COE" $E(KortNr,3)=""
 .Set:$E(KortNr,1,3)="FRT" $E(KortNr,3)=""
 S KortT="D"_FAMNr_$S($L(FAMNr)>3:"",1:".")_Kleur_$S($L(KortNr)>3:"",1:".")_KortNr
 If $L(KortT)>11 Write !,"*** Korttekst te lang >11 ",KortT
 If '$L($P($G(^BURBID("T",OmschE)),D,1)) Write !,"*** Korttekst onvolledig voor ",KortT
 S KortT=KortT_$J("",11-$L(KortT))_$P($G(^BURBID("T",OmschE)),D,1)
 S KortT=KortT_$J("",25-$L(KortT)-$L(KleurT))_KleurT
 If $L(KortT)>25 Write !,"*** Korttekst te lang >25",KortT
 I $$EXISTKT^PRODUKT2(KortT) Set Prijs="" Write !,"**** Bestaat reeds : ",KortT Quit
 S $P(TT(0),D,1)=KortT
 ; *** Nederandse omschrijving
 S LT1=$S($D(^BURBID("T",FAMNr)):$P(^(FAMNr),D,2),1:FAMNr)
 S LT2=$$REPLACE^vhRtn1($S('$L(AfmE):"",$D(^BURBID("T",AfmE)):$P(^(AfmE),D,2),1:AfmE)," x ","x")
 S:$L(LT1)+$L(LT2)<25&$L(LT2) LT1=LT1_", "_LT2,LT2=""
 S:$L(LT2) LT2=LT2_", " 
 S LT2=LT2_$P($G(^BURBID("T",OmschE)),D,2)
 If $L(LT1)>26 Write !,"*** Langtekst N te lang >26 ",KortT,"; ",LT1
 If $L(LT2)>44 Write !,"*** Langtekst N te lang >45 ",KortT,"; ",LT2
 S $P(TT(0),D,2)=LT1
 S $P(TT(0),D,11)=LT2
 ; *** Franse omschrijving
 S LT1=$S($D(^BURBID("T",FAMNr)):$P(^(FAMNr),D,3),1:FAMNr)
 S LT2=$$REPLACE^vhRtn1($S('$L(AfmE):"",$D(^BURBID("T",AfmE)):$P(^(AfmE),D,3),1:AfmE)," x ","x")
 S:$L(LT1)+$L(LT2)<25&$L(LT2) LT1=LT1_", "_LT2,LT2=""
 S:$L(LT2) LT2=LT2_", " 
 S LT2=LT2_$P($G(^BURBID("T",OmschE)),D,3)
 If $L(LT1)>26 Write !,"*** Langtekst F te lang >26 ",KortT,"; ",LT1
 If $L(LT2)>44 Write !,"*** Langtekst F te lang >45 ",KortT,"; ",LT2
 S $P(TT(1),D,22)=LT1
 S $P(TT(3),D,21)=LT2
 S $P(TT(1),D,20)=""
 ;S $P(TT(1),D,20)=$S(Nr=0:1,1:"") ; Monsterdeuren is Stock
 S $P(TT("J"),D,19)=Prijs
 S $P(TT("J"),D,7)=LevTrm
 S $P(TT("J"),D,24)=Winst
 S $P(TT("J"),D,9)=Kort
 ; Leveranciers ref
 Set:"("_FAMNr_")"=AltFAM AltFAM="" ; Bij gelijke Reeks en altref
 Set:"("_FAMNr_"-"_Kleur_")"=AltFAM AltFAM=""
 S Bestel=FAMNr_"-"_Kleur_"-"_$S($L(Nr)=1:$TR($J(Nr,2)," ",0),1:Nr)_$S($L(AltFAM):AltFAM,1:"")
 S $P(TT("J"),D,3)=Bestel
 S BestT1=$S($D(^BURBID("T",FAMNr)):$P(^(FAMNr),D,1)_" "_FAMNr,1:FAMNr)_", "_OmschE,BestT2=""
 I $L(BestT1_", "_AfmE)<45 s:$L(AfmE) BestT1=BestT1_", "_AfmE
 E  I $L(BestT1)>44 Do
 .For  Quit:$L(BestT1)<45&($L(BestT1," ")>1)  Set BestT2=$P(BestT1," ",$L(BestT1," "))_" "_BestT2,BestT1=$P(BestT1," ",1,$L(BestT1," ")-1)
 .S:$L(AfmE) BestT2=BestT2_", "_AfmE
 E  s BestT2=AfmE
 If $L(BestT1)>44 Write !,"*** BestelTxt 1 te lang >44 ",KortT,"; ",BestT1
 If $L(BestT2)>44 Write !,"*** BestelTxt 2 te lang >44 ",KortT,"; ",BestT2
 S $P(TT(4),D,1,2)=BestT1_D_BestT2
 Set $P(TT("I"),D,1)=KHS
 Set $P(TT("I"),D,2)=KGS
 Set $P(TT("I"),D,3)=KSS
 Set $P(TT("I"),D,4)=KKey
 Quit
 
 
TAAL Set Dev=$$OPEN^vhDEV($$DIRUSER^vhDEV,$$ASKFILE^vhDEV("VERTALING.TXT"),"R")
 Quit:'Dev
 Use Dev
 Set Tab=$C(9)
 S D="\"
 S Key=" "
 Kill ^BURBID("T")
 D VANNAAR^vhTERMINA("P")
 F  Use Dev R K Quit:$ZC=-1  Do
 .Use 0
 .S K=$TR(K,FNAAR,FVAN) ; Omgekeerde vertaling
 .S Key=$P(K,Tab,1)
 .S Rec=$TR($P(K,Tab,2,99),Tab,D)
 .Q:Key=""
 .S ^BURBID("T",Key)=Rec
 Close Dev
 Quit
exptaal Set Dev=$$OPEN^vhDEV($$DIRUSER^vhDEV,$$ASKFILE^vhDEV("VERTALING.TXT"),"W")
 Quit:'Dev
 Use Dev
 S D="\",Tab=$C(9)
 Set Key=""
 For  Set Key=$O(^BURBID("T",Key)) Quit:Key=""  Do
 .Set Rec=^(Key)
 .Write !,Key,Tab,$TR(Rec,D,Tab)
 Close Dev
 Quit
DELETE2 
 d ^cA604 S Tab=$C(9),D="\"
 Set PRNr=0
 Set K=""
 W !,"Produkten verwijderen",!,"V[]=Verwijderen,  []=Niet verwijderen,  -[]=Stoppen"
 Set R="V"
 For  Set PRNr=$O(^KPR(PRNr)) Quit:PRNr=""  Do  Quit:K="-"
 .Quit:'$D(^KPR(PRNr,"J5810"))
 .;Quit:'$P(^KPR(PRNr,1),D,25) ; Nog aktief
 .Set KT=$P(^KPR(PRNr,0),D,1)
 .Set Ref=$P($TR($E(KT,2,11),".","-")," ")
 .Quit:'$D(^BURBID("DEL",PRNr))
 .Write !,"Produkt verwijderen : "_Ref_" " Set K="V" ;R K
 .Quit:(K'="V")&(K'="v")
 .Set Tekst=$$CHECKDEL^PRODUKT2(PRNr,"SFTPZ")
 .If Tekst'="" Write " Niet verwijderd  ",!,Tekst Quit
 .Write "Verwijder"
 .Do DELETE^PRODUKT2(PRNr)
 Quit
DELKREA ; Verwijderen van de zojuist gekreerde producten
 d ^cA604 S Tab=$C(9),D="\"
 Set PRNr=12380
 For  Set PRNr=$O(^KPR(PRNr)) Quit:PRNr=""  Do  ;Quit:K="-"
 .Quit:'$D(^KPR(PRNr,"J5810"))
 .S $P(^KPR(PRNr,0),D,24)=""
 q
 .;Quit:'$D(^BURBID("DEL",PRNr))
 .Set Ref=$P(^KPR(PRNr,0),D)
 .Write !,"Produkt verwijderen : "_Ref_" "
 .Set Tekst=$$CHECKDEL^PRODUKT2(PRNr,"SOTPU")
 .If Tekst'="" Write " Niet verwijderd  ",!,Tekst Quit
 .Write "Verwijder"
 .Do DELETE^PRODUKT2(PRNr)
 Quit
CHECKDEL(PRNr,What) 
 New KLNr,ULNr,Lijn,PR,List,R,I,H,W,HoofdGr,Groep,SubGroep
 If '$L($G(What)) Set What="SHOTPUZ"
 Set Res=""
 Quit:'$D(^KPR(PRNr)) "Produkt bestaat niet"
 If What["S" Set:$P(^KPR(PRNr,0),D,14) Res=Res_"S"
 If What["H" Set H=$O(^KPR(PRNr,"H")) Set:$E(H)="H" Res=Res_"H"
 If What["O",$D(^KPR(PRNr,"W")) Do  Set:$L(List) Res=Res_"O"
 .Set List="",W="W"
 .For  Set W=$O(^KPR(PRNr,W)) Quit:W=""!($E(W)'="W")  Set:$E(W,18,23)<200000 List=List_","_$E(W,18,23)
 If What["T",$D(^KPR(PRNr,"W")) Do  Set:$L(List) Res=Res_"T"
 .Set List="",W="W"
 .For  Set W=$O(^KPR(PRNr,W)) Quit:W=""!($E(W)'="W")  Set:$E(W,18,23)>200000 List=List_","_$E(W,18,23)
 If What["P",$D(^PAKKET("IP",PRNr)) Set Res=Res_"P"
 If What["U" Do  Set:$L(List) Res=Res_"U"
 .Set List=""
 .Set (KLNr,ULNr)=1
 .For  Set KLNr=$O(^KUL(KLNr)) Quit:KLNr=""  Do
 ..For  Set ULNr=$O(^KUL(KLNr,"F",ULNr)) Quit:ULNr=""  Do
 ...Set Lijn=99
 ...For  Set Lijn=$O(^KUL(KLNr,"F",ULNr,Lijn)) Quit:Lijn=""  Do
 ....Set:$P(^KUL(KLNr,"F",ULNr,Lijn),D,2)=PRNr List=List_","_ULNr,Lijn=9999
 If What["Z" Do  Set:$L(List) Res=Res_"Z"
 .Set List=""
 .set I=$O(^KPR(PRNr,"I")) Quit:$E(I)'="I"
 .Set R=^KPR(PRNr,I),HoofdGr=$P(R,D),Groep=$P(R,D,2),SubGroep=$P(R,D,3),KLNr=""
 .For  Set KLNr=$O(^KLPUTZ("IN",HoofdGr,Groep,SubGroep,PRNr,KLNr)) Quit:KLNr=""  Set List=List_","_KLNr
 If What["Z" Do  Set:$L(List) Res=Res_"Z"
 .Set List=""
 .set I=$O(^KPR(PRNr,"I")) Quit:$E(I)'="I"
 .Set R=^KPR(PRNr,I),HoofdGr=$P(R,D),Groep=$P(R,D,2),SubGroep=$P(R,D,3),KLNr=""
 .For  Set KLNr=$O(^KLPUTZ("IS",HoofdGr,Groep,SubGroep,PRNr,KLNr)) Quit:KLNr=""  Set List=List_","_KLNr
 
 Quit Res