Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCEMU2

IBCEMU2.m

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