BURBCAT ;Burbidge cataloog [ 11/22/2003   1:21 PM ]
 K  D INIT^vhTERMINA
 Write @F11,@F1,@FMTI," Burbidge cataloog export - "_QN_" ",@FMTi
 Set LEVNr=5810
 Set Reeks=$$SELREEKS^DEUR("","PB")
 Quit:'Reeks
 Set FP=1205
 Write @F,@F1," Reeks: "_$P(Reeks,D,2)
 Set Kleur=$$SELKLEUR^DEUR(Reeks,"","P")
 Set FP=1405
 Write @F,@F1," Kleur: "_$P(Kleur,D,1)_" "_$P(Kleur,D,2)
 Set Reeks=$P(Reeks,D)
 Set Kleur=$P(Kleur,D)
 Set Toebeh=1
 For TM="BF;N","BF;F","HFL;N" Do FILE(Reeks,Kleur,$P(TM,";"),$P(TM,";",2),"N",Toebeh,1,1)
 Quit
F1 ;Normaal VAN HOECKE ;1;1 
F2 ;Helmondse ijzerhandel ;1;1.25
F3 ;Biemar-Bois ;0.7;1.5
F4 ;Gijsbrechts ;1;1.174
F5 ;Brans ;1;1.21
BIEMAR DO SERIEONE("BF","F","N","F3")   Quit
GIJSBRE DO SERIEONE("BF","N","N","F4")   Quit
BRANS DO SERIEONE("BF","N","N","F5")   Quit
 ;
SERIEALL Set Fakt=$P($T(F1),";",3,4)
 Set NoSa="N"
 For TM="BF;N","BF;F","HFL;N" Do SERIE($P(TM,";"),$P(TM,";",2),NoSa,$P(Fakt,";"),$P(Fakt,";",2)),GREEP($P(TM,";"),$P(TM,";",2),NoSa,$P(Fakt,";"),$P(Fakt,";",2))
 Quit
 
SERIEONE(Munt,Taal,NoSa,FNode) 
 Set FNode=$G(FNode,"F1")
 Set NoSa=$G(NoSa,"N")
 Set Fakt=$P($T(@FNode),";",3,4)
 Do SERIE(Munt,Taal,NoSa,$P(Fakt,";"),$P(Fakt,";",2))
 Do GREEP(Munt,Taal,NoSa,$P(Fakt,";"),$P(Fakt,";",2))
 Quit
 
 
SERIE(Munt,Taal,NoSa,Fakt1,Fakt2) 
 Set LEVNr=5810
 Set Taal=$G(Taal,"N")
 Set Munt=$G(Munt,"BF")
 Set Reeks="400-"
 For  Set Reeks=$O(^BURBID("R",Reeks)) Quit:Reeks=""  Do
 .Do FILE($P(Reeks,"-",1),$P(Reeks,"-",2),Munt,Taal,NoSa,0,Fakt1,Fakt2) 
 .Do FILE($P(Reeks,"-"),$P(Reeks,"-",2),Munt,Taal,NoSa,1,Fakt1,Fakt2) 
 Quit
 
FILE(Reeks,Kleur,Munt,Taal,NoSa,Toebeh,Fakt1,Fakt2) 
 New %J,Cnt
 Set %J=$$%J^vhRtn1()
 Kill ^HULP(%J)
 If Toebeh Do
 .If Reeks>800 Do
 ..Set ^HULP(%J,1)="800 - Accessoires"
 ..Do FETCH(Reeks,800,Kleur,Munt,Taal,NoSa,Fakt1,Fakt2)
 ..Set Cnt=$O(^HULP(%J,""),-1)
 ..Set:Cnt=1 Cnt=0
 ..Set Cnt=Cnt+1,^HULP(%J,Cnt)="400 - Accessoires"
 ..Do FETCH(Reeks,400,Kleur,Munt,Taal,NoSa,Fakt1,Fakt2)
 ..Kill:Cnt=$O(^HULP(%J,""),-1) ^HULP(%J,Cnt)
 ..Do EXPORT(Reeks,800,Kleur,Munt,Taal)
 .Else  Do
 ..Set ^HULP(%J,1)="400 - Accessoires"
 ..Do FETCH(Reeks,400,Kleur,Munt,Taal,NoSa,Fakt1,Fakt2)
 ..Set Cnt=$O(^HULP(%J,""),-1)
 ..Set:Cnt=1 Cnt=0
 ..Set Cnt=Cnt+1,^HULP(%J,Cnt)="800 - Accessoires"
 ..Do FETCH(Reeks,800,Kleur,Munt,Taal,NoSa,Fakt1,Fakt2)
 ..Kill:Cnt=$O(^HULP(%J,""),-1) ^HULP(%J,Cnt)
 ..Do EXPORT(Reeks,400,Kleur,Munt,Taal)
 Else  Do
 .Do FETCH(Reeks,Reeks,Kleur,Munt,Taal,NoSa,Fakt1,Fakt2)
 .Do EXPORT(Reeks,Reeks,Kleur,Munt,Taal)
 Kill ^HULP(%J)
 Quit
 
FETCH(BasisR,Reeks,Kleur,Munt,Taal,NoSa,Fakt1,Fakt2) 
 New Start,Grp,LevRf
 Set Munt=$G(Munt,"BF")
 Set Taal=$G(Taal,"N")
 Set Start=$O(^HULP(%J,""),-1)
 Set Key=Reeks
 If '$D(^BURBID("R",Key)) Set Key=$O(^BURBID("R",Key_"-"))
 Set Grp=$P(^BURBID("R",Key),D,3)
 Set LEVNr="5810 "
 Set (MemLevRf,LevRf)=Reeks_"-"_Kleur
 For  Set LevRf=$O(^KPL(LEVNr,"  ",LevRf)) Quit:$E(LevRf,1,$L(MemLevRf))'=MemLevRf  Do ADDLEVRF(LevRf,Fakt1,Fakt2)
 Do:Reeks=800 ADDLEVRF("800-00-WB ",Fakt1,Fakt2)
 Quit
 
ADDLEVRF(LevRf,Fakt1,Fakt2) 
 New Kode,ExpRec,MemOms,Oms,Afm,Cnt,KortT,Prijs,LevTrm,PRNr
 Set Kode=$P(LevRf,"-",3)
 Set Kode=$P($P(Kode,"(")," ") ; Soms staat er nog wat achter
 Quit:Reeks=800&(BasisR<800)&(Kleur'=63)&(Kleur'=64)&(Kode'="WB")
 ;Bij 4xx mogen geen 800 accessoires bijgevoegd worden behalve voor de kleuren 63,64 als ook rieten mand
 Quit:Reeks=400&(BasisR>800)&(";90;91;95;98;39;40;42;43;L3;L5;T3;T4;M5;"'[(";"_Kode_";"))  ; Bij 8xx mogen de volgende 400-accessoires bijgevoegd worden
 Set MemOms=""
 Set ExpRec=$G(^BURBID("GC",Grp,Kode))
 Quit:'$L(ExpRec)
 Set Chk=$P(ExpRec,D,2)
 If "*"'[Chk Do  Quit:'Chk
 .B
 .Set:$E(Chk)="""" $E(Chk)="",$E(Chk,$L(Chk))=""
 .Set Chk=$$REPLACE^vhRtn1(Chk,"""""","""")
 .Xecute "Set Chk="_Chk_""""_BasisR_""""
 Set VolgNr=$P(ExpRec,D)
 Set Oms=$P(ExpRec,D,4+(2*(Taal="F")))
 Set Afm=$P(ExpRec,D,5+(2*(Taal="F")))
 If $D(^HULP(%J,Start+VolgNr)) Write "***"_LevRf_"Volgnr reeds ingevuld in HULP ****",!
 Set Cnt=0
 Set KortT=""
 For  Set KortT=$O(^KPL(LEVNr,"  ",LevRf,KortT)) Quit:KortT=""  Do
 .Set PRNr=$P(^(KortT),D)
 .Quit:$P(^KPR(PRNr,1),D,25)
 .Set Cnt=Cnt+1
 .Set Prijs=$$PRIJS(PRNr,Munt,NoSa,Fakt1,Fakt2)
 .Set LevTrm=$P(^KPR(PRNr,"J"_$P(LEVNr," ")),D,7)
 .Set ^HULP(%J,Start+VolgNr)=Oms_D_Kode_D_$S(LevTrm>2:"*",1:"")_D_Afm_D_Prijs
 If Cnt>1 Write "***"_LevRf_"Dubbel produkt voor dezelfde leveranciers referentie ****",!
 Quit
 
PRIJS(PRNr,Munt,NoSa,Fakt1,Fakt2) 
 New Prijs
 Set Prijs=""
 If Munt="AKP" Do
 .Set:NoSa="S" Prijs=$P(^KPR(PRNr,2),D,3)
 .Set Key=$O(^KPR(PRNr,"J"))
 .Set:NoSa'="S"!(Prijs="") Prijs=$P(^KPR(PRNr,Key),D,19)
 Else  Do
 .Set Prijs=$P($$PROD^KPRIJS(PRNr,1-Fakt1*100,"",Munt,,,NoSa),D)
 .Set Prijs=Prijs*Fakt2
 Set Prijs=$$EXTNUM^vhDTyp(Prijs,0,".",$S(Munt="BF":0,1:2))
 Quit Prijs
 
EXPORT(BasisR,Reeks,Kleur,Munt,Taal) 
 Do VANNAAR^vhTERMINA("M")
 Set FileNm=""
 Set:Reeks=800&("821,823,825"[BasisR) FileNm="("_BasisR_")"
 Set FileNm=Reeks_FileNm_"_"_Kleur_"_"_Munt_Taal_".txt"
 Set Dev=$$OPEN^vhDEV($$DIRUSER^vhDEV,FileNm,"W")
 Quit:0[Dev
 Use Dev
 Write "<",$S(Reeks="GRP":"GREPEN",Reeks="800"!(Reeks="400"):"ACCESSOIRES BB",1:"ARTIKELS BB")_">"
 Set VolgNr=""
 For  Set VolgNr=$O(^HULP(%J,VolgNr)) Quit:VolgNr=""  Do
 .If $P(^(VolgNr),D,2)="00" Write ! ; Extra lijn voor monsterdeur
 .Write $TR(^(VolgNr),D_FVAN,$C(9)_FNAAR),!
 Close Dev
 Quit
 
IMPTAAL ;Importeren van de lijst met producten die moeten overgebracht  worden naar de Burbidge cataloog
 ; Record : Reeks, Code, Verlengde levtermijn,omschrijving ned, afm ned, omschrijving frans, afm frans
 New Cnt
 Set FileNm=$$READ^vhDEV(,"VERTALING CATALOOG.TXT","D`PUTTAAL^BURBCAT","T","P")
 Quit
 
PUTTAAL(Rec) 
 New Grp,Kode
 Set Grp=$P(Rec,D)
 Set Kode=$P(Rec,D,2)
 If $L(Kode)=1 Set Kode="0"_Kode
 If '$D(Cnt(Grp)) Kill ^BURBID("GC",Grp) Set Cnt(Grp)=0
 Set Cnt(Grp)=Cnt(Grp)+1
 Set ^BURBID("GC",Grp,Kode)=Cnt(Grp)_D_$P(Rec,D,3,99)
 Quit
 
IMPGREEP ;Importeren van de lijst met grepen die moeten overgebracht  worden naar de Burbidge cataloog
 ; Record : Code korttxt, Verlengde levtermijn,omschrijving ned,omschrijving frans
 New Cnt
 Set Grp="GRP"
 Set Cnt=0
 Kill ^BURBID("GC","GRP")
 Set FileNm=$$READ^vhDEV(,"EXCEL GREPEN.TXT","D`PUTGREEP^BURBCAT","T","P")
 Quit
 
PUTGREEP(Rec) 
 New Kode
 Set Kode=$P(Rec,D,1)
 Set Cnt=Cnt+1
 Set ^BURBID("GC",Grp,Kode)=Cnt_D_$P(Rec,D,2,99)
 Quit
 
GREEP(Munt,Taal,NoSa,Fakt1,Fakt2) 
 Set Kode=""
 Set %J=$$%J^vhRtn1()
 Kill ^cHULP(%J)
 For  Set Kode=$O(^BURBID("GC","GRP",Kode)) Quit:Kode=""  Do
 .Set Rec=^(Kode)
 .Set Kort=Kode
 .If $E(Kort,1,3)="800" Set PRNr=$$LOCLEVR(Kort,5810)
 .Else  Set PRNr=$$LOCATE(Kort)
 .If $L(PRNr,D)>1 Write !,"Meerdere producten gevonden : "_Kode_" "_Rec_"->"_PRNr Set PRNr=$P(PRNr,D)
 .If PRNr="" Write !,"NIET gevonden : "_Kode_" "_Rec Quit
 .Set Prijs=$$PRIJS(PRNr,Munt,$G(NoSa),Fakt1,Fakt2)
 .Set ^HULP(%J,$P(Rec,D))=Kode_D_$P(Rec,D,2)_D_$P(Rec,D,4+(Taal="F"))_D_Prijs
 Do EXPORT("GRP","GRP","",Munt,Taal)
 Quit
LOCLEVR(Txt,LevNr) 
 Set PRNr=""
 If $L($G(LevNr)) Do
 .Set:$E(LevNr,$L(LevNr))'=" " LevNr=LevNr_" "
 .Do LOCLR2(Txt,LevNr)
 Else  For  Set LevNr=$O(^KPL(LevNr)) Quit:LevNr=""  Do
 .Do LOCLR2(Txt,LevNr)
 Quit $E(PRNr,2,999)
 
LOCLR2(Txt,LevNr) 
 New Merk,KortT
 Set:$E(Txt,$L(Txt))'=" " Txt=Txt_" "
 Set Merk=""
 For  Set Merk=$O(^KPL(LevNr,Merk)) Quit:Merk=""  Do
 .Quit:'$D(^KPL(LevNr,Merk,Txt))
 .Set KortT=""
 .For  Set KortT=$O(^KPL(LevNr,Merk,Txt,KortT)) Quit:KortT=""  Do
 ..Set PRNr=PRNr_"\"_^(KortT)
 Quit
 
LOCATE(Kort) 
 Set Kort=$$UPTRIMAN^vhRtn1(Kort)
 Set T=$E(Kort,1,3)
 Set PRNr=""
 For  Set T=$O(^KPR1(T)) Quit:$E(T,1,3)'=$E(Kort,1,3)  Do
 .If $E($$UPTRIMAN^vhRtn1($P(^KPR1(T),D,2)),1,$L(Kort))=Kort Set PRNr=PRNr_"\"_$P(^KPR1(T),D,1)
 Quit $E(PRNr,2,999)