- IBCEMU2 ;ALB/DSM - IB MRA Utility ;01-MAY-2003
- ;;2.0;INTEGRATED BILLING;**155,320,349,436,547**;21-MAR-94;Build 119
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- Q
- ;
- QMRA ; This is a background procedure that is spun off of the IB BATCH
- ; Print option. This process scans a queue in ^XTMP("IBMRA"_#,$J) and checks
- ; each Bill to see if a printable MRA exist, if so, prints them. MRA's print
- ; on the device associated with the 'Bill Addendum' Form Type.
- ; This process doesn't interact with users.
- ;
- ; IB*2*320: MCS - Resubmit by Print produces a scratch global also
- ; ^XTMP("IBCFP6",$J,.... for MRA's to print here
- ;
- ; Input:
- ; IBJ = $J of starting job
- ; IBFTP = "IBMRA"_# (ien of form type) or "IBCFP6"
- ;
- N IBS1,IBS2,IBS3,IBIFN,IBQ,IBPGN
- S (IBS1,IBIFN,IBQ)=0
- F S IBS1=$O(^XTMP(IBFTP,IBJ,IBS1)) Q:IBS1="" D I IBQ Q
- . S IBS2=0 F S IBS2=$O(^XTMP(IBFTP,IBJ,IBS1,IBS2)) Q:IBS2="" D I IBQ Q
- . . S IBS3=0 F S IBS3=$O(^XTMP(IBFTP,IBJ,IBS1,IBS2,IBS3)) Q:IBS3="" D I IBQ Q
- . . . S IBIFN=0 F S IBIFN=$O(^XTMP(IBFTP,IBJ,IBS1,IBS2,IBS3,IBIFN)) Q:IBIFN="" D I $$STOP S IBQ=1 Q
- . . . . I $$MRAEXIST^IBCEMU1(IBIFN) D PROC^IBCEMRAA W @IOF ;must have IBIFN set
- K ^XTMP(IBFTP,IBJ) S ZTREQ="@"
- Q ;QMRA
- ;
- STOP() ;determine if user has requested the queued report to stop
- I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***"
- Q +$G(ZTSTOP)
- ;
- ;
- STAT(IBIFN,STATUS,MRAONLY) ; Update the review status in the EOB file
- ; This procedure updates field .16 in file 361.1 for all EOB's for
- ; the given bill#
- ;
- ; IBIFN - Internal Bill# (required)
- ; STATUS - Internal Value of the Review Status field (required)
- ; MRAONLY - Optional Flag with a default of 0 if not passed in
- ; 1:only update MRA EOB's for this bill
- ; 0:update all EOB's for this bill
- ; 2:only update non-MRA EOB's for this bill (IB*2.0*547)
- ;
- NEW RESULT,IBEOB,IBM
- NEW DIE,DA,DR,D,D0,DI,DIC,DICR,DIG,DIH,DISYS,DIU,DIV,DIW,DQ,DIERR,X,Y
- S IBIFN=+$G(IBIFN),STATUS=$G(STATUS)
- S MRAONLY=$G(MRAONLY,0)
- ;
- I '$D(^IBM(361.1,"B",IBIFN)) G STATX ; no EOB's for this bill
- D CHK^DIE(361.1,.16,,STATUS,.RESULT)
- I RESULT="^" G STATX ; invalid status passed in
- ;
- S IBEOB=0 ; loop thru all EOB's for the bill
- F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D
- . S IBM=$G(^IBM(361.1,IBEOB,0))
- . I $P(IBM,U,16)=STATUS Q ; no change
- . ;I MRAONLY,'$P(IBM,U,4) Q ; skip because of parameter
- . I MRAONLY=1,'$P(IBM,U,4) Q ; skip because of parameter
- . I MRAONLY=2,$P(IBM,U,4) Q ; skip because of parameter (don't update MRA)
- . S DIE=361.1,DA=IBEOB,DR=".16////"_STATUS D ^DIE
- . Q
- ;
- STATX ;
- Q
- ;
- MRAWL(IBIFN) ; Do any MRA EOB's for this bill appear on the worklist?
- ;
- ; This function returns 1 if at least one MRA EOB for the given bill
- ; appears on the MRA management worklist. Otherwise, this function
- ; returns 0.
- ;
- NEW OK,IBEOB
- S OK=0,IBIFN=+$G(IBIFN)
- I '$D(^IBM(361.1,"B",IBIFN)) G MRAWLX ; no EOB's for this bill
- S IBEOB=0 ; loop thru all EOB's for the bill
- F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D Q:OK
- . I $$ELIG^IBCECOB1(IBEOB) S OK=1
- . Q
- MRAWLX ;
- Q OK
- ;
- TXSTS(IBIFN,IB364,REJFLG,IBZ) ; Claim transmission status information
- ; Input IBIFN - required
- ; IB364 - optional (defaults to most recent transmission#)
- ; Output REJFLG (pass by reference) - 1/0 flag if any rejection status
- ; messages on file
- ; IBZ (pass by reference) - array of information
- ;
- NEW IEN,SMCNT,SEV,BCH,BCHD0,BCHD1
- S REJFLG=0 K IBZ
- S IBIFN=+$G(IBIFN) I 'IBIFN G TXSTSX
- S IB364=+$G(IB364)
- I 'IB364 S IB364=$$LAST364^IBCEF4(IBIFN) I 'IB364 G TXSTSX
- I $P($G(^IBA(364,IB364,0)),U,1)'=IBIFN G TXSTSX
- S IEN=0,SMCNT=0
- F S IEN=$O(^IBM(361,"AERR",IB364,IEN)) Q:'IEN D
- . S SMCNT=SMCNT+1
- . S SEV=$P($G(^IBM(361,IEN,0)),U,3) ; status message severity
- . I SEV="R" S REJFLG=1
- . Q
- S BCH=+$P($G(^IBA(364,IB364,0)),U,2) ; batch ien
- S BCHD0=$G(^IBA(364.1,BCH,0))
- S BCHD1=$G(^IBA(364.1,BCH,1))
- S IBZ("DATE LAST SENT")=$P(BCHD1,U,3)
- S IBZ("NUMBER OF STATUS MESSAGES")=SMCNT
- S IBZ("BATCH NUMBER")=$P(BCHD0,U,1)
- S IBZ("TRANSMISSION STATUS")=$P($G(^IBA(364,IB364,0)),U,3)
- TXSTSX ;
- Q
- ;
- MRACALC(IBEOB,IBIFN,AR,PRCASV) ; Calculates Two Amounts:
- ; Unreimbursable Medicare Expense and Medicare Contract Adjustment
- ; Amount for a given EOB.
- ;
- ; Input IBIFN= ien of Claim file 399 - Required
- ; IBEOB= ien of EOB file 361.1 - Required
- ; AR= Flag indicating this was called from AR function
- ; Input/Output PRCASV= array with the two calculated values
- ; PRCASV("MEDURE")=Unreimbursable Medicare Expense
- ; PRCASV("MEDCA")=Medicare Contract Adjustment Amount
- ;
- ; For multiple EOB's, add up the calculated values across EOB's
- ;
- N I,LNLVL,EOBADJ,IBCOBN,INPAT,FRMTYP
- ;
- S FRMTYP=$$FT^IBCEF(IBIFN) ;Form Type 2=1500; 3=UB
- S INPAT=$$INPAT^IBCEF(IBIFN) ;Inpat/Outpat Flag
- S AR=$G(AR,0) ;initialize AR flag
- F I=0,1,2 S IBEOB(I)=$G(^IBM(361.1,IBEOB,I))
- I $P(IBEOB(0),U,4)'=1 Q ;make sure it's an MRA
- S IBCOBN=$$COBN^IBCEF(IBIFN) ;get current bill sequence
- ; Make sure we're on the right insurance sequence when AR flag is on
- I AR I $P(IBEOB(0),U,15)'=(IBCOBN-1) Q
- ;
- ; Unreimburseable Medicare Expense (same calc regardless of form type)
- ; For multiple EOB's, add up the amounts across EOB's
- S PRCASV("MEDURE")=$G(PRCASV("MEDURE"))+IBEOB(1)
- ;
- ; Handle CMS-1500 Form Type Next:
- I FRMTYP=2 D MEDCARE(IBEOB,.PRCASV) Q
- ;
- ; Handle UB Form Type Next:
- ; If Inpatient Calculate from Claim level data
- I INPAT D Q ;
- . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10)
- . S PRCASV("MEDCA")=$G(PRCASV("MEDCA"))+$$CALCMCA(.EOBADJ)
- ;
- ; If Outpatient Calculate from Service Line level data
- D MEDCARE(IBEOB,.PRCASV)
- Q ;MRACALC
- ;
- MEDCARE(IBEOB,PRCASV) ; If Outpatient Calculate from Service Line level data
- N LNLVL,EOBADJ
- S LNLVL=0
- F S LNLVL=$O(^IBM(361.1,IBEOB,15,LNLVL)) Q:'LNLVL D ;
- . K EOBADJ
- . M EOBADJ=^IBM(361.1,IBEOB,15,LNLVL,1)
- . ; Total up the Medicare Contract Adjustment across ALL Service Lines
- . S PRCASV("MEDCA")=$G(PRCASV("MEDCA"))+$$CALCMCA(.EOBADJ)
- Q ;MEDCARE
- ;
- CALCMCA(EOBADJ) ; FUNCTION - Calculate Medicare Contract Adjustment
- ; Sums up Amounts on ALL Reason Codes under ALL Group Codes = 'CO' and
- ; returns that value (which is Medicare Contract Adjustment).
- ;
- ; Input EOBADJ = Array of Group Codes & Reason Codes from either the Claim
- ; Level (10) or Service Line Level (15) of EOB file (#361.1)
- ; Output returns Medicare Contract Adjustment
- ;
- N GRPLVL,RSNLVL,RSNAMT,MCA
- S (GRPLVL,MCA)=0
- F S GRPLVL=$O(EOBADJ(GRPLVL)) Q:'GRPLVL D ;
- . I $P($G(EOBADJ(GRPLVL,0)),U)'="CO" Q
- . S RSNLVL=0
- . F S RSNLVL=$O(EOBADJ(GRPLVL,1,RSNLVL)) Q:'RSNLVL D ;
- . . S RSNAMT=$P($G(EOBADJ(GRPLVL,1,RSNLVL,0)),U,2)
- . . S MCA=MCA+RSNAMT
- Q MCA ;CALCMCA
- ;
- ALLOWED(IBEOB) ; Returns Total Allowed Amount by summing up all Allowed Amounts
- ; from Line Level Adjustment
- ; Input: IBEOB = ien of EOB file (361.1)
- ;
- N LNLVL,LNLVLD,ALWD,TOTALWD
- S (LNLVL,TOTALWD)=0
- F S LNLVL=$O(^IBM(361.1,IBEOB,15,LNLVL)) Q:'LNLVL S LNLVLD=^(LNLVL,0) D
- . S ALWD=$P(LNLVLD,U,13),TOTALWD=TOTALWD+ALWD ; Allowed Amount
- Q TOTALWD ;ALLOWED
- ;
- MRATYPE(BILL,ARDATE) ; Function - determines the MRA Receivable Type for a Third
- ; Party Receivable. This is accomplished by comparing DATE MRA FIRST ACTIVATED
- ; with AR Activation Date for the Bill.
- ;
- ; Input BILL= ien of a given Bill Number (Required)
- ; ARDATE= Date Account Receivable was Activated - date only (Required)
- ;
- ; Output - Possible Types:
- ; 1 = Pre-MRA implementation
- ; 2 = Post MRA Medicare Receivable
- ; 3 = Post MRA non-Medicare Receivable
- ;
- N MRADTACT,MRAMT
- I '$G(ARDATE)!'$G(BILL) Q 1
- ;
- ; get DATE MRA FIRST ACTIVATED at site
- S MRADTACT=$$MRADTACT()
- ;
- ; MRA not Activated at site
- I MRADTACT="" Q 1 ;MRATYPE
- ;
- ; Bill from pre-MRA implementation era
- I ARDATE<MRADTACT Q 1 ;MRATYPE
- ;
- ; Post-MRA Medicare bill; get Medicare amounts
- S MRAMT=$G(^PRCA(430,BILL,13))
- ; check Medicare Contractual Adjustment Amount
- I $P(MRAMT,U,1) Q 2 ;MRATYPE
- ; check Medicare Unreimburseable Amout
- I $P(MRAMT,U,2) Q 2 ;MRATYPE
- ; check if bill is a Medicare one
- I $$MRAEXIST^IBCEMU1(BILL) Q 2 ;MRATYPE
- ; check if bill is a Medicare Supplemental one
- I $P($$CRIT^IBRFN2(BILL),U)=2 Q 2 ;MRATYPE
- ;
- ; all others are Post-MRA non-Medicare bills
- Q 3 ;MRATYPE
- ;
- MRADTACT() ; Function - returns DATE MRA FIRST ACTIVATED at site
- Q $P($G(^IBE(350.9,1,8)),U,13)
- ;
- ;** start IB*2.0*436 **
- MRACALC2(IBIFN) ; Function - This tag will add all EOB's for a given claim number.
- ; Returns the sum of the Medicare Contractual Adj Amt
- ;
- ; Input: IBIFN - ien of Claim file 399
- ; Output: PRCASV("MEDCA") - Medicare Contractual Adj Amt
- ;
- ; Variables IBEOB = ien of EOB file 361.1
- ; PRCASV("MEDCA")= Medicare Contractual Adj Amt
- ; Note:
- ; For clarification, the following terms mean exactly the same thing.
- ; "Medicare Contractual Adj Amt" = "Medicare Unpaid Amt" = "Medicare Unallowable Amt"
- N IBEOB,I,LNLVL,EOBADJ,IBCOBN,INPAT,FRMTYP,PRCASV
- ;
- S PRCASV("MEDCA")=0
- S FRMTYP=$$FT^IBCEF(IBIFN) ;Form Type 2=1500; 3=UB
- S INPAT=$$INPAT^IBCEF(IBIFN) ;Inpat/Outpat Flag
- ; Get EOB data
- S IBEOB=0
- F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D
- . F I=0,1,2 S IBEOB(I)=$G(^IBM(361.1,IBEOB,I))
- . I $P(IBEOB(0),U,4)'=1 Q ;make sure it's an MRA
- . S IBCOBN=$$COBN^IBCEF(IBIFN) ;get current bill sequence
- . ;
- . ; Handle CMS-1500 Form Type Next:
- . I FRMTYP=2 D MEDCARE(IBEOB,.PRCASV) Q
- . ;
- . ; Handle UB Form Type Next:
- . ; If Inpatient Calculate from Claim level data
- . I INPAT D Q ;
- . . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10)
- . . S PRCASV("MEDCA")=$G(PRCASV("MEDCA"))+$$CALCMCA(.EOBADJ)
- . ; If Outpatient Calculate from Service Line level data
- . D MEDCARE(IBEOB,.PRCASV)
- Q PRCASV("MEDCA") ;MRACALC2
- ;** end IB*2.0*436 **
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEMU2 10404 printed Jan 18, 2025@03:12:27 Page 2
- IBCEMU2 ;ALB/DSM - IB MRA Utility ;01-MAY-2003
- +1 ;;2.0;INTEGRATED BILLING;**155,320,349,436,547**;21-MAR-94;Build 119
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 QUIT
- +5 ;
- QMRA ; This is a background procedure that is spun off of the IB BATCH
- +1 ; Print option. This process scans a queue in ^XTMP("IBMRA"_#,$J) and checks
- +2 ; each Bill to see if a printable MRA exist, if so, prints them. MRA's print
- +3 ; on the device associated with the 'Bill Addendum' Form Type.
- +4 ; This process doesn't interact with users.
- +5 ;
- +6 ; IB*2*320: MCS - Resubmit by Print produces a scratch global also
- +7 ; ^XTMP("IBCFP6",$J,.... for MRA's to print here
- +8 ;
- +9 ; Input:
- +10 ; IBJ = $J of starting job
- +11 ; IBFTP = "IBMRA"_# (ien of form type) or "IBCFP6"
- +12 ;
- +13 NEW IBS1,IBS2,IBS3,IBIFN,IBQ,IBPGN
- +14 SET (IBS1,IBIFN,IBQ)=0
- +15 FOR
- SET IBS1=$ORDER(^XTMP(IBFTP,IBJ,IBS1))
- if IBS1=""
- QUIT
- Begin DoDot:1
- +16 SET IBS2=0
- FOR
- SET IBS2=$ORDER(^XTMP(IBFTP,IBJ,IBS1,IBS2))
- if IBS2=""
- QUIT
- Begin DoDot:2
- +17 SET IBS3=0
- FOR
- SET IBS3=$ORDER(^XTMP(IBFTP,IBJ,IBS1,IBS2,IBS3))
- if IBS3=""
- QUIT
- Begin DoDot:3
- +18 SET IBIFN=0
- FOR
- SET IBIFN=$ORDER(^XTMP(IBFTP,IBJ,IBS1,IBS2,IBS3,IBIFN))
- if IBIFN=""
- QUIT
- Begin DoDot:4
- +19 ;must have IBIFN set
- IF $$MRAEXIST^IBCEMU1(IBIFN)
- DO PROC^IBCEMRAA
- WRITE @IOF
- End DoDot:4
- IF $$STOP
- SET IBQ=1
- QUIT
- End DoDot:3
- IF IBQ
- QUIT
- End DoDot:2
- IF IBQ
- QUIT
- End DoDot:1
- IF IBQ
- QUIT
- +20 KILL ^XTMP(IBFTP,IBJ)
- SET ZTREQ="@"
- +21 ;QMRA
- QUIT
- +22 ;
- STOP() ;determine if user has requested the queued report to stop
- +1 IF $DATA(ZTQUEUED)
- IF $$S^%ZTLOAD
- SET ZTSTOP=1
- KILL ZTREQ
- IF +$GET(IBPGN)
- WRITE !,"***TASK STOPPED BY USER***"
- +2 QUIT +$GET(ZTSTOP)
- +3 ;
- +4 ;
- STAT(IBIFN,STATUS,MRAONLY) ; Update the review status in the EOB file
- +1 ; This procedure updates field .16 in file 361.1 for all EOB's for
- +2 ; the given bill#
- +3 ;
- +4 ; IBIFN - Internal Bill# (required)
- +5 ; STATUS - Internal Value of the Review Status field (required)
- +6 ; MRAONLY - Optional Flag with a default of 0 if not passed in
- +7 ; 1:only update MRA EOB's for this bill
- +8 ; 0:update all EOB's for this bill
- +9 ; 2:only update non-MRA EOB's for this bill (IB*2.0*547)
- +10 ;
- +11 NEW RESULT,IBEOB,IBM
- +12 NEW DIE,DA,DR,D,D0,DI,DIC,DICR,DIG,DIH,DISYS,DIU,DIV,DIW,DQ,DIERR,X,Y
- +13 SET IBIFN=+$GET(IBIFN)
- SET STATUS=$GET(STATUS)
- +14 SET MRAONLY=$GET(MRAONLY,0)
- +15 ;
- +16 ; no EOB's for this bill
- IF '$DATA(^IBM(361.1,"B",IBIFN))
- GOTO STATX
- +17 DO CHK^DIE(361.1,.16,,STATUS,.RESULT)
- +18 ; invalid status passed in
- IF RESULT="^"
- GOTO STATX
- +19 ;
- +20 ; loop thru all EOB's for the bill
- SET IBEOB=0
- +21 FOR
- SET IBEOB=$ORDER(^IBM(361.1,"B",IBIFN,IBEOB))
- if 'IBEOB
- QUIT
- Begin DoDot:1
- +22 SET IBM=$GET(^IBM(361.1,IBEOB,0))
- +23 ; no change
- IF $PIECE(IBM,U,16)=STATUS
- QUIT
- +24 ;I MRAONLY,'$P(IBM,U,4) Q ; skip because of parameter
- +25 ; skip because of parameter
- IF MRAONLY=1
- IF '$PIECE(IBM,U,4)
- QUIT
- +26 ; skip because of parameter (don't update MRA)
- IF MRAONLY=2
- IF $PIECE(IBM,U,4)
- QUIT
- +27 SET DIE=361.1
- SET DA=IBEOB
- SET DR=".16////"_STATUS
- DO ^DIE
- +28 QUIT
- End DoDot:1
- +29 ;
- STATX ;
- +1 QUIT
- +2 ;
- MRAWL(IBIFN) ; Do any MRA EOB's for this bill appear on the worklist?
- +1 ;
- +2 ; This function returns 1 if at least one MRA EOB for the given bill
- +3 ; appears on the MRA management worklist. Otherwise, this function
- +4 ; returns 0.
- +5 ;
- +6 NEW OK,IBEOB
- +7 SET OK=0
- SET IBIFN=+$GET(IBIFN)
- +8 ; no EOB's for this bill
- IF '$DATA(^IBM(361.1,"B",IBIFN))
- GOTO MRAWLX
- +9 ; loop thru all EOB's for the bill
- SET IBEOB=0
- +10 FOR
- SET IBEOB=$ORDER(^IBM(361.1,"B",IBIFN,IBEOB))
- if 'IBEOB
- QUIT
- Begin DoDot:1
- +11 IF $$ELIG^IBCECOB1(IBEOB)
- SET OK=1
- +12 QUIT
- End DoDot:1
- if OK
- QUIT
- MRAWLX ;
- +1 QUIT OK
- +2 ;
- TXSTS(IBIFN,IB364,REJFLG,IBZ) ; Claim transmission status information
- +1 ; Input IBIFN - required
- +2 ; IB364 - optional (defaults to most recent transmission#)
- +3 ; Output REJFLG (pass by reference) - 1/0 flag if any rejection status
- +4 ; messages on file
- +5 ; IBZ (pass by reference) - array of information
- +6 ;
- +7 NEW IEN,SMCNT,SEV,BCH,BCHD0,BCHD1
- +8 SET REJFLG=0
- KILL IBZ
- +9 SET IBIFN=+$GET(IBIFN)
- IF 'IBIFN
- GOTO TXSTSX
- +10 SET IB364=+$GET(IB364)
- +11 IF 'IB364
- SET IB364=$$LAST364^IBCEF4(IBIFN)
- IF 'IB364
- GOTO TXSTSX
- +12 IF $PIECE($GET(^IBA(364,IB364,0)),U,1)'=IBIFN
- GOTO TXSTSX
- +13 SET IEN=0
- SET SMCNT=0
- +14 FOR
- SET IEN=$ORDER(^IBM(361,"AERR",IB364,IEN))
- if 'IEN
- QUIT
- Begin DoDot:1
- +15 SET SMCNT=SMCNT+1
- +16 ; status message severity
- SET SEV=$PIECE($GET(^IBM(361,IEN,0)),U,3)
- +17 IF SEV="R"
- SET REJFLG=1
- +18 QUIT
- End DoDot:1
- +19 ; batch ien
- SET BCH=+$PIECE($GET(^IBA(364,IB364,0)),U,2)
- +20 SET BCHD0=$GET(^IBA(364.1,BCH,0))
- +21 SET BCHD1=$GET(^IBA(364.1,BCH,1))
- +22 SET IBZ("DATE LAST SENT")=$PIECE(BCHD1,U,3)
- +23 SET IBZ("NUMBER OF STATUS MESSAGES")=SMCNT
- +24 SET IBZ("BATCH NUMBER")=$PIECE(BCHD0,U,1)
- +25 SET IBZ("TRANSMISSION STATUS")=$PIECE($GET(^IBA(364,IB364,0)),U,3)
- TXSTSX ;
- +1 QUIT
- +2 ;
- MRACALC(IBEOB,IBIFN,AR,PRCASV) ; Calculates Two Amounts:
- +1 ; Unreimbursable Medicare Expense and Medicare Contract Adjustment
- +2 ; Amount for a given EOB.
- +3 ;
- +4 ; Input IBIFN= ien of Claim file 399 - Required
- +5 ; IBEOB= ien of EOB file 361.1 - Required
- +6 ; AR= Flag indicating this was called from AR function
- +7 ; Input/Output PRCASV= array with the two calculated values
- +8 ; PRCASV("MEDURE")=Unreimbursable Medicare Expense
- +9 ; PRCASV("MEDCA")=Medicare Contract Adjustment Amount
- +10 ;
- +11 ; For multiple EOB's, add up the calculated values across EOB's
- +12 ;
- +13 NEW I,LNLVL,EOBADJ,IBCOBN,INPAT,FRMTYP
- +14 ;
- +15 ;Form Type 2=1500; 3=UB
- SET FRMTYP=$$FT^IBCEF(IBIFN)
- +16 ;Inpat/Outpat Flag
- SET INPAT=$$INPAT^IBCEF(IBIFN)
- +17 ;initialize AR flag
- SET AR=$GET(AR,0)
- +18 FOR I=0,1,2
- SET IBEOB(I)=$GET(^IBM(361.1,IBEOB,I))
- +19 ;make sure it's an MRA
- IF $PIECE(IBEOB(0),U,4)'=1
- QUIT
- +20 ;get current bill sequence
- SET IBCOBN=$$COBN^IBCEF(IBIFN)
- +21 ; Make sure we're on the right insurance sequence when AR flag is on
- +22 IF AR
- IF $PIECE(IBEOB(0),U,15)'=(IBCOBN-1)
- QUIT
- +23 ;
- +24 ; Unreimburseable Medicare Expense (same calc regardless of form type)
- +25 ; For multiple EOB's, add up the amounts across EOB's
- +26 SET PRCASV("MEDURE")=$GET(PRCASV("MEDURE"))+IBEOB(1)
- +27 ;
- +28 ; Handle CMS-1500 Form Type Next:
- +29 IF FRMTYP=2
- DO MEDCARE(IBEOB,.PRCASV)
- QUIT
- +30 ;
- +31 ; Handle UB Form Type Next:
- +32 ; If Inpatient Calculate from Claim level data
- +33 ;
- IF INPAT
- Begin DoDot:1
- +34 KILL EOBADJ
- MERGE EOBADJ=^IBM(361.1,IBEOB,10)
- +35 SET PRCASV("MEDCA")=$GET(PRCASV("MEDCA"))+$$CALCMCA(.EOBADJ)
- End DoDot:1
- QUIT
- +36 ;
- +37 ; If Outpatient Calculate from Service Line level data
- +38 DO MEDCARE(IBEOB,.PRCASV)
- +39 ;MRACALC
- QUIT
- +40 ;
- MEDCARE(IBEOB,PRCASV) ; If Outpatient Calculate from Service Line level data
- +1 NEW LNLVL,EOBADJ
- +2 SET LNLVL=0
- +3 ;
- FOR
- SET LNLVL=$ORDER(^IBM(361.1,IBEOB,15,LNLVL))
- if 'LNLVL
- QUIT
- Begin DoDot:1
- +4 KILL EOBADJ
- +5 MERGE EOBADJ=^IBM(361.1,IBEOB,15,LNLVL,1)
- +6 ; Total up the Medicare Contract Adjustment across ALL Service Lines
- +7 SET PRCASV("MEDCA")=$GET(PRCASV("MEDCA"))+$$CALCMCA(.EOBADJ)
- End DoDot:1
- +8 ;MEDCARE
- QUIT
- +9 ;
- CALCMCA(EOBADJ) ; FUNCTION - Calculate Medicare Contract Adjustment
- +1 ; Sums up Amounts on ALL Reason Codes under ALL Group Codes = 'CO' and
- +2 ; returns that value (which is Medicare Contract Adjustment).
- +3 ;
- +4 ; Input EOBADJ = Array of Group Codes & Reason Codes from either the Claim
- +5 ; Level (10) or Service Line Level (15) of EOB file (#361.1)
- +6 ; Output returns Medicare Contract Adjustment
- +7 ;
- +8 NEW GRPLVL,RSNLVL,RSNAMT,MCA
- +9 SET (GRPLVL,MCA)=0
- +10 ;
- FOR
- SET GRPLVL=$ORDER(EOBADJ(GRPLVL))
- if 'GRPLVL
- QUIT
- Begin DoDot:1
- +11 IF $PIECE($GET(EOBADJ(GRPLVL,0)),U)'="CO"
- QUIT
- +12 SET RSNLVL=0
- +13 ;
- FOR
- SET RSNLVL=$ORDER(EOBADJ(GRPLVL,1,RSNLVL))
- if 'RSNLVL
- QUIT
- Begin DoDot:2
- +14 SET RSNAMT=$PIECE($GET(EOBADJ(GRPLVL,1,RSNLVL,0)),U,2)
- +15 SET MCA=MCA+RSNAMT
- End DoDot:2
- End DoDot:1
- +16 ;CALCMCA
- QUIT MCA
- +17 ;
- ALLOWED(IBEOB) ; Returns Total Allowed Amount by summing up all Allowed Amounts
- +1 ; from Line Level Adjustment
- +2 ; Input: IBEOB = ien of EOB file (361.1)
- +3 ;
- +4 NEW LNLVL,LNLVLD,ALWD,TOTALWD
- +5 SET (LNLVL,TOTALWD)=0
- +6 FOR
- SET LNLVL=$ORDER(^IBM(361.1,IBEOB,15,LNLVL))
- if 'LNLVL
- QUIT
- SET LNLVLD=^(LNLVL,0)
- Begin DoDot:1
- +7 ; Allowed Amount
- SET ALWD=$PIECE(LNLVLD,U,13)
- SET TOTALWD=TOTALWD+ALWD
- End DoDot:1
- +8 ;ALLOWED
- QUIT TOTALWD
- +9 ;
- MRATYPE(BILL,ARDATE) ; Function - determines the MRA Receivable Type for a Third
- +1 ; Party Receivable. This is accomplished by comparing DATE MRA FIRST ACTIVATED
- +2 ; with AR Activation Date for the Bill.
- +3 ;
- +4 ; Input BILL= ien of a given Bill Number (Required)
- +5 ; ARDATE= Date Account Receivable was Activated - date only (Required)
- +6 ;
- +7 ; Output - Possible Types:
- +8 ; 1 = Pre-MRA implementation
- +9 ; 2 = Post MRA Medicare Receivable
- +10 ; 3 = Post MRA non-Medicare Receivable
- +11 ;
- +12 NEW MRADTACT,MRAMT
- +13 IF '$GET(ARDATE)!'$GET(BILL)
- QUIT 1
- +14 ;
- +15 ; get DATE MRA FIRST ACTIVATED at site
- +16 SET MRADTACT=$$MRADTACT()
- +17 ;
- +18 ; MRA not Activated at site
- +19 ;MRATYPE
- IF MRADTACT=""
- QUIT 1
- +20 ;
- +21 ; Bill from pre-MRA implementation era
- +22 ;MRATYPE
- IF ARDATE<MRADTACT
- QUIT 1
- +23 ;
- +24 ; Post-MRA Medicare bill; get Medicare amounts
- +25 SET MRAMT=$GET(^PRCA(430,BILL,13))
- +26 ; check Medicare Contractual Adjustment Amount
- +27 ;MRATYPE
- IF $PIECE(MRAMT,U,1)
- QUIT 2
- +28 ; check Medicare Unreimburseable Amout
- +29 ;MRATYPE
- IF $PIECE(MRAMT,U,2)
- QUIT 2
- +30 ; check if bill is a Medicare one
- +31 ;MRATYPE
- IF $$MRAEXIST^IBCEMU1(BILL)
- QUIT 2
- +32 ; check if bill is a Medicare Supplemental one
- +33 ;MRATYPE
- IF $PIECE($$CRIT^IBRFN2(BILL),U)=2
- QUIT 2
- +34 ;
- +35 ; all others are Post-MRA non-Medicare bills
- +36 ;MRATYPE
- QUIT 3
- +37 ;
- MRADTACT() ; Function - returns DATE MRA FIRST ACTIVATED at site
- +1 QUIT $PIECE($GET(^IBE(350.9,1,8)),U,13)
- +2 ;
- +3 ;** start IB*2.0*436 **
- MRACALC2(IBIFN) ; Function - This tag will add all EOB's for a given claim number.
- +1 ; Returns the sum of the Medicare Contractual Adj Amt
- +2 ;
- +3 ; Input: IBIFN - ien of Claim file 399
- +4 ; Output: PRCASV("MEDCA") - Medicare Contractual Adj Amt
- +5 ;
- +6 ; Variables IBEOB = ien of EOB file 361.1
- +7 ; PRCASV("MEDCA")= Medicare Contractual Adj Amt
- +8 ; Note:
- +9 ; For clarification, the following terms mean exactly the same thing.
- +10 ; "Medicare Contractual Adj Amt" = "Medicare Unpaid Amt" = "Medicare Unallowable Amt"
- +11 NEW IBEOB,I,LNLVL,EOBADJ,IBCOBN,INPAT,FRMTYP,PRCASV
- +12 ;
- +13 SET PRCASV("MEDCA")=0
- +14 ;Form Type 2=1500; 3=UB
- SET FRMTYP=$$FT^IBCEF(IBIFN)
- +15 ;Inpat/Outpat Flag
- SET INPAT=$$INPAT^IBCEF(IBIFN)
- +16 ; Get EOB data
- +17 SET IBEOB=0
- +18 FOR
- SET IBEOB=$ORDER(^IBM(361.1,"B",IBIFN,IBEOB))
- if 'IBEOB
- QUIT
- Begin DoDot:1
- +19 FOR I=0,1,2
- SET IBEOB(I)=$GET(^IBM(361.1,IBEOB,I))
- +20 ;make sure it's an MRA
- IF $PIECE(IBEOB(0),U,4)'=1
- QUIT
- +21 ;get current bill sequence
- SET IBCOBN=$$COBN^IBCEF(IBIFN)
- +22 ;
- +23 ; Handle CMS-1500 Form Type Next:
- +24 IF FRMTYP=2
- DO MEDCARE(IBEOB,.PRCASV)
- QUIT
- +25 ;
- +26 ; Handle UB Form Type Next:
- +27 ; If Inpatient Calculate from Claim level data
- +28 ;
- IF INPAT
- Begin DoDot:2
- +29 KILL EOBADJ
- MERGE EOBADJ=^IBM(361.1,IBEOB,10)
- +30 SET PRCASV("MEDCA")=$GET(PRCASV("MEDCA"))+$$CALCMCA(.EOBADJ)
- End DoDot:2
- QUIT
- +31 ; If Outpatient Calculate from Service Line level data
- +32 DO MEDCARE(IBEOB,.PRCASV)
- End DoDot:1
- +33 ;MRACALC2
- QUIT PRCASV("MEDCA")
- +34 ;** end IB*2.0*436 **