PRUCALC ;Tijdelijk 13/8/97 Herekenen van de prijsuitzonderingen voor een produkt zodat de verkoopprijs voor die klant gelijk blijft [ 11/06/2001  3:49 PM ]
 If '$D(Q) Set Q="K" Do ^cA604,INIT^vhTERMINA
 Set %J=$$%J^vhRtn1()
 Write @F11,@F1,@FMTI," Schaduw : Terugrekenen prijsuitzondering - "_QN," ",@FMTi
 Write !!,"Dit programma gaat gebruik makend van de nieuwe aankoopprijs"
 Write !,"ingevuld in de schaduw gegevens, de prijsuitzondering aanpassen"
 Write !,"zodat de verkoopprijs voor die klant behouden blijft."
 Set BepKLNr=$$SELECT^KLANT6(1,,"Beperking op klant (- = ALLE) : ")
 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="-"
 .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
 .;Verwijderen uitzonderingen op subgroep of lager
 .S KLNr="",(KHS,KGS,KSS,KT)=""
 .For  Set KLNr=$O(^KLPUTZ("S",KLNr)) Q:KLNr=""  Do:'BepKLNr!(BepKLNr=KLNr)
 ..F  S KHS=$O(^KLPUTZ("S",KLNr,KHS)) Quit:KHS=""  Do
 ...Quit:KHS'=HG&(KHS']HG)  Quit:KHS'=HGX&(KHS]HGX)
 ...F  S KGS=$O(^KLPUTZ("S",KLNr,KHS,KGS)) Quit:KGS=""  Do
 ....Quit:KGS'=GR&(KGS']GR)  Quit:KGS'=GRX&(KGS]GRX)
 ....F  S KSS=$O(^KLPUTZ("S",KLNr,KHS,KGS,KSS)) Quit:KSS=""  Do
 .....Quit:KSS'=SG&(KSS']SG)  Quit:KSS'=SGX&(KSS]SGX)
 .....Set PRNr=""
 .....F  S PRNr=$O(^KLPUTZ("S",KLNr,KHS,KGS,KSS,PRNr)) Quit:PRNr=""  Do
 ......Kill ^KLPUTZ("S",KLNr,KHS,KGS,KSS,PRNr),^KLPUTZ("IS",KHS,KGS,KSS,PRNr,KLNr)
 .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)
 .....Quit:$P(^KPR(PRNr,1),D,25)  ; non-akt
 .....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(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")
 Kill ^HULP(%J)
 Quit
 
 ;Vul alle shaduwuitzonderingen in volgens de huidige prijszetting van een klant
KLANT(KLNr)
 ; Huidige prijs in als schaduw uitzondering opslaan, zodanig dat de klant na overzetting van de nieuwe aankoopprijzen dezelfde prijs blijft betalen als nu.
 ;Set FromNoSa="N" 
 ;Set ToNoSa="S"
 ; Nieuwe schaduw prijs als huidige uitzondering opslaan zodanig dat de klant nu reeds de nieuwe prijs betaald
 Set FromNoSa="S" 
 Set ToNoSa="N"
 If '$G(KLNr) Set KLNr=$$SELECT^KLANT6()
 Do DELOBJ^KLPUTZ(KLNr,ToNoSa)
 Set PRNr=0
 For  Set PRNr=$O(^KSTKL(KLNr,PRNr)) Quit:PRNr=""  Do
 . Quit:'$D(^KPR(PRNr))
 . Quit:$$ISORGAL^ORGALUX(PRNr)
 . Set Korting=$$BepaalKorting(KLNr,PRNr,FromNoSa,ToNoSa)
 . Do SetUitzondering(KLNr,PRNr,Korting,ToNoSa)
 Quit
 
 ; Opslaan van shaduw uitzondering
SetUitzondering(KLNr,PRNr,Korting,ToNoSa)
 New KHS,KGS,KSS
 Set RecI=$O(^KPR(PRNr,"I"))
 Quit:$E(RecI)'="I"
 Set RecI=^KPR(PRNr,RecI)
 Set KHS=$P(RecI,D,1)
 Set KGS=$P(RecI,D,2)
 Set KSS=$P(RecI,D,3)
 w PRNr," ",$P(^KPR(PRNr,0),"\")," ",Korting,!
 
 Set ^KLPUTZ(ToNoSa,KLNr,KHS,KGS,KSS,PRNr,0)=Korting_D_D_"System"_D_PRNr
 Set ^KLPUTZ("I"_ToNoSa,KHS,KGS,KSS,PRNr,KLNr)=""
 Quit
 
 ; Bepalen van de schaduwkorting zodanig dat de huidige prijs wordt bereikt
BepaalKorting(KLNr,PRNr,FromNoSa,ToNoSa)
 Set FromPrijs=$$KLANTPR^KPRIJS(KLNr,PRNr,FromNoSa)
 Set ToRec=$$PRIJSGEG^KPRIJS(PRNr,ToNoSa)
 Set LijstPrijs=$P(ToRec,D,15) ; Lijstprijs in EUR/st
 Set VerkoopPrijs=$P(FromPrijs,D,14) ; Verkoopprijs in EUR/st
 Quit:+LijstPrijs=0 0
 Set Korting=1-(VerkoopPrijs/LijstPrijs)
 Set Korting=+$J(Korting*100,0,12)
 Quit Korting
 
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
 Set SelType="B"
 Set Store=$G(Store)
 Do CALC
 Quit
 
CALC Do FETCH
 Set Verschil=$$CHECK()
 If 'Verschil,SelType'="B" Quit
 Kill ^HULP(%J)
 Set VolgNr=0,Cnt=0
 For  Set VolgNr=$O(^AKANAL(PRNr,VolgNr)) Quit:VolgNr=""  Do
 .Set KLNr=$P(^AKANAL(PRNr,VolgNr),D,2)
 .Set Rec=$$CALCKL(PRNr,KLNr)
 .Set:$L(Rec) Cnt=Cnt+1,^HULP(%J,Cnt)=Rec
 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=R
 Else  Quit:'Verschil
 If SelType'="B",Store="-" Set PRNr="ZZZZZ"
 Do PUTSCHAD:Store="S"!(Store="s")
 Do PUTHUID:Store="H"!(Store="h")
 Quit
 
CALCKL(PRNr,KLNr) ; Herrekenen klant
 Quit:'$D(^KK1(KLNr)) ""
 Quit:'('BepKLNr!(BepKLNr=KLNr)) "" ; Indien beperkt tot bep. klant
 W KLNr
 Set Munt=$P(^KKL(^KK1(KLNr),0),D,11)
 ; Tijdelijk 22-08-97 
 Set NwReg=$P(^KKL(^KK1(KLNr),0),D,20)
 ;Quit:'(NwReg>0&(NwReg<4)!(NwReg=8)) "" ; alleen IndPool
 ;Quit:$P(^KKL(^KK1(KLNr),1),D,25)=1 ""; Handels partners
 Set KlantTyp=$P(^(1),D,25)
 Set IsBruto=$P(^(2),D,5)
 Set KLNaam=$P(^(0),D,2)
 Set Codex=$P(^(2),D,3)
 Set SCodex=$P(^(2),D,25)
 Set:SCodex="" SCodex=Codex
 Set HRec=$$KLANTPR^KPRIJS(KLNr,PRNr)
 Set SRec=$$KLANTPR^KPRIJS(KLNr,PRNr,"S")
 Set Kort=$S($P(SRec,D,4):1-($P(HRec,D,1)/$P(SRec,D,4))*100,1:0)
 ; Handel moet gelijk zijn aan codex
 ;If IsBruto,Kort<(SVork*$P("0;1;.75;.5;.25;0",";",$F("GBSRL",Codex))) Set Kort=Vork*$P("0;1;.75;.5;.25;0",";",$F("GBSRL",Codex))
 ;Korting op L, R, S, B of G zetten
 ;If Kort<30,Kort>22.5 S Kort=30
 ;If Kort<22.5,Kort>15 S Kort=22.5
 ;If Kort<15,Kort>7.5 S Kort=15
 ;If Kort<7.5,Kort>0 S Kort=7.5
 Set Spec=""
 ; Geen negatieve korting
 ;If Kort<0 S Spec="Boven LP "_$J(Kort,0,2),Kort=0,^PVCALC(KLNr,PRNr)="D"
 ; Niet verkopen onder de aankoopprijs + 10%
 Set MaxKort=99
 Set:$P(SRec,D,15) MaxKort=+$J(1-($P(SRec,D,13)*1.1/$P(SRec,D,15))*100,0,2)
 ;If MaxKort<Kort Set Spec="Onder AKP "_$J(Kort,0,2),Kort=MaxKort,^PVCALC(KLNr,PRNr)="S"
 If $L($P(^KPR(PRNr,1),D,19)) Set Spec="KATPrijs "_Spec
 ; Proberen van de korting af te ronden
 For I=0,1,2,12 Do  Quit:$P(HRec,D,1)=$P(NRec,D,1)
 .If IsBruto,I=12 Quit
 .Set Kort1=Kort*(10**I)+.9999\1/(10**I),Kort2=0
 .Set:Kort>SVork Kort1=SVork,Kort2=1-((100-Kort)/(100-Kort1))*100*(10**I)+.9999\1/(10**I) 
 .Set NRec=$$PROD^KPRIJS(PRNr,Kort1,Kort2,Munt,IsBruto,KlantTyp,"S")
 Set Copy=1
 If +Kort1=+(SVork*$P("0;1;.75;.5;.25;0",";",$F("GBSRL",Codex))),'Kort2,'$D(^KLPUTZ("N",KLNr,KHS)) Set Copy=0
 Quit KLNr_D_KLNaam_D_$P(HRec,D,5,6)_D_Codex_D_Kort1_D_Kort2_D_Munt_D_KlantTyp_D_IsBruto_D_$P(^AKANAL(PRNr,VolgNr),D,4)_D_Copy_D_Spec
 
FETCH Do FETCHPR^UTILI(PRNr)
 Set KHS=$P(B("I"),D,1)
 Set KGS=$P(B("I"),D,2)
 Set KSS=$P(B("I"),D,3)
 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 Vork=$P(B("J"),D,27)
 Set Winst=$P(B("J"),D,24)
 Set Munt=$P(B("J"),D,17)
 Set MuntPar=$$MUNT^vhRtn1(Munt,,11)
 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 SWinst=$P(B(3),D,6) Set:SWinst="" SWinst=Winst
 Set SVork=$P(B(3),D,5) Set:SVork="" SVork=Vork
 Set CifPPL=PPL*MuntPar/GOrde*(100-Kort/100)*(100+Cif/100)
 Set SCifPPL=SPPL*MuntPar/GOrde*(100-SKort/100)*(100+SCif/100)
 Set LijstNA=CifPPL/(100-Winst/100) ;Niet afgeronde
 Set SLijstNA=SCifPPL/(100-SWinst/100) ;Niet afgeronde 
 Quit 
 
PUTSCHAD 
 For VolgNr=1:1:$O(^HULP(%J,""),-1) Do
 .Set Rec=^HULP(%J,VolgNr)
 .Quit:'$P(Rec,D,12)
 .Set KLNr=$P(Rec,D,1)
 .Set ^KLPUTZ("S",KLNr,KHS,KGS,KSS,PRNr,0)=$P(Rec,D,6)_D_$P(Rec,D,7)_D_$P(Rec,D,13)
 .Set ^KLPUTZ("IS",KHS,KGS,KSS,PRNr,KLNr)=""
 Quit
 
PUTHUID New Key
 w *7 Do TXT^vhINP("Opslaan als huidig nog niet geimplementeerd") Quit
 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
 .Set $P(^KPR(PRNr,Key),D,24)=SWinst
 .Set $P(^KPR(PRNr,Key),D,9)=SKort
 .Set $P(^KPR(PRNr,Key),D,19)=SPPL
 .Set $P(^KPR(PRNr,Key),D,21)=SCif
 .Set $P(^KPR(PRNr,2),D,3)=""
 .Set $P(^KPR(PRNr,2),D,4)=""
 .Set $P(^KPR(PRNr,2),D,6)=""
 .Set $P(^KPR(PRNr,2),D,7)=""
 .Do RECALC^PRODUKT2(PRNr)
 Lock -^KPR(PRNr)
 Quit
 
CHECK() Quit 1  Quit:'$L($G(B("J"))) 0
 If +SCif=+Cif,+SKort=+Kort,+SPPL=+PPL,+Winst=+SWinst Quit 0 
 If SelType="D",LijstNA<SLijstNA Quit 0 
 If SelType="S",LijstNA>SLijstNA Quit 0 
 Quit 1
 
SHOW Set FP=301 Write @F,@F1
 Set FP=408 Write @F,"Identnummer : ",$P(B(3),D,25)
 Set FP=510 Write @F,"Korttekst : ",$P(B(1),D,1)
 Set HRec=$$PROD^KPRIJS(PRNr,0,0,"","","","N")
 Set FP=601 Write @F,"Huidige lijstprijs :",$TR($FN($P(HRec,D,1),",",2),".,",",."),$S($P(HRec,D,3)="H":"%",1:"")
 Set SRec=$$PROD^KPRIJS(PRNr,0,0,"","","","S")
 Set FP=641 Write @F,"Schaduw lijstprijs :",$TR($FN($P(SRec,D,1),",",2),".,",",."),$S($P(SRec,D,3)="H":"%",1:"")
 If '$D(^HULP(%J)) Do  Quit
 .Do TXT^vhINP("Geen klanten gevonden die dit produkt kopen !")
 .S R=""
 Set FP=2401 Write @F,"[] = Mark, N = Niet opslaan, S = in schaduw, H = als huidig, ",$S(SelType'="B":"- = naar menu",1:"")
 Do INIT^PROC("PRUCALC")
 Do WL^PROC
 For  Do  Quit:$L(R)&("NHS-"[R)
 .Do SL^PROC
 .If R="ENTER" Do 
 ..Set Lijn=@DL(1)@(6),$P(^HULP(%J,Lijn),D,12)='$P(^HULP(%J,Lijn),D,12)
 ..Do:Lijn=@DL(1)@(9) EL^PROC
 ..If Lijn<@DL(1)@(9) Set DL(2)="DO" Do ML^PROC Kill DL(2)
 Quit