IBNCPDP5 ;ALB/BDB - PROCESSING FOR ECME RESP FOR SECONDARY ;11/15/07 09:43
;;2.0;INTEGRATED BILLING;**411,452,526,516,649,665**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
BILLSEC(DFN,IBD) ; Create secondary bill
;
N IBBCB,IBBCF,IBBCT,IBCAN,IBCCR,IBCDFN,IBCNFN,IBCOB,IBCTCOPY,IBDBC
N IBIFN,IBINS,IBINSN,IBOFFSET,IBPLAN,IBY,IBAMT,IBRES,IBDUP
;
;if the primary claim was rejected and we don't have any primary bill for the RX/refill (see IBSEND^BPSECMP2 for additional information)
I $G(IBD("PRIMREJ"))=1 D
. N IBRX,IBRFL,IBREJ,IBDPR,IBRESUL,IBZARR,IBAR433,IBREJINF,DA,DR,DIE,IBRJ,IBRJCODE
. S IBRX=+$G(IBD("PRESCRIPTION"))
. S IBRFL=+$G(IBD("FILL NUMBER"))
. ;check the case when we are resubmitting the secondary claims that was submitted for rejected primary claim -
. ;then we have already created a "dummy" primary bill and don't want to do this again
. I +$$RXBILL^IBNCPUT3(IBRX,IBRFL,"P",,.IBZARR)>0 S IBD("PRIOR PAYMENT")=0,IBD("PRIMARY BILL")=+$O(IBZARR(0)) Q ;quit if any primary bills exist, set IBD("PRIMARY BILL") to the first existing bill ien
. ; create a "dummy" primary bill for the primary claim as it would be a payable primary claim with 0$ amount:
. S IBDPR("PAID")=IBD("PAID")
. S IBDPR("PLAN")=IBD("PLAN")
. S IBDPR("RTYPE")=IBD("RTYPE")
. S IBD("PAID")=0
. S IBD("PLAN")=IBD("PRIMPLAN")
. S IBD("RTYPE")=""
. S IBD("RXCOB")=1
. S IBRESUL=$$BILL^IBNCPDP2(DFN,.IBD)
. ; the previous step should do contractual adjustment, if not - then we need to do something else here to adjust this amount and close the primary bill
. S IBD("PAID")=IBDPR("PAID")
. S IBD("PLAN")=IBDPR("PLAN")
. S IBD("RTYPE")=IBDPR("RTYPE")
. S IBD("RXCOB")=2
. S IBD("PRIMARY BILL")=$S(+IBRESUL>1:+IBRESUL,1:"")
. S IBD("PRIOR PAYMENT")=0
. Q:+IBD("PRIMARY BILL")=0
. ; get a reject information from IBD("REJ CODES") (see IBSEND^BPSECMP2) REJS(1,"REJ CODES",1,"08")
. S IBREJINF="Auto Dec.: ECME Primary claim rejected - "_$E($$REJINF(.IBD),1,30)
. ; put a note with the reject code/reason to AR file #433
. S IBAR433=$O(^PRCA(433,"C",+IBD("PRIMARY BILL"),0)) ; ICR# 3336
. S DA=IBAR433,DIE="^PRCA(433,",DR="41///"_IBREJINF D ^DIE ; ICR# 3336
. ; now quit to continue to create a secondary bill - i.e. allow the rest of the code to do its job
. Q
;
; IB*2*452 - esg - check for duplicate response first thing
S IBDUP=$$DUP^IBNCPDP2(.IBD) I IBDUP S IBY="0^Sec. Bill# "_$P(IBDUP,U,2)_" exists (Dup)" G BILLQ
;
; bill TRICARE copay if applicable
I $G(IBD("COPAY")) D BILL^IBNCPDP6($G(IBD("PRESCRIPTION"))_";"_$G(IBD("FILL NUMBER")),IBD("COPAY"),$G(IBD("RTYPE")))
;
S IBCAN=2,IBDBC=DT,IBBCB=DUZ,IBCTCOPY=1,IBY=1
S IBIFN=$G(IBD("PRIMARY BILL")) I IBIFN="" S IBY="0^Missing the primary bill." G BILLQ
S IBPLAN=$G(IBD("PLAN")) I IBPLAN="" S IBY="0^The Secondary Payer is not a valid Insurance Co." G BILLQ
S IBCDFN=$$PLANN^IBNCPDPU(DFN,IBD("PLAN"),IBD("DOS"))
I 'IBCDFN S IBY="-1^Plan not found in Patient's Profile." G BILLQ
S IBCNFN=$P(IBCDFN,"^",2)
S IBINSN=+^IBA(355.3,IBPLAN,0) ;insurance company
S IBINS=$G(^DIC(36,+IBINSN,0)) I IBINS="" S IBY="0^The Secondary Payer is not a valid Insurance Co." G BILLQ
S DIE="^DGCR(399,",DA=IBIFN,DR="102////"_IBINSN_";113////"_IBCNFN D ^DIE K DA,DR,DIE
S IBCOB("0",15)="" ;.15 BILL COPIED FROM
S IBCOB("0",21)=$S($G(IBD("RXCOB"))=1:"P",$G(IBD("RXCOB"))=2:"S",1:"P") ;.21 CURRENT BILL PAYER SEQUENCE
S IBCOB("M1",5)=IBD("PRIMARY BILL") ;125 PRIMARY BILL # [5P:399]
S IBCOB("U2",4)=IBD("PRIOR PAYMENT") ;218 PRIMARY PRIOR PAYMENT [4N]
;
S IBBCF=IBIFN ;this is the claim we are copying FROM
S IBIDS(.15)=IBIFN K IBIFN
STEP2 ;
S IBND0=^DGCR(399,IBIDS(.15),0) I $D(^("U")) S IBNDU=^("U")
;
; *** Note - all these fields should also be included in WHERE^IBCCC1
; ECME claims should NOT define the 399,.27 - BILL CHARGE TYPE - leave it blank for RX COST Charge Set
;
F I=2:1:12 S:$P(IBND0,"^",I)]"" IBIDS(I/100)=$P(IBND0,"^",I)
F I=16:1:19,21:1:26 S:$P(IBND0,"^",I)]"" IBIDS(I/100)=$P(IBND0,"^",I)
F I=151,152,155 S IBIDS(I)=$P(IBNDU,"^",(I-150))
S IBIDS(159.5)=$P(IBNDU,U,20)
S DFN=IBIDS(.02) D DEM^VADPT
;set rate type
I $G(IBD("RXCOB"))=2,$G(IBD("RTYPE")) S IBIDS(.07)=IBD("RTYPE")
S PRCASV("SER")=$P($G(^IBE(350.9,1,1)),"^",14)
S PRCASV("SITE")=$P($$SITE^VASITE,"^",3),IBNWBL=""
D SETUP^PRCASVC3
I $S($P(PRCASV("ARREC"),"^")=-1:1,$P(PRCASV("ARBIL"),"^")=-1:1,1:0) S IBY="0^No Billing Record Set up for: "_$P(PRCASV("ARREC"),"^",2)_" "_$P(PRCASV("ARBIL"),"^",2) G BILLQ
S IBIDS(.01)=$P(PRCASV("ARBIL"),"-",2)
S IBIDS(.17)=$S($D(IBIDS(.17)):IBIDS(.17),1:PRCASV("ARREC"))
S IBIDS(.02)=DFN,IBHV("IBIFN")=$S($G(IBIFN):IBIFN,1:$G(IBIDS(.15)))
S X=$P($T(WHERE),";;",2) F I=0:0 S I=$O(IBIDS(I)) Q:'I S X1=$P($E(X,$F(X,I)+1,999),";",1),$P(IBDR($P(X1,"^",1)),"^",$P(X1,"^",2))=IBIDS(I)
S IBIFN=PRCASV("ARREC") F I=0,"C","M","M1","S","U","U1" I $D(IBDR(I)) S ^DGCR(399,IBIFN,I)=IBDR(I)
D ; Protect variables;index entry;replace FT if copy/clone and it changes
. N IBHOLD,DIE,DR,DA,X,Y
. S IBHOLD("FT")=$P($G(^DGCR(399,IBIFN,0)),U,19)
. S $P(^DGCR(399,0),"^",3)=IBIFN,$P(^(0),"^",4)=$P(^(0),"^",4)+1 D INDEX^IBCCC2
. I IBHOLD("FT"),IBHOLD("FT")'=$P($G(^DGCR(399,IBIFN,0)),U,19) S DA=IBIFN,DIE="^DGCR(399,",DR=".19////"_IBHOLD("FT") D ^DIE
S IBYN=1
S IBBCT=IBIFN ; bill that the old claim was cloned TO.
K %,%DT,I,IB,IBA,IBBT,IBIDS,IBNWBL,J,VADM,X,X1,X2,X3,X4,Y
;
S IBIFN1=$P(^DGCR(399,IBIFN,0),"^",15) G END:$S(IBIFN1="":1,'$D(^DGCR(399,IBIFN1,0)):1,1:0)
;
;move pure data nodes
; MRD;IB*2.0*516 - Added "In7" nodes.
F I="I1","I17","I2","I27","I3","I37","M1" I $D(^DGCR(399,IBIFN1,I)) S ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
;
;move top level data node. ;Do not move 'TX' node
F I="U","U1","U2","U3","UF2","UF3","UF31","C","M" I $D(^DGCR(399,IBIFN1,I)) S IBND(I)=^(I) D @(I_"^IBCCC2")
;
;move multiple level data
F I="CC","OC","OP","OT","RC","CP","CV","PRV" I $D(^DGCR(399,IBIFN1,I,0)) D @(I_"^IBCCC2")
;
D FTPRV^IBCEU5(IBIFN) ; Ask change prov type if form type not the same
D COBCHG^IBCCC2(IBIFN,,.IBCOB)
;
D ^IBCCC3 ; copy table files (362.3)
;
S I=$G(^DGCR(399,IBIFN1,0)) I $P(I,U,13)=7,$P(I,U,20)=1 D COPYB^IBCDC(IBIFN1,IBIFN) ; update auto bill files
D PRIOR^IBCCC2(IBIFN) ; add new bill to previous bills in series, primary/secondary
I +$G(IBCTCOPY) N IBAUTO S IBAUTO=1 D PROC^IBCU7A(IBIFN),BILL^IBCRBC(IBIFN),CPTMOD26^IBCU73(IBIFN) D RECALL^DILFD(399,IBIFN_",",DUZ)
;
END ;
K %,%DT,D,DDH,DIC,DGACTDT,DGAMNT,DGBR,DGBRN,DGBSI,DGBSLOS,DGFUNC,DGIFN
K DGPCM,DGREV,DGREV00,DGREVHDR,DGRVRCAL,DGXRF1,DFN
K I,IB,IBA,IBA1,IBA2,IBAC,IBAD,IBADD1,IBARST,IBBNO,IBBS,IBBT,IBCAN
K IBCBCOPY,IBCCC,IBCH,IBCHK,IBCNCOPY,IBCOB,IBDA,IBDD,IBDD1,IBDPT,IBDR
K IBDT,IBI,IBI1,IBIDS,IBIFN,IBIFN1,IBIN,IBINS,IBIP,IBLS,IBN,IBND,IBND0
K IBNDS,IBNDU,IBO,IBOA,IBOD,IBPROC,IBPTF,IBQUIT,IBREV,IBST,IBU,IBUC
K IBUN,IBV,IBV1,IBW,IBWW,IBX,IBYN,IBZZ,J,K
K PRCASV,PRCAERCD,PRCAERR,PRCASVC,PRCAT,VA,VADM,VAEL,VAERR,X,X1,X2,X3,X4,Y
;
N DA,IBADT,IBDIV,IBDUZ,IBPAID,IBTRIC,X
S IBIFN=IBBCT,IBADT=IBD("DOS"),IBDIV=+$G(IBD("DIVISION")),IBDUZ=$S($G(IBD("USER")):IBD("USER"),1:DUZ)
;
S DIE="^DGCR(399,",DA=IBIFN
; update the primary bill,ECME fields (make sure .27 field is blank)
S DR=".17////"_$G(IBD("PRIMARY BILL"))_";.27////@;460////^S X=IBD(""BCID"")" S:$L($G(IBD("AUTH #"))) DR=DR_";461////^S X=IBD(""AUTH #"")"
D ^DIE K DA,DR,DIE
;
; if the primary ECME claim was rejected, then do some Claims Tracking updates
; since this secondary claim is payable - esg 7/8/10
I $G(IBD("PRIMREJ"))=1 D
. N IBRXN,IBFIL,IBTRKRN,X,Y,D0,DA,DI,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR
. S IBRXN=+$G(IBD("PRESCRIPTION"))
. S IBFIL=+$G(IBD("FILL NUMBER"))
. D SETCT^IBNCPDP2 ; CT updates saying bill has been billed
. I '$G(IBTRKRN) Q
. S DIE="^IBT(356,",DA=IBTRKRN
. S DR=".19///@" ; reason not billable - delete it
. S DR=DR_";1.03///"_$$NOW^XLFDT ; CT date last edited
. S DR=DR_";1.04///"_IBDUZ ; CT last edited by
. S DR=DR_";1.11///0" ; ECME Reject flag is 0 - NO
. D ^DIE
. Q
;
; need to make sure we have computed charges
S IBTRIC=$$TRICARE^IBNCPDP6($G(IBD("PRESCRIPTION"))_";"_$G(IBD("FILL NUMBER")))
D CHARGES^IBNCPDP2(IBIFN)
I $P($G(^DGCR(399,IBIFN,"U1")),U,1)'>0 S IBY="-1^Total Charges for Sec. Bill 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 ; perform AR checks
I 'PRCASV("OKAY") S IBY="-1^"_$$ARERR^IBNCPDP2($G(PRCAERR),2) G BILLQ
D REL^PRCASVC ; accept bill into AR
;
; update the AR status to Active
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")),IBOFFSET=$P($G(^DGCR(399,IBIFN,"U1")),U,2)
S IBPAID=$G(IBD("PAID"))
I IBAMT-IBPAID>.01 D
. N IBREAS
. S IBREAS="Adjust based on secondary ECME amount paid."
. I IBTRIC S IBREAS="Due to TRICARE Patient Responsibility (sec)."
. D DEC^PRCASER1(PRCASV("ARREC"),IBAMT-IBOFFSET-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(IBBCT):+IBBCT,1:IBY)
I $G(IBBCT) S IBD("BILL")=IBBCT
D LOG^IBNCPDP2("BILL",IBRES)
I IBY<0 D BULL^IBNCPEB($G(DFN),.IBD,IBRES,$G(IBBCT))
Q IBRES
;
REJINF(IBREJARR) ;
N IBREJINF,IBRJ,IBRJCODE,IBCNT
S IBREJINF="",IBCNT=0
S IBRJ=0 F S IBRJ=$O(IBREJARR("REJ CODES",IBRJ)) Q:+IBRJ=0 D
. S IBRJCODE="" F S IBRJCODE=$O(IBREJARR("REJ CODES",IBRJ,IBRJCODE)) Q:IBRJCODE="" D
. . I IBCNT>0 S IBREJINF=IBREJINF_", "
. . S IBREJINF=IBREJINF_IBRJCODE_":"_$G(IBREJARR("REJ CODES",IBRJ,IBRJCODE))
. . S IBCNT=IBCNT+1
Q IBREJINF
;
WHERE ;;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.09^0^9;.11^0^11;.12^0^12;.17^0^17;.18^0^18;.19^0^19;.15^0^15;.16^0^16;.21^0^21;.22^0^22;.23^0^23;.24^0^24;.25^0^25;.26^0^26;151^U^1;152^U^2;155^U^5;159.5^U^20;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPDP5 10511 printed Sep 02, 2024@19:09:52 Page 2
IBNCPDP5 ;ALB/BDB - PROCESSING FOR ECME RESP FOR SECONDARY ;11/15/07 09:43
+1 ;;2.0;INTEGRATED BILLING;**411,452,526,516,649,665**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
BILLSEC(DFN,IBD) ; Create secondary bill
+1 ;
+2 NEW IBBCB,IBBCF,IBBCT,IBCAN,IBCCR,IBCDFN,IBCNFN,IBCOB,IBCTCOPY,IBDBC
+3 NEW IBIFN,IBINS,IBINSN,IBOFFSET,IBPLAN,IBY,IBAMT,IBRES,IBDUP
+4 ;
+5 ;if the primary claim was rejected and we don't have any primary bill for the RX/refill (see IBSEND^BPSECMP2 for additional information)
+6 IF $GET(IBD("PRIMREJ"))=1
Begin DoDot:1
+7 NEW IBRX,IBRFL,IBREJ,IBDPR,IBRESUL,IBZARR,IBAR433,IBREJINF,DA,DR,DIE,IBRJ,IBRJCODE
+8 SET IBRX=+$GET(IBD("PRESCRIPTION"))
+9 SET IBRFL=+$GET(IBD("FILL NUMBER"))
+10 ;check the case when we are resubmitting the secondary claims that was submitted for rejected primary claim -
+11 ;then we have already created a "dummy" primary bill and don't want to do this again
+12 ;quit if any primary bills exist, set IBD("PRIMARY BILL") to the first existing bill ien
IF +$$RXBILL^IBNCPUT3(IBRX,IBRFL,"P",,.IBZARR)>0
SET IBD("PRIOR PAYMENT")=0
SET IBD("PRIMARY BILL")=+$ORDER(IBZARR(0))
QUIT
+13 ; create a "dummy" primary bill for the primary claim as it would be a payable primary claim with 0$ amount:
+14 SET IBDPR("PAID")=IBD("PAID")
+15 SET IBDPR("PLAN")=IBD("PLAN")
+16 SET IBDPR("RTYPE")=IBD("RTYPE")
+17 SET IBD("PAID")=0
+18 SET IBD("PLAN")=IBD("PRIMPLAN")
+19 SET IBD("RTYPE")=""
+20 SET IBD("RXCOB")=1
+21 SET IBRESUL=$$BILL^IBNCPDP2(DFN,.IBD)
+22 ; the previous step should do contractual adjustment, if not - then we need to do something else here to adjust this amount and close the primary bill
+23 SET IBD("PAID")=IBDPR("PAID")
+24 SET IBD("PLAN")=IBDPR("PLAN")
+25 SET IBD("RTYPE")=IBDPR("RTYPE")
+26 SET IBD("RXCOB")=2
+27 SET IBD("PRIMARY BILL")=$SELECT(+IBRESUL>1:+IBRESUL,1:"")
+28 SET IBD("PRIOR PAYMENT")=0
+29 if +IBD("PRIMARY BILL")=0
QUIT
+30 ; get a reject information from IBD("REJ CODES") (see IBSEND^BPSECMP2) REJS(1,"REJ CODES",1,"08")
+31 SET IBREJINF="Auto Dec.: ECME Primary claim rejected - "_$EXTRACT($$REJINF(.IBD),1,30)
+32 ; put a note with the reject code/reason to AR file #433
+33 ; ICR# 3336
SET IBAR433=$ORDER(^PRCA(433,"C",+IBD("PRIMARY BILL"),0))
+34 ; ICR# 3336
SET DA=IBAR433
SET DIE="^PRCA(433,"
SET DR="41///"_IBREJINF
DO ^DIE
+35 ; now quit to continue to create a secondary bill - i.e. allow the rest of the code to do its job
+36 QUIT
End DoDot:1
+37 ;
+38 ; IB*2*452 - esg - check for duplicate response first thing
+39 SET IBDUP=$$DUP^IBNCPDP2(.IBD)
IF IBDUP
SET IBY="0^Sec. Bill# "_$PIECE(IBDUP,U,2)_" exists (Dup)"
GOTO BILLQ
+40 ;
+41 ; bill TRICARE copay if applicable
+42 IF $GET(IBD("COPAY"))
DO BILL^IBNCPDP6($GET(IBD("PRESCRIPTION"))_";"_$GET(IBD("FILL NUMBER")),IBD("COPAY"),$GET(IBD("RTYPE")))
+43 ;
+44 SET IBCAN=2
SET IBDBC=DT
SET IBBCB=DUZ
SET IBCTCOPY=1
SET IBY=1
+45 SET IBIFN=$GET(IBD("PRIMARY BILL"))
IF IBIFN=""
SET IBY="0^Missing the primary bill."
GOTO BILLQ
+46 SET IBPLAN=$GET(IBD("PLAN"))
IF IBPLAN=""
SET IBY="0^The Secondary Payer is not a valid Insurance Co."
GOTO BILLQ
+47 SET IBCDFN=$$PLANN^IBNCPDPU(DFN,IBD("PLAN"),IBD("DOS"))
+48 IF 'IBCDFN
SET IBY="-1^Plan not found in Patient's Profile."
GOTO BILLQ
+49 SET IBCNFN=$PIECE(IBCDFN,"^",2)
+50 ;insurance company
SET IBINSN=+^IBA(355.3,IBPLAN,0)
+51 SET IBINS=$GET(^DIC(36,+IBINSN,0))
IF IBINS=""
SET IBY="0^The Secondary Payer is not a valid Insurance Co."
GOTO BILLQ
+52 SET DIE="^DGCR(399,"
SET DA=IBIFN
SET DR="102////"_IBINSN_";113////"_IBCNFN
DO ^DIE
KILL DA,DR,DIE
+53 ;.15 BILL COPIED FROM
SET IBCOB("0",15)=""
+54 ;.21 CURRENT BILL PAYER SEQUENCE
SET IBCOB("0",21)=$SELECT($GET(IBD("RXCOB"))=1:"P",$GET(IBD("RXCOB"))=2:"S",1:"P")
+55 ;125 PRIMARY BILL # [5P:399]
SET IBCOB("M1",5)=IBD("PRIMARY BILL")
+56 ;218 PRIMARY PRIOR PAYMENT [4N]
SET IBCOB("U2",4)=IBD("PRIOR PAYMENT")
+57 ;
+58 ;this is the claim we are copying FROM
SET IBBCF=IBIFN
+59 SET IBIDS(.15)=IBIFN
KILL IBIFN
STEP2 ;
+1 SET IBND0=^DGCR(399,IBIDS(.15),0)
IF $DATA(^("U"))
SET IBNDU=^("U")
+2 ;
+3 ; *** Note - all these fields should also be included in WHERE^IBCCC1
+4 ; ECME claims should NOT define the 399,.27 - BILL CHARGE TYPE - leave it blank for RX COST Charge Set
+5 ;
+6 FOR I=2:1:12
if $PIECE(IBND0,"^",I)]""
SET IBIDS(I/100)=$PIECE(IBND0,"^",I)
+7 FOR I=16:1:19,21:1:26
if $PIECE(IBND0,"^",I)]""
SET IBIDS(I/100)=$PIECE(IBND0,"^",I)
+8 FOR I=151,152,155
SET IBIDS(I)=$PIECE(IBNDU,"^",(I-150))
+9 SET IBIDS(159.5)=$PIECE(IBNDU,U,20)
+10 SET DFN=IBIDS(.02)
DO DEM^VADPT
+11 ;set rate type
+12 IF $GET(IBD("RXCOB"))=2
IF $GET(IBD("RTYPE"))
SET IBIDS(.07)=IBD("RTYPE")
+13 SET PRCASV("SER")=$PIECE($GET(^IBE(350.9,1,1)),"^",14)
+14 SET PRCASV("SITE")=$PIECE($$SITE^VASITE,"^",3)
SET IBNWBL=""
+15 DO SETUP^PRCASVC3
+16 IF $SELECT($PIECE(PRCASV("ARREC"),"^")=-1:1,$PIECE(PRCASV("ARBIL"),"^")=-1:1,1:0)
SET IBY="0^No Billing Record Set up for: "_$PIECE(PRCASV("ARREC"),"^",2)_" "_$PIECE(PRCASV("ARBIL"),"^",2)
GOTO BILLQ
+17 SET IBIDS(.01)=$PIECE(PRCASV("ARBIL"),"-",2)
+18 SET IBIDS(.17)=$SELECT($DATA(IBIDS(.17)):IBIDS(.17),1:PRCASV("ARREC"))
+19 SET IBIDS(.02)=DFN
SET IBHV("IBIFN")=$SELECT($GET(IBIFN):IBIFN,1:$GET(IBIDS(.15)))
+20 SET X=$PIECE($TEXT(WHERE),";;",2)
FOR I=0:0
SET I=$ORDER(IBIDS(I))
if 'I
QUIT
SET X1=$PIECE($EXTRACT(X,$FIND(X,I)+1,999),";",1)
SET $PIECE(IBDR($PIECE(X1,"^",1)),"^",$PIECE(X1,"^",2))=IBIDS(I)
+21 SET IBIFN=PRCASV("ARREC")
FOR I=0,"C","M","M1","S","U","U1"
IF $DATA(IBDR(I))
SET ^DGCR(399,IBIFN,I)=IBDR(I)
+22 ; Protect variables;index entry;replace FT if copy/clone and it changes
Begin DoDot:1
+23 NEW IBHOLD,DIE,DR,DA,X,Y
+24 SET IBHOLD("FT")=$PIECE($GET(^DGCR(399,IBIFN,0)),U,19)
+25 SET $PIECE(^DGCR(399,0),"^",3)=IBIFN
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1
DO INDEX^IBCCC2
+26 IF IBHOLD("FT")
IF IBHOLD("FT")'=$PIECE($GET(^DGCR(399,IBIFN,0)),U,19)
SET DA=IBIFN
SET DIE="^DGCR(399,"
SET DR=".19////"_IBHOLD("FT")
DO ^DIE
End DoDot:1
+27 SET IBYN=1
+28 ; bill that the old claim was cloned TO.
SET IBBCT=IBIFN
+29 KILL %,%DT,I,IB,IBA,IBBT,IBIDS,IBNWBL,J,VADM,X,X1,X2,X3,X4,Y
+30 ;
+31 SET IBIFN1=$PIECE(^DGCR(399,IBIFN,0),"^",15)
if $SELECT(IBIFN1="":1,'$DATA(^DGCR(399,IBIFN1,0)):1,1:0)
GOTO END
+32 ;
+33 ;move pure data nodes
+34 ; MRD;IB*2.0*516 - Added "In7" nodes.
+35 FOR I="I1","I17","I2","I27","I3","I37","M1"
IF $DATA(^DGCR(399,IBIFN1,I))
SET ^DGCR(399,IBIFN,I)=^DGCR(399,IBIFN1,I)
+36 ;
+37 ;move top level data node. ;Do not move 'TX' node
+38 FOR I="U","U1","U2","U3","UF2","UF3","UF31","C","M"
IF $DATA(^DGCR(399,IBIFN1,I))
SET IBND(I)=^(I)
DO @(I_"^IBCCC2")
+39 ;
+40 ;move multiple level data
+41 FOR I="CC","OC","OP","OT","RC","CP","CV","PRV"
IF $DATA(^DGCR(399,IBIFN1,I,0))
DO @(I_"^IBCCC2")
+42 ;
+43 ; Ask change prov type if form type not the same
DO FTPRV^IBCEU5(IBIFN)
+44 DO COBCHG^IBCCC2(IBIFN,,.IBCOB)
+45 ;
+46 ; copy table files (362.3)
DO ^IBCCC3
+47 ;
+48 ; update auto bill files
SET I=$GET(^DGCR(399,IBIFN1,0))
IF $PIECE(I,U,13)=7
IF $PIECE(I,U,20)=1
DO COPYB^IBCDC(IBIFN1,IBIFN)
+49 ; add new bill to previous bills in series, primary/secondary
DO PRIOR^IBCCC2(IBIFN)
+50 IF +$GET(IBCTCOPY)
NEW IBAUTO
SET IBAUTO=1
DO PROC^IBCU7A(IBIFN)
DO BILL^IBCRBC(IBIFN)
DO CPTMOD26^IBCU73(IBIFN)
DO RECALL^DILFD(399,IBIFN_",",DUZ)
+51 ;
END ;
+1 KILL %,%DT,D,DDH,DIC,DGACTDT,DGAMNT,DGBR,DGBRN,DGBSI,DGBSLOS,DGFUNC,DGIFN
+2 KILL DGPCM,DGREV,DGREV00,DGREVHDR,DGRVRCAL,DGXRF1,DFN
+3 KILL I,IB,IBA,IBA1,IBA2,IBAC,IBAD,IBADD1,IBARST,IBBNO,IBBS,IBBT,IBCAN
+4 KILL IBCBCOPY,IBCCC,IBCH,IBCHK,IBCNCOPY,IBCOB,IBDA,IBDD,IBDD1,IBDPT,IBDR
+5 KILL IBDT,IBI,IBI1,IBIDS,IBIFN,IBIFN1,IBIN,IBINS,IBIP,IBLS,IBN,IBND,IBND0
+6 KILL IBNDS,IBNDU,IBO,IBOA,IBOD,IBPROC,IBPTF,IBQUIT,IBREV,IBST,IBU,IBUC
+7 KILL IBUN,IBV,IBV1,IBW,IBWW,IBX,IBYN,IBZZ,J,K
+8 KILL PRCASV,PRCAERCD,PRCAERR,PRCASVC,PRCAT,VA,VADM,VAEL,VAERR,X,X1,X2,X3,X4,Y
+9 ;
+10 NEW DA,IBADT,IBDIV,IBDUZ,IBPAID,IBTRIC,X
+11 SET IBIFN=IBBCT
SET IBADT=IBD("DOS")
SET IBDIV=+$GET(IBD("DIVISION"))
SET IBDUZ=$SELECT($GET(IBD("USER")):IBD("USER"),1:DUZ)
+12 ;
+13 SET DIE="^DGCR(399,"
SET DA=IBIFN
+14 ; update the primary bill,ECME fields (make sure .27 field is blank)
+15 SET DR=".17////"_$GET(IBD("PRIMARY BILL"))_";.27////@;460////^S X=IBD(""BCID"")"
if $LENGTH($GET(IBD("AUTH #")))
SET DR=DR_";461////^S X=IBD(""AUTH #"")"
+16 DO ^DIE
KILL DA,DR,DIE
+17 ;
+18 ; if the primary ECME claim was rejected, then do some Claims Tracking updates
+19 ; since this secondary claim is payable - esg 7/8/10
+20 IF $GET(IBD("PRIMREJ"))=1
Begin DoDot:1
+21 NEW IBRXN,IBFIL,IBTRKRN,X,Y,D0,DA,DI,DIC,DICR,DIE,DIG,DIH,DIU,DIV,DIW,DQ,DR
+22 SET IBRXN=+$GET(IBD("PRESCRIPTION"))
+23 SET IBFIL=+$GET(IBD("FILL NUMBER"))
+24 ; CT updates saying bill has been billed
DO SETCT^IBNCPDP2
+25 IF '$GET(IBTRKRN)
QUIT
+26 SET DIE="^IBT(356,"
SET DA=IBTRKRN
+27 ; reason not billable - delete it
SET DR=".19///@"
+28 ; CT date last edited
SET DR=DR_";1.03///"_$$NOW^XLFDT
+29 ; CT last edited by
SET DR=DR_";1.04///"_IBDUZ
+30 ; ECME Reject flag is 0 - NO
SET DR=DR_";1.11///0"
+31 DO ^DIE
+32 QUIT
End DoDot:1
+33 ;
+34 ; need to make sure we have computed charges
+35 SET IBTRIC=$$TRICARE^IBNCPDP6($GET(IBD("PRESCRIPTION"))_";"_$GET(IBD("FILL NUMBER")))
+36 DO CHARGES^IBNCPDP2(IBIFN)
+37 IF $PIECE($GET(^DGCR(399,IBIFN,"U1")),U,1)'>0
SET IBY="-1^Total Charges for Sec. Bill must be greater than $0."
GOTO BILLQ
+38 ;
+39 ; update the authorize/print fields
+40 SET DIE="^DGCR(399,"
SET DA=IBIFN
+41 SET DR="9////1;12////"_DT
DO ^DIE
+42 ;
+43 ; *526 set approving official
+44 if '$DATA(^VA(200,IBDUZ,0))
SET IBDUZ=.5
+45 ; pass the claim to AR
+46 ; perform AR checks
DO GVAR^IBCBB
DO ARRAY^IBCBB1
SET PRCASV("APR")=IBDUZ
DO ^PRCASVC6
+47 IF 'PRCASV("OKAY")
SET IBY="-1^"_$$ARERR^IBNCPDP2($GET(PRCAERR),2)
GOTO BILLQ
+48 ; accept bill into AR
DO REL^PRCASVC
+49 ;
+50 ; update the AR status to Active
+51 SET PRCASV("STATUS")=16
+52 DO STATUS^PRCASVC1
+53 ;
+54 ; decrease adjust bill
+55 ; Auto decrease from service Bill#,Tran amt,person,reason,Tran date
+56 SET IBAMT=$GET(^DGCR(399,IBIFN,"U1"))
SET IBOFFSET=$PIECE($GET(^DGCR(399,IBIFN,"U1")),U,2)
+57 SET IBPAID=$GET(IBD("PAID"))
+58 IF IBAMT-IBPAID>.01
Begin DoDot:1
+59 NEW IBREAS
+60 SET IBREAS="Adjust based on secondary ECME amount paid."
+61 IF IBTRIC
SET IBREAS="Due to TRICARE Patient Responsibility (sec)."
+62 DO DEC^PRCASER1(PRCASV("ARREC"),IBAMT-IBOFFSET-IBPAID,IBDUZ,IBREAS,IBADT)
+63 ; collected/closed
IF 'IBPAID
SET PRCASV("STATUS")=22
DO STATUS^PRCASVC1
End DoDot:1
+64 ;
+65 ; set the user in 399
Begin DoDot:1
+66 NEW IBI,IBT
FOR IBI=2,5,11,13,15
SET IBT(399,IBIFN_",",IBI)=IBDUZ
+67 DO FILE^DIE("","IBT")
End DoDot:1
+68 ;
+69 ;
BILLQ ;
+1 SET IBRES=$SELECT(IBY<0:"0^"_$SELECT($LENGTH($PIECE(IBY,"^",2)):$PIECE(IBY,"^",2),1:$PIECE(IBY,"^",3)),$GET(IBBCT):+IBBCT,1:IBY)
+2 IF $GET(IBBCT)
SET IBD("BILL")=IBBCT
+3 DO LOG^IBNCPDP2("BILL",IBRES)
+4 IF IBY<0
DO BULL^IBNCPEB($GET(DFN),.IBD,IBRES,$GET(IBBCT))
+5 QUIT IBRES
+6 ;
REJINF(IBREJARR) ;
+1 NEW IBREJINF,IBRJ,IBRJCODE,IBCNT
+2 SET IBREJINF=""
SET IBCNT=0
+3 SET IBRJ=0
FOR
SET IBRJ=$ORDER(IBREJARR("REJ CODES",IBRJ))
if +IBRJ=0
QUIT
Begin DoDot:1
+4 SET IBRJCODE=""
FOR
SET IBRJCODE=$ORDER(IBREJARR("REJ CODES",IBRJ,IBRJCODE))
if IBRJCODE=""
QUIT
Begin DoDot:2
+5 IF IBCNT>0
SET IBREJINF=IBREJINF_", "
+6 SET IBREJINF=IBREJINF_IBRJCODE_":"_$GET(IBREJARR("REJ CODES",IBRJ,IBRJCODE))
+7 SET IBCNT=IBCNT+1
End DoDot:2
End DoDot:1
+8 QUIT IBREJINF
+9 ;
WHERE ;;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.09^0^9;.11^0^11;.12^0^12;.17^0^17;.18^0^18;.19^0^19;.15^0^15;.16^0^16;.21^0^21;.22^0^22;.23^0^23;.24^0^24;.25^0^25;.26^0^26;151^U^1;152^U^2;155^U^5;159.5^U^20;
+1 ;
