IBCCCB ;ALB/ARH - COPY BILL FOR COB ;2/13/06 10:46am
;;2.0;INTEGRATED BILLING;**80,106,51,151,137,182,155,323,436,432,447,547,592,690**;21-MAR-94;Build 10
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to PAUSE^VALM1 in ICR #10116
; Copy bill for COB w/out cancelling, update some flds
; Primary->Secondary->Tertiary
ASK ;
S IBCBCOPY=1 ; flag that copy function entered thru Copy COB option
;
D KVAR S IBCAN=2,IBU="UNSPECIFIED"
;
S IBX=$$PB^IBJTU2 S:+IBX=2 IBIFN=$P(IBX,U,2) I +IBX=1 S DFN=$P(IBX,U,2),IBV=1,IBAC=5 D DATE^IBCB
I '$G(IBIFN) G EXIT
;
; IB*2.0*432 Restrict access to only allow claims that are NOT on the new CBW Worklist
I $P($G(^DGCR(399,IBIFN,"S1")),U,7)=1,$G(IBMRANOT)'=1 D G ASK
. W !!?4,"This bill appears on the CBW Management Work List. Please use the"
. W !?4,"'CBW Management Menu' options for all processing related to this bill."
. S IBQUIT=1 ;IB*2.0*592 JRA need to set quit flag after issuing this message
. Q
; Restrict access to this process for REQUEST MRA bills in 2 Cases:
; 1. No MRA EOB's on File for bill
I $P($G(^DGCR(399,IBIFN,0)),U,13)=2,'$$CHK^IBCEMU1(IBIFN) D G ASK
. W !!?4,"This bill is in a status of REQUEST MRA and it has No MRA EOB's"
. W !?4,"on file. Access to this bill is restricted."
;
; 2. At least one MRA EOB appears on the MRA management worklist
I $P($G(^DGCR(399,IBIFN,0)),U,13)=2,$$MRAWL^IBCEMU2(IBIFN) D G ASK
. W !!?4,"This bill is in a status of REQUEST MRA and it does appear on the"
. W !?4,"MRA Management Work List. Please use the 'MRA Management Menu' options"
. W !?4,"for all processing related to this bill."
. Q
;
; If MRA is Activated and bill is in Entered/Not Reviewed status and current insurance Co. is WNR -->
; ask if user wants to continue
I $$EDIACTV^IBCEF4(2),$P($G(^DGCR(399,IBIFN,0)),U,13)=1,$$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN)) D I 'Y G ASK
. W !!?4,"This bill is in a status of ENTERED/NOT REVIEWED and current payer is "
. W !?4,"MEDICARE (WNR). No MRA has been requested for this bill."
. S DIR(0)="YA",DIR("B")="NO",DIR("A")=" Are you sure you want to continue to process this bill?: "
. D ^DIR K DIR
;
; Display related bills
D DSPRB^IBCCCB0(IBIFN)
;
CHKB ; Entrypoint-COB processing via EDI's COB Mgmt
; Ask if final EOB was received for previous bill
I '$$FINALEOB^IBCCCB0(IBIFN) S IBSECHK=1
I $G(IBSECHK)=1,$$MCRONBIL^IBEFUNC(IBIFN) G EXIT
;
; Warn if previous bill not at least authorized
I '$$MCRONBIL^IBEFUNC(IBIFN) I '$$COBOK^IBCCCB0(IBIFN) G EXIT
;
CHKB1 ; Entry point for Automatic/Silent COB Processing.
; No writes or reads can occur from this point forward if variable
; IBSILENT=1. Any and all error messages should be processed with
; the ERROR procedure below.
;
S IBX=$G(^DGCR(399,+IBIFN,0)),DFN=$P(IBX,U,2),IBDT=$P(IBX,U,3)\1,IBER=""
I IBCAN>1 D NOPTF^IBCB2 I 'IBAC1 D NOPTF1^IBCB2 G ASK1
;
F IBI=0,"S","U1","M","MP","M1" S IB(IBI)=$G(^DGCR(399,IBIFN,IBI))
I IB(0)="" S IBER="Invalid Bill Number" D PCERR G ASK1
;
; check to see if the bill has been cancelled
I $P(IB("S"),U,16),$P(IB("S"),U,17) D G ASK1
. N WHO
. S IBER="This bill was cancelled on "
. S IBER=IBER_$$FMTE^XLFDT($P(IB("S"),U,17),"1Z")_" by "
. S WHO="UNSPECIFIED"
. I $P(IB("S"),U,18) S WHO=$P($G(^VA(200,$P(IB("S"),U,18),0)),U,1)
. S IBER=IBER_WHO_"."
. D PCERR
. Q
;
S IBCOB=$$COB^IBCEF(IBIFN),IBCOBN=$TR(IBCOB,"PSTA","12")
S IBMRAIO=+$$CURR^IBCEF2(IBIFN),IBMRAO=$$MCRWNR^IBEFUNC(IBMRAIO)
S IBNMOLD=$S(IBCOB="P":"Primary",IBCOB="S":"Secondary",IBCOB="T":"Tertiary",IBCOB="A":"Patient",1:"")_$S(IBMRAO:"-MRA Only",1:"")
S IBINSOLD=$G(^DIC(36,$S(IB("MP"):+IB("MP"),IBMRAO:IBMRAIO,1:0),0))
;
NEXTP ; If current bill=MEDICARE WNR and valid 'next payer', use same
; bill for new payer
; If next valid 'payer' is ins co or MEDICARE WNR, create new bill
S IBCOBN=IBCOBN+1,IBNM=$S(IBCOBN=2:"Secondary Payer",IBCOBN=3:"Tertiary Payer",1:"")
;
I IBNM="" S IBER=$P(IB(0),U,1)_" is a "_IBNMOLD_" bill, there is no next bill in the series." D PCERR G ASK1
;
S IBX=+$P(IB("M1"),U,(4+IBCOBN)),IBY=$G(^DGCR(399,+IBX,0)),IBCOBIL(+IBIFN)=""
;
I $P(IBY,U,13)=7 S IBER="The "_$P(IBNM," ",1)_" bill "_$P(IBY,U,1)_" has been cancelled." D ERROR S IBX=""
;
I +IBX,$D(IBCOBIL(+IBX)) S IBER="Next bill in series can not be determined." D PCERR G ASK1
I +IBX S IBER=$P(IBNM," ",1)_" bill already defined for this series: "_$P(IBY,U,1) D PCERR S IBIFN=IBX G ASK1
;
S IBINSN=$P(IB("M"),U,IBCOBN) I 'IBINSN S IBER="There is no "_IBNM_" for "_$P(IB(0),U,1)_"." D PCERR G ASK1
S IBINS=$G(^DIC(36,+IBINSN,0)) I IBINS="" S IBER="The "_IBNM_" for "_$P(IB(0),U,1)_" is not a valid Insurance Co." D PCERR G ASK1
;
S IBMRA=0
I $P(IBINS,U,2)="N" S IBQ=0 D G:IBQ NEXTP
. I $$MCRWNR^IBEFUNC(IBINSN) D Q
.. ; Check if a valid tert ins if MCR WNR secondary
.. I IBCOBN'>2 D
... N Z
... S Z=+$P(IB("M"),U,IBCOBN+1)
... I Z,$D(^DIC(36,Z,0)),$P(^(0),U,2)'="N" S IBMRA=1,IBNM=$P(IBNM," ")_"-MRA.Only"
.. I 'IBMRA S IBER="MEDICARE will not reimburse and no further valid insurance for bill" D ERROR S IBQ=1
. S IBER=$P(IB(0),U,1)_" "_IBNM_", "_$P(IBINS,U,1)_", will not Reimburse" D ERROR S IBQ=1
;
; If processing in silent mode, skip over the following reads
I $G(IBSILENT) G SKIP
;
W !!
S DIR("?")="Enter Yes to "_$S('$G(IBMRAO):"create a new bill in the bill series for this care. The new bill will be the "_$P(IBNM," ")_" bill ",1:"enter the MRA information and change the payer to the "_$P($P(IBNM,"-")," ")_" payer ")
S DIR("?")=DIR("?")_$S('IBMRA:"with the "_IBNM_" responsible for payment.",1:"and will request an MRA from MEDICARE.")
S DIR(0)="YO",DIR("A")=$S('$G(IBMRAO):"Copy "_$P(IB(0),U,1)_" for a bill to the ",1:"Change payer on bill "_$P(IB(0),U,1)_" to ")_IBNM_", "_$P(IBINS,U,1) D ^DIR K DIR I Y'=1 S IBSECHK=1 G ASK1
;
W !
S IBQ=0
I '$G(IBMRAO) D G:IBQ ASK1
. N Z
. S DIR("?")="Enter the amount of the payment from the payer of the "_IBNMOLD_" bill."
. S DIR("?")=DIR("?")_" This will be added to the new bill as a prior payment and subtracted from the charges due for the new bill."
. S DIR("A")="Prior Payment from "_$P(IB(0),U,1)_" "_IBNMOLD_" Payer, "_$P(IBINSOLD,U,1)_": "
. S Z=$$EOBTOT^IBCEU1(IBIFN,$$COBN^IBCEF(IBIFN))
. S:Z DIR("B")=Z
. S DIR(0)="NOA^0:99999999:2"
. D ^DIR K DIR I Y=""!$D(DIRUT) S IBQ=1
. K IBCOB
. S IBCOB("U2",IBCOBN+2)=Y
. Q
;
SKIP ; Jump here if skipping over the preceeding reads
;
; If payer is Medicare (WNR) update payer sequence and quit
I IBMRAO!($G(IBSTSM)=1) D I $G(IBSTSM)'=1 G END
. N IBPRTOT,IBTOTCHG,IBPTRESP
. S IBTOTCHG=0
. ;
. ; Get Total Charges from BILLS/CLAIMS (#399) file
. S IBTOTCHG=$P($G(^DGCR(399,IBIFN,"U1")),U,1)
. ; Calculate Patient Responsibility for Bill
. ; IB*2.0*447 If claim's type of plan has effective date multiple, use those calculations
. ;S IBPTRESP=$$PREOBTOT^IBCEU0(IBIFN,$G(IBSTSM))
. ; Calculate Patient Primary/Secondary Prior Payment (field 218 or 219 of File 399)
. ; These fields are stored in DGCR(399,IBIFN,"U2") pieces 4 and 5 respectively
. ; Calculate: Prior Payment= Total Submitted Charges - Patient Responsibility
. S:$G(IBSTSM)'=1 IBPTRESP=$S($$MSEDT^IBCEMU4(IBIFN)'="":$$MSPRE^IBCEMU4(IBIFN),1:$$PREOBTOT^IBCEU0(IBIFN,$G(IBSTSM))),IBPRTOT=IBTOTCHG-IBPTRESP
. S:$G(IBSTSM)=1 IBPRTOT=$$EOBTOT^IBCEU1(IBIFN,$$COBN^IBCEF(IBIFN)) ;Pat Resp for non-medicare
. I IBPRTOT<0 S IBPRTOT=0 ; don't allow negative prior payment or offset
. S IBCOB("U2",IBCOBN+2)=IBPRTOT
. ; IB*2.0*547 don't change status back to 1.5 if auto-creating secondary or tertiary in silent mode
. ; D:$G(IBSTSM)'=1 COBCHG^IBCCC2(IBIFN,IBMRAIO,.IBCOB)
. ; D STAT^IBCEMU2(IBIFN,1.5,1) ; mra eob status update
. I $G(IBSTSM)'=1 D COBCHG^IBCCC2(IBIFN,IBMRAIO,.IBCOB),STAT^IBCEMU2(IBIFN,1.5,1) ; mra eob status update
. I $G(IBSILENT) S IBERRMSG=""
. Q
;
; We should NOT get to here in silent mode .... just in case
I $G(IBSILENT),$G(IBSTSM)'=1 G END ; currently only MCRWNR in silent mode
;
; Payer is not Medicare (WNR) - Perform additional steps
S IBCOB(0,15)=""
S IBCOB(0,21)=$S(IBCOBN=2:"S",IBCOBN=3:"T",1:"")
I IBCOB(0,21)="" G END
S IBCOB("M1",IBCOBN+3)=IBIFN
S IBIDS(.15)=IBIFN
D KVAR
G STEP2^IBCCC
;
END ;
Q
;
;
ASK1 ; If entering thru EDI COB processing, don't ask for new bill, quit
I $G(IBCBASK) G EXIT
G ASK
;
ERROR ; Display/Save error message
I '$G(IBSILENT) W !,IBER,!
E S IBERRMSG=IBER
S IBER=""
I $D(IBSECHK) S IBSECHK=1
Q
;
EXIT K IBCAN,IBCOB,IBU
KVAR K IBX,IBY,IBI,IBIFN,DFN,IBDT,IB,IBCOBN,IBNMOLD,IBINSOLD,IBNM,IBINSN,IBINS,IBER,DIR,IBAC,IBAC1,IBV,X,Y,IBDATA,IBT,IBND0,DIRUT,IBCOBIL,IBMRA,IBMRAI,IBMRAO,IBMRAIO,IBCBCOPY
K ^UTILITY($J)
Q
;
DSPRB(IBIFN) ; display related bills
;
D DSPRB^IBCCCB0(IBIFN) ; Code moved for size too big
Q
;
; ==============
;
; Copy a bill for Reasonable Charges without cancelling it, update certain fields
;
; there is always both inpt inst (created first) and prof charges, always need both bills
; there may be both outpt inst (created first) and prof charges, may not need both bills
; if billing by episode rather than by day (current standard) then may need multiple prof bills per day
;
; Inst bills are copied to create prof Bills automatically
; Subsequent prof bills may be created if the user wants them
;
; Only the first bill in the COB series of bills should be copied for the next prof bill
; The primary inst bill should be copied to get the secondary inst bill
; The primary prof bill should be copied to get the secondary prof bill
;
CTCOPY(IBIFN,IBMRA) ; based on the type of bill, copy without cancelling
; IBMRA = 1 if an MRA bill and copy for prof components is desired
;
D CTCOPY^IBCCCB0(IBIFN,$G(IBMRA)) ;Moved due to routine size
Q
;
PCERR ; Display/pause error message for interaction - *690
I '$G(IBSILENT) W !,IBER D PAUSE^VALM1
I $G(IBSILENT) S IBERRMSG=IBER
S IBER=""
I $D(IBSECHK) S IBSECHK=1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCCCB 10178 printed Sep 23, 2025@19:45:21 Page 2
IBCCCB ;ALB/ARH - COPY BILL FOR COB ;2/13/06 10:46am
+1 ;;2.0;INTEGRATED BILLING;**80,106,51,151,137,182,155,323,436,432,447,547,592,690**;21-MAR-94;Build 10
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to PAUSE^VALM1 in ICR #10116
+5 ; Copy bill for COB w/out cancelling, update some flds
+6 ; Primary->Secondary->Tertiary
ASK ;
+1 ; flag that copy function entered thru Copy COB option
SET IBCBCOPY=1
+2 ;
+3 DO KVAR
SET IBCAN=2
SET IBU="UNSPECIFIED"
+4 ;
+5 SET IBX=$$PB^IBJTU2
if +IBX=2
SET IBIFN=$PIECE(IBX,U,2)
IF +IBX=1
SET DFN=$PIECE(IBX,U,2)
SET IBV=1
SET IBAC=5
DO DATE^IBCB
+6 IF '$GET(IBIFN)
GOTO EXIT
+7 ;
+8 ; IB*2.0*432 Restrict access to only allow claims that are NOT on the new CBW Worklist
+9 IF $PIECE($GET(^DGCR(399,IBIFN,"S1")),U,7)=1
IF $GET(IBMRANOT)'=1
Begin DoDot:1
+10 WRITE !!?4,"This bill appears on the CBW Management Work List. Please use the"
+11 WRITE !?4,"'CBW Management Menu' options for all processing related to this bill."
+12 ;IB*2.0*592 JRA need to set quit flag after issuing this message
SET IBQUIT=1
+13 QUIT
End DoDot:1
GOTO ASK
+14 ; Restrict access to this process for REQUEST MRA bills in 2 Cases:
+15 ; 1. No MRA EOB's on File for bill
+16 IF $PIECE($GET(^DGCR(399,IBIFN,0)),U,13)=2
IF '$$CHK^IBCEMU1(IBIFN)
Begin DoDot:1
+17 WRITE !!?4,"This bill is in a status of REQUEST MRA and it has No MRA EOB's"
+18 WRITE !?4,"on file. Access to this bill is restricted."
End DoDot:1
GOTO ASK
+19 ;
+20 ; 2. At least one MRA EOB appears on the MRA management worklist
+21 IF $PIECE($GET(^DGCR(399,IBIFN,0)),U,13)=2
IF $$MRAWL^IBCEMU2(IBIFN)
Begin DoDot:1
+22 WRITE !!?4,"This bill is in a status of REQUEST MRA and it does appear on the"
+23 WRITE !?4,"MRA Management Work List. Please use the 'MRA Management Menu' options"
+24 WRITE !?4,"for all processing related to this bill."
+25 QUIT
End DoDot:1
GOTO ASK
+26 ;
+27 ; If MRA is Activated and bill is in Entered/Not Reviewed status and current insurance Co. is WNR -->
+28 ; ask if user wants to continue
+29 IF $$EDIACTV^IBCEF4(2)
IF $PIECE($GET(^DGCR(399,IBIFN,0)),U,13)=1
IF $$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))
Begin DoDot:1
+30 WRITE !!?4,"This bill is in a status of ENTERED/NOT REVIEWED and current payer is "
+31 WRITE !?4,"MEDICARE (WNR). No MRA has been requested for this bill."
+32 SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")=" Are you sure you want to continue to process this bill?: "
+33 DO ^DIR
KILL DIR
End DoDot:1
IF 'Y
GOTO ASK
+34 ;
+35 ; Display related bills
+36 DO DSPRB^IBCCCB0(IBIFN)
+37 ;
CHKB ; Entrypoint-COB processing via EDI's COB Mgmt
+1 ; Ask if final EOB was received for previous bill
+2 IF '$$FINALEOB^IBCCCB0(IBIFN)
SET IBSECHK=1
+3 IF $GET(IBSECHK)=1
IF $$MCRONBIL^IBEFUNC(IBIFN)
GOTO EXIT
+4 ;
+5 ; Warn if previous bill not at least authorized
+6 IF '$$MCRONBIL^IBEFUNC(IBIFN)
IF '$$COBOK^IBCCCB0(IBIFN)
GOTO EXIT
+7 ;
CHKB1 ; Entry point for Automatic/Silent COB Processing.
+1 ; No writes or reads can occur from this point forward if variable
+2 ; IBSILENT=1. Any and all error messages should be processed with
+3 ; the ERROR procedure below.
+4 ;
+5 SET IBX=$GET(^DGCR(399,+IBIFN,0))
SET DFN=$PIECE(IBX,U,2)
SET IBDT=$PIECE(IBX,U,3)\1
SET IBER=""
+6 IF IBCAN>1
DO NOPTF^IBCB2
IF 'IBAC1
DO NOPTF1^IBCB2
GOTO ASK1
+7 ;
+8 FOR IBI=0,"S","U1","M","MP","M1"
SET IB(IBI)=$GET(^DGCR(399,IBIFN,IBI))
+9 IF IB(0)=""
SET IBER="Invalid Bill Number"
DO PCERR
GOTO ASK1
+10 ;
+11 ; check to see if the bill has been cancelled
+12 IF $PIECE(IB("S"),U,16)
IF $PIECE(IB("S"),U,17)
Begin DoDot:1
+13 NEW WHO
+14 SET IBER="This bill was cancelled on "
+15 SET IBER=IBER_$$FMTE^XLFDT($PIECE(IB("S"),U,17),"1Z")_" by "
+16 SET WHO="UNSPECIFIED"
+17 IF $PIECE(IB("S"),U,18)
SET WHO=$PIECE($GET(^VA(200,$PIECE(IB("S"),U,18),0)),U,1)
+18 SET IBER=IBER_WHO_"."
+19 DO PCERR
+20 QUIT
End DoDot:1
GOTO ASK1
+21 ;
+22 SET IBCOB=$$COB^IBCEF(IBIFN)
SET IBCOBN=$TRANSLATE(IBCOB,"PSTA","12")
+23 SET IBMRAIO=+$$CURR^IBCEF2(IBIFN)
SET IBMRAO=$$MCRWNR^IBEFUNC(IBMRAIO)
+24 SET IBNMOLD=$SELECT(IBCOB="P":"Primary",IBCOB="S":"Secondary",IBCOB="T":"Tertiary",IBCOB="A":"Patient",1:"")_$SELECT(IBMRAO:"-MRA Only",1:"")
+25 SET IBINSOLD=$GET(^DIC(36,$SELECT(IB("MP"):+IB("MP"),IBMRAO:IBMRAIO,1:0),0))
+26 ;
NEXTP ; If current bill=MEDICARE WNR and valid 'next payer', use same
+1 ; bill for new payer
+2 ; If next valid 'payer' is ins co or MEDICARE WNR, create new bill
+3 SET IBCOBN=IBCOBN+1
SET IBNM=$SELECT(IBCOBN=2:"Secondary Payer",IBCOBN=3:"Tertiary Payer",1:"")
+4 ;
+5 IF IBNM=""
SET IBER=$PIECE(IB(0),U,1)_" is a "_IBNMOLD_" bill, there is no next bill in the series."
DO PCERR
GOTO ASK1
+6 ;
+7 SET IBX=+$PIECE(IB("M1"),U,(4+IBCOBN))
SET IBY=$GET(^DGCR(399,+IBX,0))
SET IBCOBIL(+IBIFN)=""
+8 ;
+9 IF $PIECE(IBY,U,13)=7
SET IBER="The "_$PIECE(IBNM," ",1)_" bill "_$PIECE(IBY,U,1)_" has been cancelled."
DO ERROR
SET IBX=""
+10 ;
+11 IF +IBX
IF $DATA(IBCOBIL(+IBX))
SET IBER="Next bill in series can not be determined."
DO PCERR
GOTO ASK1
+12 IF +IBX
SET IBER=$PIECE(IBNM," ",1)_" bill already defined for this series: "_$PIECE(IBY,U,1)
DO PCERR
SET IBIFN=IBX
GOTO ASK1
+13 ;
+14 SET IBINSN=$PIECE(IB("M"),U,IBCOBN)
IF 'IBINSN
SET IBER="There is no "_IBNM_" for "_$PIECE(IB(0),U,1)_"."
DO PCERR
GOTO ASK1
+15 SET IBINS=$GET(^DIC(36,+IBINSN,0))
IF IBINS=""
SET IBER="The "_IBNM_" for "_$PIECE(IB(0),U,1)_" is not a valid Insurance Co."
DO PCERR
GOTO ASK1
+16 ;
+17 SET IBMRA=0
+18 IF $PIECE(IBINS,U,2)="N"
SET IBQ=0
Begin DoDot:1
+19 IF $$MCRWNR^IBEFUNC(IBINSN)
Begin DoDot:2
+20 ; Check if a valid tert ins if MCR WNR secondary
+21 IF IBCOBN'>2
Begin DoDot:3
+22 NEW Z
+23 SET Z=+$PIECE(IB("M"),U,IBCOBN+1)
+24 IF Z
IF $DATA(^DIC(36,Z,0))
IF $PIECE(^(0),U,2)'="N"
SET IBMRA=1
SET IBNM=$PIECE(IBNM," ")_"-MRA.Only"
End DoDot:3
+25 IF 'IBMRA
SET IBER="MEDICARE will not reimburse and no further valid insurance for bill"
DO ERROR
SET IBQ=1
End DoDot:2
QUIT
+26 SET IBER=$PIECE(IB(0),U,1)_" "_IBNM_", "_$PIECE(IBINS,U,1)_", will not Reimburse"
DO ERROR
SET IBQ=1
End DoDot:1
if IBQ
GOTO NEXTP
+27 ;
+28 ; If processing in silent mode, skip over the following reads
+29 IF $GET(IBSILENT)
GOTO SKIP
+30 ;
+31 WRITE !!
+32 SET DIR("?")="Enter Yes to "_$SELECT('$GET(IBMRAO):"create a new bill in the bill series for this care. The new bill will be the "_$PIECE(IBNM," ")_" bill ",1:"enter the MRA information and change the payer to the "_$PIECE(...
... $PIECE(IBNM,"-")," ")_" payer ")
+33 SET DIR("?")=DIR("?")_$SELECT('IBMRA:"with the "_IBNM_" responsible for payment.",1:"and will request an MRA from MEDICARE.")
+34 SET DIR(0)="YO"
SET DIR("A")=$SELECT('$GET(IBMRAO):"Copy "_$PIECE(IB(0),U,1)_" for a bill to the ",1:"Change payer on bill "_$PIECE(IB(0),U,1)_" to ")_IBNM_", "_$PIECE(IBINS,U,1)
DO ^DIR
KILL DIR
IF Y'=1
SET IBSECHK=1
GOTO ASK1
+35 ;
+36 WRITE !
+37 SET IBQ=0
+38 IF '$GET(IBMRAO)
Begin DoDot:1
+39 NEW Z
+40 SET DIR("?")="Enter the amount of the payment from the payer of the "_IBNMOLD_" bill."
+41 SET DIR("?")=DIR("?")_" This will be added to the new bill as a prior payment and subtracted from the charges due for the new bill."
+42 SET DIR("A")="Prior Payment from "_$PIECE(IB(0),U,1)_" "_IBNMOLD_" Payer, "_$PIECE(IBINSOLD,U,1)_": "
+43 SET Z=$$EOBTOT^IBCEU1(IBIFN,$$COBN^IBCEF(IBIFN))
+44 if Z
SET DIR("B")=Z
+45 SET DIR(0)="NOA^0:99999999:2"
+46 DO ^DIR
KILL DIR
IF Y=""!$DATA(DIRUT)
SET IBQ=1
+47 KILL IBCOB
+48 SET IBCOB("U2",IBCOBN+2)=Y
+49 QUIT
End DoDot:1
if IBQ
GOTO ASK1
+50 ;
SKIP ; Jump here if skipping over the preceeding reads
+1 ;
+2 ; If payer is Medicare (WNR) update payer sequence and quit
+3 IF IBMRAO!($GET(IBSTSM)=1)
Begin DoDot:1
+4 NEW IBPRTOT,IBTOTCHG,IBPTRESP
+5 SET IBTOTCHG=0
+6 ;
+7 ; Get Total Charges from BILLS/CLAIMS (#399) file
+8 SET IBTOTCHG=$PIECE($GET(^DGCR(399,IBIFN,"U1")),U,1)
+9 ; Calculate Patient Responsibility for Bill
+10 ; IB*2.0*447 If claim's type of plan has effective date multiple, use those calculations
+11 ;S IBPTRESP=$$PREOBTOT^IBCEU0(IBIFN,$G(IBSTSM))
+12 ; Calculate Patient Primary/Secondary Prior Payment (field 218 or 219 of File 399)
+13 ; These fields are stored in DGCR(399,IBIFN,"U2") pieces 4 and 5 respectively
+14 ; Calculate: Prior Payment= Total Submitted Charges - Patient Responsibility
+15 if $GET(IBSTSM)'=1
SET IBPTRESP=$SELECT($$MSEDT^IBCEMU4(IBIFN)'="":$$MSPRE^IBCEMU4(IBIFN),1:$$PREOBTOT^IBCEU0(IBIFN,$GET(IBSTSM)))
SET IBPRTOT=IBTOTCHG-IBPTRESP
+16 ;Pat Resp for non-medicare
if $GET(IBSTSM)=1
SET IBPRTOT=$$EOBTOT^IBCEU1(IBIFN,$$COBN^IBCEF(IBIFN))
+17 ; don't allow negative prior payment or offset
IF IBPRTOT<0
SET IBPRTOT=0
+18 SET IBCOB("U2",IBCOBN+2)=IBPRTOT
+19 ; IB*2.0*547 don't change status back to 1.5 if auto-creating secondary or tertiary in silent mode
+20 ; D:$G(IBSTSM)'=1 COBCHG^IBCCC2(IBIFN,IBMRAIO,.IBCOB)
+21 ; D STAT^IBCEMU2(IBIFN,1.5,1) ; mra eob status update
+22 ; mra eob status update
IF $GET(IBSTSM)'=1
DO COBCHG^IBCCC2(IBIFN,IBMRAIO,.IBCOB)
DO STAT^IBCEMU2(IBIFN,1.5,1)
+23 IF $GET(IBSILENT)
SET IBERRMSG=""
+24 QUIT
End DoDot:1
IF $GET(IBSTSM)'=1
GOTO END
+25 ;
+26 ; We should NOT get to here in silent mode .... just in case
+27 ; currently only MCRWNR in silent mode
IF $GET(IBSILENT)
IF $GET(IBSTSM)'=1
GOTO END
+28 ;
+29 ; Payer is not Medicare (WNR) - Perform additional steps
+30 SET IBCOB(0,15)=""
+31 SET IBCOB(0,21)=$SELECT(IBCOBN=2:"S",IBCOBN=3:"T",1:"")
+32 IF IBCOB(0,21)=""
GOTO END
+33 SET IBCOB("M1",IBCOBN+3)=IBIFN
+34 SET IBIDS(.15)=IBIFN
+35 DO KVAR
+36 GOTO STEP2^IBCCC
+37 ;
END ;
+1 QUIT
+2 ;
+3 ;
ASK1 ; If entering thru EDI COB processing, don't ask for new bill, quit
+1 IF $GET(IBCBASK)
GOTO EXIT
+2 GOTO ASK
+3 ;
ERROR ; Display/Save error message
+1 IF '$GET(IBSILENT)
WRITE !,IBER,!
+2 IF '$TEST
SET IBERRMSG=IBER
+3 SET IBER=""
+4 IF $DATA(IBSECHK)
SET IBSECHK=1
+5 QUIT
+6 ;
EXIT KILL IBCAN,IBCOB,IBU
KVAR KILL IBX,IBY,IBI,IBIFN,DFN,IBDT,IB,IBCOBN,IBNMOLD,IBINSOLD,IBNM,IBINSN,IBINS,IBER,DIR,IBAC,IBAC1,IBV,X,Y,IBDATA,IBT,IBND0,DIRUT,IBCOBIL,IBMRA,IBMRAI,IBMRAO,IBMRAIO,IBCBCOPY
+1 KILL ^UTILITY($JOB)
+2 QUIT
+3 ;
DSPRB(IBIFN) ; display related bills
+1 ;
+2 ; Code moved for size too big
DO DSPRB^IBCCCB0(IBIFN)
+3 QUIT
+4 ;
+5 ; ==============
+6 ;
+7 ; Copy a bill for Reasonable Charges without cancelling it, update certain fields
+8 ;
+9 ; there is always both inpt inst (created first) and prof charges, always need both bills
+10 ; there may be both outpt inst (created first) and prof charges, may not need both bills
+11 ; if billing by episode rather than by day (current standard) then may need multiple prof bills per day
+12 ;
+13 ; Inst bills are copied to create prof Bills automatically
+14 ; Subsequent prof bills may be created if the user wants them
+15 ;
+16 ; Only the first bill in the COB series of bills should be copied for the next prof bill
+17 ; The primary inst bill should be copied to get the secondary inst bill
+18 ; The primary prof bill should be copied to get the secondary prof bill
+19 ;
CTCOPY(IBIFN,IBMRA) ; based on the type of bill, copy without cancelling
+1 ; IBMRA = 1 if an MRA bill and copy for prof components is desired
+2 ;
+3 ;Moved due to routine size
DO CTCOPY^IBCCCB0(IBIFN,$GET(IBMRA))
+4 QUIT
+5 ;
PCERR ; Display/pause error message for interaction - *690
+1 IF '$GET(IBSILENT)
WRITE !,IBER
DO PAUSE^VALM1
+2 IF $GET(IBSILENT)
SET IBERRMSG=IBER
+3 SET IBER=""
+4 IF $DATA(IBSECHK)
SET IBSECHK=1
+5 QUIT
+6 ;
