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

IBNCPDP2.m

Go to the documentation of this file.
  1. IBNCPDP2 ;OAK/ELZ - PROCESSING FOR ECME RESP ;11/15/07 09:43
  1. ;;2.0;INTEGRATED BILLING;**223,276,342,347,363,383,405,384,411,435,452,526,550,649,665**;21-MAR-94;Build 28
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; Reference to DEC^PRCASER1 supported by IA# 593
  1. ; Reference to REL^PRCASVC supported by IA# 385
  1. ; Reference to STATUS^PRCASVC1 supported by IA# 387
  1. ; Reference to ^PRCASVC6 supported by IA# 384
  1. ; Reference to $$RXSITE^PSOBPSUT supported by IA# 4701
  1. ; Reference to $$GETPHARM^BPSUTIL supported by IA# 4146
  1. ;
  1. ECME(DFN,IBD) ; function called by STORESP^IBNCPDP
  1. ; input - DFN - patient IEN for the prescription
  1. ; IBD array passed in by reference
  1. ; The IBD array is passed to various subroutines depending
  1. ; on the ePharmacy event as evaluated by IBD("STATUS")
  1. I $G(IBD("EPHARM"))="" S IBD("EPHARM")=$$EPHARM(+$G(IBD("PRESCRIPTION")),+$G(IBD("FILL NUMBER")))
  1. I IBD("STATUS")="PAID",$G(IBD("RXCOB"))=2 Q $$BILLSEC^IBNCPDP5(DFN,.IBD)
  1. I IBD("STATUS")="PAID" Q $$BILL(DFN,.IBD)
  1. I IBD("STATUS")="REVERSED" Q $$REVERSE^IBNCPDP3(DFN,.IBD)
  1. I IBD("STATUS")="CLOSED" Q $$CLOSE^IBNCPDP4(DFN,.IBD)
  1. I IBD("STATUS")="RELEASED" Q $$RELEASE^IBNCPDP4(DFN,.IBD)
  1. I IBD("STATUS")="SUBMITTED" Q $$SUBMIT^IBNCPDP4(DFN,.IBD)
  1. I IBD("STATUS")="REOPEN" Q $$REOPEN^IBNCPDP4(DFN,.IBD)
  1. I IBD("STATUS")="ELIG" Q $$ELIG^IBNCPDP3(DFN,.IBD)
  1. D LOG("UNKNOWN")
  1. Q "0^Cannot determine ECME event status"
  1. ;
  1. MATCH(BCID,IBS) ; right bill, right COB payer
  1. N IBX,IBPS,IBFOUND,ECMELEN,BCID1
  1. S IBPS=$S(IBS=1:"P",IBS=2:"S",IBS=3:"T",1:"P")
  1. S IBFOUND=0
  1. ;
  1. ; need to check for ECME# lengths of both 7 digits and 12 digits to be sure
  1. F ECMELEN=12,7 D Q:IBFOUND
  1. . I $L(+BCID)>ECMELEN Q ; quit if too large
  1. . S BCID1=BCID
  1. . S $P(BCID1,";",1)=$$RJ^XLFSTR(+BCID,ECMELEN,0)
  1. . S IBX=0 ; quit when we have found a non-cancelled claim with a payer sequence match
  1. . F S IBX=$O(^DGCR(399,"AG",BCID1,IBX)) Q:'IBX!IBFOUND I '$P($G(^DGCR(399,IBX,"S")),U,16),(IBPS=$P($G(^DGCR(399,IBX,0)),U,21)) S IBFOUND=IBX Q
  1. . Q
  1. ;
  1. Q IBFOUND
  1. ;
  1. BILL(DFN,IBD) ; create bills
  1. N IBDIV,IBAMT,IBY,IBSERV,IBFAC,IBSITE,IBDRX,IB,IBCDFN,IBINS,IBIDS,IBIFN,IBDFN,PRCASV,IBTRIC,IBLGL,IBLDT2,IBDUP,CHKBL
  1. N PRCAERR,IBADT,IBRXN,IBFIL,IBTRKRN,DIE,DA,DR,IBRES,IBLOCK,IBLDT,IBNOW,IBDUZ,RCDUZ,IBPREV,IBQUERY,IBPAID,IBACT,%,DGRVRCAL
  1. ;
  1. S IBDUZ=.5 ;POSTMASTER
  1. S RCDUZ=IBDUZ
  1. ;
  1. S IBY=1,IBLOCK=0
  1. I 'DFN S IBY="0^Missing DFN" G BILLQ
  1. S IBAMT=+$G(IBD("BILLED")) ;FI portion of charge
  1. I 'IBAMT S IBY="-1^Zero amount billed" G BILLQ
  1. S IBADT=+$G(IBD("DOS"),DT)
  1. S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBY="0^Missing Rx IEN" G BILLQ
  1. S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBY="0^No fill number" G BILLQ
  1. ;
  1. ; IB*2*452 - esg - check for duplicate response
  1. S IBDUP=$$DUP(.IBD) I IBDUP S IBY="0^Bill# "_$P(IBDUP,U,2)_" exists (Duplicate)" G BILLQ
  1. ;
  1. S IBDIV=+$G(IBD("DIVISION"))
  1. I '$L($G(IBD("CLAIMID"))) S IBY="-1^Missing ECME Number" G BILLQ
  1. S IBD("BCID")=$$BCID^IBNCPDP4(IBD("CLAIMID"),IBADT)
  1. L +^DGCR(399,"AG",IBD("BCID")):15 E S IBY="0^Cannot lock ECME number." G BILLQ
  1. ;
  1. S IBTRIC=$$TRICARE^IBNCPDP6(IBRXN_";"_IBFIL)
  1. ; do patient copay first (only applicable if TRICARE)
  1. I $G(IBD("COPAY")),IBTRIC D BILL^IBNCPDP6(IBRXN_";"_IBFIL,IBD("COPAY"),$G(IBD("RTYPE"))) ; create TRICARE Rx copay charge
  1. ;
  1. S IBLOCK=1,IBLDT2=""
  1. S IBLDT=$$FMADD^XLFDT(DT,1) F S IBLGL=$O(^XTMP("IBNCPLDT"_IBLDT),-1),IBLDT=$E(IBLGL,9,15) Q:IBLDT<$$FMADD^XLFDT(DT,-3)!(IBLGL'["IBNCPLDT") I $D(^XTMP(IBLGL,IBD("BCID"))) S IBLDT2=^(IBD("BCID")) Q ;Last time called
  1. D NOW^%DTC S IBNOW=%
  1. ; 2 calls in 45 sec
  1. I IBLDT2,$$FMDIFF^XLFDT(IBNOW,IBLDT2,2)<45 S IBY="0^Duplicate billing call" G BILLQ
  1. ;
  1. ; check to see if a non-cancelled bill (same ECME#, same DOS, same payer sequence) already exists
  1. ; if it does, then cancel this previous bill using the REVERSE action
  1. S CHKBL=$$MATCH(IBD("BCID"),IBD("RXCOB"))
  1. I CHKBL D
  1. . N IBARR
  1. . M IBARR=IBD
  1. . S IBARR("REVERSAL REASON")="Cancel the existing bill ("_$P($G(^DGCR(399,CHKBL,0)),U,1)_")"
  1. . I $$REVERSE^IBNCPDP3(DFN,.IBARR)
  1. . Q
  1. ;
  1. ; derive minimal variables
  1. I '$$CHECK^IBECEAU(0) S IBY="-1^IB SITE" G BILLQ
  1. S IBSERV=$P($G(^IBE(350.1,1,0)),"^",4)
  1. I '$$SERV^IBARX1(IBSERV) S IBY="-1^IB SERVICE" G BILLQ
  1. I 'IBDIV S IBDIV=$P($$MCDIV^IBNCPEB(IBRXN,IBFIL),U,2)
  1. I 'IBDIV S IBDIV=+$P($G(^SC(+$$FILE^IBRXUTL(IBRXN,5),0)),"^",15)
  1. I 'IBDIV S IBDIV=+$P($G(^IBE(350.9,1,1)),U,25) ;dflt
  1. I IBDIV S IBD("DIVISION")=IBDIV
  1. ; - establish a stub claim/receivable
  1. D SET^IBR I IBY<0 G BILLQ
  1. ;
  1. ; set up the following variables for claim establishment:
  1. ; .01 BILL #
  1. ; .17 ORIG CLAIM
  1. ; .2 AUTO?
  1. ; .02 DFN
  1. ; .06 TIMEFRAME
  1. ; .07 RATE TYPE
  1. ; .18 SC AT TIME?
  1. ; .04 LOCATION
  1. ; .22 DIVISION
  1. ; .05 BILL CLASSIF (3)
  1. ; .03 EVT DATE (DATE OF SERVICE)
  1. ; 151 BILL FROM
  1. ; 152 BILL TO
  1. ; 155 SENSITIVE DX
  1. ; 157 ROI OBTAINED
  1. ; 101 PRIMARY INS CARRIER
  1. K IB
  1. S (IB(.02),IBDFN)=DFN
  1. S IB(.07)=$$RT^IBNCPDP6(IBRXN_";"_IBFIL) ; previously determined rate type
  1. I 'IB(.07) S IB(.07)=+$$RT^IBNCPDPU(DFN) ; cannot find previously, try to recompute
  1. I 'IB(.07) S IBY="-1^IB RATE TYPE" G BILLQ
  1. ;
  1. S IBIFN=PRCASV("ARREC")
  1. S IB(.01)=$P(PRCASV("ARBIL"),"-",2)
  1. S IB(.17)=""
  1. S IB(.2)=0
  1. S IB(.06)=1
  1. S IB(.18)=$$SC^IBCU3(DFN)
  1. S IB(.04)=$S(+$P($G(^DG(40.8,+IBDIV,0)),U,3):7,1:1)
  1. S:IBDIV IB(.22)=+IBDIV
  1. S IB(.05)=3
  1. S (IB(.03),IB(151),IB(152))=IBADT
  1. S IBINS=$P($G(^IBA(355.3,+$G(IBD("PLAN")),0)),"^") I IBINS S IB(101)=IBINS
  1. ;
  1. ; set 362.4 node to rx#^p50^days sup^date of service^qty^ndc
  1. S IB(362.4,IBRXN,IBFIL)=IBD("RX NO")_"^"_IBD("DRUG")_"^"_IBD("DAYS SUPPLY")_"^"_IBD("DOS")_"^"_IBD("QTY")_"^"_IBD("NDC")
  1. ;
  1. ; Sensitive Diagnosis Drug check
  1. I $$SENS^IBNCPDR(IBD("DRUG")) S IB(155)=1,IB(157)=1 ; set sensitive dx and ROI obtained
  1. ;
  1. ; call the autobiller module to create the claim with a default
  1. ; diagnosis and procedure for prescriptions
  1. D EN^IBCD3(.IBQUERY)
  1. D CLOSE^IBSDU(.IBQUERY)
  1. ;
  1. S:'$D(^XTMP("IBNCPLDT"_DT)) ^XTMP("IBNCPLDT"_DT,0)=$$FMADD^XLFDT(DT,2)_U_DT S ^XTMP("IBNCPLDT"_DT,IBD("BCID"))=IBNOW
  1. S DIE="^DGCR(399,",DA=IBIFN
  1. ; update the ECME fields
  1. S DR="460////^S X=IBD(""BCID"")" S:$L($G(IBD("AUTH #"))) DR=DR_";461////^S X=IBD(""AUTH #"")"
  1. D ^DIE K DA,DR,DIE
  1. D SETCT ; Set Claims Tracking record
  1. ;
  1. ; IEN to 2.3121
  1. S IBCDFN=$$PLANN^IBNCPDPU(DFN,IBD("PLAN"),IBADT)
  1. I 'IBCDFN S IBY="-1^Plan not found in Patient's Profile." G BILLQ
  1. ;
  1. ; add the payer (fiscal intermediary) to the claim
  1. S IBINS=+IBCDFN,IBCDFN=$P(IBCDFN,"^",2)
  1. S DIE="^DGCR(399,",DA=IBIFN,DR="112////"_IBCDFN
  1. D ^DIE K DA,DR,DIE,DGRVRCAL
  1. ;
  1. ; need to make sure we have computed charges
  1. D CHARGES(IBIFN)
  1. I $P($G(^DGCR(399,IBIFN,"U1")),U,1)'>0 S IBY="-1^Total Charges must be greater than $0." G BILLQ
  1. ;
  1. ; update the authorize/print fields
  1. S DIE="^DGCR(399,",DA=IBIFN
  1. S DR="9////1;12////"_DT D ^DIE
  1. ;
  1. ; *526 set approving official
  1. S:'$D(^VA(200,IBDUZ,0)) IBDUZ=.5
  1. ; pass the claim to AR
  1. D GVAR^IBCBB,ARRAY^IBCBB1 S PRCASV("APR")=IBDUZ D ^PRCASVC6
  1. I 'PRCASV("OKAY") S IBY="-1^"_$$ARERR($G(PRCAERR),1) G BILLQ
  1. D REL^PRCASVC
  1. ;
  1. ; update the AR status to Active
  1. ; D AUDITX^PRCAUDT(PRCASV("ARREC"))
  1. S PRCASV("STATUS")=16
  1. D STATUS^PRCASVC1
  1. ;
  1. ; decrease adjust bill
  1. ; Auto decrease from service Bill#,Tran amt,person,reason,Tran date
  1. S IBAMT=$G(^DGCR(399,IBIFN,"U1"))
  1. S IBPAID=$G(IBD("PAID"))
  1. I IBAMT-IBPAID>.01 D
  1. . N IBREAS
  1. . S IBREAS="Adjust based on ECME amount paid."
  1. . I IBTRIC S IBREAS="Due to TRICARE Patient Responsibility."
  1. . D DEC^PRCASER1(PRCASV("ARREC"),IBAMT-IBPAID,IBDUZ,IBREAS,IBADT)
  1. . I 'IBPAID S PRCASV("STATUS")=22 D STATUS^PRCASVC1 ; collected/closed
  1. ;
  1. D ; set the user in 399
  1. . N IBI,IBT F IBI=2,5,11,13,15 S IBT(399,IBIFN_",",IBI)=IBDUZ
  1. . D FILE^DIE("","IBT")
  1. ;
  1. BILLQ S IBRES=$S(IBY<0:"0^"_$S($L($P(IBY,"^",2)):$P(IBY,"^",2),1:$P(IBY,"^",3)),$G(IBIFN):+IBIFN,1:IBY)
  1. I $G(IBIFN) S IBD("BILL")=IBIFN
  1. D LOG("BILL",IBRES)
  1. I IBY<0 D BULL^IBNCPEB($G(DFN),.IBD,IBRES,$G(IBIFN))
  1. I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
  1. Q IBRES
  1. ;
  1. SETCT ; update claims tracking saying bill has been billed
  1. N X,Y,D0,DA,DI,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR
  1. S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
  1. I IBTRKRN S DIE="^IBT(356,",DA=IBTRKRN,DR=".11////^S X=IBIFN;.17///@" D ^DIE
  1. I IBTRKRN,(+$G(IBD("DOS"))'=$P(^IBT(356,IBTRKRN,0),U,6)) S DIE="^IBT(356,",DA=IBTRKRN,DR=".06////"_IBD("DOS") D ^DIE ; Check Date of Service
  1. I IBTRKRN,IBIFN D CTB^IBCDC(IBTRKRN,IBIFN)
  1. Q
  1. ;
  1. LOG(PROC,RESULT) ;Store the data
  1. ;Log values passed into IB by outside applications
  1. ;
  1. ;implicit input variables/arrays :
  1. ; IBD array with values sent to IB (see calling subroutines)
  1. ; DFN - patient's IEN (file #2)
  1. ; DUZ - user's IEN(file #200)
  1. ;explicit parameters:
  1. ; PROC - type of event as string, i.e. BILL, REJECT and so on
  1. ; RESULT - result of the event processing, format: return_code^message
  1. ;
  1. D LOG^IBNCPLOG(.IBD,DFN,PROC,RESULT,$J,$$NOW^XLFDT(),+DUZ)
  1. Q
  1. ;
  1. EPHARM(IBRX,IBREFILL) ;
  1. ;returns ien of #9002313.56 BPS PHARMACIES associated
  1. ;with the prescription specified by:
  1. ; IBRX - IEN in file #52
  1. ; IBREFILL - zero(0) for the original prescription or the refill
  1. ; number for a refill (IEN of REFILL multiple #52.1)
  1. I +$G(IBRX)=0 Q ""
  1. I $G(IBREFILL)="" Q ""
  1. N IBDIV59
  1. S IBDIV59=+$$RXSITE^PSOBPSUT(+IBRX,+IBREFILL)
  1. I IBDIV59>0 Q $$GETPHARM^BPSUTIL(IBDIV59)
  1. Q ""
  1. ;
  1. CHARGES(IBIFN) ; set up charges on the bill
  1. ;
  1. ; Input: IBIFN = Bill (399) ien
  1. N DGPTUPDT
  1. D BILL^IBCRBC(IBIFN) ; generic bill charge calculator
  1. Q
  1. ;
  1. DUP(IBD) ; Function to determine if processing a duplicate response
  1. ; and if a bill should be created
  1. ; Input
  1. ; IBD array values
  1. ; Output
  1. ; Function value: [1] "1" if a duplicate response received and a non-cancelled bill already exists
  1. ; [2] non-cancelled external bill# if piece [1] =1
  1. ; or
  1. ; [1] "0" if not a duplicate response OR no bill exists
  1. ; [2] ""
  1. ;
  1. N RET,RXIEN,RXFIL,COB,IBZ,IBARR,IBIFN,ARSTAT
  1. S RET=0
  1. I $G(IBD("RESPONSE"))'="DUPLICATE" G DUPX
  1. ;
  1. ; set up variables from array data and try to find bills
  1. S RXIEN=+$G(IBD("PRESCRIPTION"))
  1. S RXFIL=+$G(IBD("FILL NUMBER"))
  1. S COB=+$G(IBD("RXCOB")),COB=$S(COB=2:"S",COB=3:"T",1:"P")
  1. S IBZ=$$RXBILL^IBNCPUT3(RXIEN,RXFIL,COB,,.IBARR)
  1. ;
  1. ; if the function returned an active bill, then use it and get out
  1. I +$P(IBZ,U,2) S IBIFN=+$P(IBZ,U,2),RET=1_U_$P($G(^DGCR(399,IBIFN,0)),U,1) G DUPX
  1. ;
  1. ; if no bills found at all then get out
  1. I '$P(IBZ,U,1) G DUPX
  1. I '$D(IBARR) G DUPX
  1. ;
  1. ; loop thru the array looking for any non-cancelled bills
  1. S IBIFN="" F S IBIFN=$O(IBARR(IBIFN),-1) Q:'IBIFN D Q:+RET
  1. . S ARSTAT=$P($G(IBARR(IBIFN)),U,2)
  1. . I ARSTAT'="CB",ARSTAT'="CN" S RET=1_U_$P($G(^DGCR(399,IBIFN,0)),U,1) Q
  1. . Q
  1. DUPX ;
  1. Q RET
  1. ;
  1. ARERR(CODE,COB) ; retrieve AR error text
  1. ; This function is called after calling AR routine PRCASVC6 and that routine indicates
  1. ; some AR error has been detected. Variable PRCAERR is passed into this function as
  1. ; the CODE parameter. The COB parameter indicates the COB payer sequence.
  1. ;
  1. ; Format of CODE: -1^PRCA error code in file 350.8
  1. ; or -1^AR text error message
  1. ; or undefined
  1. ;
  1. N ERR,IBZ
  1. S ERR=""
  1. S CODE=$P($G(CODE),U,2)
  1. S COB=$G(COB,1)
  1. I CODE="" S ERR="Cannot establish receivable in AR" G ARERRX ; generic error message
  1. ;
  1. S IBZ=+$O(^IBE(350.8,"C",CODE,0))
  1. I IBZ S ERR=$P($G(^IBE(350.8,IBZ,0)),U,2) G ARERRX ; error message from IB file
  1. ;
  1. S ERR=CODE ; error message text from routine PRCASVC6
  1. ;
  1. ARERRX ;
  1. S ERR=$$TRIM^XLFSTR(ERR,"R",".") ; remove ending period
  1. I COB>1 S ERR=ERR_" ("_$S(COB=2:"Sec",1:"Tert")_" Ins)"
  1. S ERR="AR Error: "_ERR
  1. Q ERR
  1. ;