- 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 Jan 18, 2025@03:25:48 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 ;