- 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 Feb 18, 2025@23:35:31 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 ;