BURBIDC ;Controle op verwijdering, bijvoegen of wijziging van BURBIDGE produkten[ 02/21/2003  1:12 PM ]
 Quit
 
BLDTABLE Set DupPRNr=8358
 Set LevNr=5810 ; Burbidge
 ; Opzoeken van de klassificatie
 ; De subgroepen beginnen met de nummers van prod families
 Do GETKLAS
 Kill ^BURBID("ADD"),^BURBID("DEL"),^BURBID("MOD")
 Kill CntTable
 Set VolgNr=0
 For  Set VolgNr=$O(^BURBID("B",VolgNr)) Quit:VolgNr=""  Do ONETABLE(VolgNr) Quit:VolgNr>100000
 ;Do ZOEKDEL
 Write !,"Tellingen",! zw CntTable Write !
 Quit
 
MODIFY  ; Prijs
 Set VolgNr=""
 Do GETKLAS
 Set PRNr=""
 For  Set PRNr=$O(^BURBID("MOD",PRNr)) Quit:PRNr=""  Do
 .Quit:'$P(^BURBID("MOD",PRNr),D,2)  ; Geen wijziging
 .Set VolgNr=$P(^BURBID("MOD",PRNr),D)
 .Do FETCH(VolgNr)
 .Do FETCHPR(PRNr)
 .Set Diff=$$PRIJS("S") ; Invullen in schaduw
 .Write !,$P(RecN(0),D),"  ",$P(RecN(2),D,3,6)
 .Set ^KPR(PRNr,2)=RecN(2) ; Schaduw
 .Set $P(^KPR(PRNr,1),D,25)=""
 Quit
 
CREATE Set DupPRNr=8358
 Set VolgNr=""
 Do GETKLAS
 For  Set VolgNr=$O(^BURBID("ADD",VolgNr)) Quit:VolgNr=""  Do 
 .Do FETCH(VolgNr)
 .Do FETCHPR(DupPRNr)
 .Do CLEAN
 .Do BUILD("N")
 .zw RecN
 .Do SAVE
 Quit
 
DELETE Set K=""
 Set R="V"
 Set PRNr=0
 Set NoRead="N" ; Geen READ per produkt allen in eens op non aktief
 If $L(NoRead) Write "Alles ineens "_$S(NoRead="N":"op non-aktief zetten",1:"verwijderen")," JA[]" Read K  Quit:K'="JA"
 Else  W !,"Produkten verwijderen",!,"V[]=Verwijderen, N[]=Non-aktief, []=Niet verwijderen,   -[]=Stoppen"
 For  Set PRNr=$O(^BURBID("DEL",PRNr)) Quit:PRNr=""  Do  Quit:K="-"
 .Quit:'$D(^KPR(PRNr,"J5810"))
 .Set KT=$P(^KPR(PRNr,0),D,1)
 .Set Ref=$P($TR($E(KT,2,11),".","-")," ")
 .Write !,"Produkt verwijderen : "_Ref_" "
 .If $L(NoRead) Do
 ..Set K=NoRead
 .Else  Do
 ..Read ": ",K
 .Set K=$$UPCASE^vhRtn1(K)
 .Quit:(K'="V")&(K'="N")
 .Set Tekst=$$CHECKDEL^PRODUKT2(PRNr,"SFT")
 .If Tekst'="" Write *7," NIET ",$S(K="N":"op non aktief gezet",1:"verwijderd")," -> ",Tekst,! Quit
 .If K="V" Do  ; Verwijder
 ..Do DELETE^PRODUKT2(PRNr)
 ..Write "verwijderd"
 .Else  Do  ;Non aktief
 ..Set $P(^KPR(PRNr,1),D,25)=1
 ..Write "non-aktief"
 Quit
 
MODLVW Set VolgNr=""
 Set LevNr=5810
 For  Set VolgNr=$O(^BURBID("ADD",VolgNr)) Quit:VolgNr=""  Do 
 .Kill RecN
 .Do FETCH(VolgNr)
 .Do LEVREF
 .Do LEVWK
 .Set PRNr=$$SEARCH($P(RecN("J"),D,3))
 .If 'PRNr Write "Prod LEVREF niet gevonden",! Quit
 .Set LevWk=$P(RecN("J"),D,7)
 .Write $P(^KPR(PRNr,0),D),"  ",LevWk,!
 .Quit:'$D(^KPR(PRNr,"J5810"))
 .Set $P(^KPR(PRNr,"J5810"),D,7)=LevWk
 Quit
 
ONETABLE(VolgNr) 
 New RecN 
 Do FETCH(VolgNr)
 Do LEVREF
 Set PRNr=$$SEARCH($P(RecN("J"),D,3))
 If 'PRNr Do
 .Set ^BURBID("ADD",VolgNr)=""
 .Set CntTable("ADD")=$G(CntTable("ADD"))+1
 Else  Do 
 .Do FETCHPR(PRNr)
 .Set Diff=$$PRIJS("S")
 .Set ^BURBID("MOD",PRNr)=VolgNr_D_Diff
 .Set:Diff CntTable("MOD")=$G(CntTable("MOD"))+1
 .Set:'Diff CntTable("EQ")=$G(CntTable("EQ"))+1
 Quit
 
ZOEKDEL Set PRNr=0  
 For  Set PRNr=$O(^KPR(PRNr)) Quit:PRNr=""  Do
 .Quit:'$D(^KPR(PRNr,"J"_LevNr))  ; Geen burbidge produkt
 .Quit:$D(^BURBID("MOD",PRNr))  ; Bestaat nog steeds
 .Quit:$L($P(^KPR(PRNr,0),D,3))  ; Generische of afgeleid produkt
 .Quit:$P(^KPR(PRNr,"J"_LevNr),D,3)["EDELW"  ; Bijzonder prijs EDELW
 .Quit:$P(^KPR(PRNr,$O(^KPR(PRNr,"I"))),D,2)["ACC"  ; Toebehoren niet opnemen in de DEL tabel
 .Quit:$P(^KPR(PRNr,$O(^KPR(PRNr,"I"))),D,2)["G&K"  ; Grepen en knoppen niet opnemen in de DEL tabel
 .Set ^BURBID("DEL",PRNr)=$$CHECKDEL(PRNr,"SOTU")_D_$$CHECKDEL(PRNr,"HZP")
 .Set CntTable("DEL")=$G(CntTable("DEL"))+1
 Quit
 
FETCH(VolgNr) 
 Set RecB=^BURBID("B",VolgNr)
 Set Reeks=$P(RecB,D)
 Set Kleur=$P(RecB,D,2)
 Set Code=$P(RecB,D,3)
 Set RecR=$G(^BURBID("R",Reeks_"-"_Kleur))
 Set:RecR="" RecR=^BURBID("R",Reeks) ; Accessoires 400 & 800
 Set GrpCode=$P(RecR,D,3) ; 400,800,XXX of YYY
 Set RecC=^BURBID("GC",GrpCode,Code)
 Quit
 
FETCHPR(PRNr) 
 Do FETCHPR^UTILI(PRNr,"RecN")
 Quit
 
BUILD(NoSa) 
 Do KLAS
 Do LEVREF
 Do KORTTXT
 Do LANGTXT("N"),LANGTXT("F")
 Do LEVTXT
 Do LEVWK
 Set Diff=$$PRIJS(NoSa)
 ;Set PRNr=$$SEARCH($P(RecN("J"),D,3))
 ;Write Reeks," ",$P(RecN(0),D,1)," ",$P(RecN("J"),D,3)," ",PRNr," ",$S(PRNr:$P(^KPR(PRNr,0),D),1:"?"),!
 ;Write $P(RecB,D,4)," ",$P(RecN(4),D,1)," & ",$P(RecN(4),D,2),!
 ;Write "           ",$P(RecN(1),D,22)," & ",$P(RecN(3),D,21),!
 Quit
 
SAVE ; Produktnummer en identnr
 New NewPRNr,X,PRNr,Som,IdentNr
 Set NewPRNr=$$NEXTID^PRODUKT()
 Set IdentNr=$$IDENTNR^PRODUKT(NewPRNr)
 Set $P(RecN(2),D,25)=IdentNr
 Set PRNr=NewPRNr    
 ; Opslag
 F I=0,1,2,3,4,5 Set ^KPR(PRNr,I)=RecN(I)
 Set ^KPR(PRNr,"I")="",^KPR(PRNr,"I1")=RecN("I")
 Do RECALC^PRODUKT2(PRNr,RecN("J"))
 Do BLDIND^PRODUKT2(PRNr)
 Do Gemaakt^PRODUKT2(PRNr)
 Quit
 
LEVTXT New LevT1,Oms,Afm,LevT2
 Set LevT1=$P(RecR,D,1)
 Set Oms=$P(RecC,D,8)
 Set Afm=$$REPLACE^vhRtn1($P(RecC,D,9)," x ","x")
 Set LevT2=""
 If $L(LevT1_", "_Oms)<45 Do
 .Set:$L(Oms) LevT1=LevT1_", "_Oms
 .If $L(LevT1_", "_Afm)<45 Do
 ..Set:$L(Afm) LevT1=LevT1_", "_Afm
 .Else  Do
 ..Set LevT2=Afm
 Else  Do
 .Set LevT2=Oms
 ..Set:$L(Afm) LevT2=LevT2_", "_Afm
 If $L(LevT1)>44 Write *7,!,"*** BestelTxt 1 te lang >44 ",KortT,"; ",Best
T1 
 If $L(LevT2)>44 Write *7,!,"*** BestelTxt 2 te lang >44 ",KortT,"; ",Best
T2 
 S $P(RecN(4),D,1)=LevT1
 S $P(RecN(4),D,2)=LevT2
 Quit
 
LEVWK New LevTrm
 S LevTrm=$P(RecB,D,8) ; "*" of leeg
 Set LevTrm=$S(LevTrm="*":4,1:2)
 Set $P(RecN("J"),D,7)=LevTrm
 Quit
 
PRIJS(NoSa)  New AKP,Kort,DB,Diff
 Set AKP=$TR($P(RecB,D,5),",",".") ; In munt van de lev.
 Set Kort=$TR($P(RecB,D,6),",",".")
 Set DB=$TR($P(RecB,D,7),",",".")
 ;Controle 
 If AKP<0.1!(AKP>10000) Write *7,!,$P(RecB,D,4)," Foutieve aankoopprijs : ",AKP
 If Kort<30!(Kort>50) Write *7,!,$P(RecB,D,4)," Foutieve korting : ",Kort
 If DB<30!(DB>50) Write *7,!,$P(RecB,D,4)," Foutieve DB : ",DB
 Set Diff=0
 If NoSa="N" Do
 .Set $P(RecN("J"),D,19)=AKP
 .Set $P(RecN("J"),D,9)=Kort
 .Set $P(RecN("J"),D,24)=DB
 Else  Do  ; Default schaduw
 .For I=3:1:7 Set $P(RecN(2),D,I)="" ; Wissen oude shaduwinstellingen
 .Set:+$P(RecN("J"),D,19)'=+AKP $P(RecN(2),D,3)=AKP,Diff=1
 .Set:+$P(RecN("J"),D,9)'=+Kort $P(RecN(2),D,4)=Kort,Diff=1
 .Set:+$P(RecN("J"),D,24)'=+DB $P(RecN(2),D,6)=DB,Diff=1
 Quit Diff
 
LANGTXT(Taal) 
 New LT1,LT2,Afm,Oms
 Set LT1=$P(RecR,D,1+(Taal="F"))
 Set Afm=$P(RecC,D,5+(Taal="F"*2))
 Set Oms=$P(RecC,D,4+(Taal="F"*2))
 Set LT2=$$REPLACE^vhRtn1(Afm," x ","x")
 Set:$L(LT1)+$L(LT2)<25&$L(LT2) LT1=LT1_", "_LT2,LT2=""
 Set:$L(LT2) LT2=LT2_", " 
 Set LT2=LT2_Oms
 If $L(LT1)>26 Write *7,!,"*** Langtekst N te lang >26 ",KortT,"; ",LT1
 If $L(LT2)>44 Write *7,!,"*** Langtekst N te lang >45 ",KortT,"; ",LT2
 If Taal="F" Do
 .Set $P(RecN(1),D,22)=LT1
 .Set $P(RecN(3),D,21)=LT2
 Else  Do
 .Set $P(RecN(0),D,2)=LT1
 .Set $P(RecN(0),D,11)=LT2
 Quit
 
KORTTXT New Code2,KortT,VHKleur
 Set Code2=Code
 IF Code2="FR1500" Set Code2="FR15" ; Inkorten
 Set KortT="D"_Reeks_$S($L(Reeks)>3:"",1:".")_Kleur_$S($L(Code2)>3:"",1:".")_Code2
 If $L(KortT)>11 Write *7,!,"*** Korttekst te lang >11 ",KortT
 Set KortT=KortT_$J("",11-$L(KortT))_$P(RecC,D,3) ; omschrijving in korttekst
 Set VHKleur=^BURBID("K",Kleur)
 Set KortT=KortT_$J("",25-$L(KortT)-$L(VHKleur))_VHKleur
 If $L(KortT)>25 Write *7,!,"*** Korttekst te lang >25",KortT
 ;If $$EXISTKT^PRODUKT2(KortT) Set Prijs="" Write !,"**** Bestaat reeds : ",KortT
 Set $P(RecN(0),D,1)=KortT
 Quit
 
LEVREF New LevRef
 Set Code=$P(RecB,D,3)
 Set LevRef=Reeks_"-"_Kleur_"-"_Code
 Set:Reeks'=$E($P(RecB,D,4),1,3) LevRef=LevRef_" ("_$E($P(RecB,D,4),1,3)_")"
 Set $P(RecN("J"),D,3)=LevRef
 Quit
 
SEARCH(LevRef) 
 New LevR1,LevR,LevR2,PRNr
 Set LevR1=LevRef_" "
 Set LevR=""
 If $D(^KPL(LevNr_" ","  ",LevR1)) Set LevR=LevR1
 Set LevR1=$P($P(LevRef," "),"(")_" " ; Zonder extra appendix (XXX)
 If LevR="",$D(^KPL(LevNr_" ","  ",LevR1)) Set LevR=LevR1
 If LevR="" Do  ; Nakijken of er een bestaat met extra appendix
 .Set LevR2=$O(^KPL(LevNr_" ","  ",LevR1),-1)
 .For  Set LevR2=$O(^KPL(LevNr_" ","  ",LevR2)) Quit:LevR2=""  Quit:$P($P(LevR2," "),"(")=$P(LevR1," ")  Quit:$E(LevR2,1,7)'=$E(LevR1,1,7)
 .If $P($P(LevR2," "),"(")=$P(LevR1," ") Set LevR=LevR2
 Quit:LevR="" ""
 ; Opzoeken van de korttekst
 Set KT=$O(^KPL(LevNr_" ","  ",LevR,""))
 Quit:$O(^KPL(LevNr_" ","  ",LevR,KT))'="" "DUBBEL"
 Set PRNr=^KPL(LevNr_" ","  ",LevR,KT)
 Quit PRNr
 
GETKLAS New SG
 Set SG=""
 For  Set SG=$O(^KPSG1(SG)) Quit:SG=""  If $E(SG,$L(SG)-2,$L(SG))="BU " s Klas($E(SG,12,14))=$P(^KPSG1(SG),D,6)  ; Klas(Reeks)=KKey
 Quit
 
KLAS New KlasR,KKey,HG,GR,SG
 Set KlasR=$P(RecR,D,5)
 Set KKey=Klas(KlasR)
 Set HG=$$GETSORT^KLASS(KKey,1)
 Set GR=$$GETSORT^KLASS(KKey,2)
 Set SG=$$GETSORT^KLASS(KKey,3)
 Set RecN("I")=HG_D_GR_D_SG_D_KKey
 Quit
 
CLEAN Set $P(RecN(0),D,6)="" ; Ligging
 Set $P(RecN(0),D,9)="" ; Reservatie WMS
 Set $P(RecN(0),D,12,14)=D_D ; Beginstock,FysStock
 Set $P(RecN(0),D,16)="" ; Laatste beweging
 Set $P(RecN(0),D,17)="" ; Bestelling
 Set $P(RecN(0),D,20)="" ; Schaduwkorttekst
 Set $P(RecN(0),D,21)="" ; Schaduw sectie
 Do  ; Bufferweken
 .If '$P(RecN(1),D,20) Set $P(RecN(1),D,17)=""
 .Else  Set:'$P(RecN(1),D,17) $P(RecN(1),D,17)=2
 Set $P(RecN(1),D,21)="" ; Gem Weekverkoop
 Set $P(RecN(1),D,23)="" ; Gewogen gem. weekverkoop
 Set $P(RecN(1),D,9)="" ; Inventaris fysstock
 Set $P(RecN(2),D,3)="" ; Schad PPL
 Set $P(RecN(2),D,4)="" ; Schad Korting
 Set $P(RecN(2),D,5)="" ; Schad Vork
 Set $P(RecN(2),D,6)="" ; Schad Winst
 Set $P(RecN(2),D,7)="" ; Schad Cif
 Set $P(RecN(2),D,9)="" ; Reservatie
 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