- IBNCPDP2 ;OAK/ELZ - PROCESSING FOR ECME RESP ;11/15/07 09:43
- ;;2.0;INTEGRATED BILLING;**223,276,342,347,363,383,405,384,411,435,452,526,550,649,665**;21-MAR-94;Build 28
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ; Reference to DEC^PRCASER1 supported by IA# 593
- ; Reference to REL^PRCASVC supported by IA# 385
- ; Reference to STATUS^PRCASVC1 supported by IA# 387
- ; Reference to ^PRCASVC6 supported by IA# 384
- ; Reference to $$RXSITE^PSOBPSUT supported by IA# 4701
- ; Reference to $$GETPHARM^BPSUTIL supported by IA# 4146
- ;
- ECME(DFN,IBD) ; function called by STORESP^IBNCPDP
- ; input - DFN - patient IEN for the prescription
- ; IBD array passed in by reference
- ; The IBD array is passed to various subroutines depending
- ; on the ePharmacy event as evaluated by IBD("STATUS")
- I $G(IBD("EPHARM"))="" S IBD("EPHARM")=$$EPHARM(+$G(IBD("PRESCRIPTION")),+$G(IBD("FILL NUMBER")))
- I IBD("STATUS")="PAID",$G(IBD("RXCOB"))=2 Q $$BILLSEC^IBNCPDP5(DFN,.IBD)
- I IBD("STATUS")="PAID" Q $$BILL(DFN,.IBD)
- I IBD("STATUS")="REVERSED" Q $$REVERSE^IBNCPDP3(DFN,.IBD)
- I IBD("STATUS")="CLOSED" Q $$CLOSE^IBNCPDP4(DFN,.IBD)
- I IBD("STATUS")="RELEASED" Q $$RELEASE^IBNCPDP4(DFN,.IBD)
- I IBD("STATUS")="SUBMITTED" Q $$SUBMIT^IBNCPDP4(DFN,.IBD)
- I IBD("STATUS")="REOPEN" Q $$REOPEN^IBNCPDP4(DFN,.IBD)
- I IBD("STATUS")="ELIG" Q $$ELIG^IBNCPDP3(DFN,.IBD)
- D LOG("UNKNOWN")
- Q "0^Cannot determine ECME event status"
- ;
- MATCH(BCID,IBS) ; right bill, right COB payer
- N IBX,IBPS,IBFOUND,ECMELEN,BCID1
- S IBPS=$S(IBS=1:"P",IBS=2:"S",IBS=3:"T",1:"P")
- S IBFOUND=0
- ;
- ; need to check for ECME# lengths of both 7 digits and 12 digits to be sure
- F ECMELEN=12,7 D Q:IBFOUND
- . I $L(+BCID)>ECMELEN Q ; quit if too large
- . S BCID1=BCID
- . S $P(BCID1,";",1)=$$RJ^XLFSTR(+BCID,ECMELEN,0)
- . S IBX=0 ; quit when we have found a non-cancelled claim with a payer sequence match
- . 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
- . Q
- ;
- Q IBFOUND
- ;
- BILL(DFN,IBD) ; create bills
- N IBDIV,IBAMT,IBY,IBSERV,IBFAC,IBSITE,IBDRX,IB,IBCDFN,IBINS,IBIDS,IBIFN,IBDFN,PRCASV,IBTRIC,IBLGL,IBLDT2,IBDUP,CHKBL
- N PRCAERR,IBADT,IBRXN,IBFIL,IBTRKRN,DIE,DA,DR,IBRES,IBLOCK,IBLDT,IBNOW,IBDUZ,RCDUZ,IBPREV,IBQUERY,IBPAID,IBACT,%,DGRVRCAL
- ;
- S IBDUZ=.5 ;POSTMASTER
- S RCDUZ=IBDUZ
- ;
- S IBY=1,IBLOCK=0
- I 'DFN S IBY="0^Missing DFN" G BILLQ
- S IBAMT=+$G(IBD("BILLED")) ;FI portion of charge
- I 'IBAMT S IBY="-1^Zero amount billed" G BILLQ
- S IBADT=+$G(IBD("DOS"),DT)
- S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBY="0^Missing Rx IEN" G BILLQ
- S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBY="0^No fill number" G BILLQ
- ;
- ; IB*2*452 - esg - check for duplicate response
- S IBDUP=$$DUP(.IBD) I IBDUP S IBY="0^Bill# "_$P(IBDUP,U,2)_" exists (Duplicate)" G BILLQ
- ;
- S IBDIV=+$G(IBD("DIVISION"))
- I '$L($G(IBD("CLAIMID"))) S IBY="-1^Missing ECME Number" G BILLQ
- S IBD("BCID")=$$BCID^IBNCPDP4(IBD("CLAIMID"),IBADT)
- L +^DGCR(399,"AG",IBD("BCID")):15 E S IBY="0^Cannot lock ECME number." G BILLQ
- ;
- S IBTRIC=$$TRICARE^IBNCPDP6(IBRXN_";"_IBFIL)
- ; do patient copay first (only applicable if TRICARE)
- I $G(IBD("COPAY")),IBTRIC D BILL^IBNCPDP6(IBRXN_";"_IBFIL,IBD("COPAY"),$G(IBD("RTYPE"))) ; create TRICARE Rx copay charge
- ;
- S IBLOCK=1,IBLDT2=""
- 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
- D NOW^%DTC S IBNOW=%
- ; 2 calls in 45 sec
- I IBLDT2,$$FMDIFF^XLFDT(IBNOW,IBLDT2,2)<45 S IBY="0^Duplicate billing call" G BILLQ
- ;
- ; check to see if a non-cancelled bill (same ECME#, same DOS, same payer sequence) already exists
- ; if it does, then cancel this previous bill using the REVERSE action
- S CHKBL=$$MATCH(IBD("BCID"),IBD("RXCOB"))
- I CHKBL D
- . N IBARR
- . M IBARR=IBD
- . S IBARR("REVERSAL REASON")="Cancel the existing bill ("_$P($G(^DGCR(399,CHKBL,0)),U,1)_")"
- . I $$REVERSE^IBNCPDP3(DFN,.IBARR)
- . Q
- ;
- ; derive minimal variables
- I '$$CHECK^IBECEAU(0) S IBY="-1^IB SITE" G BILLQ
- S IBSERV=$P($G(^IBE(350.1,1,0)),"^",4)
- I '$$SERV^IBARX1(IBSERV) S IBY="-1^IB SERVICE" G BILLQ
- I 'IBDIV S IBDIV=$P($$MCDIV^IBNCPEB(IBRXN,IBFIL),U,2)
- I 'IBDIV S IBDIV=+$P($G(^SC(+$$FILE^IBRXUTL(IBRXN,5),0)),"^",15)
- I 'IBDIV S IBDIV=+$P($G(^IBE(350.9,1,1)),U,25) ;dflt
- I IBDIV S IBD("DIVISION")=IBDIV
- ; - establish a stub claim/receivable
- D SET^IBR I IBY<0 G BILLQ
- ;
- ; set up the following variables for claim establishment:
- ; .01 BILL #
- ; .17 ORIG CLAIM
- ; .2 AUTO?
- ; .02 DFN
- ; .06 TIMEFRAME
- ; .07 RATE TYPE
- ; .18 SC AT TIME?
- ; .04 LOCATION
- ; .22 DIVISION
- ; .05 BILL CLASSIF (3)
- ; .03 EVT DATE (DATE OF SERVICE)
- ; 151 BILL FROM
- ; 152 BILL TO
- ; 155 SENSITIVE DX
- ; 157 ROI OBTAINED
- ; 101 PRIMARY INS CARRIER
- K IB
- S (IB(.02),IBDFN)=DFN
- S IB(.07)=$$RT^IBNCPDP6(IBRXN_";"_IBFIL) ; previously determined rate type
- I 'IB(.07) S IB(.07)=+$$RT^IBNCPDPU(DFN) ; cannot find previously, try to recompute
- I 'IB(.07) S IBY="-1^IB RATE TYPE" G BILLQ
- ;
- S IBIFN=PRCASV("ARREC")
- S IB(.01)=$P(PRCASV("ARBIL"),"-",2)
- S IB(.17)=""
- S IB(.2)=0
- S IB(.06)=1
- S IB(.18)=$$SC^IBCU3(DFN)
- S IB(.04)=$S(+$P($G(^DG(40.8,+IBDIV,0)),U,3):7,1:1)
- S:IBDIV IB(.22)=+IBDIV
- S IB(.05)=3
- S (IB(.03),IB(151),IB(152))=IBADT
- S IBINS=$P($G(^IBA(355.3,+$G(IBD("PLAN")),0)),"^") I IBINS S IB(101)=IBINS
- ;
- ; set 362.4 node to rx#^p50^days sup^date of service^qty^ndc
- S IB(362.4,IBRXN,IBFIL)=IBD("RX NO")_"^"_IBD("DRUG")_"^"_IBD("DAYS SUPPLY")_"^"_IBD("DOS")_"^"_IBD("QTY")_"^"_IBD("NDC")
- ;
- ; Sensitive Diagnosis Drug check
- I $$SENS^IBNCPDR(IBD("DRUG")) S IB(155)=1,IB(157)=1 ; set sensitive dx and ROI obtained
- ;
- ; call the autobiller module to create the claim with a default
- ; diagnosis and procedure for prescriptions
- D EN^IBCD3(.IBQUERY)
- D CLOSE^IBSDU(.IBQUERY)
- ;
- S:'$D(^XTMP("IBNCPLDT"_DT)) ^XTMP("IBNCPLDT"_DT,0)=$$FMADD^XLFDT(DT,2)_U_DT S ^XTMP("IBNCPLDT"_DT,IBD("BCID"))=IBNOW
- S DIE="^DGCR(399,",DA=IBIFN
- ; update the ECME fields
- S DR="460////^S X=IBD(""BCID"")" S:$L($G(IBD("AUTH #"))) DR=DR_";461////^S X=IBD(""AUTH #"")"
- D ^DIE K DA,DR,DIE
- D SETCT ; Set Claims Tracking record
- ;
- ; IEN to 2.3121
- S IBCDFN=$$PLANN^IBNCPDPU(DFN,IBD("PLAN"),IBADT)
- I 'IBCDFN S IBY="-1^Plan not found in Patient's Profile." G BILLQ
- ;
- ; add the payer (fiscal intermediary) to the claim
- S IBINS=+IBCDFN,IBCDFN=$P(IBCDFN,"^",2)
- S DIE="^DGCR(399,",DA=IBIFN,DR="112////"_IBCDFN
- D ^DIE K DA,DR,DIE,DGRVRCAL
- ;
- ; need to make sure we have computed charges
- D CHARGES(IBIFN)
- I $P($G(^DGCR(399,IBIFN,"U1")),U,1)'>0 S IBY="-1^Total Charges must be greater than $0." G BILLQ
- ;
- ; update the authorize/print fields
- S DIE="^DGCR(399,",DA=IBIFN
- S DR="9////1;12////"_DT D ^DIE
- ;
- ; *526 set approving official
- S:'$D(^VA(200,IBDUZ,0)) IBDUZ=.5
- ; pass the claim to AR
- D GVAR^IBCBB,ARRAY^IBCBB1 S PRCASV("APR")=IBDUZ D ^PRCASVC6
- I 'PRCASV("OKAY") S IBY="-1^"_$$ARERR($G(PRCAERR),1) G BILLQ
- D REL^PRCASVC
- ;
- ; update the AR status to Active
- ; D AUDITX^PRCAUDT(PRCASV("ARREC"))
- S PRCASV("STATUS")=16
- D STATUS^PRCASVC1
- ;
- ; decrease adjust bill
- ; Auto decrease from service Bill#,Tran amt,person,reason,Tran date
- S IBAMT=$G(^DGCR(399,IBIFN,"U1"))
- S IBPAID=$G(IBD("PAID"))
- I IBAMT-IBPAID>.01 D
- . N IBREAS
- . S IBREAS="Adjust based on ECME amount paid."
- . I IBTRIC S IBREAS="Due to TRICARE Patient Responsibility."
- . D DEC^PRCASER1(PRCASV("ARREC"),IBAMT-IBPAID,IBDUZ,IBREAS,IBADT)
- . I 'IBPAID S PRCASV("STATUS")=22 D STATUS^PRCASVC1 ; collected/closed
- ;
- D ; set the user in 399
- . N IBI,IBT F IBI=2,5,11,13,15 S IBT(399,IBIFN_",",IBI)=IBDUZ
- . D FILE^DIE("","IBT")
- ;
- BILLQ S IBRES=$S(IBY<0:"0^"_$S($L($P(IBY,"^",2)):$P(IBY,"^",2),1:$P(IBY,"^",3)),$G(IBIFN):+IBIFN,1:IBY)
- I $G(IBIFN) S IBD("BILL")=IBIFN
- D LOG("BILL",IBRES)
- I IBY<0 D BULL^IBNCPEB($G(DFN),.IBD,IBRES,$G(IBIFN))
- I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
- Q IBRES
- ;
- SETCT ; update claims tracking saying bill has been billed
- N X,Y,D0,DA,DI,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR
- S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
- I IBTRKRN S DIE="^IBT(356,",DA=IBTRKRN,DR=".11////^S X=IBIFN;.17///@" D ^DIE
- 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
- I IBTRKRN,IBIFN D CTB^IBCDC(IBTRKRN,IBIFN)
- Q
- ;
- LOG(PROC,RESULT) ;Store the data
- ;Log values passed into IB by outside applications
- ;
- ;implicit input variables/arrays :
- ; IBD array with values sent to IB (see calling subroutines)
- ; DFN - patient's IEN (file #2)
- ; DUZ - user's IEN(file #200)
- ;explicit parameters:
- ; PROC - type of event as string, i.e. BILL, REJECT and so on
- ; RESULT - result of the event processing, format: return_code^message
- ;
- D LOG^IBNCPLOG(.IBD,DFN,PROC,RESULT,$J,$$NOW^XLFDT(),+DUZ)
- Q
- ;
- EPHARM(IBRX,IBREFILL) ;
- ;returns ien of #9002313.56 BPS PHARMACIES associated
- ;with the prescription specified by:
- ; IBRX - IEN in file #52
- ; IBREFILL - zero(0) for the original prescription or the refill
- ; number for a refill (IEN of REFILL multiple #52.1)
- I +$G(IBRX)=0 Q ""
- I $G(IBREFILL)="" Q ""
- N IBDIV59
- S IBDIV59=+$$RXSITE^PSOBPSUT(+IBRX,+IBREFILL)
- I IBDIV59>0 Q $$GETPHARM^BPSUTIL(IBDIV59)
- Q ""
- ;
- CHARGES(IBIFN) ; set up charges on the bill
- ;
- ; Input: IBIFN = Bill (399) ien
- N DGPTUPDT
- D BILL^IBCRBC(IBIFN) ; generic bill charge calculator
- Q
- ;
- DUP(IBD) ; Function to determine if processing a duplicate response
- ; and if a bill should be created
- ; Input
- ; IBD array values
- ; Output
- ; Function value: [1] "1" if a duplicate response received and a non-cancelled bill already exists
- ; [2] non-cancelled external bill# if piece [1] =1
- ; or
- ; [1] "0" if not a duplicate response OR no bill exists
- ; [2] ""
- ;
- N RET,RXIEN,RXFIL,COB,IBZ,IBARR,IBIFN,ARSTAT
- S RET=0
- I $G(IBD("RESPONSE"))'="DUPLICATE" G DUPX
- ;
- ; set up variables from array data and try to find bills
- S RXIEN=+$G(IBD("PRESCRIPTION"))
- S RXFIL=+$G(IBD("FILL NUMBER"))
- S COB=+$G(IBD("RXCOB")),COB=$S(COB=2:"S",COB=3:"T",1:"P")
- S IBZ=$$RXBILL^IBNCPUT3(RXIEN,RXFIL,COB,,.IBARR)
- ;
- ; if the function returned an active bill, then use it and get out
- I +$P(IBZ,U,2) S IBIFN=+$P(IBZ,U,2),RET=1_U_$P($G(^DGCR(399,IBIFN,0)),U,1) G DUPX
- ;
- ; if no bills found at all then get out
- I '$P(IBZ,U,1) G DUPX
- I '$D(IBARR) G DUPX
- ;
- ; loop thru the array looking for any non-cancelled bills
- S IBIFN="" F S IBIFN=$O(IBARR(IBIFN),-1) Q:'IBIFN D Q:+RET
- . S ARSTAT=$P($G(IBARR(IBIFN)),U,2)
- . I ARSTAT'="CB",ARSTAT'="CN" S RET=1_U_$P($G(^DGCR(399,IBIFN,0)),U,1) Q
- . Q
- DUPX ;
- Q RET
- ;
- ARERR(CODE,COB) ; retrieve AR error text
- ; This function is called after calling AR routine PRCASVC6 and that routine indicates
- ; some AR error has been detected. Variable PRCAERR is passed into this function as
- ; the CODE parameter. The COB parameter indicates the COB payer sequence.
- ;
- ; Format of CODE: -1^PRCA error code in file 350.8
- ; or -1^AR text error message
- ; or undefined
- ;
- N ERR,IBZ
- S ERR=""
- S CODE=$P($G(CODE),U,2)
- S COB=$G(COB,1)
- I CODE="" S ERR="Cannot establish receivable in AR" G ARERRX ; generic error message
- ;
- S IBZ=+$O(^IBE(350.8,"C",CODE,0))
- I IBZ S ERR=$P($G(^IBE(350.8,IBZ,0)),U,2) G ARERRX ; error message from IB file
- ;
- S ERR=CODE ; error message text from routine PRCASVC6
- ;
- ARERRX ;
- S ERR=$$TRIM^XLFSTR(ERR,"R",".") ; remove ending period
- I COB>1 S ERR=ERR_" ("_$S(COB=2:"Sec",1:"Tert")_" Ins)"
- S ERR="AR Error: "_ERR
- Q ERR
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPDP2 12001 printed Jan 18, 2025@03:25:49 Page 2
- 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
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; Reference to DEC^PRCASER1 supported by IA# 593
- +5 ; Reference to REL^PRCASVC supported by IA# 385
- +6 ; Reference to STATUS^PRCASVC1 supported by IA# 387
- +7 ; Reference to ^PRCASVC6 supported by IA# 384
- +8 ; Reference to $$RXSITE^PSOBPSUT supported by IA# 4701
- +9 ; Reference to $$GETPHARM^BPSUTIL supported by IA# 4146
- +10 ;
- ECME(DFN,IBD) ; function called by STORESP^IBNCPDP
- +1 ; input - DFN - patient IEN for the prescription
- +2 ; IBD array passed in by reference
- +3 ; The IBD array is passed to various subroutines depending
- +4 ; on the ePharmacy event as evaluated by IBD("STATUS")
- +5 IF $GET(IBD("EPHARM"))=""
- SET IBD("EPHARM")=$$EPHARM(+$GET(IBD("PRESCRIPTION")),+$GET(IBD("FILL NUMBER")))
- +6 IF IBD("STATUS")="PAID"
- IF $GET(IBD("RXCOB"))=2
- QUIT $$BILLSEC^IBNCPDP5(DFN,.IBD)
- +7 IF IBD("STATUS")="PAID"
- QUIT $$BILL(DFN,.IBD)
- +8 IF IBD("STATUS")="REVERSED"
- QUIT $$REVERSE^IBNCPDP3(DFN,.IBD)
- +9 IF IBD("STATUS")="CLOSED"
- QUIT $$CLOSE^IBNCPDP4(DFN,.IBD)
- +10 IF IBD("STATUS")="RELEASED"
- QUIT $$RELEASE^IBNCPDP4(DFN,.IBD)
- +11 IF IBD("STATUS")="SUBMITTED"
- QUIT $$SUBMIT^IBNCPDP4(DFN,.IBD)
- +12 IF IBD("STATUS")="REOPEN"
- QUIT $$REOPEN^IBNCPDP4(DFN,.IBD)
- +13 IF IBD("STATUS")="ELIG"
- QUIT $$ELIG^IBNCPDP3(DFN,.IBD)
- +14 DO LOG("UNKNOWN")
- +15 QUIT "0^Cannot determine ECME event status"
- +16 ;
- MATCH(BCID,IBS) ; right bill, right COB payer
- +1 NEW IBX,IBPS,IBFOUND,ECMELEN,BCID1
- +2 SET IBPS=$SELECT(IBS=1:"P",IBS=2:"S",IBS=3:"T",1:"P")
- +3 SET IBFOUND=0
- +4 ;
- +5 ; need to check for ECME# lengths of both 7 digits and 12 digits to be sure
- +6 FOR ECMELEN=12,7
- Begin DoDot:1
- +7 ; quit if too large
- IF $LENGTH(+BCID)>ECMELEN
- QUIT
- +8 SET BCID1=BCID
- +9 SET $PIECE(BCID1,";",1)=$$RJ^XLFSTR(+BCID,ECMELEN,0)
- +10 ; quit when we have found a non-cancelled claim with a payer sequence match
- SET IBX=0
- +11 FOR
- SET IBX=$ORDER(^DGCR(399,"AG",BCID1,IBX))
- if 'IBX!IBFOUND
- QUIT
- IF '$PIECE($GET(^DGCR(399,IBX,"S")),U,16)
- IF (IBPS=$PIECE($GET(^DGCR(399,IBX,0)),U,21))
- SET IBFOUND=IBX
- QUIT
- +12 QUIT
- End DoDot:1
- if IBFOUND
- QUIT
- +13 ;
- +14 QUIT IBFOUND
- +15 ;
- BILL(DFN,IBD) ; create bills
- +1 NEW IBDIV,IBAMT,IBY,IBSERV,IBFAC,IBSITE,IBDRX,IB,IBCDFN,IBINS,IBIDS,IBIFN,IBDFN,PRCASV,IBTRIC,IBLGL,IBLDT2,IBDUP,CHKBL
- +2 NEW PRCAERR,IBADT,IBRXN,IBFIL,IBTRKRN,DIE,DA,DR,IBRES,IBLOCK,IBLDT,IBNOW,IBDUZ,RCDUZ,IBPREV,IBQUERY,IBPAID,IBACT,%,DGRVRCAL
- +3 ;
- +4 ;POSTMASTER
- SET IBDUZ=.5
- +5 SET RCDUZ=IBDUZ
- +6 ;
- +7 SET IBY=1
- SET IBLOCK=0
- +8 IF 'DFN
- SET IBY="0^Missing DFN"
- GOTO BILLQ
- +9 ;FI portion of charge
- SET IBAMT=+$GET(IBD("BILLED"))
- +10 IF 'IBAMT
- SET IBY="-1^Zero amount billed"
- GOTO BILLQ
- +11 SET IBADT=+$GET(IBD("DOS"),DT)
- +12 SET IBRXN=+$GET(IBD("PRESCRIPTION"))
- IF 'IBRXN
- SET IBY="0^Missing Rx IEN"
- GOTO BILLQ
- +13 SET IBFIL=+$GET(IBD("FILL NUMBER"),-1)
- IF IBFIL<0
- SET IBY="0^No fill number"
- GOTO BILLQ
- +14 ;
- +15 ; IB*2*452 - esg - check for duplicate response
- +16 SET IBDUP=$$DUP(.IBD)
- IF IBDUP
- SET IBY="0^Bill# "_$PIECE(IBDUP,U,2)_" exists (Duplicate)"
- GOTO BILLQ
- +17 ;
- +18 SET IBDIV=+$GET(IBD("DIVISION"))
- +19 IF '$LENGTH($GET(IBD("CLAIMID")))
- SET IBY="-1^Missing ECME Number"
- GOTO BILLQ
- +20 SET IBD("BCID")=$$BCID^IBNCPDP4(IBD("CLAIMID"),IBADT)
- +21 LOCK +^DGCR(399,"AG",IBD("BCID")):15
- IF '$TEST
- SET IBY="0^Cannot lock ECME number."
- GOTO BILLQ
- +22 ;
- +23 SET IBTRIC=$$TRICARE^IBNCPDP6(IBRXN_";"_IBFIL)
- +24 ; do patient copay first (only applicable if TRICARE)
- +25 ; create TRICARE Rx copay charge
- IF $GET(IBD("COPAY"))
- IF IBTRIC
- DO BILL^IBNCPDP6(IBRXN_";"_IBFIL,IBD("COPAY"),$GET(IBD("RTYPE")))
- +26 ;
- +27 SET IBLOCK=1
- SET IBLDT2=""
- +28 ;Last time called
- SET IBLDT=$$FMADD^XLFDT(DT,1)
- FOR
- SET IBLGL=$ORDER(^XTMP("IBNCPLDT"_IBLDT),-1)
- SET IBLDT=$EXTRACT(IBLGL,9,15)
- if IBLDT<$$FMADD^XLFDT(DT,-3)!(IBLGL'["IBNCPLDT")
- QUIT
- IF $DATA(^XTMP(IBLGL,IBD("BCID")))
- SET IBLDT2=^(IBD("BCID"))
- QUIT
- +29 DO NOW^%DTC
- SET IBNOW=%
- +30 ; 2 calls in 45 sec
- +31 IF IBLDT2
- IF $$FMDIFF^XLFDT(IBNOW,IBLDT2,2)<45
- SET IBY="0^Duplicate billing call"
- GOTO BILLQ
- +32 ;
- +33 ; check to see if a non-cancelled bill (same ECME#, same DOS, same payer sequence) already exists
- +34 ; if it does, then cancel this previous bill using the REVERSE action
- +35 SET CHKBL=$$MATCH(IBD("BCID"),IBD("RXCOB"))
- +36 IF CHKBL
- Begin DoDot:1
- +37 NEW IBARR
- +38 MERGE IBARR=IBD
- +39 SET IBARR("REVERSAL REASON")="Cancel the existing bill ("_$PIECE($GET(^DGCR(399,CHKBL,0)),U,1)_")"
- +40 IF $$REVERSE^IBNCPDP3(DFN,.IBARR)
- +41 QUIT
- End DoDot:1
- +42 ;
- +43 ; derive minimal variables
- +44 IF '$$CHECK^IBECEAU(0)
- SET IBY="-1^IB SITE"
- GOTO BILLQ
- +45 SET IBSERV=$PIECE($GET(^IBE(350.1,1,0)),"^",4)
- +46 IF '$$SERV^IBARX1(IBSERV)
- SET IBY="-1^IB SERVICE"
- GOTO BILLQ
- +47 IF 'IBDIV
- SET IBDIV=$PIECE($$MCDIV^IBNCPEB(IBRXN,IBFIL),U,2)
- +48 IF 'IBDIV
- SET IBDIV=+$PIECE($GET(^SC(+$$FILE^IBRXUTL(IBRXN,5),0)),"^",15)
- +49 ;dflt
- IF 'IBDIV
- SET IBDIV=+$PIECE($GET(^IBE(350.9,1,1)),U,25)
- +50 IF IBDIV
- SET IBD("DIVISION")=IBDIV
- +51 ; - establish a stub claim/receivable
- +52 DO SET^IBR
- IF IBY<0
- GOTO BILLQ
- +53 ;
- +54 ; set up the following variables for claim establishment:
- +55 ; .01 BILL #
- +56 ; .17 ORIG CLAIM
- +57 ; .2 AUTO?
- +58 ; .02 DFN
- +59 ; .06 TIMEFRAME
- +60 ; .07 RATE TYPE
- +61 ; .18 SC AT TIME?
- +62 ; .04 LOCATION
- +63 ; .22 DIVISION
- +64 ; .05 BILL CLASSIF (3)
- +65 ; .03 EVT DATE (DATE OF SERVICE)
- +66 ; 151 BILL FROM
- +67 ; 152 BILL TO
- +68 ; 155 SENSITIVE DX
- +69 ; 157 ROI OBTAINED
- +70 ; 101 PRIMARY INS CARRIER
- +71 KILL IB
- +72 SET (IB(.02),IBDFN)=DFN
- +73 ; previously determined rate type
- SET IB(.07)=$$RT^IBNCPDP6(IBRXN_";"_IBFIL)
- +74 ; cannot find previously, try to recompute
- IF 'IB(.07)
- SET IB(.07)=+$$RT^IBNCPDPU(DFN)
- +75 IF 'IB(.07)
- SET IBY="-1^IB RATE TYPE"
- GOTO BILLQ
- +76 ;
- +77 SET IBIFN=PRCASV("ARREC")
- +78 SET IB(.01)=$PIECE(PRCASV("ARBIL"),"-",2)
- +79 SET IB(.17)=""
- +80 SET IB(.2)=0
- +81 SET IB(.06)=1
- +82 SET IB(.18)=$$SC^IBCU3(DFN)
- +83 SET IB(.04)=$SELECT(+$PIECE($GET(^DG(40.8,+IBDIV,0)),U,3):7,1:1)
- +84 if IBDIV
- SET IB(.22)=+IBDIV
- +85 SET IB(.05)=3
- +86 SET (IB(.03),IB(151),IB(152))=IBADT
- +87 SET IBINS=$PIECE($GET(^IBA(355.3,+$GET(IBD("PLAN")),0)),"^")
- IF IBINS
- SET IB(101)=IBINS
- +88 ;
- +89 ; set 362.4 node to rx#^p50^days sup^date of service^qty^ndc
- +90 SET IB(362.4,IBRXN,IBFIL)=IBD("RX NO")_"^"_IBD("DRUG")_"^"_IBD("DAYS SUPPLY")_"^"_IBD("DOS")_"^"_IBD("QTY")_"^"_IBD("NDC")
- +91 ;
- +92 ; Sensitive Diagnosis Drug check
- +93 ; set sensitive dx and ROI obtained
- IF $$SENS^IBNCPDR(IBD("DRUG"))
- SET IB(155)=1
- SET IB(157)=1
- +94 ;
- +95 ; call the autobiller module to create the claim with a default
- +96 ; diagnosis and procedure for prescriptions
- +97 DO EN^IBCD3(.IBQUERY)
- +98 DO CLOSE^IBSDU(.IBQUERY)
- +99 ;
- +100 if '$DATA(^XTMP("IBNCPLDT"_DT))
- SET ^XTMP("IBNCPLDT"_DT,0)=$$FMADD^XLFDT(DT,2)_U_DT
- SET ^XTMP("IBNCPLDT"_DT,IBD("BCID"))=IBNOW
- +101 SET DIE="^DGCR(399,"
- SET DA=IBIFN
- +102 ; update the ECME fields
- +103 SET DR="460////^S X=IBD(""BCID"")"
- if $LENGTH($GET(IBD("AUTH #")))
- SET DR=DR_";461////^S X=IBD(""AUTH #"")"
- +104 DO ^DIE
- KILL DA,DR,DIE
- +105 ; Set Claims Tracking record
- DO SETCT
- +106 ;
- +107 ; IEN to 2.3121
- +108 SET IBCDFN=$$PLANN^IBNCPDPU(DFN,IBD("PLAN"),IBADT)
- +109 IF 'IBCDFN
- SET IBY="-1^Plan not found in Patient's Profile."
- GOTO BILLQ
- +110 ;
- +111 ; add the payer (fiscal intermediary) to the claim
- +112 SET IBINS=+IBCDFN
- SET IBCDFN=$PIECE(IBCDFN,"^",2)
- +113 SET DIE="^DGCR(399,"
- SET DA=IBIFN
- SET DR="112////"_IBCDFN
- +114 DO ^DIE
- KILL DA,DR,DIE,DGRVRCAL
- +115 ;
- +116 ; need to make sure we have computed charges
- +117 DO CHARGES(IBIFN)
- +118 IF $PIECE($GET(^DGCR(399,IBIFN,"U1")),U,1)'>0
- SET IBY="-1^Total Charges must be greater than $0."
- GOTO BILLQ
- +119 ;
- +120 ; update the authorize/print fields
- +121 SET DIE="^DGCR(399,"
- SET DA=IBIFN
- +122 SET DR="9////1;12////"_DT
- DO ^DIE
- +123 ;
- +124 ; *526 set approving official
- +125 if '$DATA(^VA(200,IBDUZ,0))
- SET IBDUZ=.5
- +126 ; pass the claim to AR
- +127 DO GVAR^IBCBB
- DO ARRAY^IBCBB1
- SET PRCASV("APR")=IBDUZ
- DO ^PRCASVC6
- +128 IF 'PRCASV("OKAY")
- SET IBY="-1^"_$$ARERR($GET(PRCAERR),1)
- GOTO BILLQ
- +129 DO REL^PRCASVC
- +130 ;
- +131 ; update the AR status to Active
- +132 ; D AUDITX^PRCAUDT(PRCASV("ARREC"))
- +133 SET PRCASV("STATUS")=16
- +134 DO STATUS^PRCASVC1
- +135 ;
- +136 ; decrease adjust bill
- +137 ; Auto decrease from service Bill#,Tran amt,person,reason,Tran date
- +138 SET IBAMT=$GET(^DGCR(399,IBIFN,"U1"))
- +139 SET IBPAID=$GET(IBD("PAID"))
- +140 IF IBAMT-IBPAID>.01
- Begin DoDot:1
- +141 NEW IBREAS
- +142 SET IBREAS="Adjust based on ECME amount paid."
- +143 IF IBTRIC
- SET IBREAS="Due to TRICARE Patient Responsibility."
- +144 DO DEC^PRCASER1(PRCASV("ARREC"),IBAMT-IBPAID,IBDUZ,IBREAS,IBADT)
- +145 ; collected/closed
- IF 'IBPAID
- SET PRCASV("STATUS")=22
- DO STATUS^PRCASVC1
- End DoDot:1
- +146 ;
- +147 ; set the user in 399
- Begin DoDot:1
- +148 NEW IBI,IBT
- FOR IBI=2,5,11,13,15
- SET IBT(399,IBIFN_",",IBI)=IBDUZ
- +149 DO FILE^DIE("","IBT")
- End DoDot:1
- +150 ;
- BILLQ SET IBRES=$SELECT(IBY<0:"0^"_$SELECT($LENGTH($PIECE(IBY,"^",2)):$PIECE(IBY,"^",2),1:$PIECE(IBY,"^",3)),$GET(IBIFN):+IBIFN,1:IBY)
- +1 IF $GET(IBIFN)
- SET IBD("BILL")=IBIFN
- +2 DO LOG("BILL",IBRES)
- +3 IF IBY<0
- DO BULL^IBNCPEB($GET(DFN),.IBD,IBRES,$GET(IBIFN))
- +4 IF IBLOCK
- LOCK -^DGCR(399,"AG",IBD("BCID"))
- +5 QUIT IBRES
- +6 ;
- SETCT ; update claims tracking saying bill has been billed
- +1 NEW X,Y,D0,DA,DI,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR
- +2 SET IBTRKRN=+$ORDER(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
- +3 IF IBTRKRN
- SET DIE="^IBT(356,"
- SET DA=IBTRKRN
- SET DR=".11////^S X=IBIFN;.17///@"
- DO ^DIE
- +4 ; Check Date of Service
- IF IBTRKRN
- IF (+$GET(IBD("DOS"))'=$PIECE(^IBT(356,IBTRKRN,0),U,6))
- SET DIE="^IBT(356,"
- SET DA=IBTRKRN
- SET DR=".06////"_IBD("DOS")
- DO ^DIE
- +5 IF IBTRKRN
- IF IBIFN
- DO CTB^IBCDC(IBTRKRN,IBIFN)
- +6 QUIT
- +7 ;
- LOG(PROC,RESULT) ;Store the data
- +1 ;Log values passed into IB by outside applications
- +2 ;
- +3 ;implicit input variables/arrays :
- +4 ; IBD array with values sent to IB (see calling subroutines)
- +5 ; DFN - patient's IEN (file #2)
- +6 ; DUZ - user's IEN(file #200)
- +7 ;explicit parameters:
- +8 ; PROC - type of event as string, i.e. BILL, REJECT and so on
- +9 ; RESULT - result of the event processing, format: return_code^message
- +10 ;
- +11 DO LOG^IBNCPLOG(.IBD,DFN,PROC,RESULT,$JOB,$$NOW^XLFDT(),+DUZ)
- +12 QUIT
- +13 ;
- EPHARM(IBRX,IBREFILL) ;
- +1 ;returns ien of #9002313.56 BPS PHARMACIES associated
- +2 ;with the prescription specified by:
- +3 ; IBRX - IEN in file #52
- +4 ; IBREFILL - zero(0) for the original prescription or the refill
- +5 ; number for a refill (IEN of REFILL multiple #52.1)
- +6 IF +$GET(IBRX)=0
- QUIT ""
- +7 IF $GET(IBREFILL)=""
- QUIT ""
- +8 NEW IBDIV59
- +9 SET IBDIV59=+$$RXSITE^PSOBPSUT(+IBRX,+IBREFILL)
- +10 IF IBDIV59>0
- QUIT $$GETPHARM^BPSUTIL(IBDIV59)
- +11 QUIT ""
- +12 ;
- CHARGES(IBIFN) ; set up charges on the bill
- +1 ;
- +2 ; Input: IBIFN = Bill (399) ien
- +3 NEW DGPTUPDT
- +4 ; generic bill charge calculator
- DO BILL^IBCRBC(IBIFN)
- +5 QUIT
- +6 ;
- DUP(IBD) ; Function to determine if processing a duplicate response
- +1 ; and if a bill should be created
- +2 ; Input
- +3 ; IBD array values
- +4 ; Output
- +5 ; Function value: [1] "1" if a duplicate response received and a non-cancelled bill already exists
- +6 ; [2] non-cancelled external bill# if piece [1] =1
- +7 ; or
- +8 ; [1] "0" if not a duplicate response OR no bill exists
- +9 ; [2] ""
- +10 ;
- +11 NEW RET,RXIEN,RXFIL,COB,IBZ,IBARR,IBIFN,ARSTAT
- +12 SET RET=0
- +13 IF $GET(IBD("RESPONSE"))'="DUPLICATE"
- GOTO DUPX
- +14 ;
- +15 ; set up variables from array data and try to find bills
- +16 SET RXIEN=+$GET(IBD("PRESCRIPTION"))
- +17 SET RXFIL=+$GET(IBD("FILL NUMBER"))
- +18 SET COB=+$GET(IBD("RXCOB"))
- SET COB=$SELECT(COB=2:"S",COB=3:"T",1:"P")
- +19 SET IBZ=$$RXBILL^IBNCPUT3(RXIEN,RXFIL,COB,,.IBARR)
- +20 ;
- +21 ; if the function returned an active bill, then use it and get out
- +22 IF +$PIECE(IBZ,U,2)
- SET IBIFN=+$PIECE(IBZ,U,2)
- SET RET=1_U_$PIECE($GET(^DGCR(399,IBIFN,0)),U,1)
- GOTO DUPX
- +23 ;
- +24 ; if no bills found at all then get out
- +25 IF '$PIECE(IBZ,U,1)
- GOTO DUPX
- +26 IF '$DATA(IBARR)
- GOTO DUPX
- +27 ;
- +28 ; loop thru the array looking for any non-cancelled bills
- +29 SET IBIFN=""
- FOR
- SET IBIFN=$ORDER(IBARR(IBIFN),-1)
- if 'IBIFN
- QUIT
- Begin DoDot:1
- +30 SET ARSTAT=$PIECE($GET(IBARR(IBIFN)),U,2)
- +31 IF ARSTAT'="CB"
- IF ARSTAT'="CN"
- SET RET=1_U_$PIECE($GET(^DGCR(399,IBIFN,0)),U,1)
- QUIT
- +32 QUIT
- End DoDot:1
- if +RET
- QUIT
- DUPX ;
- +1 QUIT RET
- +2 ;
- ARERR(CODE,COB) ; retrieve AR error text
- +1 ; This function is called after calling AR routine PRCASVC6 and that routine indicates
- +2 ; some AR error has been detected. Variable PRCAERR is passed into this function as
- +3 ; the CODE parameter. The COB parameter indicates the COB payer sequence.
- +4 ;
- +5 ; Format of CODE: -1^PRCA error code in file 350.8
- +6 ; or -1^AR text error message
- +7 ; or undefined
- +8 ;
- +9 NEW ERR,IBZ
- +10 SET ERR=""
- +11 SET CODE=$PIECE($GET(CODE),U,2)
- +12 SET COB=$GET(COB,1)
- +13 ; generic error message
- IF CODE=""
- SET ERR="Cannot establish receivable in AR"
- GOTO ARERRX
- +14 ;
- +15 SET IBZ=+$ORDER(^IBE(350.8,"C",CODE,0))
- +16 ; error message from IB file
- IF IBZ
- SET ERR=$PIECE($GET(^IBE(350.8,IBZ,0)),U,2)
- GOTO ARERRX
- +17 ;
- +18 ; error message text from routine PRCASVC6
- SET ERR=CODE
- +19 ;
- ARERRX ;
- +1 ; remove ending period
- SET ERR=$$TRIM^XLFSTR(ERR,"R",".")
- +2 IF COB>1
- SET ERR=ERR_" ("_$SELECT(COB=2:"Sec",1:"Tert")_" Ins)"
- +3 SET ERR="AR Error: "_ERR
- +4 QUIT ERR
- +5 ;