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

IBNCPDP1.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; Reference to CL^SDCO21 supported by IA# 406
  1. ; Reference to IN5^VADPT supported by IA# 10061
  1. ; Reference to $$MWC^PSOBPSU2 supported by IA# 4970
  1. ;
  1. RX(DFN,IBD) ; pharmacy package call, passing in IBD by ref
  1. ; this is called by PSO for all prescriptions issued, return is
  1. ; a response to bill ECME or not with array for billing data elements
  1. ;
  1. ;warning: back-billing flag:
  1. ;if passed IBSCRES(IBRXN,IBFIL)=1
  1. ; - then the SC Determination is just done by the IB clerk (billable)
  1. ; - set by routine IBNCPBB
  1. ;
  1. ; IBD("PLAN") - is specified only if RX API is called for billing
  1. ; determination for secondary claims or if the user is resubmitting
  1. ; a claim from the PSO Reject Information Screen.
  1. ;
  1. ;clean up the list of non-answered SC/Env.indicators questions and INS
  1. K IBD("SC/EI NO ANSW"),IBD("INS")
  1. ;
  1. N IBACDUTY,IBADMINFEE,IBADT,IBANY,IBARR,IBBI,IBCHG,IBDEA,IBDISPFEE
  1. N IBELIG,IBFEE,IBFIL,IBINGCOST,IBINS,IBINSXRES,IBIT,IBNEEDS,IBPRDATA
  1. N IBPRICE,IBPTYP,IBRES,IBRMARK,IBROIMAIBRS,IBRT,IBRXN,IBSAVE,IBT
  1. N IBTRKR,IBTRKRN,IBTRN,IBX
  1. N BPS57,INSIEN,POLNO,STOP
  1. ;
  1. ; eligibility verification request flag - esg 9/9/10 IB*2*435
  1. S IBELIG=($G(IBD("RX ACTION"))="ELIG")
  1. ;
  1. I '$G(DFN) S IBRES="0^No DFN" G RXQ
  1. ;
  1. S IBRES="0^Error"
  1. S IBADT=+$G(IBD("DOS"),DT) ; date of service (default to today)
  1. ;
  1. ; -- gather all active pharmacy insurance policies for patient on date of service
  1. D RXINS^IBNCPDPU(DFN,IBADT,.IBINS)
  1. ;
  1. ; If current action is a result of a resubmit from ECME User Screen
  1. ; and the selected claim is not the primary claim or the patient
  1. ; only has one insurance, reverse loop through BPS Log of Transaction
  1. ; file looking for an entry related to PRO Option. If PRO Option entry
  1. ; exists, set Rate Type and Plan ID into IBD array. This will ensure the
  1. ; rate type on the resubmit is the same rate type used during secondary
  1. ; claims processing.
  1. I ($G(BWHERE)="ERES"!($G(BWHERE)="ERWV"))&(($G(IBD("RXCOB"))>1)!($G(IBINS)=1)) D
  1. . S STOP=0
  1. . S BPS57=""
  1. . F S BPS57=$O(^BPSTL("AEC",BRXIEN,BPS57),-1) Q:BPS57=""!(STOP=1) D
  1. . . ; Skip this entry if not from PRO Option
  1. . . I $$GET1^DIQ(9002313.57,BPS57,1201)'["P2" Q
  1. . . S POLNO=$$GET1^DIQ(9002313.57,BPS57,1.05)
  1. . . S INSIEN=""
  1. . . F S INSIEN=$O(^BPSTL(BPS57,10,INSIEN)) Q:INSIEN=""!(STOP=1) D
  1. . . . ; Skip entry if Policy # on the transaction does not match Policy # for
  1. . . . ; the insurance. This is an extra check to be sure to use the data
  1. . . . ; from the correct insurance - if more than one insurance exists.
  1. . . . I POLNO'=$$GET1^DIQ(9002313.57902,INSIEN_","_BPS57,902.35) Q
  1. . . . S IBD("RTYPE")=$$GET1^DIQ(9002313.57902,INSIEN_","_BPS57,902.29,"I")
  1. . . . S IBD("PLAN")=$$GET1^DIQ(9002313.57902,INSIEN_","_BPS57,.01,"I")
  1. . . . S STOP=1
  1. ;
  1. ; -- determine rate type
  1. S IBRT=$$RT^IBNCPDPU(DFN,IBADT,.IBINS,.IBPTYP)
  1. ;
  1. ; If the rate type was selected by the user for manual primary or secondary claims processing, then update IBRT
  1. I $G(IBD("RTYPE")),$G(IBD("PLAN")) D
  1. . S $P(IBRT,U,1)=+IBD("RTYPE") ; overwrite the rate type ien [1]
  1. . S $P(IBRT,U,2)=$$COSTTYP^IBNCPUT3(+IBD("RTYPE"),IBADT) ; overwrite the basis of cost determination [2]
  1. . I $P(IBRT,U,3)="" S $P(IBRT,U,3)=IBPTYP ; overwrite eligibility if null [3]
  1. . Q
  1. ;
  1. ; -- Process an eligibility verification request
  1. I IBELIG D G RXQ
  1. . S IBRES=1
  1. . D SETINSUR(IBADT,IBRT,IBELIG,.IBINS,.IBD,.IBRES)
  1. . Q
  1. ;
  1. ; additional data integrity checks
  1. S IBRXN=+$G(IBD("IEN")) I 'IBRXN S IBRES="0^No Rx IEN" G RXQ
  1. S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBRES="0^No fill number" G RXQ
  1. S IBD("QTY")=+$G(IBD("QTY")) I 'IBD("QTY") S IBRES="0^No Quantity" G RXQ
  1. ;
  1. ; -- Gather claims tracking information if it exists
  1. S IBTRKR=$G(^IBE(350.9,1,6))
  1. ; date can't be before parameters
  1. S $P(IBTRKR,U)=$S('$P(IBTRKR,U,4):0,+IBTRKR&(IBADT<+IBTRKR):0,1:IBADT)
  1. ; already in claims tracking
  1. S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
  1. ;
  1. ; Gather and store insurance information in the IBD("INS") insurance array
  1. D SETINSUR(IBADT,IBRT,IBELIG,.IBINS,.IBD,.IBRES)
  1. I $G(IBD("NO ECME INSURANCE")) S IBINSXRES=$G(IBRES) ; save IBRES when there are insurance errors
  1. ;
  1. ;for secondary billing - skip claim tracking functionality
  1. I $G(IBD("RXCOB"))>1 G GETINS
  1. ;
  1. ; -- claims tracking info
  1. I IBTRKRN,$$PAPERBIL^IBNCPNB(IBTRKRN) D G RXQ
  1. . S IBRES="0^Existing IB Bill in CT. OPECC to Cancel Existing Bill in IB & Resubmit Claim"
  1. . S IBD("NO ECME INSURANCE")=1
  1. . ; Add comment to be displayed on the ECME User Screen
  1. . D ADDCOMM^BPSBUTL(IBRXN,IBFIL,"OPECC to Cancel Existing Bill in IB & Resubmit Claim")
  1. ;
  1. ; -- no pharmacy coverage, update ct if applicable, quit
  1. 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
  1. ;
  1. ; Environmental Indicators Validation
  1. ; Find out if the patient is Active Duty - IB*2*534
  1. S IBACDUTY=$P(IBRT,U,3)="T"&$$ACDUTY^IBNCPDPU(DFN)
  1. ; Retrieve indicators from file #52 and overwrite the indicators in IBD array
  1. D GETINDIC^IBNCPUT2(+IBD("IEN"),.IBD)
  1. ; Process patient exemptions if any and if not already resolved
  1. S IBNEEDS=0 ;flag will be set to 1 if at least one of the questions wasn't answered
  1. I ($G(IBD("SC/EI OVR"))'=1&'IBACDUTY)&($G(IBD("ACT DTY OVR"))'=1) D
  1. . D CL^SDCO21(DFN,IBADT,"",.IBARR)
  1. . I $D(IBARR)>9 F IBX=2:1 S IBT=$P($T(EXEMPT+IBX),";;",2) Q:IBT="" D:$D(IBARR(+IBT))
  1. . . I $G(IBD($P(IBT,U,2)))=0 Q
  1. . . I $G(IBD($P(IBT,U,2))) S IBRMARK=$P(IBT,U,3) Q
  1. . . I '$G(IBSCRES(IBRXN,IBFIL)) S IBNEEDS=1 D
  1. . . . 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))
  1. I '$D(IBRMARK),IBNEEDS=1 S IBRMARK="NEEDS SC DETERMINATION"
  1. I $D(IBRMARK) D CT S IBRES="0^"_IBRMARK G RXQ
  1. ;
  1. ; -- check for drug billable
  1. I '$$BILLABLE^IBNCPDP($G(IBD("DRUG")),$P(IBRT,U,3),.IBRMARK,.IBD) S IBRES="0^"_IBRMARK D CT G RXQ
  1. ;
  1. ; -- check for sensitive diagnosis drug and ROI on file
  1. ; $$SENS^IBNCPDR returns 1 if the drug is a sensitive diagnosis drug
  1. I $$SENS^IBNCPDR($G(IBD("DRUG")),.IBD),$D(IBD("INS",1,3)) D
  1. . ; If the Date of Service is on or after the Mission Act
  1. . ; implementation date do not perform ROI checks.
  1. . I $$MACHK^IBNCPDR4(IBADT) Q
  1. . I '$$ROI^IBNCPDR4(DFN,$G(IBD("DRUG")),+$P($G(IBD("INS",1,3)),U,5),IBADT) D Q
  1. .. ;
  1. .. ; no active ROI found for patient/drug/insurance/DOS
  1. .. S IBRMARK="ROI NOT OBTAINED"
  1. .. S IBRES="0^NO ACTIVE/VALID ROI FOR DRUG OR INSURANCE" ; PSO routine PSOREJU3 contains this text
  1. .. Q
  1. . ;
  1. . ; active ROI found, clear out RNB from Claims Tracking and variable IBRMARK
  1. . D ROICLN^IBNCPDR4(IBTRKRN,IBRXN,IBFIL)
  1. . I $G(IBRMARK)["ROI" K IBRMARK
  1. . Q
  1. I $D(IBRMARK) D CT G RXQ
  1. ;
  1. ; Clean-up the NEEDS SC DETERMINATION record if resolved
  1. ; And check if it is non-billable in CT
  1. I IBTRKRN D
  1. . N IBNBR,IBNBRT
  1. . S IBNBR=$P($G(^IBT(356,+IBTRKRN,0)),U,19) Q:'IBNBR
  1. . S IBNBRT=$P($G(^IBE(356.8,IBNBR,0)),U) Q:IBNBRT=""
  1. . ;
  1. . ; if refill was deleted (not RX) and now the refill is re-entered
  1. . ; use $$RXSTATUS^IBNCPRR instead of $G(^PSRX(IBRXN,"STA"))
  1. . I IBNBRT="PRESCRIPTION DELETED",$$RXSTATUS^IBNCPRR(DFN,IBRXN)'=13 D Q
  1. . . N DIE,DA,DR
  1. . . ; clean up REASON NOT BILLABLE and ADDITIONAL COMMENT
  1. . . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@;1.08////@" D ^DIE
  1. . ;
  1. . ; Clean up NBR if released
  1. . I IBNBRT="PRESCRIPTION NOT RELEASED" D:$G(IBD("RELEASE DATE")) Q
  1. . . N DIE,DA,DR
  1. . . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@" D ^DIE
  1. . ;
  1. . ; Clean up 'Needs SC determ'
  1. . I IBNBRT="NEEDS SC DETERMINATION" D Q
  1. . . N DIE,DA,DR
  1. . . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@" D ^DIE
  1. . ;
  1. . ; Clean up 'DRUG NOT BILLABLE' since we made it through the $$BILLABLE function above - IB*2*550
  1. . I IBNBRT="DRUG NOT BILLABLE" D Q
  1. . . N DIE,DA,DR
  1. . . S DIE="^IBT(356,",DA=+IBTRKRN,DR=".19////@;1.08////@" D ^DIE
  1. . . Q
  1. . ;
  1. . S IBRMARK=IBNBRT
  1. . Q
  1. ;
  1. I $D(IBRMARK) S IBRES="0^Non-Billable in CT: "_IBRMARK G RXQ
  1. ;
  1. GETINS ; -- examine the insurance data for a patient
  1. ;
  1. ; if insurance errors were detected earlier, then restore IBRES and get out
  1. I $G(IBD("NO ECME INSURANCE")) S IBRES=$G(IBINSXRES) G RXQ
  1. ;
  1. RATEPRIC ; determine rates/prices to use
  1. ;
  1. I 'IBRT D CT S IBRES="0^Cannot determine Rate type" G RXQ
  1. S IBBI=$$EVNTITM^IBCRU3(+IBRT,3,"PRESCRIPTION FILL",IBADT,.IBRS)
  1. I 'IBBI,$P(IBBI,";")'="VA COST" D CT S IBRES="0^Cannot find Billable Item" G RXQ
  1. ;
  1. ; Check for missing NDC
  1. I $G(IBD("NDC"))="" D CT S IBRES="0^Missing NDC" G RXQ
  1. ;
  1. ;1;BEDSECTION;1^
  1. ;IBRS(1,18,5)=
  1. S IBRS=+$O(IBRS($P(IBBI,";"),0))
  1. S IBIT=$$ITPTR^IBCRU2($P(IBBI,";"),$S($P(IBRT,U,2)="A":$$NDC^IBNCPNB($G(IBD("NDC"))),1:"PRESCRIPTION"))
  1. I 'IBIT,$P(IBRT,U,2)'="C" D CT S IBRES="0^Cannot find Item Pointer" G RXQ
  1. ;8
  1. S IBPRICE=+$$BICOST^IBCRCI(+IBRT,3,IBADT,"PRESCRIPTION FILL",+IBIT,,,$S($P(IBRT,U,2)="A":IBD("QTY"),1:1))
  1. ;36^2991001
  1. ;
  1. ; return the true value of drug cost for 3rd party bill if it is zero
  1. I +IBD("COST")=0,$P($G(^DGCR(399.3,+$P(IBRT,U,1),0)),U,5) S IBD("COST")=$$RXPCT(.IBD,.BWHERE)
  1. ;
  1. ; $$RATECHG^IBCRCC will return dispensing fee and administrative fee
  1. ; (in IBFEE, passed by reference) and adjusted charge amount based on
  1. ; the rate schedule.
  1. ;
  1. S IBCHG=$$RATECHG^IBCRCC(+IBRS,$S($P(IBRT,U,2)'="C":1,1:IBD("QTY")*IBD("COST")),IBADT,.IBFEE)
  1. I $P(IBRT,U,2)="C" S IBPRICE=+IBCHG
  1. S IBDISPFEE=+$P($G(IBFEE),U,1) ; dispensing fee
  1. S IBADMINFEE=+$P($G(IBFEE),U,2) ; administrative fee
  1. ;
  1. I 'IBPRICE D CT S IBRES="0^Cannot find price for Item" G RXQ
  1. ;
  1. ; Calculate the ingredient cost. Default to 0.01 if less than that.
  1. ;
  1. S IBINGCOST=IBD("QTY")*IBD("COST")
  1. I IBINGCOST<0.01 S IBINGCOST=0.01,IBPRICE=IBPRICE+0.01
  1. ;
  1. ; build pricing data string
  1. S IBPRDATA=""
  1. S $P(IBPRDATA,U,1)=IBDISPFEE ; dispensing fee
  1. S $P(IBPRDATA,U,2)=$S($P(IBRT,U,2)="A":"01",$P(IBRT,U,2)="C":"05",1:"07") ; basis of cost determination
  1. 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
  1. S $P(IBPRDATA,U,4)=IBPRICE ; gross amount due
  1. S $P(IBPRDATA,U,5)=IBADMINFEE ; administrative fee
  1. S $P(IBPRDATA,U,6)=IBINGCOST ; ingredient cost
  1. S $P(IBPRDATA,U,7)=IBPRICE-IBADMINFEE ; usual & customary charge (U&C)
  1. ;
  1. ; store the pricing data string on each node 2 that may exist
  1. S IBX=0 F S IBX=$O(IBD("INS",IBX)) Q:'IBX S IBD("INS",IBX,2)=IBPRDATA
  1. ;
  1. S IBRES=$S($D(IBRMARK):"0^"_IBRMARK,1:1)
  1. I IBRES,'$G(IBD("RELEASE DATE")) S IBRMARK="PRESCRIPTION NOT RELEASED"
  1. ;
  1. D CT
  1. ;
  1. RXQ ; final processing
  1. ; set the 3rd piece of IBRES (default Vet)
  1. S $P(IBRES,U,3)=$S($L($P($G(IBRT),U,3)):$P(IBRT,U,3),1:"V")
  1. ; If patient does not have active insurance and is TRICARE/CHAMPVA,
  1. ; set the 3rd piece of IBRES to the patient type.
  1. I $G(IBD("NO ECME INSURANCE")),((IBPTYP="C")!(IBPTYP="T")) D
  1. . S $P(IBRES,U,3)=IBPTYP
  1. . S IBD("PATIENT TYPE")=IBPTYP
  1. ; possibly add entries to files 366.14 and 366.15 (not for eligibility verification requests)
  1. I 'IBELIG D
  1. . I IBRES D START^IBNCPDP6(IBRXN_";"_IBFIL,$P(IBRES,U,3),+IBRT)
  1. . D LOG^IBNCPDP2("BILLABLE STATUS CHECK",IBRES)
  1. . Q
  1. ;
  1. Q IBRES
  1. ;
  1. ;
  1. CT ; files in claims tracking
  1. I $G(IBD("RXCOB"))>1 Q ;Claim Tracking is updated only for the primary payer (payer sequence =1)
  1. ;If null then the payer sequence = Primary is assumed
  1. I IBTRKR D CT^IBNCPDPU(DFN,IBRXN,IBFIL,IBADT,$G(IBRMARK))
  1. Q
  1. ;
  1. SETINSUR(IBADT,IBRT,IBELIG,IBINS,IBD,IBRES) ; build insurance data array
  1. ; Input variables:
  1. ; IBADT - date of service/identify insurance as of this date
  1. ; IBRT - rate type variable - [1] rate type ien, [2] type (A/C/T), [3] eligibility (V/T/C)
  1. ; IBELIG - eligibility request flag (1/0)
  1. ; IBINS - insurance array as returned by RXINS^IBNCPDPU
  1. ; IBD - input/output - array entries passed in and certain array entries returned
  1. ; Output variable:
  1. ; IBRES - only returned if insurance errors
  1. ;
  1. ; Note: if more than one insurance with the same COB then the latest insurance occurrence overrides the first one(s)
  1. ; Example:
  1. ; IBINS("S",1,1)=""
  1. ; IBINS("S",1,3)="" <<--- this will be primary
  1. ;
  1. K IBD("INS"),IBD("NO ECME INSURANCE")
  1. ;
  1. N IBCNT,IBERMSG,IBRXPOL,IBT,IBX
  1. ; IBERMSG - error message array
  1. ; IBRXPOL - array of Rx policies found
  1. ;
  1. S IBX=0 F S IBX=$O(IBINS("S",IBX)) Q:'IBX D
  1. . S IBT=0 F S IBT=$O(IBINS("S",IBX,IBT)) Q:'IBT D
  1. .. N IBDAT,IBPL,IBINSN,IBPIEN,IBY,IBZ,IBCHNM,IBREL,IBPLNTYP
  1. .. S IBZ=$G(IBINS(IBT,0)) Q:IBZ=""
  1. .. S IBPL=$P(IBZ,U,18) ; plan
  1. .. Q:'IBPL
  1. .. Q:'$$PLCOV^IBCNSU3(IBPL,IBADT,3) ; not a pharmacy plan
  1. .. I $G(IBD("PLAN")) Q:IBPL'=$G(IBD("PLAN")) ; skip other plans if we call RX API for a specific plan (IBD("PLAN"))
  1. .. ;
  1. .. ; at this point we have found an Rx policy. We'll count these up later by IBX.
  1. .. S IBRXPOL(IBX,IBT)=""
  1. .. ;
  1. .. 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
  1. .. 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
  1. .. ;
  1. .. S IBPIEN=+$G(^IBA(355.3,+IBPL,6))
  1. .. I 'IBPIEN S IBERMSG(IBX)="Plan not linked to the Payer" Q ; Not linked
  1. .. ;
  1. .. K IBY D STCHK^IBCNRU1(IBPIEN,.IBY,IBELIG)
  1. .. I $E($G(IBY(1)))'="A" S IBERMSG(IBX)=$$ERMSG^IBNCPNB($G(IBY(6))) Q ; not active
  1. .. ;
  1. .. ; at this point we have a valid policy for this IBX
  1. .. S IBERMSG(IBX)="" ; no error message
  1. .. S IBINSN=$P($G(^DIC(36,+$G(^IBA(355.3,+IBPL,0)),0)),U) ; ins name
  1. .. S IBCHNM=$$NAME^IBCEFG1($P(IBZ,U,17)) ; standardize subscriber/cardholder name
  1. .. S IBREL=+$P($G(IBINS(IBT,4)),U,5) ; pointer to pharmacy relationship code file
  1. .. ; use the #4.05 field if it exists, otherwise use the old pt relationship field #16
  1. .. S IBREL=$S(IBREL:$$EXTERNAL^DILFD(2.312,4.05,,IBREL),1:$P(IBZ,U,16))
  1. .. ;
  1. .. S IBDAT=""
  1. .. S $P(IBDAT,U,1)=IBPL ; Plan IEN
  1. .. S $P(IBDAT,U,2)=$G(IBY(2)) ; BIN
  1. .. S $P(IBDAT,U,3)=$G(IBY(3)) ; PCN
  1. .. S $P(IBDAT,U,4)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",1),0)),U) ; Payer Sheet B1 name
  1. .. S $P(IBDAT,U,5)=$P($G(IBINS(IBT,355.3)),U,4) ; Group ID
  1. .. S $P(IBDAT,U,6)=$P(IBZ,U,2) ; Cardholder ID
  1. .. S $P(IBDAT,U,7)=IBREL ; Patient Relationship Code
  1. .. S $P(IBDAT,U,8)=$P(IBCHNM,U,2) ; Cardholder First Name
  1. .. S $P(IBDAT,U,9)=$P(IBCHNM,U,1) ; Cardholder Last Name
  1. .. S $P(IBDAT,U,10)=$P($G(^DIC(36,+IBZ,.11)),U,5) ; State
  1. .. S $P(IBDAT,U,11)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",2),0)),U) ; Payer Sheet B2 name
  1. .. S $P(IBDAT,U,12)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",3),0)),U) ; Payer Sheet B3 name
  1. .. S $P(IBDAT,U,13)=$G(IBY(4)) ; Software/Vendor Cert ID
  1. .. S $P(IBDAT,U,14)=IBINSN ; Ins Name
  1. .. S $P(IBDAT,U,15)=$P($G(^BPSF(9002313.92,+$P($G(IBY(5)),",",4),0)),U) ; Payer Sheet E1 name
  1. .. S $P(IBDAT,U,16)=+$P($G(IBY(5)),",",1) ; Payer Sheet B1 ien
  1. .. S $P(IBDAT,U,17)=+$P($G(IBY(5)),",",2) ; Payer Sheet B2 ien
  1. .. S $P(IBDAT,U,18)=+$P($G(IBY(5)),",",3) ; Payer Sheet B3 ien
  1. .. S $P(IBDAT,U,19)=+$P($G(IBY(5)),",",4) ; Payer Sheet E1 ien
  1. .. S $P(IBDAT,U,20)=$P($G(IBINS(IBT,4)),U,6) ; Pharmacy Person Code
  1. .. S IBD("INS",IBX,1)=IBDAT
  1. .. ;
  1. .. S IBDAT=""
  1. .. S $P(IBDAT,U,1)=$P($G(IBINS(IBT,355.3)),U,3) ;group name
  1. .. S $P(IBDAT,U,2)=$$PHONE^IBNCPDP6(+IBZ) ;ins co ph 3
  1. .. S $P(IBDAT,U,3)=$$GET1^DIQ(366.03,IBPIEN_",",.01) ;plan ID
  1. .. S $P(IBDAT,U,4)=$S(IBPLNTYP="TRICARE":"T",IBPLNTYP="CHAMPVA":"C",1:"V") ; plan type
  1. .. S $P(IBDAT,U,5)=+$G(^IBA(355.3,+IBPL,0)) ; insurance co ien
  1. .. S $P(IBDAT,U,6)=$P(IBZ,U,20) ;(#.2) COB field of the (#.3121) insurance Type multiple of the Patient file (#2)
  1. .. S $P(IBDAT,U,7)=IBT ; 2.312 subfile ien
  1. .. S $P(IBDAT,U,8)=$$GET1^DIQ(366.03,IBPIEN_",",10.1) ; maximum ncpdp transactions
  1. .. S IBD("INS",IBX,3)=IBDAT
  1. .. Q
  1. . Q
  1. ;
  1. ; Count the number of pharmacy insurance policies by IBX found up above
  1. S IBX=0 F IBCNT=0:1 S IBX=$O(IBRXPOL(IBX)) Q:'IBX
  1. ;
  1. ; Determine the value of the IBX variable here. This is basically the COB sequence# to be used.
  1. ; If there is only 1 pharmacy policy or no pharmacy policies, then set IBX in this manner
  1. I IBCNT'>1 D
  1. . I $D(IBD("INS")) S IBX=+$O(IBD("INS",0)) ; use the only one in this array
  1. . I '$D(IBD("INS")) S IBX=+$O(IBERMSG(0)) ; the only one here (or 0)
  1. . Q
  1. ;
  1. ; If there are multiple pharmacy policies on file, then the COB field in the pt. policy must be used correctly
  1. ; and primary insurance must be at #1
  1. I IBCNT>1 S IBX=1
  1. ;
  1. ; In all cases, if this variable is set, then use it
  1. I $G(IBD("RXCOB"))>1 S IBX=$G(IBD("RXCOB"))
  1. ;
  1. ; Check insurance at IBX
  1. I '$D(IBD("INS",IBX)),$G(IBERMSG(IBX))'="" S IBRES="0^Not ECME billable: "_IBERMSG(IBX),IBD("NO ECME INSURANCE")=1 G SETINX
  1. I '$D(IBD("INS",IBX)) S IBRES="0^No Insurance ECME billable",IBD("NO ECME INSURANCE")=1
  1. SETINX ;
  1. Q
  1. ;
  1. RXPCT(IBD,BWHERE) ; Penny drug cost calculation
  1. ; Input-IBD array, BWHERE
  1. ; Output-return quotient of drug true value with 4 decimal places, or 0
  1. N IBDIEN,IBDRX,IBNDC,IBFRM,IBDRFL,IBUNIT,IBSYN,IBQUO,IBDQUO,IBPSUF,IBPORD,IBPDISP,IBDRUG
  1. S IBDIEN=IBD("IEN"),IBNDC=IBD("NDC"),IBDRX=IBD("DRUG"),IBDRFL=IBD("FILL NUMBER")
  1. S IBFRM=$G(BWHERE),IBQUO=0
  1. G:'IBDRX RXPCTQ
  1. ; default unit price from (50-13/15)
  1. D GETS^DIQ(50,IBDRX,".01;13;15","I","IBUNIT")
  1. S IBPORD=$G(IBUNIT(50,IBDRX_",",13,"I"))
  1. S IBPDISP=$G(IBUNIT(50,IBDRX_",",15,"I"))
  1. S (IBDQUO,IBQUO)=$S(IBPORD&IBPDISP:(IBPORD/IBPDISP),1:0)
  1. ;
  1. ; unit price from (50.1-402/403) if NDC exists in the SYNONYM subfile
  1. D DATA^IBRXUTL(IBDRX)
  1. S IBSYN=0 F S IBSYN=$O(^TMP($J,"IBDRUG",IBDRX,"SYN",IBSYN)) Q:'IBSYN D
  1. . I IBNDC'="",$G(^TMP($J,"IBDRUG",IBDRX,"SYN",IBSYN,2))=IBNDC D
  1. .. S IBPSUF=IBSYN_","_IBDRX_","
  1. .. D GETS^DIQ(50.1,IBPSUF,".01;402;403","I","IBUNIT")
  1. .. S IBPORD=$G(IBUNIT(50.1,IBPSUF,402,"I"))
  1. .. S IBPDISP=$G(IBUNIT(50.1,IBPSUF,403,"I"))
  1. .. S IBQUO=$S(IBPORD&IBPDISP:(IBPORD/IBPDISP),1:0)
  1. ;
  1. ; API #4970 - use the default unit price for CMOP
  1. I $$MWC^PSOBPSU2(IBDIEN,IBDRFL)="C" D
  1. . Q:(IBFRM="PE")!(IBFRM="PP")
  1. . S IBQUO=IBDQUO
  1. ; set the lowest value 0.0001 with 4 decimal if less than 0.00005
  1. I IBQUO S IBQUO=$J(IBQUO,1,4),IBQUO=$S(IBQUO>0:IBQUO,1:"0.0001")
  1. K ^TMP($J,"IBDRUG")
  1. RXPCTQ ;
  1. Q IBQUO
  1. ;
  1. EXEMPT ; exemption reasons
  1. ; variable from SD call ^ variable from PSO ^ reason not billable
  1. ;;1^AO^AGENT ORANGE
  1. ;;2^IR^IONIZING RADIATION
  1. ;;3^SC^SC TREATMENT
  1. ;;4^SWA^SOUTHWEST ASIA
  1. ;;5^MST^MILITARY SEXUAL TRAUMA
  1. ;;6^HNC^HEAD/NECK CANCER
  1. ;;7^CV^COMBAT VETERAN
  1. ;;8^SHAD^PROJECT 112/SHAD
  1. ;;
  1. ;