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 Oct 16, 2024@18:11:55 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 **
