PRSCALC ;Herekenen van het DB% in de schaduw zodat de verkoopprijs gelijk blijft met de huidige verkoopprijs [ 10/22/2003  4:13 PM ]
 If '$D(Q) Set Q="K" Do ^cA604,INIT^vhTERMINA
 Write @F11,@F1,@FMTI," Schaduw : Terugrekenen DB - "_QN," ",@FMTi
 Write !!,"Dit programma gaat gebruik makend van de nieuwe aankoopprijs"
 Write !,"ingevuld in de schaduw gegevens, de DB herrekenen zodat"
 Write !,"de verkoopprijs behouden blijft."
 Set Y="20\Produkt selectie :"
 Do LIST^POP("PRSCALC1","",20,"Produkt selectie  (- = Exit)","P")
 Set SelType=X
 Quit:'$L(X)
 Set FP=2001 Write @F,@F1
 Set R=$S(SelType="B":"Bepaalde",SelType="D":"Dalende",SelType="S":"Stijgende",1:"Alle"),FP=178-$L(R) Write @F,@FMTB," ",R," ",@FMTb
 Set Confirm=1,Store=""
 If X'="B" Do LIST^POP("PRSCALC2","B",20,"Bevestiging  (- = Exit)","P")  Quit:'$L(X)  Set Confirm=X="B",Store=X
 Set FP=2001 Write @F,@F1
 If SelType="B" Do
 .For  Set PRNr=$$SELECT^PRODUKT6("","") Quit:'PRNr  Do
 ..Set FP=301 Write @F,@F1
 ..Do CALC
 Else  Do  ; Alle produkten volgens klassificatie
 .Do ^KPSELQ
 .Quit:K="-"
 .Set LevNr=$$SELECT^LEVER(1,"","Beperkt tot Leverancier : ")
 .If LevNr  Set FP=1301 Write @F,"Beperking leverancier : "_LevNr_" "_$P(^KLE(^KL1(LevNr),0),D,2)
 .Else  Set LevNr=""
 .If 'Confirm Do  Quit:X'="J"&(X'="j")
 ..Set X=$$ASK^vhINP("Verder gaan : ",1,"","U bent zeker dat u alle produkten wenst aan te passen","ZONDER bevestiging per produkt , J[] = zonder bevestiging,  []= exit")
 ..Set FP=2001 Write @F,@F1
 .Set Verschil=Confirm
 .Set (KHS,KGS,KSS,KT)="",Cnt=0
 .F  S KHS=$O(^KPH(KHS)) Quit:KHS=""  Do
 ..Quit:KHS'=HG&(KHS']HG)  Quit:KHS'=HGX&(KHS]HGX)
 ..F  S KGS=$O(^KPH(KHS,KGS)) Quit:KGS=""  Do
 ...Quit:KGS'=GR&(KGS']GR)  Quit:KGS'=GRX&(KGS]GRX)
 ...F  S KSS=$O(^KPH(KHS,KGS,KSS)) Quit:KSS=""  Do
 ....Quit:KSS'=SG&(KSS']SG)  Quit:KSS'=SGX&(KSS]SGX)
 ....F  S KT=$O(^KPH(KHS,KGS,KSS,"  ",KT)) Quit:KT=""  Do
 .....Set PRNr=+^(KT)
 .....If $G(LevNr) Quit:'$D(^KPR(PRNr,"J"_LevNr))
 .....If Confirm,Verschil Set FP=2001,Verschil=0 Write @F,@F1,!!!,"Even geduld, op zoek naar volgend produkt..."
 .....Do CALC
 .....If 'Confirm,Verschil Set FP=2001 Write @F,@F1,!!!,"Produkt : "_$P($G(B(1)),D,1)
 .....Set:PRNr["Z" (KT,KSS,KGS,KHS)=PRNr
 .If PRNr'["Z" Set FP=2001 Write @F,@F1 Do TXT^vhINP("Alle produkten verwerkt, terug naar menu")
 Quit
 
ONE(PRNr,Confirm,Store) 
 New B,I1,Verschil,I,J,R,T,SelType
 New PPL,Kort,Cif,Winst,LijstNA,CifPPL,GOrde,Munt,MuntPar
 New SPPL,SKort,SCif,SWinst,SLijstNA,SCifPPL,CopyRec,MemRecJ,MemRec1,MemRec2
 Set CopyRec=$$CHKCOPY(PRNr)
 Do:CopyRec COPY(PRNr,$P(CopyRec,D,3),$P(CopyRec,D,1),$P(CopyRec,D,2))
 Set SelType="B"
 Set Store=$G(Store)
 Do CALC
 Lock +^KPR(PRNr)
 If Store="S",$D(MemRecJ) Do  ; In schaduw gestockeerd herstellen J-node
 .Set ^KPR(PRNr,"J"_$P(MemRecJ,D))=MemRecJ
 If Store="H",$D(MemRecJ) Do  ; In huidig gestockeerd herstellen 2-node
 .Set ^KPR(PRNr,1)=MemRec1
 .Set ^KPR(PRNr,2)=MemRec2
 If Store'="S",Store'="H",$D(MemRecJ) Do  ; Annuleer
 .Set ^KPR(PRNr,1)=MemRec1
 .Set ^KPR(PRNr,2)=MemRec2
 .Set ^KPR(PRNr,"J"_$P(MemRecJ,D))=MemRecJ
 Lock -^KPR(PRNr)
 Quit
 
CHKCOPY(PRNr) 
 New KortTxt,Y,X
 Set KortTxt=$P(^KPR(PRNr,0),D,1)
 Set Y=0
 ;If $E(KortTxt,12,26)'["*" Quit ""
 Set Y=Y+1,Y(Y)="W`Dekkingsbijdrage herrekenen zoals reeds ingesteld"
 Set Y=Y+1,Y(Y)="S`Lijstprijs gelijkzetten vertrekkend van SCHADUW"
 Set Y=Y+1,Y(Y)="H`Lijstprijs gelijkzetten vertrekkend van HUIDIG"
 Set X=$$WILD^vhPOPUP("C;C","KO1B",KortTxt,.Y,"W")
 If X'="S",X'="H" Quit ""
 Set PRNr=$$SELECT^PRODUKT6(,,$E(KortTxt,1,5),"Basisproduct : ")
 Quit:'PRNr ""
 Kill Y
 Set Y=$$^vhTXTPOP("PRSCALC","COPY",,$S(X="H":"HUIDIGE",1:"SCHADUW"),KortTxt,$P(^KPR(PRNr,0),D,1))
 If Y'="S",Y'="H" Quit ""
 Quit PRNr_D_$S(Y:"N",1:"S")_D_$S(X="H":"N",1:"S")
 
COPY(PRNr,NoSa,CopyPRNr,CopyNoSa,Optie) 
 New Rec1,Rec2,KeyJ,RecJ,RecC1,RecC2,RecCJ
 Lock +^KPR(PRNr)
 Set (MemRec2,Rec2)=^KPR(PRNr,2)
 Set (MemRec1,Rec1)=^KPR(PRNr,1)
 Set KeyJ=$O(^KPR(PRNr,"J"))
 Set (MemRecJ,RecJ)=^KPR(PRNr,KeyJ)
 Set RecC1=^KPR(CopyPRNr,1)
 Set RecC2=^KPR(CopyPRNr,2)
 Set RecCJ=^KPR(CopyPRNr,$O(^KPR(CopyPRNr,"J")))
 If NoSa="S" Do  ; Vervolledigen schaduw
 .Set:$P(Rec2,D,3)="" $P(Rec2,D,3)=$P(RecJ,D,19) ; PPL
 .Set:$P(Rec2,D,4)="" $P(Rec2,D,4)=$S($P(RecJ,D,9)="":0,1:$P(RecJ,D,9)) ; Korting
 .Set:$P(Rec2,D,7)="" $P(Rec2,D,7)=$S($P(RecJ,D,21)="":0,1:$P(RecJ,D,21)) ; Cif
 .Set:$P(Rec1,D,3)="" $P(Rec1,D,3)=$P(RecJ,D,17) ; Munt
 Else  Do  ; Copieren huidig naar schaduw
 .Set $P(Rec2,D,3)=$P(RecJ,D,19) ; PPL
 .Set $P(Rec2,D,4)=$S($P(RecJ,D,9)="":0,1:$P(RecJ,D,9)) ; Korting
 .Set $P(Rec2,D,7)=$S($P(RecJ,D,21)="":0,1:$P(RecJ,D,21)) ; Cif
 .Set $P(Rec1,D,3)=$P(RecJ,D,17) ; Munt
 If CopyNoSa="S" Do  ; Copieren van de COPY-schaduw naar huidig
 .Set $P(RecJ,D,19)=$S($P(RecC2,D,3)="":$P(RecCJ,D,19),1:$P(RecC2,D,3)) ; PPL
 .Set $P(RecJ,D,9)=$S($P(RecC2,D,4)="":$P(RecCJ,D,9),1:$P(RecC2,D,4)) ; Korting
 .Set $P(RecJ,D,21)=$S($P(RecC2,D,7)="":$P(RecCJ,D,21),1:$P(RecC2,D,7)) ; Cif
 .Set $P(RecJ,D,17)=$S($P(RecC1,D,3)="":$P(RecCJ,D,17),1:$P(RecC1,D,3)) ; Munt
 .Set $P(RecJ,D,24)=$S($P(RecC2,D,6)="":$P(RecCJ,D,24),1:$P(RecC2,D,6)) ; DB%
 Else  Do  ; Copieren van COPY-huidig naar huidig
 .Set $P(RecJ,D,19)=$P(RecCJ,D,19) ; PPL
 .Set $P(RecJ,D,9)=$P(RecCJ,D,9) ; Korting
 .Set $P(RecJ,D,21)=$P(RecCJ,D,21) ; Cif
 .Set $P(RecJ,D,17)=$P(RecCJ,D,17) ; Munt
 .Set $P(RecJ,D,24)=$P(RecCJ,D,24) ; DB%
 ; Opslaan nieuwe prijzen
 Set ^KPR(PRNr,2)=Rec2
 Set ^KPR(PRNr,1)=Rec1
 Set ^KPR(PRNr,KeyJ)=RecJ
 Lock -^KPR(PRNr)
 Quit
 
CALC Do FETCH
 If '$D(B) Do TXT^vhINP("Probleem met DB herekenen, gelieve schaduw prijs","voor produkt "_$P(^KPR(PRNr,0),D,1)_" na te kijken") Set FP=2201 Write @F,@F1 Quit
 Set Verschil=$$CHECK()
 If 'Verschil,SelType'="B" Quit
 If Confirm Do
 .If 'Verschil Do TXT^vhINP("Geen verschillen in huidige prijs en schaduw prijs","voor produkt "_$P(B(1),D,1)) Quit
 .Do SHOW
 .Set Store=$$ASK^vhINP("Nieuw DB% opslaan : ",1,""," [] = niet opslaan, S[] = in schaduw"_$S($D(^KBA("S",11,Munt)):"",1:", H[] = in huidige prijs"),$S(SelType'="B":"-[] = terug naar menu",1:""),,,,"U")
 Else  Quit:'Verschil
 If SelType'="B",Store="-" Set PRNr="ZZZZZ"
 If $D(^KBA("S",11,Munt)),Store="H" Do
 .New Txt
 .Set Txt(1)="Korttekst : "_$P(B(1),D,1)
 .Set Txt(2)="Munt bestaat in de schaduw kan niet stokeren in huidige prijszetting,"
 .Set Txt(3)="zal stokeren in schaduw !"
 .Set Txt=3
 .Set Txt=$$WILD^vhTXTPOP("C;C","PROBLEEM","Txt")
 .Set Store="S"
 Do PUTSCHAD:Store="S"
 Do PUTHUID:Store="H"
 Quit
 
CALCDB(PRRec) ; Terugrekenen nieuw DB%
 ; PRRec via .Local
 New B,PPL,Kort,Cif,Winst,Munt,MuntPar,GOrde,SPPL,SKort,SCif,SMUnt,SMuntPar,CifPPL,SCifPPL,LijstNA,SWinst,Key
 
 ; Vermits de B record struct begint van 1 ipv 0 alle numerieke indexen met 1 verhogen.
 Set Key=""
 For  Set Key=$O(PRRec(Key)) Quit:Key=""  Set B($S(Key?1.N:Key+1,1:Key))=PRRec(Key)
 Do FETCH2 ; werkt met de B record struct
 Quit $S($D(B):SWinst,1:"")
 
FETCH Do FETCHPR^UTILI(PRNr)
FETCH2 Quit:'$L($G(B("J"))) 
 Set PPL=$P(B("J"),D,19)
 Set Kort=$P(B("J"),D,9)
 Set Cif=$P(B("J"),D,21)
 Set CorFakt=$P(B("J"),D,8)
 Set Winst=$P(B("J"),D,24)
 Set Munt=$P(B("J"),D,17)
 Set MuntPar=$$MUNTPAR^vhRtn1(Munt,1)
 Set GOrde=$S($P(B("J"),D,28)="M":1000,$P(B("J"),D,28)="H":100,1:1)
 Set SPPL=$P(B(3),D,3) Set:SPPL="" SPPL=PPL
 Set SKort=$P(B(3),D,4) Set:SKort="" SKort=Kort
 Set SCif=$P(B(3),D,7) Set:SCif="" SCif=Cif
 Set SMunt=$P(B(2),D,3) Set:SMunt="" SMunt=Munt
 Set SMuntPar=$$MUNTPAR^vhRtn1(SMunt,1,"S")
 Set CifPPL=PPL/MuntPar/GOrde*(100-Kort/100)*(100+Cif/100)
 Set SCifPPL=SPPL/SMuntPar/GOrde*(100-SKort/100)*(100+SCif/100)
 Set LijstNA=CifPPL/(100-Winst/100)
 Set SCorFakt=+$J(CifPPL-SCifPPL,0,4)
 If +$J(LijstNA,0,4)=0 Kill B Quit  ; Indien verkooppijs = 0 kan men de DB niet terugrekenen
 Set SWinst=100-(SCifPPL/LijstNA*100)*10000000\1/10000000
 ;Write "Old: " zw SWinst
 
 Set CifPPL=PPL*(100-Kort)/100*(100+Cif)/100,CifPPL=$J(CifPPL,1,4) Set:'CifPPL Winst=0
 Set DB=CifPPL/(100-Winst/100)*Winst/100  ;,DB=$J(DB,1,4)
 Set LijstNA=CifPPL+DB
 Set SCifPPL=SPPL*(100-SKort)/100*(100+SCif)/100,SCifPPL=$J(SCifPPL,1,4) Set:'SCifPPL SWinst=0
 Set SDB=LijstNA-SCifPPL
 Set:SDB SWinst=(1/((SCifPPL/SDB)+1))*100*10000000\1/10000000
 ;Write "New:"	zw SWinst
 ;r k
 
 If SWinst=100 Kill B Quit  ; Winst van 100% kan ook niet
 Set SLijstNA=SCifPPL/(100-SWinst/100)
 Quit
 
PUTSCHAD 
 Lock +^KPR(PRNr):1 Else  Do LDISP^vhLock("^KPR("_PRNr_")","Dit produkt is ingebruik") Quit
 Do MODFIELD^PRODUKT(PRNr,"306",SWinst,1,"S-DB% (WH)")
 Do MODFIELD^PRODUKT(PRNr,"326",SCorFakt,1,"S-Cor.fakt.(WH)")
 Lock -^KPR(PRNr)
 Quit
 
PUTHUID New Key
 Lock +^KPR(PRNr):1 Else  Do LDISP^vhLock("^KPR("_PRNr_")","Dit produkt is ingebruik") Quit
 Set Key=$O(^KPR(PRNr,"J")) 
 If $E(Key)="J" Do
 . ; overbrengen naar huidige prijs	
 . Do MODFIELD^PRODUKT(PRNr,"J24",SWinst,1,"DB%(WH)")
 . Do MODFIELD^PRODUKT(PRNr,"J08",SCorFakt,1,"Cor.fakt.(WH)")
 . Do MODFIELD^PRODUKT(PRNr,"J09",SKort,1,"Korting%(WH)")
 . Do MODFIELD^PRODUKT(PRNr,"J19",SPPL,1,"PPL (WH)")
 . Do MODFIELD^PRODUKT(PRNr,"J21",SCif,1,"CIF% (WH)")
 . Do MODFIELD^PRODUKT(PRNr,"J17",SMunt,1,"Munt (WH)")
 . ; wissen schaduw
 . Do MODFIELD^PRODUKT(PRNr,"303","",1,"S-PPL (WH)")
 . Do MODFIELD^PRODUKT(PRNr,"304","",1,"S-korting% (WH)")
 . Do MODFIELD^PRODUKT(PRNr,"306","",1,"S-DB% (WH)")
 . Do MODFIELD^PRODUKT(PRNr,"307","",1,"S-Cif% (WH)")
 . Do MODFIELD^PRODUKT(PRNr,"326","",1,"S-Cor.fakt.(WH)")
 . Do MODFIELD^PRODUKT(PRNr,"203","",1,"S-Munt (WH)")
 .Do RECALC^PRODUKT2(PRNr)
 Lock -^KPR(PRNr)
 Quit
 
CHECK() Quit:'$L($G(B("J"))) 0
 If +SCif=+Cif,+SKort=+Kort,+SPPL=+PPL,CifPPL=SCifPPL Quit 0 
 If SelType="D",CifPPL<SCifPPL Quit 0 
 If SelType="S",CifPPL>SCifPPL Quit 0 
 Quit 1
 
T1 ;710;@FMTU,"Kenmerk";735;"Huidig";754;"Schaduw",@FMTu      
T2 ;910;"PPL";930;$$EXTNUM^vhDTyp(PPL,11,"",2)," ",Munt,"/",$P(B("J"),D,28);950;$$EXTNUM^vhDTyp(SPPL,11,"",2)," ",SMunt,"/",$P(B("J"),D,28)
T3 ;1010;"Korting%";1030;$$EXTNUM^vhDTyp(Kort,11,"",2);1050;$$EXTNUM^vhDTyp(SKort,11,"",2)
T4 ;1110;"Cif%";1130;$$EXTNUM^vhDTyp(Cif,11,"",2);1150;$$EXTNUM^vhDTyp(SCif,11,"",2)
T5 ;1210;"CifPPL";1230;$$EXTNUM^vhDTyp(CifPPL,11,"",2)," EUR";1250;$$EXTNUM^vhDTyp(SCifPPL,11,"",2)," EUR  "_$S("SD"[SelType:"",CifPPL>SCifPPL:"(Dalend)",1:"(Stijgend)")
T6 ;1410;"Cor.faktor";1430;$$EXTNUM^vhDTyp(CorFakt,11,"",2);1450;@FMTB,$$EXTNUM^vhDTyp(SCorFakt,11,"",2),@FMTb
T7 ;1510;"DB%";1530;$$EXTNUM^vhDTyp(Winst,11,"",2);1550;@FMTB,$$EXTNUM^vhDTyp(SWinst,11,"",2),@FMTb
T8 ;1610;"Lijstprijs";1630;$$EXTNUM^vhDTyp(LijstNA,11,"",2)," EUR";1650;$$EXTNUM^vhDTyp(SLijstNA,11,"",2)," EUR"
T9 ;1710;"Vork%";1730;$$EXTNUM^vhDTyp($P(B("J"),D,27),11,"",2);1750;$$EXTNUM^vhDTyp($S($P(B(3),D,5)="":$P(B("J"),D,27),1:$P(B(3),D,5)),11,"",2)
 
SHOW Set FP=301 Write @F,@F1
 Set FP=402 Write @F,"Identnummer : ",$P(B(3),D,25)
 Set FP=504 Write @F,"Korttekst : ",$P(B(1),D,1)
 For I=1:1 Set R=$T(@("T"_I)) Quit:'$L(R)  Do
 .For J=2:2:7 Set FP=$P(R,";",J) Write @F,@$P(R,";",J+1)
 Set FP=1902 Write @F,"Opmerking : Een kleine afwijking in de lijstprijs is toegelaten, omdat",!,"             het DB% wordt opgeslagen met 4 cijfers na de komma"
 Set FP=2102 Write:MuntPar'=SMuntPar @F,@FMTB,"Belangrijk: De schaduw muntpariteit verschilt van de huidige muntpariteit",@FMTb
 Quit