ABSPOSQP ; IHS/FCS/DRS - SGM 05:46 PM 20 Jan 1997 ; [ 09/12/2002 10:18 AM ]
;;1.0;PHARMACY POINT OF SALE;**3,12,40**;JUN 21, 2001;Build 38
; Entry points:
; EN called from ABSPOSQB from ABSPOSQ1
; PAGE7 called from ABSPOSI7
;
;----------------------------------------------------------------------
;IHS/SD/lwj 3/1/05 patch 12
; Puyallup noticed that the calculation for determining the price
; differed between the original claim and the "new" claim. Pam and
; Carlene authorized the logic to be altered to be consistent between
; the two. Need to check for zero and null, not just null.
;----------------------------------------------------------------------
Q
EN ;EP - PRICING ; called from ABSPOSQB
;
; Need lots of stuff set up
; including ABSBRXI,ABSBRXR,ABSBNDC,INSURER
; Set up lots of variables:
; DRGDFN,DRGNAME
; PROVDFN,PROV
; PRICING,PRICALC
; where PRICING=qty^unit price^subtotal^disp fee^total^^incentive amount
; (Not necessarily rounded off until "total")
; Stores PRICING in the ^ABSPT(ABSBRXI,5) for you.
;
N DRGDFN S DRGDFN=ABSBDRGI
S DRGNAME=$P($G(^PSDRUG(DRGDFN,0)),U,1) ; (DRUG,GENERIC NAME)
I DRGNAME="" S DRGNAME="Missing ^PSDRUG("_DRGDFN_")"
S PROVDFN=$P($G(^PSRX(ABSBRXI,0)),U,4) ; (PRESCRIPTION,PROVIDER)
I PROVDFN S PROV=$P($G(^VA(200,PROVDFN,0)),U,1)
E S PROV=""
I PROV="" S PROV="Missing ^VA(200,"_PROVDFN_")"
D PRICING()
Q
METHNUM() ; pricing method number
N METHOD S METHOD=0
I INSURER S METHOD=$P($G(^ABSPEI(INSURER,100)),U,6)
I 'METHOD S METHOD=1
Q METHOD
METHOD() ; what pricing method to use?
; point to an entry in 9002313.53 and return the zero node
Q $G(^ABSP(9002313.53,$$METHNUM,0))
GETAWP() ; Given ABSBNDC, get AWP-MED TRANSACTION file's avg. wholesale price
I ABSBNDC="" Q "" ; should never happen, in theory, but it does
N X S X=$O(^APSAMDF("B",ABSBNDC,0))
I X Q $P($G(^APSAMDF(X,0)),U,3)
E Q ""
GETAWPPD() ; Given DRGDFN
Q $P($G(^PSDRUG(DRGDFN,999999931)),U,2) ; AWP PER DISP UNIT field
GETPPDU() ; Given DRGDFN
Q $P($G(^PSDRUG(DRGDFN,660)),U,6) ; PRICE PER DISPENSE UNIT
GETCPTRT() ; Given DRGDFN, try to find it in the CHARGE file RATE field
N CPTDFN S CPTDFN=$O(^ABSCPT(9002300,"AVMED",DRGDFN,0))
I 'CPTDFN Q ""
Q $P($G(^ABSCPT(9002300,CPTDFN,0)),U,5)
GETPSRXA() ; get unit price from ^PSRX prescription file, AWP field
I '$G(ABSBRXR) Q $P($G(^PSRX(ABSBRXI,9999999)),U,6)
E Q $P($G(^PSRX(ABSBRXI,1,ABSBRXR,9999999)),U,6)
GETPSRXU() ; get unit price from ^PSRX prescription file
I '$G(ABSBRXR) Q $P(^PSRX(ABSBRXI,0),U,17)
Q $P(^PSRX(ABSBRXI,1,ABSBRXR,0),U,11)
UNITPRI() ; unit price ; NOT ROUNDED!!!
; KEEP UNITPRI1() BASICALLY THE SAME AS UNITPRI!!
; If one method fails, others might be tried
N X,Y ; METHOD already set up by caller
S Y=$P(METHOD,U,2),X=""
I Y="APSAMDF" S X=$$GETAWP
I Y="PSDRUG-AWPPDU" S X=$$GETAWPPD
I Y="PSDRUG-PPDU" S X=$$GETPPDU
I Y="PSRX-AWP" S X=$$GETPSRXA
I Y="PSRX-UNIT" S X=$$GETPSRXU
I Y="ABSCPT" S X=$$GETCPTRT
; If primary method failed, try all the others, finally default to $1
I 'X S X=$$GETAWP ; these are in order of priority, from highest...
I 'X S X=$$GETAWPPD
I 'X S X=$$GETPSRXA
I 'X S X=$$GETPSRXU
I 'X S X=$$GETPPDU
I 'X S X=$$GETCPTRT ; ... to lowest
I 'X S X=1.001 ; just stuff this price for now
I $P(METHOD,U,3)="STEP" S X=$$STEP(X)
; E it must be ="LINEAR"
Q X
UNITPRI1() ; same as UNITPRI except retval is price^method
N X,Y ; caller already set up method
S Y=$P(METHOD,U,2)
S X=$$UNITPRI2(Y) ; try the primary method first
; and if it failed, try all the other methods, in order
;IHS/SD/lwj 3/1/05 patch 12 - nxt seven lines remkd out
; following 7 lines added. Logic altered to match the
; calculation of price for the original claim - need to
; check for zero and null - not just null.
;
;I X="" S X=$$UNITPRI2("APSAMDF")
;I X="" S X=$$UNITPRI2("PSDRUG-AWPPDU")
;I X="" S X=$$UNITPRI2("PSDRUG-PPDU")
;I X="" S X=$$UNITPRI2("PSRX-AWP")
;I X="" S X=$$UNITPRI2("PSRX-UNIT")
;I X="" S X=$$UNITPRI2("ABSCPT")
;I X="" S X=$$UNITPRI2("")
;
I 'X S X=$$UNITPRI2("APSAMDF")
I 'X S X=$$UNITPRI2("PSDRUG-AWPPDU")
I 'X S X=$$UNITPRI2("PSDRUG-PPDU")
I 'X S X=$$UNITPRI2("PSRX-AWP")
I 'X S X=$$UNITPRI2("PSRX-UNIT")
I 'X S X=$$UNITPRI2("ABSCPT")
I 'X S X=$$UNITPRI2("")
;
Q X
UNITPRI2(Y) ; given Y = method,
; return unit price ^ method,
; or return "" if price not found using that method
I Y="APSAMDF" S X=$$GETAWP
E I Y="PSDRUG-AWPPDU" S X=$$GETAWPPD
E I Y="PSDRUG-PPDU" S X=$$GETPPDU
E I Y="PSRX-AWP" S X=$$GETPSRXA
E I Y="PSRX-UNIT" S X=$$GETPSRXU
E I Y="ABSCPT" S X=$$GETCPTRT
E I Y="" S Y="NOT FOUND",X=1.01 ; hardcode desperation default of $1.01 per unit
E D IMPOSS^ABSPOSUE("DB,P","TI","No match on price source "_Y,,"UNITPRI2",$T(+0))
Q $S(X="":"",1:X_U_Y)
STEP(X) ; INCOMPLETE!!!! deal with step formula in 9002313.53
D IMPOSS^ABSPOSUE("DB,P","TI","STEP formulas not implemented",,"STEP",$T(+0))
Q
; This is what Cherokee will want to have
;S PRICALC=PRICALC_"$$STEP("_X_")="
; then compute it
;S PRICALC=PRICALC_result
;S PRICALC=PRICALC_";"
;Q retval
PRICING() ; compute the price - want to integrate with $$UNITPRI
S PRICALC="" ; side effect - sets PRICALC
N METHOD S METHOD=$$METHOD ; pricing method data
; METHOD = name^unit price source^formula^multiplier^disp fee
N QTY S QTY=$$QTY I QTY'=1 S PRICALC=PRICALC_QTY
N UNITPRI S UNITPRI=$$UNITPRI S PRICALC=PRICALC_"*"_UNITPRI
N MULTIP S MULTIP=$P(METHOD,U,4) S:'MULTIP MULTIP=1
I MULTIP'=1 S UNITPRI=UNITPRI*MULTIP,PRICALC=PRICALC_"*"_MULTIP
N DISPFEE S DISPFEE=$$DISPFEE I DISPFEE S PRICALC=PRICALC_"+"_DISPFEE
;IHS/OIT/SCR 11/20/08 ADD INCENTIVE AMOUNT SUBMITTED TO PRICING
N ABSPINCN S ABSPINCN=0 S PRICALC=PRICALC_"+"_ABSPINCN
;N X S X=$$ROUND(UNITPRI*QTY+DISPFEE) S PRICALC=PRICALC_"="_X
N X S X=$$ROUND(UNITPRI*QTY+DISPFEE+ABSPINCN) S PRICALC=PRICALC_"="_X
S PRICING=QTY_U_UNITPRI_U_(QTY*UNITPRI)_U_DISPFEE_U_X
S PRICING=PRICING_U_U_ABSPINCN ;IHS/OIT/SCR 11/20/08
S ^ABSPT(IEN59,5)=PRICING
Q:$Q X Q
IEN59() Q ABSBRXI_"."_$TR($J(ABSBRXR,4)," ","0")_"1"
ROUND(X) Q X*100+.5\1/100 ; round to the nearest cent
QTY() ; given ABSBRXI, ABSBRXR
I $G(ABSBRXR) Q $P($G(^PSRX(ABSBRXI,1,ABSBRXR,0)),U,4) ; REFILL,QTY
Q $P($G(^PSRX(ABSBRXI,0)),U,7) ; QTY
DISPFEE() ;
N FEE
; First, see if we have a dispensing fee for this e-insurer.
I INSURER D I FEE]"" Q FEE
. S FEE=$P($G(^ABSPEI(INSURER,100)),U,2)
;
; Default is in PEC/MIS - Setup file
; No, I guess there's none in there.
;
; There may be one in METHOD
S FEE=$P($$METHOD,U,5) I FEE]"" Q FEE
;
; Next, we look in the BILLING SETUP file.
; Now there's a multiple on RX2 that varies the fee depending on cost.
; Ignore that for now, just take the constant value.
;
S FEE=$P($G(^ABSSETUP(9002314,1,"RX")),U) ;RX MARKUP field
I FEE]"" Q FEE
; Can't come up with a fee, just say zero for now.
Q 0
PAGE7 ;EP - called from ABSPOSI7 - pop-up page for pricing
; want to set some defaults
I ^TMP("DDS",$J,$P(DDS,U),"F9002313.512",DDSDA,.02,"D")="" S DDSERROR=299 Q ;IHS/OIT/CNI/SCR patch 40 avoid undefined when user saves blank RX
N INSURER,ABSBRXI,ABSBRXR,DRGDFN,METHOD,ABSBNDC
S INSURER=$$GET^DDSVAL(DIE,.DA,7.01)
S ABSBRXI=$$GET^DDSVAL(DIE,.DA,1.01)
I ABSBRXI="" D Q ; special case: CPT code, not a prescription drug
. N CPTIEN S CPTIEN=$$GET^DDSVAL(DIE,.DA,1.08)
. I 'CPTIEN D IMPOSS^ABSPOSUE("DB,P","TI","code for supply item is not yet here? should be",,"PAGE7",$T(+0))
. ; must have CPTIEN by now ?!
. I $$GET^DDSVAL(DIE,.DA,5.01)="" D PUT^DDSVAL(DIE,.DA,5.01,1)
. I $$GET^DDSVAL(DIE,.DA,5.02)="" D
. . N PRICE S PRICE=$P(^ABSCPT(9002300,CPTIEN,0),U,5)
. . I PRICE="" D Q
. . . D PUT^DDSVAL(DIE,.DA,5.03,"")
. . . D PUT^DDSVAL(DIE,.DA,5.04,"")
. . . D PUT^DDSVAL(DIE,.DA,5.05,"")
. . E D
. . . D PUT^DDSVAL(DIE,.DA,5.02,PRICE)
. . . D PUT^DDSVAL(DIE,.DA,5.04,0)
. . . D PUT^DDSVAL(DIE,.DA,5.06,"ABSCPT",,"I")
. . . D RECALC1^ABSPOSI7
S ABSBRXR=$$GET^DDSVAL(DIE,.DA,1.02)
S METHOD=$$METHOD
S DRGDFN=$$GET^DDSVAL(DIE,.DA,1.03)
S ABSBNDC=$$GET^DDSVAL(DIE,.DA,.03)
I ABSBNDC["-" S ABSBNDC=$$MAKE11N^ABSPOS9(ABSBNDC)
D PUT^DDSVAL(DIE,.DA,5.01,$$QTY)
N X S X=$$UNITPRI1 ; price^source
D PUT^DDSVAL(DIE,.DA,5.02,$$ZEROES($P(X,U)))
D PUT^DDSVAL(DIE,.DA,5.04,$J($$DISPFEE,0,2))
D PUT^DDSVAL(DIE,.DA,5.06,$P(X,U,2),,"I")
;IHS/OIT/SCR 11/20/08 add INCENTIVE AMOUNT
N ABSPINCT
S ABSPINCT=$$GET^DDSVAL(DIE,.DA,5.07)
I ABSPINCT="" S ABSPINCT=0
D PUT^DDSVAL(DIE,.DA,5.07,$$ZEROES(ABSPINCT))
;IHS/OIT/SCR 11/19/08 END CHANGES
D RECALC1^ABSPOSI7 ; do the math
Q
ZEROES(X) ; strip leading and trailing zeroes, and "." if not needed
F Q:$E(X)'="0" S X=$E(X,2,$L(X))
I X["." D
. F Q:$E(X,$L(X))'="0" S X=$E(X,1,$L(X)-1)
I $E(X,$L(X))="." S X=$E(X,1,$L(X))
Q X
NEWENTRY ;EP - this is called by ENTRY ACTION of option ABSP SETUP PRICING
N COUNT S COUNT=$P(^ABSP(9002313.53,0),U,4)
W !!,"At this time, you have "
I COUNT=1 D
. W "only the STANDARD pricing formula.",!
E D
. W COUNT," pricing formulas on file.",!
. D ASK^ABSPOSS3 ; "Do you want to see a list?"
Q
ABSPOSQP ; IHS/FCS/DRS - SGM 05:46 PM 20 Jan 1997 ; [ 09/12/2002 10:18 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**3,12,40**;JUN 21, 2001;Build 38
+2 ; Entry points:
+3 ; EN called from ABSPOSQB from ABSPOSQ1
+4 ; PAGE7 called from ABSPOSI7
+5 ;
+6 ;----------------------------------------------------------------------
+7 ;IHS/SD/lwj 3/1/05 patch 12
+8 ; Puyallup noticed that the calculation for determining the price
+9 ; differed between the original claim and the "new" claim. Pam and
+10 ; Carlene authorized the logic to be altered to be consistent between
+11 ; the two. Need to check for zero and null, not just null.
+12 ;----------------------------------------------------------------------
+13 QUIT
EN ;EP - PRICING ; called from ABSPOSQB
+1 ;
+2 ; Need lots of stuff set up
+3 ; including ABSBRXI,ABSBRXR,ABSBNDC,INSURER
+4 ; Set up lots of variables:
+5 ; DRGDFN,DRGNAME
+6 ; PROVDFN,PROV
+7 ; PRICING,PRICALC
+8 ; where PRICING=qty^unit price^subtotal^disp fee^total^^incentive amount
+9 ; (Not necessarily rounded off until "total")
+10 ; Stores PRICING in the ^ABSPT(ABSBRXI,5) for you.
+11 ;
+12 NEW DRGDFN
SET DRGDFN=ABSBDRGI
+13 ; (DRUG,GENERIC NAME)
SET DRGNAME=$PIECE($GET(^PSDRUG(DRGDFN,0)),U,1)
+14 IF DRGNAME=""
SET DRGNAME="Missing ^PSDRUG("_DRGDFN_")"
+15 ; (PRESCRIPTION,PROVIDER)
SET PROVDFN=$PIECE($GET(^PSRX(ABSBRXI,0)),U,4)
+16 IF PROVDFN
SET PROV=$PIECE($GET(^VA(200,PROVDFN,0)),U,1)
+17 IF '$TEST
SET PROV=""
+18 IF PROV=""
SET PROV="Missing ^VA(200,"_PROVDFN_")"
+19 DO PRICING()
+20 QUIT
METHNUM() ; pricing method number
+1 NEW METHOD
SET METHOD=0
+2 IF INSURER
SET METHOD=$PIECE($GET(^ABSPEI(INSURER,100)),U,6)
+3 IF 'METHOD
SET METHOD=1
+4 QUIT METHOD
METHOD() ; what pricing method to use?
+1 ; point to an entry in 9002313.53 and return the zero node
+2 QUIT $GET(^ABSP(9002313.53,$$METHNUM,0))
GETAWP() ; Given ABSBNDC, get AWP-MED TRANSACTION file's avg. wholesale price
+1 ; should never happen, in theory, but it does
IF ABSBNDC=""
QUIT ""
+2 NEW X
SET X=$ORDER(^APSAMDF("B",ABSBNDC,0))
+3 IF X
QUIT $PIECE($GET(^APSAMDF(X,0)),U,3)
+4 IF '$TEST
QUIT ""
GETAWPPD() ; Given DRGDFN
+1 ; AWP PER DISP UNIT field
QUIT $PIECE($GET(^PSDRUG(DRGDFN,999999931)),U,2)
GETPPDU() ; Given DRGDFN
+1 ; PRICE PER DISPENSE UNIT
QUIT $PIECE($GET(^PSDRUG(DRGDFN,660)),U,6)
GETCPTRT() ; Given DRGDFN, try to find it in the CHARGE file RATE field
+1 NEW CPTDFN
SET CPTDFN=$ORDER(^ABSCPT(9002300,"AVMED",DRGDFN,0))
+2 IF 'CPTDFN
QUIT ""
+3 QUIT $PIECE($GET(^ABSCPT(9002300,CPTDFN,0)),U,5)
GETPSRXA() ; get unit price from ^PSRX prescription file, AWP field
+1 IF '$GET(ABSBRXR)
QUIT $PIECE($GET(^PSRX(ABSBRXI,9999999)),U,6)
+2 IF '$TEST
QUIT $PIECE($GET(^PSRX(ABSBRXI,1,ABSBRXR,9999999)),U,6)
GETPSRXU() ; get unit price from ^PSRX prescription file
+1 IF '$GET(ABSBRXR)
QUIT $PIECE(^PSRX(ABSBRXI,0),U,17)
+2 QUIT $PIECE(^PSRX(ABSBRXI,1,ABSBRXR,0),U,11)
UNITPRI() ; unit price ; NOT ROUNDED!!!
+1 ; KEEP UNITPRI1() BASICALLY THE SAME AS UNITPRI!!
+2 ; If one method fails, others might be tried
+3 ; METHOD already set up by caller
NEW X,Y
+4 SET Y=$PIECE(METHOD,U,2)
SET X=""
+5 IF Y="APSAMDF"
SET X=$$GETAWP
+6 IF Y="PSDRUG-AWPPDU"
SET X=$$GETAWPPD
+7 IF Y="PSDRUG-PPDU"
SET X=$$GETPPDU
+8 IF Y="PSRX-AWP"
SET X=$$GETPSRXA
+9 IF Y="PSRX-UNIT"
SET X=$$GETPSRXU
+10 IF Y="ABSCPT"
SET X=$$GETCPTRT
+11 ; If primary method failed, try all the others, finally default to $1
+12 ; these are in order of priority, from highest...
IF 'X
SET X=$$GETAWP
+13 IF 'X
SET X=$$GETAWPPD
+14 IF 'X
SET X=$$GETPSRXA
+15 IF 'X
SET X=$$GETPSRXU
+16 IF 'X
SET X=$$GETPPDU
+17 ; ... to lowest
IF 'X
SET X=$$GETCPTRT
+18 ; just stuff this price for now
IF 'X
SET X=1.001
+19 IF $PIECE(METHOD,U,3)="STEP"
SET X=$$STEP(X)
+20 ; E it must be ="LINEAR"
+21 QUIT X
UNITPRI1() ; same as UNITPRI except retval is price^method
+1 ; caller already set up method
NEW X,Y
+2 SET Y=$PIECE(METHOD,U,2)
+3 ; try the primary method first
SET X=$$UNITPRI2(Y)
+4 ; and if it failed, try all the other methods, in order
+5 ;IHS/SD/lwj 3/1/05 patch 12 - nxt seven lines remkd out
+6 ; following 7 lines added. Logic altered to match the
+7 ; calculation of price for the original claim - need to
+8 ; check for zero and null - not just null.
+9 ;
+10 ;I X="" S X=$$UNITPRI2("APSAMDF")
+11 ;I X="" S X=$$UNITPRI2("PSDRUG-AWPPDU")
+12 ;I X="" S X=$$UNITPRI2("PSDRUG-PPDU")
+13 ;I X="" S X=$$UNITPRI2("PSRX-AWP")
+14 ;I X="" S X=$$UNITPRI2("PSRX-UNIT")
+15 ;I X="" S X=$$UNITPRI2("ABSCPT")
+16 ;I X="" S X=$$UNITPRI2("")
+17 ;
+18 IF 'X
SET X=$$UNITPRI2("APSAMDF")
+19 IF 'X
SET X=$$UNITPRI2("PSDRUG-AWPPDU")
+20 IF 'X
SET X=$$UNITPRI2("PSDRUG-PPDU")
+21 IF 'X
SET X=$$UNITPRI2("PSRX-AWP")
+22 IF 'X
SET X=$$UNITPRI2("PSRX-UNIT")
+23 IF 'X
SET X=$$UNITPRI2("ABSCPT")
+24 IF 'X
SET X=$$UNITPRI2("")
+25 ;
+26 QUIT X
UNITPRI2(Y) ; given Y = method,
+1 ; return unit price ^ method,
+2 ; or return "" if price not found using that method
+3 IF Y="APSAMDF"
SET X=$$GETAWP
+4 IF '$TEST
IF Y="PSDRUG-AWPPDU"
SET X=$$GETAWPPD
+5 IF '$TEST
IF Y="PSDRUG-PPDU"
SET X=$$GETPPDU
+6 IF '$TEST
IF Y="PSRX-AWP"
SET X=$$GETPSRXA
+7 IF '$TEST
IF Y="PSRX-UNIT"
SET X=$$GETPSRXU
+8 IF '$TEST
IF Y="ABSCPT"
SET X=$$GETCPTRT
+9 ; hardcode desperation default of $1.01 per unit
IF '$TEST
IF Y=""
SET Y="NOT FOUND"
SET X=1.01
+10 IF '$TEST
DO IMPOSS^ABSPOSUE("DB,P","TI","No match on price source "_Y,,"UNITPRI2",$TEXT(+0))
+11 QUIT $SELECT(X="":"",1:X_U_Y)
STEP(X) ; INCOMPLETE!!!! deal with step formula in 9002313.53
+1 DO IMPOSS^ABSPOSUE("DB,P","TI","STEP formulas not implemented",,"STEP",$TEXT(+0))
+2 QUIT
+3 ; This is what Cherokee will want to have
+4 ;S PRICALC=PRICALC_"$$STEP("_X_")="
+5 ; then compute it
+6 ;S PRICALC=PRICALC_result
+7 ;S PRICALC=PRICALC_";"
+8 ;Q retval
PRICING() ; compute the price - want to integrate with $$UNITPRI
+1 ; side effect - sets PRICALC
SET PRICALC=""
+2 ; pricing method data
NEW METHOD
SET METHOD=$$METHOD
+3 ; METHOD = name^unit price source^formula^multiplier^disp fee
+4 NEW QTY
SET QTY=$$QTY
IF QTY'=1
SET PRICALC=PRICALC_QTY
+5 NEW UNITPRI
SET UNITPRI=$$UNITPRI
SET PRICALC=PRICALC_"*"_UNITPRI
+6 NEW MULTIP
SET MULTIP=$PIECE(METHOD,U,4)
IF 'MULTIP
SET MULTIP=1
+7 IF MULTIP'=1
SET UNITPRI=UNITPRI*MULTIP
SET PRICALC=PRICALC_"*"_MULTIP
+8 NEW DISPFEE
SET DISPFEE=$$DISPFEE
IF DISPFEE
SET PRICALC=PRICALC_"+"_DISPFEE
+9 ;IHS/OIT/SCR 11/20/08 ADD INCENTIVE AMOUNT SUBMITTED TO PRICING
+10 NEW ABSPINCN
SET ABSPINCN=0
SET PRICALC=PRICALC_"+"_ABSPINCN
+11 ;N X S X=$$ROUND(UNITPRI*QTY+DISPFEE) S PRICALC=PRICALC_"="_X
+12 NEW X
SET X=$$ROUND(UNITPRI*QTY+DISPFEE+ABSPINCN)
SET PRICALC=PRICALC_"="_X
+13 SET PRICING=QTY_U_UNITPRI_U_(QTY*UNITPRI)_U_DISPFEE_U_X
+14 ;IHS/OIT/SCR 11/20/08
SET PRICING=PRICING_U_U_ABSPINCN
+15 SET ^ABSPT(IEN59,5)=PRICING
+16 IF $QUIT
QUIT X
QUIT
IEN59() QUIT ABSBRXI_"."_$TRANSLATE($JUSTIFY(ABSBRXR,4)," ","0")_"1"
ROUND(X) ; round to the nearest cent
QUIT X*100+.5\1/100
QTY() ; given ABSBRXI, ABSBRXR
+1 ; REFILL,QTY
IF $GET(ABSBRXR)
QUIT $PIECE($GET(^PSRX(ABSBRXI,1,ABSBRXR,0)),U,4)
+2 ; QTY
QUIT $PIECE($GET(^PSRX(ABSBRXI,0)),U,7)
DISPFEE() ;
+1 NEW FEE
+2 ; First, see if we have a dispensing fee for this e-insurer.
+3 IF INSURER
Begin DoDot:1
+4 SET FEE=$PIECE($GET(^ABSPEI(INSURER,100)),U,2)
End DoDot:1
IF FEE]""
QUIT FEE
+5 ;
+6 ; Default is in PEC/MIS - Setup file
+7 ; No, I guess there's none in there.
+8 ;
+9 ; There may be one in METHOD
+10 SET FEE=$PIECE($$METHOD,U,5)
IF FEE]""
QUIT FEE
+11 ;
+12 ; Next, we look in the BILLING SETUP file.
+13 ; Now there's a multiple on RX2 that varies the fee depending on cost.
+14 ; Ignore that for now, just take the constant value.
+15 ;
+16 ;RX MARKUP field
SET FEE=$PIECE($GET(^ABSSETUP(9002314,1,"RX")),U)
+17 IF FEE]""
QUIT FEE
+18 ; Can't come up with a fee, just say zero for now.
+19 QUIT 0
PAGE7 ;EP - called from ABSPOSI7 - pop-up page for pricing
+1 ; want to set some defaults
+2 ;IHS/OIT/CNI/SCR patch 40 avoid undefined when user saves blank RX
IF ^TMP("DDS",$JOB,$PIECE(DDS,U),"F9002313.512",DDSDA,.02,"D")=""
SET DDSERROR=299
QUIT
+3 NEW INSURER,ABSBRXI,ABSBRXR,DRGDFN,METHOD,ABSBNDC
+4 SET INSURER=$$GET^DDSVAL(DIE,.DA,7.01)
+5 SET ABSBRXI=$$GET^DDSVAL(DIE,.DA,1.01)
+6 ; special case: CPT code, not a prescription drug
IF ABSBRXI=""
Begin DoDot:1
+7 NEW CPTIEN
SET CPTIEN=$$GET^DDSVAL(DIE,.DA,1.08)
+8 IF 'CPTIEN
DO IMPOSS^ABSPOSUE("DB,P","TI","code for supply item is not yet here? should be",,"PAGE7",$TEXT(+0))
+9 ; must have CPTIEN by now ?!
+10 IF $$GET^DDSVAL(DIE,.DA,5.01)=""
DO PUT^DDSVAL(DIE,.DA,5.01,1)
+11 IF $$GET^DDSVAL(DIE,.DA,5.02)=""
Begin DoDot:2
+12 NEW PRICE
SET PRICE=$PIECE(^ABSCPT(9002300,CPTIEN,0),U,5)
+13 IF PRICE=""
Begin DoDot:3
+14 DO PUT^DDSVAL(DIE,.DA,5.03,"")
+15 DO PUT^DDSVAL(DIE,.DA,5.04,"")
+16 DO PUT^DDSVAL(DIE,.DA,5.05,"")
End DoDot:3
QUIT
+17 IF '$TEST
Begin DoDot:3
+18 DO PUT^DDSVAL(DIE,.DA,5.02,PRICE)
+19 DO PUT^DDSVAL(DIE,.DA,5.04,0)
+20 DO PUT^DDSVAL(DIE,.DA,5.06,"ABSCPT",,"I")
+21 DO RECALC1^ABSPOSI7
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+22 SET ABSBRXR=$$GET^DDSVAL(DIE,.DA,1.02)
+23 SET METHOD=$$METHOD
+24 SET DRGDFN=$$GET^DDSVAL(DIE,.DA,1.03)
+25 SET ABSBNDC=$$GET^DDSVAL(DIE,.DA,.03)
+26 IF ABSBNDC["-"
SET ABSBNDC=$$MAKE11N^ABSPOS9(ABSBNDC)
+27 DO PUT^DDSVAL(DIE,.DA,5.01,$$QTY)
+28 ; price^source
NEW X
SET X=$$UNITPRI1
+29 DO PUT^DDSVAL(DIE,.DA,5.02,$$ZEROES($PIECE(X,U)))
+30 DO PUT^DDSVAL(DIE,.DA,5.04,$JUSTIFY($$DISPFEE,0,2))
+31 DO PUT^DDSVAL(DIE,.DA,5.06,$PIECE(X,U,2),,"I")
+32 ;IHS/OIT/SCR 11/20/08 add INCENTIVE AMOUNT
+33 NEW ABSPINCT
+34 SET ABSPINCT=$$GET^DDSVAL(DIE,.DA,5.07)
+35 IF ABSPINCT=""
SET ABSPINCT=0
+36 DO PUT^DDSVAL(DIE,.DA,5.07,$$ZEROES(ABSPINCT))
+37 ;IHS/OIT/SCR 11/19/08 END CHANGES
+38 ; do the math
DO RECALC1^ABSPOSI7
+39 QUIT
ZEROES(X) ; strip leading and trailing zeroes, and "." if not needed
+1 FOR
IF $EXTRACT(X)'="0"
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 IF X["."
Begin DoDot:1
+3 FOR
IF $EXTRACT(X,$LENGTH(X))'="0"
QUIT
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
End DoDot:1
+4 IF $EXTRACT(X,$LENGTH(X))="."
SET X=$EXTRACT(X,1,$LENGTH(X))
+5 QUIT X
NEWENTRY ;EP - this is called by ENTRY ACTION of option ABSP SETUP PRICING
+1 NEW COUNT
SET COUNT=$PIECE(^ABSP(9002313.53,0),U,4)
+2 WRITE !!,"At this time, you have "
+3 IF COUNT=1
Begin DoDot:1
+4 WRITE "only the STANDARD pricing formula.",!
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 WRITE COUNT," pricing formulas on file.",!
+7 ; "Do you want to see a list?"
DO ASK^ABSPOSS3
End DoDot:1
+8 QUIT
