Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABSPOSQP

ABSPOSQP.m

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