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 Apr 09, 2024@21:22:14 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 ;
