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 ---[H[J[2J[HIBCAPP2 11200 printed Apr 09, 2024@21:29:20 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
