IBNCPDP1 ;OAK/ELZ - IB BILLING DETERMINATION PROCESSING FOR NEW RX REQUESTS ;5/22/08
;;2.0;INTEGRATED BILLING;**223,276,339,363,383,405,384,411,434,437,435,455,452,473,494,534,550,617,624,636,647,648,649,712**;21-MAR-94;Build 14
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to CL^SDCO21 supported by IA# 406
; Reference to IN5^VADPT supported by IA# 10061
; Reference to $$MWC^PSOBPSU2 supported by IA# 4970
;
RX(DFN,IBD) ; pharmacy package call, passing in IBD by ref
; this is called by PSO for all prescriptions issued, return is
; a response to bill ECME or not with array for billing data elements
;
;warning: back-billing flag:
;if passed IBSCRES(IBRXN,IBFIL)=1
; - then the SC Determination is just done by the IB clerk (billable)
; - set by routine IBNCPBB
;
; IBD("PLAN") - is specified only if RX API is called for billing
; determination for secondary claims or if the user is resubmitting
; a claim from the PSO Reject Information Screen.
;
;clean up the list of non-answered SC/Env.indicators questions and INS
K IBD("SC/EI NO ANSW"),IBD("INS")
;
N IBACDUTY,IBADMINFEE,IBADT,IBANY,IBARR,IBBI,IBCHG,IBDEA,IBDISPFEE
N IBELIG,IBFEE,IBFIL,IBINGCOST,IBINS,IBINSXRES,IBIT,IBNEEDS,IBPRDATA
N IBPRICE,IBPTYP,IBRES,IBRMARK,IBROIMAIBRS,IBRT,IBRXN,IBSAVE,IBT
N IBTRKR,IBTRKRN,IBTRN,IBX
N BPS57,INSIEN,POLNO,STOP
;
; eligibility verification request flag - esg 9/9/10 IB*2*435
S IBELIG=($G(IBD("RX ACTION"))="ELIG")
;
I '$G(DFN) S IBRES="0^No DFN" G RXQ
;
S IBRES="0^Error"
S IBADT=+$G(IBD("DOS"),DT) ; date of service (default to today)
;
; -- gather all active pharmacy insurance policies for patient on date of service
D RXINS^IBNCPDPU(DFN,IBADT,.IBINS)
;
; If current action is a result of a resubmit from ECME User Screen
; and the selected claim is not the primary claim or the patient
; only has one insurance, reverse loop through BPS Log of Transaction
; file looking for an entry related to PRO Option. If PRO Option entry
; exists, set Rate Type and Plan ID into IBD array. This will ensure the
; rate type on the resubmit is the same rate type used during secondary
; claims processing.
I ($G(BWHERE)="ERES"!($G(BWHERE)="ERWV"))&(($G(IBD("RXCOB"))>1)!($G(IBINS)=1)) D
. S STOP=0
. S BPS57=""
. F S BPS57=$O(^BPSTL("AEC",BRXIEN,BPS57),-1) Q:BPS57=""!(STOP=1) D
. . ; Skip this entry if not from PRO Option
. . I $$GET1^DIQ(9002313.57,BPS57,1201)'["P2" Q
. . S POLNO=$$GET1^DIQ(9002313.57,BPS57,1.05)
. . S INSIEN=""
. . F S INSIEN=$O(^BPSTL(BPS57,10,INSIEN)) Q:INSIEN=""!(STOP=1) D
. . . ; Skip entry if Policy # on the transaction does not match Policy # for
. . . ; the insurance. This is an extra check to be sure to use the data
. . . ; from the correct insurance - if more than one insurance exists.
. . . I POLNO'=$$GET1^DIQ(9002313.57902,INSIEN_","_BPS57,902.35) Q
. . . S IBD("RTYPE")=$$GET1^DIQ(9002313.57902,INSIEN_","_BPS57,902.29,"I")
. . . S IBD("PLAN")=$$GET1^DIQ(9002313.57902,INSIEN_","_BPS57,.01,"I")
. . . S STOP=1
;
; -- determine rate type
S IBRT=$$RT^IBNCPDPU(DFN,IBADT,.IBINS,.IBPTYP)
;
; If the rate type was selected by the user for manual primary or secondary claims processing, then update IBRT
I $G(IBD("RTYPE")),$G(IBD("PLAN")) D
. S $P(IBRT,U,1)=+IBD("RTYPE") ; overwrite the rate type ien [1]
. S $P(IBRT,U,2)=$$COSTTYP^IBNCPUT3(+IBD("RTYPE"),IBADT) ; overwrite the basis of cost determination [2]
. I $P(IBRT,U,3)="" S $P(IBRT,U,3)=IBPTYP ; overwrite eligibility if null [3]
. Q
;
; -- Process an eligibility verification request
I IBELIG D G RXQ
. S IBRES=1
. D SETINSUR(IBADT,IBRT,IBELIG,.IBINS,.IBD,.IBRES)
. Q
;
; additional data integrity checks
S IBRXN=+$G(IBD("IEN")) I 'IBRXN S IBRES="0^No Rx IEN" G RXQ
S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G RXQ
S IBD("QTY")=+$G(IBD("QTY")) I 'IBD("QTY") S IBRES="0^No Quantity" G RXQ
;
; -- Gather claims tracking information if it exists
S IBTRKR=$G(^IBE(350.9,1,6))
; date can't be before parameters
S $P(IBTRKR,U)=$S('$P(IBTRKR,U,4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
; already in claims tracking
S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
;
; Gather and store insurance information in the IBD("INS") insurance array
D SETINSUR(IBADT,IBRT,IBELIG,.IBINS,.IBD,.IBRES)
I $G(IBD("NO ECME INSURANCE")) S IBINSXRES=$G(IBRES) ; save IBRES when there are insurance errors
;
;for secondary billing - skip claim tracking functionality
I $G(IBD("RXCOB"))>1 G GETINS
;
; -- claims tracking info
I IBTRKRN,$$PAPERBIL^IBNCPNB(IBTRKRN) D G RXQ
. S IBRES="0^Existing IB Bill in CT. OPECC to Cancel Existing Bill in IB & Resubmit Claim"
. S IBD("NO ECME INSURANCE")=1
. ; Add comment to be displayed on the ECME User Screen
. D ADDCOMM^BPSBUTL(IBRXN,IBFIL,"OPECC to Cancel Existing Bill in IB & Resubmit Claim")
;
; -- no pharmacy coverage, update ct if applicable, quit
I '$$PTCOV^IBCNSU3(DFN,IBADT,"PHARMACY",.IBANY) S IBRMARK=$S($G(IBANY):"SERVICE NOT COVERED",1:"NOT INSURED") D:$P(IBTRKR,U,4)=2 CT S IBRES="0^"_IBRMARK,IBD("NO ECME INSURANCE")=1 G RXQ
;
; Environmental Indicators Validation
; Find out if the patient is Active Duty - IB*2*534
S IBACDUTY=$P(IBRT,U,3)="T"&$$ACDUTY^IBNCPDPU(DFN)
; Retrieve indicators from file #52 and overwrite the indicators in IBD array
D GETINDIC^IBNCPUT2(+IBD("IEN"),.IBD)
; Process patient exemptions if any and if not already resolved
S IBNEEDS=0 ;flag will be set to 1 if at least one of the questions wasn't answered
I ($G(IBD("SC/EI OVR"))'=1&'IBACDUTY)&($G(IBD("ACT DTY OVR"))'=1) D
. D CL^SDCO21(DFN,IBADT,"",.IBARR)
. I $D(IBARR)>9 F IBX=2:1 S IBT=$P($T(EXEMPT+IBX),";;",2) Q:IBT="" D:$D(IBARR(+IBT))
. . I $G(IBD($P(IBT,U,2)))=0 Q
. . I $G(IBD($P(IBT,U,2))) S IBRMARK=$P(IBT,U,3) Q
. . I '$G(IBSCRES(IBRXN,IBFIL)) S IBNEEDS=1 D
. . . S IBD("SC/EI NO ANSW")=$S($G(IBD("SC/EI NO ANSW"))="":$P(IBT,U,2),1:$G(IBD("SC/EI NO ANSW"))_","_$P(IBT,U,2))
I '$D(IBRMARK),IBNEEDS=1 S IBRMARK="NEEDS SC DETERMINATION"
I $D(IBRMARK) D CT S IBRES="0^"_IBRMARK G RXQ
;
; -- check for drug billable
I '$$BILLABLE^IBNCPDP($G(IBD("DRUG")),$P(IBRT,U,3),.IBRMARK,.IBD) S IBRES="0^"_IBRMARK D CT G RXQ
;
; -- check for sensitive diagnosis drug and ROI on file
; $$SENS^IBNCPDR returns 1 if the drug is a sensitive diagnosis drug
I $$SENS^IBNCPDR($G(IBD("DRUG")),.IBD),$D(IBD("INS",1,3)) D
. ; If the Date of Service is on or after the Mission Act
. ; implementation date do not perform ROI checks.
. I $$MACHK^IBNCPDR4(IBADT) Q
. I '$$ROI^IBNCPDR4(DFN,$G(IBD("DRUG")),+$P($G(IBD("INS",1,3)),U,5),IBADT) D Q
.. ;
.. ; no active ROI found for patient/drug/insurance/DOS
.. S IBRMARK="ROI NOT OBTAINED"
.. S IBRES="0^NO ACTIVE/VALID ROI FOR DRUG OR INSURANCE" ; PSO routine PSOREJU3 contains this text
.. Q
. ;
. ; active ROI found, clear out RNB from Claims Tracking and variable IBRMARK
. D ROICLN^IBNCPDR4(IBTRKRN,IBRXN,IBFIL)
. I $G(IBRMARK)["ROI" K IBRMARK
. Q
I $D(IBRMARK) D CT G RXQ
;
; Clean-up the NEEDS SC DETERMINATION record if resolved
; And check if it is non-billable in CT
I IBTRKRN D
. N IBNBR,IBNBRT
. S IBNBR=$P($G(^IBT(356,+IBTRKRN,0)),U,19) Q:'IBNBR
. S IBNBRT=$P($G(^IBE(356.8,IBNBR,0)),U) Q:IBNBRT=""
. ;
. ; if refill was deleted (not RX) and now the refill is re-entered
. ; use $$RXSTATUS^IBNCPRR instead of $G(^PSRX(IBRXN,"STA"))
. I IBNBRT="PRESCRIPTION DELETED",$$RXSTATUS^IBNCPRR(DFN,IBRXN)'=13 D Q
. . N DIE,DA,DR
. . ; clean up REASON NOT BILLABLE and ADDITIONAL COMMENT
. . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@;1.08////@" D ^DIE
. ;
. ; Clean up NBR if released
. I IBNBRT="PRESCRIPTION NOT RELEASED" D:$G(IBD("RELEASE DATE")) Q
. . N DIE,DA,DR
. . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@" D ^DIE
. ;
. ; Clean up 'Needs SC determ'
. I IBNBRT="NEEDS SC DETERMINATION" D Q
. . N DIE,DA,DR
. . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@" D ^DIE
. ;
. ; Clean up 'DRUG NOT BILLABLE' since we made it through the $$BILLABLE function above - IB*2*550
. I IBNBRT="DRUG NOT BILLABLE" D Q
. . N DIE,DA,DR
. . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@;1.08////@" D ^DIE
. . Q
. ;
. S IBRMARK=IBNBRT
. Q
;
I $D(IBRMARK) S IBRES="0^Non-Billable in CT: "_IBRMARK G RXQ
;
GETINS ; -- examine the insurance data for a patient
;
; if insurance errors were detected earlier, then restore IBRES and get out
I $G(IBD("NO ECME INSURANCE")) S IBRES=$G(IBINSXRES) G RXQ
;
RATEPRIC ; determine rates/prices to use
;
I 'IBRT D CT S IBRES="0^Cannot determine Rate type" G RXQ
S IBBI=$$EVNTITM^IBCRU3(+IBRT,3,"PRESCRIPTION FILL",IBADT,.IBRS)
I 'IBBI,$P(IBBI,";")'="VA COST" D CT S IBRES="0^Cannot find Billable Item" G RXQ
;
; Check for missing NDC
I $G(IBD("NDC"))="" D CT S IBRES="0^Missing NDC" G RXQ
;
;1;BEDSECTION;1^
;IBRS(1,18,5)=
S IBRS=+$O(IBRS($P(IBBI,";"),0))
S IBIT=$$ITPTR^IBCRU2($P(IBBI,";"),$S($P(IBRT,U,2)="A":$$NDC^IBNCPNB($G(IBD("NDC"))),1:"PRESCRIPTION"))
I 'IBIT,$P(IBRT,U,2)'="C" D CT S IBRES="0^Cannot find Item Pointer" G RXQ
;8
S IBPRICE=+$$BICOST^IBCRCI(+IBRT,3,IBADT,"PRESCRIPTION FILL",+IBIT,,,$S($P(IBRT,U,2)="A":IBD("QTY"),1:1))
;36^2991001
;
; return the true value of drug cost for 3rd party bill if it is zero
I +IBD("COST")=0,$P($G(^DGCR(399.3,+$P(IBRT,U,1),0)),U,5) S IBD("COST")=$$RXPCT(.IBD,.BWHERE)
;
; $$RATECHG^IBCRCC will return dispensing fee and administrative fee
; (in IBFEE, passed by reference) and adjusted charge amount based on
; the rate schedule.
;
S IBCHG=$$RATECHG^IBCRCC(+IBRS,$S($P(IBRT,U,2)'="C":1,1:IBD("QTY")*IBD("COST")),IBADT,.IBFEE)
I $P(IBRT,U,2)="C" S IBPRICE=+IBCHG
S IBDISPFEE=+$P($G(IBFEE),U,1) ; dispensing fee
S IBADMINFEE=+$P($G(IBFEE),U,2) ; administrative fee
;
I 'IBPRICE D CT S IBRES="0^Cannot find price for Item" G RXQ
;
; Calculate the ingredient cost. Default to 0.01 if less than that.
;
S IBINGCOST=IBD("QTY")*IBD("COST")
I IBINGCOST<0.01 S IBINGCOST=0.01,IBPRICE=IBPRICE+0.01
;
; build pricing data string
S IBPRDATA=""
S $P(IBPRDATA,U,1)=IBDISPFEE ; dispensing fee
S $P(IBPRDATA,U,2)=$S($P(IBRT,U,2)="A":"01",$P(IBRT,U,2)="C":"05",1:"07") ; basis of cost determination
S $P(IBPRDATA,U,3)=$S($P(IBRT,U,2)="C":IBINGCOST+IBDISPFEE,$P(IBRT,U,2)="A":IBPRICE-IBDISPFEE-IBADMINFEE,1:IBPRICE) ; basis of cost amount
S $P(IBPRDATA,U,4)=IBPRICE ; gross amount due
S $P(IBPRDATA,U,5)=IBADMINFEE ; administrative fee
S $P(IBPRDATA,U,6)=IBINGCOST ; ingredient cost
S $P(IBPRDATA,U,7)=IBPRICE-IBADMINFEE ; usual & customary charge (U&C)
;
; store the pricing data string on each node 2 that may exist
S IBX=0 F S IBX=$O(IBD("INS",IBX)) Q:'IBX S IBD("INS",IBX,2)=IBPRDATA
;
S IBRES=$S($D(IBRMARK):"0^"_IBRMARK,1:1)
I IBRES,'$G(IBD("RELEASE DATE")) S IBRMARK="PRESCRIPTION NOT RELEASED"
;
D CT
;
RXQ ; final processing
; set the 3rd piece of IBRES (default Vet)
S $P(IBRES,U,3)=$S($L($P($G(IBRT),U,3)):$P(IBRT,U,3),1:"V")
; If patient does not have active insurance and is TRICARE/CHAMPVA,
; set the 3rd piece of IBRES to the patient type.
I $G(IBD("NO ECME INSURANCE")),((IBPTYP="C")!(IBPTYP="T")) D
. S $P(IBRES,U,3)=IBPTYP
. S IBD("PATIENT TYPE")=IBPTYP
; possibly add entries to files 366.14 and 366.15 (not for eligibility verification requests)
I 'IBELIG D
. I IBRES D START^IBNCPDP6(IBRXN_";"_IBFIL,$P(IBRES,U,3),+IBRT)
. D LOG^IBNCPDP2("BILLABLE STATUS CHECK",IBRES)
. Q
;
Q IBRES
;
;
CT ; files in claims tracking
I $G(IBD("RXCOB"))>1 Q ;Claim Tracking is updated only for the primary payer (payer sequence =1)
;If null then the payer sequence = Primary is assumed
I IBTRKR D CT^IBNCPDPU(DFN,IBRXN,IBFIL,IBADT,$G(IBRMARK))
Q
;
SETINSUR(IBADT,IBRT,IBELIG,IBINS,IBD,IBRES) ; build insurance data array
; Input variables:
; IBADT - date of service/identify insurance as of this date
; IBRT - rate type variable - [1] rate type ien, [2] type (A/C/T), [3] eligibility (V/T/C)
; IBELIG - eligibility request flag (1/0)
; IBINS - insurance array as returned by RXINS^IBNCPDPU
; IBD - input/output - array entries passed in and certain array entries returned
; Output variable:
; IBRES - only returned if insurance errors
;
; Note: if more than one insurance with the same COB then the latest insurance occurrence overrides the first one(s)
; Example:
; IBINS("S",1,1)=""
; IBINS("S",1,3)="" <<--- this will be primary
;
K IBD("INS"),IBD("NO ECME INSURANCE")
;
N IBCNT,IBERMSG,IBRXPOL,IBT,IBX
; IBERMSG - error message array
; IBRXPOL - array of Rx policies found
;
S IBX=0 F S IBX=$O(IBINS("S",IBX)) Q:'IBX D
. S IBT=0 F S IBT=$O(IBINS("S",IBX,IBT)) Q:'IBT D
.. N IBDAT,IBPL,IBINSN,IBPIEN,IBY,IBZ,IBCHNM,IBREL,IBPLNTYP
.. S IBZ=$G(IBINS(IBT,0)) Q:IBZ=""
.. S IBPL=$P(IBZ,U,18) ; plan
.. Q:'IBPL
.. Q:'$$PLCOV^IBCNSU3(IBPL,IBADT,3) ; not a pharmacy plan
.. I $G(IBD("PLAN")) Q:IBPL'=$G(IBD("PLAN")) ; skip other plans if we call RX API for a specific plan (IBD("PLAN"))
.. ;
.. ; at this point we have found an Rx policy. We'll count these up later by IBX.
.. S IBRXPOL(IBX,IBT)=""
.. ;
.. S IBPLNTYP=$P($G(^IBE(355.1,+$P($G(IBINS(IBT,355.3)),U,9),0)),U,1) ; type of plan name, insurance plan type
.. I "^ERES^ERWV^"'[("^"_$G(BWHERE)_"^"),'$G(IBD("PLAN")),'$D(IBD("INS",IBX)),$P(IBRT,U,3)="V",(IBPLNTYP["TRICARE"!(IBPLNTYP="CHAMPVA")) S IBERMSG(IBX)=IBPLNTYP_" coverage for a Veteran" Q
.. ;
.. S IBPIEN=+$G(^IBA(355.3,+IBPL,6))
.. I 'IBPIEN S IBERMSG(IBX)="Plan not linked to the Payer" Q ; Not linked
.. ;
.. K IBY D STCHK^IBCNRU1(IBPIEN,.IBY,IBELIG)
.. I $E($G(IBY(1)))'="A" S IBERMSG(IBX)=$$ERMSG^IBNCPNB($G(IBY(6))) Q ; not active
.. ;
.. ; at this point we have a valid policy for this IBX
.. S IBERMSG(IBX)="" ; no error message
.. S IBINSN=$P($G(^DIC(36,+$G(^IBA(355.3,+IBPL,0)),0)),U) ; ins name
.. S IBCHNM=$$NAME^IBCEFG1($P(IBZ,U,17)) ; standardize subscriber/cardholder name
.. S IBREL=+$P($G(IBINS(IBT,4)),U,5) ; pointer to pharmacy relationship code file
.. ; use the #4.05 field if it exists, otherwise use the old pt relationship field #16
.. S IBREL=$S(IBREL:$$EXTERNAL^DILFD(2.312,4.05,,IBREL),1:$P(IBZ,U,16))
.. ;
.. S IBDAT=""
.. S $P(IBDAT,U,1)=IBPL ; Plan IEN
.. S $P(IBDAT,U,2)=$G(IBY(2)) ; BIN
.. S $P(IBDAT,U,3)=$G(IBY(3)) ; PCN
.. S $P(IBDAT,U,4)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",1),0)),U) ; Payer Sheet B1 name
.. S $P(IBDAT,U,5)=$P($G(IBINS(IBT,355.3)),U,4) ; Group ID
.. S $P(IBDAT,U,6)=$P(IBZ,U,2) ; Cardholder ID
.. S $P(IBDAT,U,7)=IBREL ; Patient Relationship Code
.. S $P(IBDAT,U,8)=$P(IBCHNM,U,2) ; Cardholder First Name
.. S $P(IBDAT,U,9)=$P(IBCHNM,U,1) ; Cardholder Last Name
.. S $P(IBDAT,U,10)=$P($G(^DIC(36,+IBZ,.11)),U,5) ; State
.. S $P(IBDAT,U,11)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",2),0)),U) ; Payer Sheet B2 name
.. S $P(IBDAT,U,12)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",3),0)),U) ; Payer Sheet B3 name
.. S $P(IBDAT,U,13)=$G(IBY(4)) ; Software/Vendor Cert ID
.. S $P(IBDAT,U,14)=IBINSN ; Ins Name
.. S $P(IBDAT,U,15)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",4),0)),U) ; Payer Sheet E1 name
.. S $P(IBDAT,U,16)=+$P($G(IBY(5)),",",1) ; Payer Sheet B1 ien
.. S $P(IBDAT,U,17)=+$P($G(IBY(5)),",",2) ; Payer Sheet B2 ien
.. S $P(IBDAT,U,18)=+$P($G(IBY(5)),",",3) ; Payer Sheet B3 ien
.. S $P(IBDAT,U,19)=+$P($G(IBY(5)),",",4) ; Payer Sheet E1 ien
.. S $P(IBDAT,U,20)=$P($G(IBINS(IBT,4)),U,6) ; Pharmacy Person Code
.. S IBD("INS",IBX,1)=IBDAT
.. ;
.. S IBDAT=""
.. S $P(IBDAT,U,1)=$P($G(IBINS(IBT,355.3)),U,3) ;group name
.. S $P(IBDAT,U,2)=$$PHONE^IBNCPDP6(+IBZ) ;ins co ph 3
.. S $P(IBDAT,U,3)=$$GET1^DIQ(366.03,IBPIEN_",",.01) ;plan ID
.. S $P(IBDAT,U,4)=$S(IBPLNTYP="TRICARE":"T",IBPLNTYP="CHAMPVA":"C",1:"V") ; plan type
.. S $P(IBDAT,U,5)=+$G(^IBA(355.3,+IBPL,0)) ; insurance co ien
.. S $P(IBDAT,U,6)=$P(IBZ,U,20) ;(#.2) COB field of the (#.3121) insurance Type multiple of the Patient file (#2)
.. S $P(IBDAT,U,7)=IBT ; 2.312 subfile ien
.. S $P(IBDAT,U,8)=$$GET1^DIQ(366.03,IBPIEN_",",10.1) ; maximum ncpdp transactions
.. S IBD("INS",IBX,3)=IBDAT
.. Q
. Q
;
; Count the number of pharmacy insurance policies by IBX found up above
S IBX=0 F IBCNT=0:1 S IBX=$O(IBRXPOL(IBX)) Q:'IBX
;
; Determine the value of the IBX variable here. This is basically the COB sequence# to be used.
; If there is only 1 pharmacy policy or no pharmacy policies, then set IBX in this manner
I IBCNT'>1 D
. I $D(IBD("INS")) S IBX=+$O(IBD("INS",0)) ; use the only one in this array
. I '$D(IBD("INS")) S IBX=+$O(IBERMSG(0)) ; the only one here (or 0)
. Q
;
; If there are multiple pharmacy policies on file, then the COB field in the pt. policy must be used correctly
; and primary insurance must be at #1
I IBCNT>1 S IBX=1
;
; In all cases, if this variable is set, then use it
I $G(IBD("RXCOB"))>1 S IBX=$G(IBD("RXCOB"))
;
; Check insurance at IBX
I '$D(IBD("INS",IBX)),$G(IBERMSG(IBX))'="" S IBRES="0^Not ECME billable: "_IBERMSG(IBX),IBD("NO ECME INSURANCE")=1 G SETINX
I '$D(IBD("INS",IBX)) S IBRES="0^No Insurance ECME billable",IBD("NO ECME INSURANCE")=1
SETINX ;
Q
;
RXPCT(IBD,BWHERE) ; Penny drug cost calculation
; Input-IBD array, BWHERE
; Output-return quotient of drug true value with 4 decimal places, or 0
N IBDIEN,IBDRX,IBNDC,IBFRM,IBDRFL,IBUNIT,IBSYN,IBQUO,IBDQUO,IBPSUF,IBPORD,IBPDISP,IBDRUG
S IBDIEN=IBD("IEN"),IBNDC=IBD("NDC"),IBDRX=IBD("DRUG"),IBDRFL=IBD("FILL NUMBER")
S IBFRM=$G(BWHERE),IBQUO=0
G:'IBDRX RXPCTQ
; default unit price from (50-13/15)
D GETS^DIQ(50,IBDRX,".01;13;15","I","IBUNIT")
S IBPORD=$G(IBUNIT(50,IBDRX_",",13,"I"))
S IBPDISP=$G(IBUNIT(50,IBDRX_",",15,"I"))
S (IBDQUO,IBQUO)=$S(IBPORD&IBPDISP:(IBPORD/IBPDISP),1:0)
;
; unit price from (50.1-402/403) if NDC exists in the SYNONYM subfile
D DATA^IBRXUTL(IBDRX)
S IBSYN=0 F S IBSYN=$O(^TMP($J,"IBDRUG",IBDRX,"SYN",IBSYN)) Q:'IBSYN D
. I IBNDC'="",$G(^TMP($J,"IBDRUG",IBDRX,"SYN",IBSYN,2))=IBNDC D
.. S IBPSUF=IBSYN_","_IBDRX_","
.. D GETS^DIQ(50.1,IBPSUF,".01;402;403","I","IBUNIT")
.. S IBPORD=$G(IBUNIT(50.1,IBPSUF,402,"I"))
.. S IBPDISP=$G(IBUNIT(50.1,IBPSUF,403,"I"))
.. S IBQUO=$S(IBPORD&IBPDISP:(IBPORD/IBPDISP),1:0)
;
; API #4970 - use the default unit price for CMOP
I $$MWC^PSOBPSU2(IBDIEN,IBDRFL)="C" D
. Q:(IBFRM="PE")!(IBFRM="PP")
. S IBQUO=IBDQUO
; set the lowest value 0.0001 with 4 decimal if less than 0.00005
I IBQUO S IBQUO=$J(IBQUO,1,4),IBQUO=$S(IBQUO>0:IBQUO,1:"0.0001")
K ^TMP($J,"IBDRUG")
RXPCTQ ;
Q IBQUO
;
EXEMPT ; exemption reasons
; variable from SD call ^ variable from PSO ^ reason not billable
;;1^AO^AGENT ORANGE
;;2^IR^IONIZING RADIATION
;;3^SC^SC TREATMENT
;;4^SWA^SOUTHWEST ASIA
;;5^MST^MILITARY SEXUAL TRAUMA
;;6^HNC^HEAD/NECK CANCER
;;7^CV^COMBAT VETERAN
;;8^SHAD^PROJECT 112/SHAD
;;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPDP1 19443 printed Sep 23, 2025@20:00:56 Page 2
IBNCPDP1 ;OAK/ELZ - IB BILLING DETERMINATION PROCESSING FOR NEW RX REQUESTS ;5/22/08
+1 ;;2.0;INTEGRATED BILLING;**223,276,339,363,383,405,384,411,434,437,435,455,452,473,494,534,550,617,624,636,647,648,649,712**;21-MAR-94;Build 14
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to CL^SDCO21 supported by IA# 406
+5 ; Reference to IN5^VADPT supported by IA# 10061
+6 ; Reference to $$MWC^PSOBPSU2 supported by IA# 4970
+7 ;
RX(DFN,IBD) ; pharmacy package call, passing in IBD by ref
+1 ; this is called by PSO for all prescriptions issued, return is
+2 ; a response to bill ECME or not with array for billing data elements
+3 ;
+4 ;warning: back-billing flag:
+5 ;if passed IBSCRES(IBRXN,IBFIL)=1
+6 ; - then the SC Determination is just done by the IB clerk (billable)
+7 ; - set by routine IBNCPBB
+8 ;
+9 ; IBD("PLAN") - is specified only if RX API is called for billing
+10 ; determination for secondary claims or if the user is resubmitting
+11 ; a claim from the PSO Reject Information Screen.
+12 ;
+13 ;clean up the list of non-answered SC/Env.indicators questions and INS
+14 KILL IBD("SC/EI NO ANSW"),IBD("INS")
+15 ;
+16 NEW IBACDUTY,IBADMINFEE,IBADT,IBANY,IBARR,IBBI,IBCHG,IBDEA,IBDISPFEE
+17 NEW IBELIG,IBFEE,IBFIL,IBINGCOST,IBINS,IBINSXRES,IBIT,IBNEEDS,IBPRDATA
+18 NEW IBPRICE,IBPTYP,IBRES,IBRMARK,IBROIMAIBRS,IBRT,IBRXN,IBSAVE,IBT
+19 NEW IBTRKR,IBTRKRN,IBTRN,IBX
+20 NEW BPS57,INSIEN,POLNO,STOP
+21 ;
+22 ; eligibility verification request flag - esg 9/9/10 IB*2*435
+23 SET IBELIG=($GET(IBD("RX ACTION"))="ELIG")
+24 ;
+25 IF '$GET(DFN)
SET IBRES="0^No DFN"
GOTO RXQ
+26 ;
+27 SET IBRES="0^Error"
+28 ; date of service (default to today)
SET IBADT=+$GET(IBD("DOS"),DT)
+29 ;
+30 ; -- gather all active pharmacy insurance policies for patient on date of service
+31 DO RXINS^IBNCPDPU(DFN,IBADT,.IBINS)
+32 ;
+33 ; If current action is a result of a resubmit from ECME User Screen
+34 ; and the selected claim is not the primary claim or the patient
+35 ; only has one insurance, reverse loop through BPS Log of Transaction
+36 ; file looking for an entry related to PRO Option. If PRO Option entry
+37 ; exists, set Rate Type and Plan ID into IBD array. This will ensure the
+38 ; rate type on the resubmit is the same rate type used during secondary
+39 ; claims processing.
+40 IF ($GET(BWHERE)="ERES"!($GET(BWHERE)="ERWV"))&(($GET(IBD("RXCOB"))>1)!($GET(IBINS)=1))
Begin DoDot:1
+41 SET STOP=0
+42 SET BPS57=""
+43 FOR
SET BPS57=$ORDER(^BPSTL("AEC",BRXIEN,BPS57),-1)
if BPS57=""!(STOP=1)
QUIT
Begin DoDot:2
+44 ; Skip this entry if not from PRO Option
+45 IF $$GET1^DIQ(9002313.57,BPS57,1201)'["P2"
QUIT
+46 SET POLNO=$$GET1^DIQ(9002313.57,BPS57,1.05)
+47 SET INSIEN=""
+48 FOR
SET INSIEN=$ORDER(^BPSTL(BPS57,10,INSIEN))
if INSIEN=""!(STOP=1)
QUIT
Begin DoDot:3
+49 ; Skip entry if Policy # on the transaction does not match Policy # for
+50 ; the insurance. This is an extra check to be sure to use the data
+51 ; from the correct insurance - if more than one insurance exists.
+52 IF POLNO'=$$GET1^DIQ(9002313.57902,INSIEN_","_BPS57,902.35)
QUIT
+53 SET IBD("RTYPE")=$$GET1^DIQ(9002313.57902,INSIEN_","_BPS57,902.29,"I")
+54 SET IBD("PLAN")=$$GET1^DIQ(9002313.57902,INSIEN_","_BPS57,.01,"I")
+55 SET STOP=1
End DoDot:3
End DoDot:2
End DoDot:1
+56 ;
+57 ; -- determine rate type
+58 SET IBRT=$$RT^IBNCPDPU(DFN,IBADT,.IBINS,.IBPTYP)
+59 ;
+60 ; If the rate type was selected by the user for manual primary or secondary claims processing, then update IBRT
+61 IF $GET(IBD("RTYPE"))
IF $GET(IBD("PLAN"))
Begin DoDot:1
+62 ; overwrite the rate type ien [1]
SET $PIECE(IBRT,U,1)=+IBD("RTYPE")
+63 ; overwrite the basis of cost determination [2]
SET $PIECE(IBRT,U,2)=$$COSTTYP^IBNCPUT3(+IBD("RTYPE"),IBADT)
+64 ; overwrite eligibility if null [3]
IF $PIECE(IBRT,U,3)=""
SET $PIECE(IBRT,U,3)=IBPTYP
+65 QUIT
End DoDot:1
+66 ;
+67 ; -- Process an eligibility verification request
+68 IF IBELIG
Begin DoDot:1
+69 SET IBRES=1
+70 DO SETINSUR(IBADT,IBRT,IBELIG,.IBINS,.IBD,.IBRES)
+71 QUIT
End DoDot:1
GOTO RXQ
+72 ;
+73 ; additional data integrity checks
+74 SET IBRXN=+$GET(IBD("IEN"))
IF 'IBRXN
SET IBRES="0^No Rx IEN"
GOTO RXQ
+75 SET IBFIL=+$GET(IBD("FILL NUMBER"),-1)
IF IBFIL<0
SET IBRES="0^No fill number"
GOTO RXQ
+76 SET IBD("QTY")=+$GET(IBD("QTY"))
IF 'IBD("QTY")
SET IBRES="0^No Quantity"
GOTO RXQ
+77 ;
+78 ; -- Gather claims tracking information if it exists
+79 SET IBTRKR=$GET(^IBE(350.9,1,6))
+80 ; date can't be before parameters
+81 SET $PIECE(IBTRKR,U)=$SELECT('$PIECE(IBTRKR,U,4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
+82 ; already in claims tracking
+83 SET IBTRKRN=+$ORDER(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
+84 ;
+85 ; Gather and store insurance information in the IBD("INS") insurance array
+86 DO SETINSUR(IBADT,IBRT,IBELIG,.IBINS,.IBD,.IBRES)
+87 ; save IBRES when there are insurance errors
IF $GET(IBD("NO ECME INSURANCE"))
SET IBINSXRES=$GET(IBRES)
+88 ;
+89 ;for secondary billing - skip claim tracking functionality
+90 IF $GET(IBD("RXCOB"))>1
GOTO GETINS
+91 ;
+92 ; -- claims tracking info
+93 IF IBTRKRN
IF $$PAPERBIL^IBNCPNB(IBTRKRN)
Begin DoDot:1
+94 SET IBRES="0^Existing IB Bill in CT. OPECC to Cancel Existing Bill in IB & Resubmit Claim"
+95 SET IBD("NO ECME INSURANCE")=1
+96 ; Add comment to be displayed on the ECME User Screen
+97 DO ADDCOMM^BPSBUTL(IBRXN,IBFIL,"OPECC to Cancel Existing Bill in IB & Resubmit Claim")
End DoDot:1
GOTO RXQ
+98 ;
+99 ; -- no pharmacy coverage, update ct if applicable, quit
+100 IF '$$PTCOV^IBCNSU3(DFN,IBADT,"PHARMACY",.IBANY)
SET IBRMARK=$SELECT($GET(IBANY):"SERVICE NOT COVERED",1:"NOT INSURED")
if $PIECE(IBTRKR,U,4)=2
DO CT
SET IBRES="0^"_IBRMARK
SET IBD("NO ECME INSURANCE")=1
GOTO RXQ
+101 ;
+102 ; Environmental Indicators Validation
+103 ; Find out if the patient is Active Duty - IB*2*534
+104 SET IBACDUTY=$PIECE(IBRT,U,3)="T"&$$ACDUTY^IBNCPDPU(DFN)
+105 ; Retrieve indicators from file #52 and overwrite the indicators in IBD array
+106 DO GETINDIC^IBNCPUT2(+IBD("IEN"),.IBD)
+107 ; Process patient exemptions if any and if not already resolved
+108 ;flag will be set to 1 if at least one of the questions wasn't answered
SET IBNEEDS=0
+109 IF ($GET(IBD("SC/EI OVR"))'=1&'IBACDUTY)&($GET(IBD("ACT DTY OVR"))'=1)
Begin DoDot:1
+110 DO CL^SDCO21(DFN,IBADT,"",.IBARR)
+111 IF $DATA(IBARR)>9
FOR IBX=2:1
SET IBT=$PIECE($TEXT(EXEMPT+IBX),";;",2)
if IBT=""
QUIT
if $DATA(IBARR(+IBT))
Begin DoDot:2
+112 IF $GET(IBD($PIECE(IBT,U,2)))=0
QUIT
+113 IF $GET(IBD($PIECE(IBT,U,2)))
SET IBRMARK=$PIECE(IBT,U,3)
QUIT
+114 IF '$GET(IBSCRES(IBRXN,IBFIL))
SET IBNEEDS=1
Begin DoDot:3
+115 SET IBD("SC/EI NO ANSW")=$SELECT($GET(IBD("SC/EI NO ANSW"))="":$PIECE(IBT,U,2),1:$GET(IBD("SC/EI NO ANSW"))_","_$PIECE(IBT,U,2))
End DoDot:3
End DoDot:2
End DoDot:1
+116 IF '$DATA(IBRMARK)
IF IBNEEDS=1
SET IBRMARK="NEEDS SC DETERMINATION"
+117 IF $DATA(IBRMARK)
DO CT
SET IBRES="0^"_IBRMARK
GOTO RXQ
+118 ;
+119 ; -- check for drug billable
+120 IF '$$BILLABLE^IBNCPDP($GET(IBD("DRUG")),$PIECE(IBRT,U,3),.IBRMARK,.IBD)
SET IBRES="0^"_IBRMARK
DO CT
GOTO RXQ
+121 ;
+122 ; -- check for sensitive diagnosis drug and ROI on file
+123 ; $$SENS^IBNCPDR returns 1 if the drug is a sensitive diagnosis drug
+124 IF $$SENS^IBNCPDR($GET(IBD("DRUG")),.IBD)
IF $DATA(IBD("INS",1,3))
Begin DoDot:1
+125 ; If the Date of Service is on or after the Mission Act
+126 ; implementation date do not perform ROI checks.
+127 IF $$MACHK^IBNCPDR4(IBADT)
QUIT
+128 IF '$$ROI^IBNCPDR4(DFN,$GET(IBD("DRUG")),+$PIECE($GET(IBD("INS",1,3)),U,5),IBADT)
Begin DoDot:2
+129 ;
+130 ; no active ROI found for patient/drug/insurance/DOS
+131 SET IBRMARK="ROI NOT OBTAINED"
+132 ; PSO routine PSOREJU3 contains this text
SET IBRES="0^NO ACTIVE/VALID ROI FOR DRUG OR INSURANCE"
+133 QUIT
End DoDot:2
QUIT
+134 ;
+135 ; active ROI found, clear out RNB from Claims Tracking and variable IBRMARK
+136 DO ROICLN^IBNCPDR4(IBTRKRN,IBRXN,IBFIL)
+137 IF $GET(IBRMARK)["ROI"
KILL IBRMARK
+138 QUIT
End DoDot:1
+139 IF $DATA(IBRMARK)
DO CT
GOTO RXQ
+140 ;
+141 ; Clean-up the NEEDS SC DETERMINATION record if resolved
+142 ; And check if it is non-billable in CT
+143 IF IBTRKRN
Begin DoDot:1
+144 NEW IBNBR,IBNBRT
+145 SET IBNBR=$PIECE($GET(^IBT(356,+IBTRKRN,0)),U,19)
if 'IBNBR
QUIT
+146 SET IBNBRT=$PIECE($GET(^IBE(356.8,IBNBR,0)),U)
if IBNBRT=""
QUIT
+147 ;
+148 ; if refill was deleted (not RX) and now the refill is re-entered
+149 ; use $$RXSTATUS^IBNCPRR instead of $G(^PSRX(IBRXN,"STA"))
+150 IF IBNBRT="PRESCRIPTION DELETED"
IF $$RXSTATUS^IBNCPRR(DFN,IBRXN)'=13
Begin DoDot:2
+151 NEW DIE,DA,DR
+152 ; clean up REASON NOT BILLABLE and ADDITIONAL COMMENT
+153 SET DIE="^IBT(356,"
SET DA=+IBTRKRN
SET DR=".19////@;1.08////@"
DO ^DIE
End DoDot:2
QUIT
+154 ;
+155 ; Clean up NBR if released
+156 IF IBNBRT="PRESCRIPTION NOT RELEASED"
if $GET(IBD("RELEASE DATE"))
Begin DoDot:2
+157 NEW DIE,DA,DR
+158 SET DIE="^IBT(356,"
SET DA=+IBTRKRN
SET DR=".19////@"
DO ^DIE
End DoDot:2
QUIT
+159 ;
+160 ; Clean up 'Needs SC determ'
+161 IF IBNBRT="NEEDS SC DETERMINATION"
Begin DoDot:2
+162 NEW DIE,DA,DR
+163 SET DIE="^IBT(356,"
SET DA=+IBTRKRN
SET DR=".19////@"
DO ^DIE
End DoDot:2
QUIT
+164 ;
+165 ; Clean up 'DRUG NOT BILLABLE' since we made it through the $$BILLABLE function above - IB*2*550
+166 IF IBNBRT="DRUG NOT BILLABLE"
Begin DoDot:2
+167 NEW DIE,DA,DR
+168 SET DIE="^IBT(356,"
SET DA=+IBTRKRN
SET DR=".19////@;1.08////@"
DO ^DIE
+169 QUIT
End DoDot:2
QUIT
+170 ;
+171 SET IBRMARK=IBNBRT
+172 QUIT
End DoDot:1
+173 ;
+174 IF $DATA(IBRMARK)
SET IBRES="0^Non-Billable in CT: "_IBRMARK
GOTO RXQ
+175 ;
GETINS ; -- examine the insurance data for a patient
+1 ;
+2 ; if insurance errors were detected earlier, then restore IBRES and get out
+3 IF $GET(IBD("NO ECME INSURANCE"))
SET IBRES=$GET(IBINSXRES)
GOTO RXQ
+4 ;
RATEPRIC ; determine rates/prices to use
+1 ;
+2 IF 'IBRT
DO CT
SET IBRES="0^Cannot determine Rate type"
GOTO RXQ
+3 SET IBBI=$$EVNTITM^IBCRU3(+IBRT,3,"PRESCRIPTION FILL",IBADT,.IBRS)
+4 IF 'IBBI
IF $PIECE(IBBI,";")'="VA COST"
DO CT
SET IBRES="0^Cannot find Billable Item"
GOTO RXQ
+5 ;
+6 ; Check for missing NDC
+7 IF $GET(IBD("NDC"))=""
DO CT
SET IBRES="0^Missing NDC"
GOTO RXQ
+8 ;
+9 ;1;BEDSECTION;1^
+10 ;IBRS(1,18,5)=
+11 SET IBRS=+$ORDER(IBRS($PIECE(IBBI,";"),0))
+12 SET IBIT=$$ITPTR^IBCRU2($PIECE(IBBI,";"),$SELECT($PIECE(IBRT,U,2)="A":$$NDC^IBNCPNB($GET(IBD("NDC"))),1:"PRESCRIPTION"))
+13 IF 'IBIT
IF $PIECE(IBRT,U,2)'="C"
DO CT
SET IBRES="0^Cannot find Item Pointer"
GOTO RXQ
+14 ;8
+15 SET IBPRICE=+$$BICOST^IBCRCI(+IBRT,3,IBADT,"PRESCRIPTION FILL",+IBIT,,,$SELECT($PIECE(IBRT,U,2)="A":IBD("QTY"),1:1))
+16 ;36^2991001
+17 ;
+18 ; return the true value of drug cost for 3rd party bill if it is zero
+19 IF +IBD("COST")=0
IF $PIECE($GET(^DGCR(399.3,+$PIECE(IBRT,U,1),0)),U,5)
SET IBD("COST")=$$RXPCT(.IBD,.BWHERE)
+20 ;
+21 ; $$RATECHG^IBCRCC will return dispensing fee and administrative fee
+22 ; (in IBFEE, passed by reference) and adjusted charge amount based on
+23 ; the rate schedule.
+24 ;
+25 SET IBCHG=$$RATECHG^IBCRCC(+IBRS,$SELECT($PIECE(IBRT,U,2)'="C":1,1:IBD("QTY")*IBD("COST")),IBADT,.IBFEE)
+26 IF $PIECE(IBRT,U,2)="C"
SET IBPRICE=+IBCHG
+27 ; dispensing fee
SET IBDISPFEE=+$PIECE($GET(IBFEE),U,1)
+28 ; administrative fee
SET IBADMINFEE=+$PIECE($GET(IBFEE),U,2)
+29 ;
+30 IF 'IBPRICE
DO CT
SET IBRES="0^Cannot find price for Item"
GOTO RXQ
+31 ;
+32 ; Calculate the ingredient cost. Default to 0.01 if less than that.
+33 ;
+34 SET IBINGCOST=IBD("QTY")*IBD("COST")
+35 IF IBINGCOST<0.01
SET IBINGCOST=0.01
SET IBPRICE=IBPRICE+0.01
+36 ;
+37 ; build pricing data string
+38 SET IBPRDATA=""
+39 ; dispensing fee
SET $PIECE(IBPRDATA,U,1)=IBDISPFEE
+40 ; basis of cost determination
SET $PIECE(IBPRDATA,U,2)=$SELECT($PIECE(IBRT,U,2)="A":"01",$PIECE(IBRT,U,2)="C":"05",1:"07")
+41 ; basis of cost amount
SET $PIECE(IBPRDATA,U,3)=$SELECT($PIECE(IBRT,U,2)="C":IBINGCOST+IBDISPFEE,$PIECE(IBRT,U,2)="A":IBPRICE-IBDISPFEE-IBADMINFEE,1:IBPRICE)
+42 ; gross amount due
SET $PIECE(IBPRDATA,U,4)=IBPRICE
+43 ; administrative fee
SET $PIECE(IBPRDATA,U,5)=IBADMINFEE
+44 ; ingredient cost
SET $PIECE(IBPRDATA,U,6)=IBINGCOST
+45 ; usual & customary charge (U&C)
SET $PIECE(IBPRDATA,U,7)=IBPRICE-IBADMINFEE
+46 ;
+47 ; store the pricing data string on each node 2 that may exist
+48 SET IBX=0
FOR
SET IBX=$ORDER(IBD("INS",IBX))
if 'IBX
QUIT
SET IBD("INS",IBX,2)=IBPRDATA
+49 ;
+50 SET IBRES=$SELECT($DATA(IBRMARK):"0^"_IBRMARK,1:1)
+51 IF IBRES
IF '$GET(IBD("RELEASE DATE"))
SET IBRMARK="PRESCRIPTION NOT RELEASED"
+52 ;
+53 DO CT
+54 ;
RXQ ; final processing
+1 ; set the 3rd piece of IBRES (default Vet)
+2 SET $PIECE(IBRES,U,3)=$SELECT($LENGTH($PIECE($GET(IBRT),U,3)):$PIECE(IBRT,U,3),1:"V")
+3 ; If patient does not have active insurance and is TRICARE/CHAMPVA,
+4 ; set the 3rd piece of IBRES to the patient type.
+5 IF $GET(IBD("NO ECME INSURANCE"))
IF ((IBPTYP="C")!(IBPTYP="T"))
Begin DoDot:1
+6 SET $PIECE(IBRES,U,3)=IBPTYP
+7 SET IBD("PATIENT TYPE")=IBPTYP
End DoDot:1
+8 ; possibly add entries to files 366.14 and 366.15 (not for eligibility verification requests)
+9 IF 'IBELIG
Begin DoDot:1
+10 IF IBRES
DO START^IBNCPDP6(IBRXN_";"_IBFIL,$PIECE(IBRES,U,3),+IBRT)
+11 DO LOG^IBNCPDP2("BILLABLE STATUS CHECK",IBRES)
+12 QUIT
End DoDot:1
+13 ;
+14 QUIT IBRES
+15 ;
+16 ;
CT ; files in claims tracking
+1 ;Claim Tracking is updated only for the primary payer (payer sequence =1)
IF $GET(IBD("RXCOB"))>1
QUIT
+2 ;If null then the payer sequence = Primary is assumed
+3 IF IBTRKR
DO CT^IBNCPDPU(DFN,IBRXN,IBFIL,IBADT,$GET(IBRMARK))
+4 QUIT
+5 ;
SETINSUR(IBADT,IBRT,IBELIG,IBINS,IBD,IBRES) ; build insurance data array
+1 ; Input variables:
+2 ; IBADT - date of service/identify insurance as of this date
+3 ; IBRT - rate type variable - [1] rate type ien, [2] type (A/C/T), [3] eligibility (V/T/C)
+4 ; IBELIG - eligibility request flag (1/0)
+5 ; IBINS - insurance array as returned by RXINS^IBNCPDPU
+6 ; IBD - input/output - array entries passed in and certain array entries returned
+7 ; Output variable:
+8 ; IBRES - only returned if insurance errors
+9 ;
+10 ; Note: if more than one insurance with the same COB then the latest insurance occurrence overrides the first one(s)
+11 ; Example:
+12 ; IBINS("S",1,1)=""
+13 ; IBINS("S",1,3)="" <<--- this will be primary
+14 ;
+15 KILL IBD("INS"),IBD("NO ECME INSURANCE")
+16 ;
+17 NEW IBCNT,IBERMSG,IBRXPOL,IBT,IBX
+18 ; IBERMSG - error message array
+19 ; IBRXPOL - array of Rx policies found
+20 ;
+21 SET IBX=0
FOR
SET IBX=$ORDER(IBINS("S",IBX))
if 'IBX
QUIT
Begin DoDot:1
+22 SET IBT=0
FOR
SET IBT=$ORDER(IBINS("S",IBX,IBT))
if 'IBT
QUIT
Begin DoDot:2
+23 NEW IBDAT,IBPL,IBINSN,IBPIEN,IBY,IBZ,IBCHNM,IBREL,IBPLNTYP
+24 SET IBZ=$GET(IBINS(IBT,0))
if IBZ=""
QUIT
+25 ; plan
SET IBPL=$PIECE(IBZ,U,18)
+26 if 'IBPL
QUIT
+27 ; not a pharmacy plan
if '$$PLCOV^IBCNSU3(IBPL,IBADT,3)
QUIT
+28 ; skip other plans if we call RX API for a specific plan (IBD("PLAN"))
IF $GET(IBD("PLAN"))
if IBPL'=$GET(IBD("PLAN"))
QUIT
+29 ;
+30 ; at this point we have found an Rx policy. We'll count these up later by IBX.
+31 SET IBRXPOL(IBX,IBT)=""
+32 ;
+33 ; type of plan name, insurance plan type
SET IBPLNTYP=$PIECE($GET(^IBE(355.1,+$PIECE($GET(IBINS(IBT,355.3)),U,9),0)),U,1)
+34 IF "^ERES^ERWV^"'[("^"_$GET(BWHERE)_"^")
IF '$GET(IBD("PLAN"))
IF '$DATA(IBD("INS",IBX))
IF $PIECE(IBRT,U,3)="V"
IF (IBPLNTYP["TRICARE"!(IBPLNTYP="CHAMPVA"))
SET IBERMSG(IBX)=IBPLNTYP_" coverage for a Veteran"
QUIT
+35 ;
+36 SET IBPIEN=+$GET(^IBA(355.3,+IBPL,6))
+37 ; Not linked
IF 'IBPIEN
SET IBERMSG(IBX)="Plan not linked to the Payer"
QUIT
+38 ;
+39 KILL IBY
DO STCHK^IBCNRU1(IBPIEN,.IBY,IBELIG)
+40 ; not active
IF $EXTRACT($GET(IBY(1)))'="A"
SET IBERMSG(IBX)=$$ERMSG^IBNCPNB($GET(IBY(6)))
QUIT
+41 ;
+42 ; at this point we have a valid policy for this IBX
+43 ; no error message
SET IBERMSG(IBX)=""
+44 ; ins name
SET IBINSN=$PIECE($GET(^DIC(36,+$GET(^IBA(355.3,+IBPL,0)),0)),U)
+45 ; standardize subscriber/cardholder name
SET IBCHNM=$$NAME^IBCEFG1($PIECE(IBZ,U,17))
+46 ; pointer to pharmacy relationship code file
SET IBREL=+$PIECE($GET(IBINS(IBT,4)),U,5)
+47 ; use the #4.05 field if it exists, otherwise use the old pt relationship field #16
+48 SET IBREL=$SELECT(IBREL:$$EXTERNAL^DILFD(2.312,4.05,,IBREL),1:$PIECE(IBZ,U,16))
+49 ;
+50 SET IBDAT=""
+51 ; Plan IEN
SET $PIECE(IBDAT,U,1)=IBPL
+52 ; BIN
SET $PIECE(IBDAT,U,2)=$GET(IBY(2))
+53 ; PCN
SET $PIECE(IBDAT,U,3)=$GET(IBY(3))
+54 ; Payer Sheet B1 name
SET $PIECE(IBDAT,U,4)=$PIECE($GET(^BPSF(9002313.92,+$PIECE($GET(IBY(5)),",",1),0)),U)
+55 ; Group ID
SET $PIECE(IBDAT,U,5)=$PIECE($GET(IBINS(IBT,355.3)),U,4)
+56 ; Cardholder ID
SET $PIECE(IBDAT,U,6)=$PIECE(IBZ,U,2)
+57 ; Patient Relationship Code
SET $PIECE(IBDAT,U,7)=IBREL
+58 ; Cardholder First Name
SET $PIECE(IBDAT,U,8)=$PIECE(IBCHNM,U,2)
+59 ; Cardholder Last Name
SET $PIECE(IBDAT,U,9)=$PIECE(IBCHNM,U,1)
+60 ; State
SET $PIECE(IBDAT,U,10)=$PIECE($GET(^DIC(36,+IBZ,.11)),U,5)
+61 ; Payer Sheet B2 name
SET $PIECE(IBDAT,U,11)=$PIECE($GET(^BPSF(9002313.92,+$PIECE($GET(IBY(5)),",",2),0)),U)
+62 ; Payer Sheet B3 name
SET $PIECE(IBDAT,U,12)=$PIECE($GET(^BPSF(9002313.92,+$PIECE($GET(IBY(5)),",",3),0)),U)
+63 ; Software/Vendor Cert ID
SET $PIECE(IBDAT,U,13)=$GET(IBY(4))
+64 ; Ins Name
SET $PIECE(IBDAT,U,14)=IBINSN
+65 ; Payer Sheet E1 name
SET $PIECE(IBDAT,U,15)=$PIECE($GET(^BPSF(9002313.92,+$PIECE($GET(IBY(5)),",",4),0)),U)
+66 ; Payer Sheet B1 ien
SET $PIECE(IBDAT,U,16)=+$PIECE($GET(IBY(5)),",",1)
+67 ; Payer Sheet B2 ien
SET $PIECE(IBDAT,U,17)=+$PIECE($GET(IBY(5)),",",2)
+68 ; Payer Sheet B3 ien
SET $PIECE(IBDAT,U,18)=+$PIECE($GET(IBY(5)),",",3)
+69 ; Payer Sheet E1 ien
SET $PIECE(IBDAT,U,19)=+$PIECE($GET(IBY(5)),",",4)
+70 ; Pharmacy Person Code
SET $PIECE(IBDAT,U,20)=$PIECE($GET(IBINS(IBT,4)),U,6)
+71 SET IBD("INS",IBX,1)=IBDAT
+72 ;
+73 SET IBDAT=""
+74 ;group name
SET $PIECE(IBDAT,U,1)=$PIECE($GET(IBINS(IBT,355.3)),U,3)
+75 ;ins co ph 3
SET $PIECE(IBDAT,U,2)=$$PHONE^IBNCPDP6(+IBZ)
+76 ;plan ID
SET $PIECE(IBDAT,U,3)=$$GET1^DIQ(366.03,IBPIEN_",",.01)
+77 ; plan type
SET $PIECE(IBDAT,U,4)=$SELECT(IBPLNTYP="TRICARE":"T",IBPLNTYP="CHAMPVA":"C",1:"V")
+78 ; insurance co ien
SET $PIECE(IBDAT,U,5)=+$GET(^IBA(355.3,+IBPL,0))
+79 ;(#.2) COB field of the (#.3121) insurance Type multiple of the Patient file (#2)
SET $PIECE(IBDAT,U,6)=$PIECE(IBZ,U,20)
+80 ; 2.312 subfile ien
SET $PIECE(IBDAT,U,7)=IBT
+81 ; maximum ncpdp transactions
SET $PIECE(IBDAT,U,8)=$$GET1^DIQ(366.03,IBPIEN_",",10.1)
+82 SET IBD("INS",IBX,3)=IBDAT
+83 QUIT
End DoDot:2
+84 QUIT
End DoDot:1
+85 ;
+86 ; Count the number of pharmacy insurance policies by IBX found up above
+87 SET IBX=0
FOR IBCNT=0:1
SET IBX=$ORDER(IBRXPOL(IBX))
if 'IBX
QUIT
+88 ;
+89 ; Determine the value of the IBX variable here. This is basically the COB sequence# to be used.
+90 ; If there is only 1 pharmacy policy or no pharmacy policies, then set IBX in this manner
+91 IF IBCNT'>1
Begin DoDot:1
+92 ; use the only one in this array
IF $DATA(IBD("INS"))
SET IBX=+$ORDER(IBD("INS",0))
+93 ; the only one here (or 0)
IF '$DATA(IBD("INS"))
SET IBX=+$ORDER(IBERMSG(0))
+94 QUIT
End DoDot:1
+95 ;
+96 ; If there are multiple pharmacy policies on file, then the COB field in the pt. policy must be used correctly
+97 ; and primary insurance must be at #1
+98 IF IBCNT>1
SET IBX=1
+99 ;
+100 ; In all cases, if this variable is set, then use it
+101 IF $GET(IBD("RXCOB"))>1
SET IBX=$GET(IBD("RXCOB"))
+102 ;
+103 ; Check insurance at IBX
+104 IF '$DATA(IBD("INS",IBX))
IF $GET(IBERMSG(IBX))'=""
SET IBRES="0^Not ECME billable: "_IBERMSG(IBX)
SET IBD("NO ECME INSURANCE")=1
GOTO SETINX
+105 IF '$DATA(IBD("INS",IBX))
SET IBRES="0^No Insurance ECME billable"
SET IBD("NO ECME INSURANCE")=1
SETINX ;
+1 QUIT
+2 ;
RXPCT(IBD,BWHERE) ; Penny drug cost calculation
+1 ; Input-IBD array, BWHERE
+2 ; Output-return quotient of drug true value with 4 decimal places, or 0
+3 NEW IBDIEN,IBDRX,IBNDC,IBFRM,IBDRFL,IBUNIT,IBSYN,IBQUO,IBDQUO,IBPSUF,IBPORD,IBPDISP,IBDRUG
+4 SET IBDIEN=IBD("IEN")
SET IBNDC=IBD("NDC")
SET IBDRX=IBD("DRUG")
SET IBDRFL=IBD("FILL NUMBER")
+5 SET IBFRM=$GET(BWHERE)
SET IBQUO=0
+6 if 'IBDRX
GOTO RXPCTQ
+7 ; default unit price from (50-13/15)
+8 DO GETS^DIQ(50,IBDRX,".01;13;15","I","IBUNIT")
+9 SET IBPORD=$GET(IBUNIT(50,IBDRX_",",13,"I"))
+10 SET IBPDISP=$GET(IBUNIT(50,IBDRX_",",15,"I"))
+11 SET (IBDQUO,IBQUO)=$SELECT(IBPORD&IBPDISP:(IBPORD/IBPDISP),1:0)
+12 ;
+13 ; unit price from (50.1-402/403) if NDC exists in the SYNONYM subfile
+14 DO DATA^IBRXUTL(IBDRX)
+15 SET IBSYN=0
FOR
SET IBSYN=$ORDER(^TMP($JOB,"IBDRUG",IBDRX,"SYN",IBSYN))
if 'IBSYN
QUIT
Begin DoDot:1
+16 IF IBNDC'=""
IF $GET(^TMP($JOB,"IBDRUG",IBDRX,"SYN",IBSYN,2))=IBNDC
Begin DoDot:2
+17 SET IBPSUF=IBSYN_","_IBDRX_","
+18 DO GETS^DIQ(50.1,IBPSUF,".01;402;403","I","IBUNIT")
+19 SET IBPORD=$GET(IBUNIT(50.1,IBPSUF,402,"I"))
+20 SET IBPDISP=$GET(IBUNIT(50.1,IBPSUF,403,"I"))
+21 SET IBQUO=$SELECT(IBPORD&IBPDISP:(IBPORD/IBPDISP),1:0)
End DoDot:2
End DoDot:1
+22 ;
+23 ; API #4970 - use the default unit price for CMOP
+24 IF $$MWC^PSOBPSU2(IBDIEN,IBDRFL)="C"
Begin DoDot:1
+25 if (IBFRM="PE")!(IBFRM="PP")
QUIT
+26 SET IBQUO=IBDQUO
End DoDot:1
+27 ; set the lowest value 0.0001 with 4 decimal if less than 0.00005
+28 IF IBQUO
SET IBQUO=$JUSTIFY(IBQUO,1,4)
SET IBQUO=$SELECT(IBQUO>0:IBQUO,1:"0.0001")
+29 KILL ^TMP($JOB,"IBDRUG")
RXPCTQ ;
+1 QUIT IBQUO
+2 ;
EXEMPT ; exemption reasons
+1 ; variable from SD call ^ variable from PSO ^ reason not billable
+2 ;;1^AO^AGENT ORANGE
+3 ;;2^IR^IONIZING RADIATION
+4 ;;3^SC^SC TREATMENT
+5 ;;4^SWA^SOUTHWEST ASIA
+6 ;;5^MST^MILITARY SEXUAL TRAUMA
+7 ;;6^HNC^HEAD/NECK CANCER
+8 ;;7^CV^COMBAT VETERAN
+9 ;;8^SHAD^PROJECT 112/SHAD
+10 ;;
+11 ;
