IBCAPP2.m

IBCAPP2 ;ALB/GEF - Claims Auto Processing ;14-OCT-10

 ;;2.0;INTEGRATED BILLING;**432,447,516,547,727**;21-MAR-94;Build 34

 ;;Per VA Directive 6402, this routine should not be modified.

 ;

 ; IBMRANOT = 1 when dealing with the COB Management Worklist.   

 ;            It is set by the entry action in the option file. 

 ;

CAP ; Build list from CAP x-ref entrypoint.  Called from BLD^IBCECOB1 for non-MRA worklist

 N IBDA,IBIFN

 S IBIFN=0 F  S IBIFN=$O(^DGCR(399,"CAP",1,IBIFN)) Q:'IBIFN  D

 .; screen all eob's for the claim to see if claim can be on worklist

 .; IBDA= ien of 1st eob to pass all checks - or - 0 if none passed - or - -1 if process as paper EOB

 .S IBDA=$$MELG(IBIFN,IBMRADUP) Q:'IBDA

 .D BLD1(IBIFN,$S(IBDA=-1:"",1:IBDA))

 Q

 ;

BLD1(IBIFN,IBDA) ;

 N IB3611,IBTXT,IBX,IBPY,I,IB364,IBDT,IBAPY,IBB,IBB364,IBBPY,IBDAY,IBEUT

 N IBINS1,IBINS2,IBMRACNT,Z,Z0,IBMUT,IBNBAL,IBNDI1,IBNDI2,IBNDI3,IBNDM

 N IBPTRSP,IBQ,IBSEQ,IBSRVC,IBEXPY,IBFND,IBINS,IBNDS,IBOAM,IBPTNM,IBDENDUP,IBDIV

 ;

 Q:$D(^TMP("IBCOBSTX",$J,IBIFN))  ;show each bill once on the worklist

 S IBB=$G(^DGCR(399,IBIFN,0))

 ;

 ; MRD;IB*2.0*516 - Use Division to sort claims.  If user has specified

 ; one or more divisions to include, then quit if this claim's division

 ; is not on that list.

 ;

 S IBDIV=$P(IBB,U,22) I IBDIV="" S IBDIV="UNKNOWN"

 I $D(^TMP("IBBIL-DIV",$J)),'$D(^TMP("IBBIL-DIV",$J,IBDIV)) Q

 ;

 S IBNDS=$G(^DGCR(399,IBIFN,"S")),IBNDI1=$G(^("I1")),IBNDI2=$G(^("I2")),IBNDI3=$G(^("I3")),IBNDM=$G(^("M"))

 S IBMUT=+$P(IBNDS,U,8),IBEUT=+$P(IBNDS,U,2)

 S IBINS="",IBSEQ=$$COBN^IBCEF(IBIFN),IB364="UNKNOWN",IBDT="UNKNOWN"

 ; IB*2.0*547 - allow users to search for particular payer sequence, default is B for Both

 I $G(IBSRCH)="P",IBSEQ'=1 Q  ; quit of user wants primary claims and current sequence not primary

 I $G(IBSRCH)="S",IBSEQ=1 Q  ; quit if user wants secondary/tertiary and current sequence is primary

 S IB3611=$S($G(IBDA)'="":$G(^IBM(361.1,IBDA,0)),1:"")

 I $G(IB3611)'="" S IB364=$P(IB3611,U,19),IBDT=+$P(IB3611,U,6),IBSEQ=$P(IB3611,U,15)

 F I=1:1:3 S Z="IBNDI"_I I @Z D

 . N Q

 . S Q=(IBSEQ=I)

 . I Q S IBINS1=+@Z_U_$P($G(^DIC(36,+@Z,0)),U)

 . S IBINS=IBINS_$S(IBINS="":"",1:", ")_$P($G(^DIC(36,+@Z,0)),U)

 ;

 ; IB*2.0*547 - removed below code since only applicable for MRW, not CBW.  For CBW, always should be secondary insurance.

 ; Get the payer/insurance company that comes after Medicare WNR

 ; If WNR is Primary, get the secondary ins. co.

 ; If WNR is secondary, get the tertiary ins. co.

 ;D  I $P($G(IBINS2),U,2)="" S $P(IBINS2,U,2)="UNKNOWN"

 ;. I $$WNRBILL^IBEFUNC(IBIFN,1) S IBINS2=+IBNDI2_U_$P($G(^DIC(36,+IBNDI2,0)),U) Q

 ;. S IBINS2=+IBNDI3_U_$P($G(^DIC(36,+IBNDI3,0)),U)

 S IBINS2=+IBNDI2_U_$P($G(^DIC(36,+IBNDI2,0)),U)

 ;

 S IBFND=0

 ; biller entry not ALL and no biller, then get entered/edited by user

 I $D(^TMP("IBBIL",$J)) D  Q:'IBFND

 . S IBFND=$S($D(^TMP("IBBIL",$J,IBMUT)):IBMUT,$D(^TMP("IBBIL",$J,IBEUT)):IBEUT,1:0)

 S Z=$S(IBFND:IBFND,IBMUT:IBMUT,1:IBEUT)

 S IBMUT=$P($G(^VA(200,+Z,0)),U)_"~"_Z

 S:'$P(IBMUT,"~",2) IBMUT="UNKNOWN~0"

 S IBBPY=+$$COBN^IBCEF(IBIFN),IBQ=1

 ;IBQ;1=EOB without subsequent insurer,0=COB,2=0 balance

 D  ;I IBQ Q

 . ;Check for no reimbursable subsequent insurance

 .  F I=IBBPY+1:1:3 D  Q:'IBQ

 .. S Z="IBNDI"_I,Z=$G(@Z)

 .. I $P($G(^DIC(36,+Z,0)),U,2)="N" S IBQ=0 Q

 . ;Check if next ins doesn't exist or next bill# already created

 . S Z="IBNDI"_(IBBPY+1),Z=$G(@Z)

 . I Z,'$P($G(^DGCR(399,IBIFN,"M1")),U,5+IBBPY) S IBQ=0

 ;

 ; Days since transmission of latest bill in COB - IBDAY

 S IBDAY=+$P($G(^DGCR(399,IBIFN,"TX")),U,2) I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1)

 ; if no Last Electronic Extract Date on file 399, get it from file 364

 I 'IBDAY D  I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1) ;calc. the difference

 . S IBB364=$$LAST364^IBCEF4(IBIFN) I IBB364'="" S IBDAY=+$P($P($G(^IBA(364,IBB364,0)),U,4),".",1)

 ;

 S IBAPY=$$TPR^PRCAFN(IBIFN) ; payment on this bill from A/R  IA#380

 S:$G(IBDA)'="" IBEXPY=+$G(^IBM(361.1,IBDA,1))       ; payer paid amount

 S IBPY=$S(IBAPY:IBAPY,1:+$G(IBEXPY))

 S IBOAM=+$G(^DGCR(399,IBIFN,"U1"))     ; total charges for bill

 ; Don't include claim if AR STATUS is COLLECTED/CLOSED and no subsequent payer and not one of the TRICARE/Champus claims that needs to be evaluated for Pt Payment,remove from list and quit

 I $P($$BILL^RCJIBFN2(IBIFN),U,2)=22 S IBX=$$EOB^IBCNSBL2(IBIFN,IBOAM,IBPY,.IBTXT) I '$D(IBTXT) D RMV(IBIFN) Q

 S IBNBAL=IBOAM-IBPY

 S IBPTRSP=$S(IBNBAL>0:IBNBAL,1:0)

 I IBNBAL'>0 S IBQ=2

 S IBPTNM=$P($G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0)),U) I IBPTNM="" S IBPTNM="UNKNOWN"

 S IBSRVC=$P($G(^DGCR(399,IBIFN,"U")),U)

 ; IB*2.0*547 - added primary insurance as a possible sort, had to split into 2 lines (too long)

 S Z0=$S(IBSRT="B":IBMUT,IBSRT="D":-IBDAY,IBSRT="I":$P(IBINS2,U,2)_"~"_$P(IBINS2,U),IBSRT="M":$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13)),IBSRT="R":-IBPTRSP,IBSRT="P":IBPTNM,IBSRT="S":+IBSRVC,1:+IBDT)

 S:IBSRT="K" Z0=$P($G(^DIC(36,+IBNDI1,0)),U)_"~"_+IBNDI1

 S:((IBSRT="M")&(Z0="")) Z0="UNKNOWN"   ;USE UNKNOWN IF NOT SET - BI;IB*2.0*432

 ;

 ; MRD;IB*2.0*516 - Added Division as a subscript.

 ;S ^TMP("IBCOBST",$J,Z0,IBIFN)=IBSRVC_U_IBOAM_U_IBAPY_U_$S(IBNBAL>0:IBNBAL,1:0)_U_$P(IBB,U,5)_U_$P(IBB,U,19)_U_IBBPY_U_$P(IBMUT,"~")_U_IBINS_U_$G(IBDA)_U_$$HIS(IBIFN)_U_$G(IBDAY)_U_$G(IBDT)_U_IBQ_U_$G(IB364)_U_IBSEQ_U_$G(IBEXPY)_U_IBPTRSP

 ;S ^TMP("IBCOBST",$J,Z0,IBIFN,1)=$S($G(IB3611)="":"No EEOB Received ",1:$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13))_", "_$$FMTE^XLFDT($P($P(IB3611,"^",6),"."))_"^"_$P(IB3611,"^",16))

 S ^TMP("IBCOBST",$J,IBDIV,Z0,IBIFN)=IBSRVC_U_IBOAM_U_IBAPY_U_$S(IBNBAL>0:IBNBAL,1:0)_U_$P(IBB,U,5)_U_$P(IBB,U,19)_U_IBBPY_U_$P(IBMUT,"~")_U_IBINS_U_$G(IBDA)_U_$$HIS(IBIFN)_U_$G(IBDAY)_U_$G(IBDT)_U_IBQ_U_$G(IB364)_U_IBSEQ_U_$G(IBEXPY)_U_IBPTRSP

 S ^TMP("IBCOBST",$J,IBDIV,Z0,IBIFN,1)=$S($G(IB3611)="":"No EEOB Received ",1:$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13))_", "_$$FMTE^XLFDT($P($P(IB3611,"^",6),"."))_"^"_$P(IB3611,"^",16))

 S ^TMP("IBCOBSTX",$J,IBIFN)=$G(IBDA)  ;keep track of compiled IBIFN's

 ;

 ; Save some data when there are multiple MRA's on file for this bill

 S IBMRACNT=$$MRACNT^IBCEMU1(IBIFN,$G(IBMRANOT))   ;WCJ IB*2.0*432

 ; MRD;IB*2.0*516 - Added Division as a subscript.

 ;I IBMRACNT>1 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,1)="Multiple "_$S($G(IBMRANOT):"EOBs",1:"MRA's")_" on file"  ;WCJ IB*2.0*432

 ;S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,3)=IBMRACNT

 ;S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=$G(IBDENDUP)

 ;S:$G(IBDA)'="" $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=$$DENDUP^IBCEMU4(IBDA,1)

 I IBMRACNT>1 S $P(^TMP("IBCOBST",$J,IBDIV,Z0,IBIFN,1),U,1)="Multiple "_$S($G(IBMRANOT):"EOBs",1:"MRA's")_" on file"  ;WCJ IB*2.0*432

 S $P(^TMP("IBCOBST",$J,IBDIV,Z0,IBIFN,1),U,3)=IBMRACNT

 S $P(^TMP("IBCOBST",$J,IBDIV,Z0,IBIFN,1),U,4)=$G(IBDENDUP)

 S:$G(IBDA)'="" $P(^TMP("IBCOBST",$J,IBDIV,Z0,IBIFN,1),U,4)=$$DENDUP^IBCEMU4(IBDA,1)

 Q

 ;

HIS(IBIFN) ; COB history

 N A,B,IBST,IBBIL,IBHIS

 S IBHIS="",A=0 F  S A=$O(^IBM(361.1,"ABS",IBIFN,A)) Q:'A  S B=0 F  S B=$O(^IBM(361.1,"ABS",IBIFN,A,B)) Q:'B  D

 . S IBST=$P($G(^IBM(361.1,B,0)),U,4),IBBIL=$P($G(^DGCR(399,IBIFN,"M1")),U,4+A)   ;WCJ IB*2.0*432 added $G

 . Q:IBBIL=""

 . S IBHIS=IBHIS_$S(IBHIS="":"",1:";")_$S(A=1:"PRIMARY",A=2:"SECONDARY",1:"TERTIARY")_" "_$S(IBST:"MRA",1:"EOB")_" RECEIVED - "_IBBIL

 I '$D(^IBM(361.1,"ABS",IBIFN)) F A=1:1:3 S IBBIL=$P($G(^DGCR(399,IBIFN,"M1")),U,4+A) I IBBIL'="" S IBHIS=IBHIS_$S(IBHIS="":"",1:";")_$S(A=1:"PRIMARY",A=2:"SECONDARY",A=3:"TERTIARY",1:"UNKNOWN")_" No EOB RECEIVED - "_IBBIL

 Q IBHIS

 ;

MELG(IBIFN,IBMRADUP) ; function to check all EOBs for a claim and determine if they are

 ; eligible for inclusion on the COB management worklist, uses both B & C x-ref

 ; IBIFN - claim ien (required)

 ; IBMRADUP - indicates user said NO to "include denied for duplicate" prompt

 ;

 ; Returns EOB ien to use for display, if at least 1 EOB passed all checks

 ; if multiple EOBs passed but some have filing errors, returns the 1st EOB found that does NOT have filing errors

 ; if all EOBs have filing errors, tries to find one that is a PROCESSED status and return that one for CBW display

 ; Returns -1 if claim should appear on the worklist with no EOB

 ; Returns 0 if no EOBs passed the checks and claim should not appear on the worklist, also removes it

 ;

 ; IBCK = Total number of EOBs found for this claim ien

 ; IBECT = Total number of EOBs that failed the EOB TYPE check

 ; IBCT = Total number of EOBs for a claim that passed ALL the checks

 ;

 N IBDA,IBCT,IBEOBNDX,IBEOB,IB3611,IBCK,IBETC

 S IBCT=0,IBCK=0,IBETC=0

 F IBEOBNDX="B","C" D

 .S IBDA=0 F  S IBDA=$O(^IBM(361.1,IBEOBNDX,IBIFN,IBDA)) Q:'+IBDA  D

 ..Q:$D(IBEOB(IBDA))

 ..S IB3611=$G(^IBM(361.1,IBDA,0)),IBCK=IBCK+1

 ..;Q:$D(^IBM(361.1,IBDA,"ERR")) ;TPF;EBILL-2436;IB*2.0*727 ALLOW EOB CLAIMS WITH MSE TO BE DISPLAYED AGAIN ON CBW

 ..; if this is a denied EOB and user does NOT want to include denied as duplicates and this EOB was denied as duplicate, don't include

 ..I $P(IB3611,U,13)=2,'$G(IBMRADUP),$$DENDUP^IBCEMU4(IBDA,1) Q

 ..; eob type must be correct for this worklist

 ..I $P(IB3611,U,4)=1 S IBETC=IBETC+1 Q

 ..; allow filing errors on worklist, but try to find at least 1 Processed EOB w/out errors

 ..I $D(^IBM(361.1,IBDA,"ERR")) S:$P($G(^IBM(361.1,IBDA,0)),U,13)'=1 IBEOB("DER",IBDA)="" S:$P($G(^IBM(361.1,IBDA,0)),U,13)=1 IBEOB("PER",IBDA)="" Q

 ..S IBEOB(IBDA)="",IBCT=IBCT+1

 ; if no EOB was found to check, return -1 to process as no EOB

 Q:IBCK=0 -1

 ; if no EOB passed, check to see if the EOBs were all MRA primaries that failed the EOB type check (2ndary/tertiaries were paper)

 I IBCT=0,$$WNRBILL^IBEFUNC(IBIFN,1),$$COBN^IBCEF(IBIFN)>1,(IBCK=IBETC) Q -1

 ; if no EOB's passed, check for filing errors and use that EOB, with Processed EOB's taking priority over denied

 I IBCT=0,$D(IBEOB("PER")) Q $O(IBEOB("PER",0))

 I IBCT=0,$D(IBEOB("DER")) Q $O(IBEOB("DER",0))

 ; if no EOB passed and not MRA primary w/subsequent paper EOB's or filing errors, do not put on CBW

 Q:IBCT=0 0

 ; if one or more EOBs passed, return the 1st one that passed the checks as the one to use for CBW display

 Q $O(IBEOB(0))

 ;

RMV(DA) ;remove from worklist claims that are erroneously there

 N DIE,DR

 S DIE="^DGCR(399,",DR="35////@" D ^DIE ; Should never have been on the WORKLIST

 Q

 ;

FILERR(IBIFN) ; function to check EOBs for a claim to see if any had filing errors.

 ; IBIFN - claim ien (required)

 ;

 ; Returns 0 if none of EOBs had filing errors

 ; Returns 1 if at lease one of EOBs had filing errors

 ;

 N IBDA,IBEOBNDX,IBEOB,IB3611,IBFILERR

 S IBFILERR=0

 F IBEOBNDX="B","C" D

 . S IBDA=0 F  S IBDA=$O(^IBM(361.1,IBEOBNDX,IBIFN,IBDA)) Q:'+IBDA  D  Q:IBFILERR

 .. Q:$D(IBEOB(IBDA))

 .. S IBEOB(IBDA)=""

 .. S IB3611=$G(^IBM(361.1,IBDA,0))

 .. ; I $P(IB3611,U,4)=1 Q  ; don't care about MRAs ; I take that back, I do care about MRAs 

 .. I ".1.2."'[("."_$P(IB3611,U,13)_".") Q  ;  only care if processed (1) or denied  (2)

 .. I $D(^IBM(361.1,IBDA,"ERR")) S IBFILERR=1 Q

 Q IBFILERR

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBCAPP2   11200     printed  Apr 23, 2025@18:23:08                                                                                                                                                                                                    Page 2

IBCAPP2   ;ALB/GEF - Claims Auto Processing ;14-OCT-10

 +1       ;;2.0;INTEGRATED BILLING;**432,447,516,547,727**;21-MAR-94;Build 34

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ; IBMRANOT = 1 when dealing with the COB Management Worklist.   

 +5       ;            It is set by the entry action in the option file. 

 +6       ;

CAP       ; Build list from CAP x-ref entrypoint.  Called from BLD^IBCECOB1 for non-MRA worklist

 +1        NEW IBDA,IBIFN

 +2        SET IBIFN=0

           FOR 

               SET IBIFN=$ORDER(^DGCR(399,"CAP",1,IBIFN))

               if 'IBIFN

                   QUIT 

               Begin DoDot:1

 +3       ; screen all eob's for the claim to see if claim can be on worklist

 +4       ; IBDA= ien of 1st eob to pass all checks - or - 0 if none passed - or - -1 if process as paper EOB

 +5                SET IBDA=$$MELG(IBIFN,IBMRADUP)

                   if 'IBDA

                       QUIT 

 +6                DO BLD1(IBIFN,$SELECT(IBDA=-1:"",1:IBDA))

               End DoDot:1

 +7        QUIT 

 +8       ;

BLD1(IBIFN,IBDA) ;

 +1        NEW IB3611,IBTXT,IBX,IBPY,I,IB364,IBDT,IBAPY,IBB,IBB364,IBBPY,IBDAY,IBEUT

 +2        NEW IBINS1,IBINS2,IBMRACNT,Z,Z0,IBMUT,IBNBAL,IBNDI1,IBNDI2,IBNDI3,IBNDM

 +3        NEW IBPTRSP,IBQ,IBSEQ,IBSRVC,IBEXPY,IBFND,IBINS,IBNDS,IBOAM,IBPTNM,IBDENDUP,IBDIV

 +4       ;

 +5       ;show each bill once on the worklist

           if $DATA(^TMP("IBCOBSTX",$JOB,IBIFN))

               QUIT 

 +6        SET IBB=$GET(^DGCR(399,IBIFN,0))

 +7       ;

 +8       ; MRD;IB*2.0*516 - Use Division to sort claims.  If user has specified

 +9       ; one or more divisions to include, then quit if this claim's division

 +10      ; is not on that list.

 +11      ;

 +12       SET IBDIV=$PIECE(IBB,U,22)

           IF IBDIV=""

               SET IBDIV="UNKNOWN"

 +13       IF $DATA(^TMP("IBBIL-DIV",$JOB))

               IF '$DATA(^TMP("IBBIL-DIV",$JOB,IBDIV))

                   QUIT 

 +14      ;

 +15       SET IBNDS=$GET(^DGCR(399,IBIFN,"S"))

           SET IBNDI1=$GET(^("I1"))

           SET IBNDI2=$GET(^("I2"))

           SET IBNDI3=$GET(^("I3"))

           SET IBNDM=$GET(^("M"))

 +16       SET IBMUT=+$PIECE(IBNDS,U,8)

           SET IBEUT=+$PIECE(IBNDS,U,2)

 +17       SET IBINS=""

           SET IBSEQ=$$COBN^IBCEF(IBIFN)

           SET IB364="UNKNOWN"

           SET IBDT="UNKNOWN"

 +18      ; IB*2.0*547 - allow users to search for particular payer sequence, default is B for Both

 +19      ; quit of user wants primary claims and current sequence not primary

           IF $GET(IBSRCH)="P"

               IF IBSEQ'=1

                   QUIT 

 +20      ; quit if user wants secondary/tertiary and current sequence is primary

           IF $GET(IBSRCH)="S"

               IF IBSEQ=1

                   QUIT 

 +21       SET IB3611=$SELECT($GET(IBDA)'="":$GET(^IBM(361.1,IBDA,0)),1:"")

 +22       IF $GET(IB3611)'=""

               SET IB364=$PIECE(IB3611,U,19)

               SET IBDT=+$PIECE(IB3611,U,6)

               SET IBSEQ=$PIECE(IB3611,U,15)

 +23       FOR I=1:1:3

               SET Z="IBNDI"_I

               IF @Z

                   Begin DoDot:1

 +24                   NEW Q

 +25                   SET Q=(IBSEQ=I)

 +26                   IF Q

                           SET IBINS1=+@Z_U_$PIECE($GET(^DIC(36,+@Z,0)),U)

 +27                   SET IBINS=IBINS_$SELECT(IBINS="":"",1:", ")_$PIECE($GET(^DIC(36,+@Z,0)),U)

                   End DoDot:1

 +28      ;

 +29      ; IB*2.0*547 - removed below code since only applicable for MRW, not CBW.  For CBW, always should be secondary insurance.

 +30      ; Get the payer/insurance company that comes after Medicare WNR

 +31      ; If WNR is Primary, get the secondary ins. co.

 +32      ; If WNR is secondary, get the tertiary ins. co.

 +33      ;D  I $P($G(IBINS2),U,2)="" S $P(IBINS2,U,2)="UNKNOWN"

 +34      ;. I $$WNRBILL^IBEFUNC(IBIFN,1) S IBINS2=+IBNDI2_U_$P($G(^DIC(36,+IBNDI2,0)),U) Q

 +35      ;. S IBINS2=+IBNDI3_U_$P($G(^DIC(36,+IBNDI3,0)),U)

 +36       SET IBINS2=+IBNDI2_U_$PIECE($GET(^DIC(36,+IBNDI2,0)),U)

 +37      ;

 +38       SET IBFND=0

 +39      ; biller entry not ALL and no biller, then get entered/edited by user

 +40       IF $DATA(^TMP("IBBIL",$JOB))

               Begin DoDot:1

 +41               SET IBFND=$SELECT($DATA(^TMP("IBBIL",$JOB,IBMUT)):IBMUT,$DATA(^TMP("IBBIL",$JOB,IBEUT)):IBEUT,1:0)

               End DoDot:1

               if 'IBFND

                   QUIT 

 +42       SET Z=$SELECT(IBFND:IBFND,IBMUT:IBMUT,1:IBEUT)

 +43       SET IBMUT=$PIECE($GET(^VA(200,+Z,0)),U)_"~"_Z

 +44       if '$PIECE(IBMUT,"~",2)

               SET IBMUT="UNKNOWN~0"

 +45       SET IBBPY=+$$COBN^IBCEF(IBIFN)

           SET IBQ=1

 +46      ;IBQ;1=EOB without subsequent insurer,0=COB,2=0 balance

 +47      ;I IBQ Q

           Begin DoDot:1

 +48      ;Check for no reimbursable subsequent insurance

 +49           FOR I=IBBPY+1:1:3

                   Begin DoDot:2

 +50                   SET Z="IBNDI"_I

                       SET Z=$GET(@Z)

 +51                   IF $PIECE($GET(^DIC(36,+Z,0)),U,2)="N"

                           SET IBQ=0

                           QUIT 

                   End DoDot:2

                   if 'IBQ

                       QUIT 

 +52      ;Check if next ins doesn't exist or next bill# already created

 +53           SET Z="IBNDI"_(IBBPY+1)

               SET Z=$GET(@Z)

 +54           IF Z

                   IF '$PIECE($GET(^DGCR(399,IBIFN,"M1")),U,5+IBBPY)

                       SET IBQ=0

           End DoDot:1

 +55      ;

 +56      ; Days since transmission of latest bill in COB - IBDAY

 +57       SET IBDAY=+$PIECE($GET(^DGCR(399,IBIFN,"TX")),U,2)

           IF IBDAY

               SET IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1)

 +58      ; if no Last Electronic Extract Date on file 399, get it from file 364

 +59      ;calc. the difference

           IF 'IBDAY

               Begin DoDot:1

 +60               SET IBB364=$$LAST364^IBCEF4(IBIFN)

                   IF IBB364'=""

                       SET IBDAY=+$PIECE($PIECE($GET(^IBA(364,IBB364,0)),U,4),".",1)

               End DoDot:1

               IF IBDAY

                   SET IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1)

 +61      ;

 +62      ; payment on this bill from A/R  IA#380

           SET IBAPY=$$TPR^PRCAFN(IBIFN)

 +63      ; payer paid amount

           if $GET(IBDA)'=""

               SET IBEXPY=+$GET(^IBM(361.1,IBDA,1))

 +64       SET IBPY=$SELECT(IBAPY:IBAPY,1:+$GET(IBEXPY))

 +65      ; total charges for bill

           SET IBOAM=+$GET(^DGCR(399,IBIFN,"U1"))

 +66      ; Don't include claim if AR STATUS is COLLECTED/CLOSED and no subsequent payer and not one of the TRICARE/Champus claims that needs to be evaluated for Pt Payment,remove from list and quit

 +67       IF $PIECE($$BILL^RCJIBFN2(IBIFN),U,2)=22

               SET IBX=$$EOB^IBCNSBL2(IBIFN,IBOAM,IBPY,.IBTXT)

               IF '$DATA(IBTXT)

                   DO RMV(IBIFN)

                   QUIT 

 +68       SET IBNBAL=IBOAM-IBPY

 +69       SET IBPTRSP=$SELECT(IBNBAL>0:IBNBAL,1:0)

 +70       IF IBNBAL'>0

               SET IBQ=2

 +71       SET IBPTNM=$PIECE($GET(^DPT(+$PIECE($GET(^DGCR(399,IBIFN,0)),U,2),0)),U)

           IF IBPTNM=""

               SET IBPTNM="UNKNOWN"

 +72       SET IBSRVC=$PIECE($GET(^DGCR(399,IBIFN,"U")),U)

 +73      ; IB*2.0*547 - added primary insurance as a possible sort, had to split into 2 lines (too long)

 +74       SET Z0=$SELECT(IBSRT="B":IBMUT,IBSRT="D":-IBDAY,IBSRT="I":$PIECE(IBINS2,U,2)_"~"_$PIECE(IBINS2,U),IBSRT="M":$$EXTERNAL^DILFD(361.1,.13,"",$PIECE(IB3611,"^",13)),IBSRT="R":-IBPTRSP,IBSRT="P":IBPTNM,IBSRT="S":+IBSRVC,1:+IBDT)

 +75       if IBSRT="K"

               SET Z0=$PIECE($GET(^DIC(36,+IBNDI1,0)),U)_"~"_+IBNDI1

 +76      ;USE UNKNOWN IF NOT SET - BI;IB*2.0*432

           if ((IBSRT="M")&(Z0=""))

               SET Z0="UNKNOWN"

 +77      ;

 +78      ; MRD;IB*2.0*516 - Added Division as a subscript.

 +79      ;S ^TMP("IBCOBST",$J,Z0,IBIFN)=IBSRVC_U_IBOAM_U_IBAPY_U_$S(IBNBAL>0:IBNBAL,1:0)_U_$P(IBB,U,5)_U_$P(IBB,U,19)_U_IBBPY_U_$P(IBMUT,"~")_U_IBINS_U_$G(IBDA)_U_$$HIS(IBIFN)_U_$G(IBDAY)_U_$G(IBDT)_U_IBQ_U_$G(IB364)_U_IBSEQ_U_$G(IBEXPY)_U_IBPTRSP

 +80      ;S ^TMP("IBCOBST",$J,Z0,IBIFN,1)=$S($G(IB3611)="":"No EEOB Received ",1:$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13))_", "_$$FMTE^XLFDT($P($P(IB3611,"^",6),"."))_"^"_$P(IB3611,"^",16))

 +81      SET ^TMP("IBCOBST",$JOB,IBDIV,Z0,IBIFN)=IBSRVC_U_IBOAM_U_IBAPY_U_$SELECT(IBNBAL>0:IBNBAL,1:0)_U_...

           ... $PIECE(IBB,U,5)_U_$PIECE(IBB,U,19)_U_IBBPY_U_$PIECE(IBMUT,"~")_U_IBINS_U_$GET(IBDA)_U_$$HIS(IBIFN)_U_$GET(IBDAY)_U_$GET(IBDT)_U_IBQ_U_$GET(IB364)_U_IBSEQ_U_$GET(IBEXPY)_U_IBPTRSP

 +82       SET ^TMP("IBCOBST",$JOB,IBDIV,Z0,IBIFN,1)=$SELECT($GET(IB3611)="":"No EEOB Received ",1:$$EXTERNAL^DILFD(361.1,.13,"",$PIECE(IB3611,"^",13))_", "_$$FMTE^XLFDT($PIECE($PIECE(IB3611,"^",6),"."))_"^"_$PIECE(IB3611,"^",16))

 +83      ;keep track of compiled IBIFN's

           SET ^TMP("IBCOBSTX",$JOB,IBIFN)=$GET(IBDA)

 +84      ;

 +85      ; Save some data when there are multiple MRA's on file for this bill

 +86      ;WCJ IB*2.0*432

           SET IBMRACNT=$$MRACNT^IBCEMU1(IBIFN,$GET(IBMRANOT))

 +87      ; MRD;IB*2.0*516 - Added Division as a subscript.

 +88      ;I IBMRACNT>1 S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,1)="Multiple "_$S($G(IBMRANOT):"EOBs",1:"MRA's")_" on file"  ;WCJ IB*2.0*432

 +89      ;S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,3)=IBMRACNT

 +90      ;S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=$G(IBDENDUP)

 +91      ;S:$G(IBDA)'="" $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=$$DENDUP^IBCEMU4(IBDA,1)

 +92      ;WCJ IB*2.0*432

           IF IBMRACNT>1

               SET $PIECE(^TMP("IBCOBST",$JOB,IBDIV,Z0,IBIFN,1),U,1)="Multiple "_$SELECT($GET(IBMRANOT):"EOBs",1:"MRA's")_" on file"

 +93       SET $PIECE(^TMP("IBCOBST",$JOB,IBDIV,Z0,IBIFN,1),U,3)=IBMRACNT

 +94       SET $PIECE(^TMP("IBCOBST",$JOB,IBDIV,Z0,IBIFN,1),U,4)=$GET(IBDENDUP)

 +95       if $GET(IBDA)'=""

               SET $PIECE(^TMP("IBCOBST",$JOB,IBDIV,Z0,IBIFN,1),U,4)=$$DENDUP^IBCEMU4(IBDA,1)

 +96       QUIT 

 +97      ;

HIS(IBIFN) ; COB history

 +1        NEW A,B,IBST,IBBIL,IBHIS

 +2        SET IBHIS=""

           SET A=0

           FOR 

               SET A=$ORDER(^IBM(361.1,"ABS",IBIFN,A))

               if 'A

                   QUIT 

               SET B=0

               FOR 

                   SET B=$ORDER(^IBM(361.1,"ABS",IBIFN,A,B))

                   if 'B

                       QUIT 

                   Begin DoDot:1

 +3       ;WCJ IB*2.0*432 added $G

                       SET IBST=$PIECE($GET(^IBM(361.1,B,0)),U,4)

                       SET IBBIL=$PIECE($GET(^DGCR(399,IBIFN,"M1")),U,4+A)

 +4                    if IBBIL=""

                           QUIT 

 +5                    SET IBHIS=IBHIS_$SELECT(IBHIS="":"",1:";")_$SELECT(A=1:"PRIMARY",A=2:"SECONDARY",1:"TERTIARY")_" "_$SELECT(IBST:"MRA",1:"EOB")_" RECEIVED - "_IBBIL

                   End DoDot:1

 +6        IF '$DATA(^IBM(361.1,"ABS",IBIFN))

               FOR A=1:1:3

                   SET IBBIL=$PIECE($GET(^DGCR(399,IBIFN,"M1")),U,4+A)

                   IF IBBIL'=""

                       SET IBHIS=IBHIS_$SELECT(IBHIS="":"",1:";")_$SELECT(A=1:"PRIMARY",A=2:"SECONDARY",A=3:"TERTIARY",1:"UNKNOWN")_" No EOB RECEIVED - "_IBBIL

 +7        QUIT IBHIS

 +8       ;

MELG(IBIFN,IBMRADUP) ; function to check all EOBs for a claim and determine if they are

 +1       ; eligible for inclusion on the COB management worklist, uses both B & C x-ref

 +2       ; IBIFN - claim ien (required)

 +3       ; IBMRADUP - indicates user said NO to "include denied for duplicate" prompt

 +4       ;

 +5       ; Returns EOB ien to use for display, if at least 1 EOB passed all checks

 +6       ; if multiple EOBs passed but some have filing errors, returns the 1st EOB found that does NOT have filing errors

 +7       ; if all EOBs have filing errors, tries to find one that is a PROCESSED status and return that one for CBW display

 +8       ; Returns -1 if claim should appear on the worklist with no EOB

 +9       ; Returns 0 if no EOBs passed the checks and claim should not appear on the worklist, also removes it

 +10      ;

 +11      ; IBCK = Total number of EOBs found for this claim ien

 +12      ; IBECT = Total number of EOBs that failed the EOB TYPE check

 +13      ; IBCT = Total number of EOBs for a claim that passed ALL the checks

 +14      ;

 +15       NEW IBDA,IBCT,IBEOBNDX,IBEOB,IB3611,IBCK,IBETC

 +16       SET IBCT=0

           SET IBCK=0

           SET IBETC=0

 +17       FOR IBEOBNDX="B","C"

               Begin DoDot:1

 +18               SET IBDA=0

                   FOR 

                       SET IBDA=$ORDER(^IBM(361.1,IBEOBNDX,IBIFN,IBDA))

                       if '+IBDA

                           QUIT 

                       Begin DoDot:2

 +19                       if $DATA(IBEOB(IBDA))

                               QUIT 

 +20                       SET IB3611=$GET(^IBM(361.1,IBDA,0))

                           SET IBCK=IBCK+1

 +21      ;Q:$D(^IBM(361.1,IBDA,"ERR")) ;TPF;EBILL-2436;IB*2.0*727 ALLOW EOB CLAIMS WITH MSE TO BE DISPLAYED AGAIN ON CBW

 +22      ; if this is a denied EOB and user does NOT want to include denied as duplicates and this EOB was denied as duplicate, don't include

 +23                       IF $PIECE(IB3611,U,13)=2

                               IF '$GET(IBMRADUP)

                                   IF $$DENDUP^IBCEMU4(IBDA,1)

                                       QUIT 

 +24      ; eob type must be correct for this worklist

 +25                       IF $PIECE(IB3611,U,4)=1

                               SET IBETC=IBETC+1

                               QUIT 

 +26      ; allow filing errors on worklist, but try to find at least 1 Processed EOB w/out errors

 +27                       IF $DATA(^IBM(361.1,IBDA,"ERR"))

                               if $PIECE($GET(^IBM(361.1,IBDA,0)),U,13)'=1

                                   SET IBEOB("DER",IBDA)=""

                               if $PIECE($GET(^IBM(361.1,IBDA,0)),U,13)=1

                                   SET IBEOB("PER",IBDA)=""

                               QUIT 

 +28                       SET IBEOB(IBDA)=""

                           SET IBCT=IBCT+1

                       End DoDot:2

               End DoDot:1

 +29      ; if no EOB was found to check, return -1 to process as no EOB

 +30       if IBCK=0

               QUIT -1

 +31      ; if no EOB passed, check to see if the EOBs were all MRA primaries that failed the EOB type check (2ndary/tertiaries were paper)

 +32       IF IBCT=0

               IF $$WNRBILL^IBEFUNC(IBIFN,1)

                   IF $$COBN^IBCEF(IBIFN)>1

                       IF (IBCK=IBETC)

                           QUIT -1

 +33      ; if no EOB's passed, check for filing errors and use that EOB, with Processed EOB's taking priority over denied

 +34       IF IBCT=0

               IF $DATA(IBEOB("PER"))

                   QUIT $ORDER(IBEOB("PER",0))

 +35       IF IBCT=0

               IF $DATA(IBEOB("DER"))

                   QUIT $ORDER(IBEOB("DER",0))

 +36      ; if no EOB passed and not MRA primary w/subsequent paper EOB's or filing errors, do not put on CBW

 +37       if IBCT=0

               QUIT 0

 +38      ; if one or more EOBs passed, return the 1st one that passed the checks as the one to use for CBW display

 +39       QUIT $ORDER(IBEOB(0))

 +40      ;

RMV(DA)   ;remove from worklist claims that are erroneously there

 +1        NEW DIE,DR

 +2       ; Should never have been on the WORKLIST

           SET DIE="^DGCR(399,"

           SET DR="35////@"

           DO ^DIE

 +3        QUIT 

 +4       ;

FILERR(IBIFN) ; function to check EOBs for a claim to see if any had filing errors.

 +1       ; IBIFN - claim ien (required)

 +2       ;

 +3       ; Returns 0 if none of EOBs had filing errors

 +4       ; Returns 1 if at lease one of EOBs had filing errors

 +5       ;

 +6        NEW IBDA,IBEOBNDX,IBEOB,IB3611,IBFILERR

 +7        SET IBFILERR=0

 +8        FOR IBEOBNDX="B","C"

               Begin DoDot:1

 +9                SET IBDA=0

                   FOR 

                       SET IBDA=$ORDER(^IBM(361.1,IBEOBNDX,IBIFN,IBDA))

                       if '+IBDA

                           QUIT 

                       Begin DoDot:2

 +10                       if $DATA(IBEOB(IBDA))

                               QUIT 

 +11                       SET IBEOB(IBDA)=""

 +12                       SET IB3611=$GET(^IBM(361.1,IBDA,0))

 +13      ; I $P(IB3611,U,4)=1 Q  ; don't care about MRAs ; I take that back, I do care about MRAs 

 +14      ;  only care if processed (1) or denied  (2)

                           IF ".1.2."'[("."_$PIECE(IB3611,U,13)_".")

                               QUIT 

 +15                       IF $DATA(^IBM(361.1,IBDA,"ERR"))

                               SET IBFILERR=1

                               QUIT 

                       End DoDot:2

                       if IBFILERR

                           QUIT 

               End DoDot:1

 +16       QUIT IBFILERR