IBCECOB1 ;ALB/CXW - IB COB MANAGEMENT SCREEN/REPORT ;14-JUN-99
;;2.0;INTEGRATED BILLING;**137,155,288,348,377,417,432,447,488,516,547,592,727,759**;21-MAR-94;Build 24
;;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.
;
BLD ; Build list entrypoint
;
N I,IB3611,IB364,IBAMT,IBAPY,IBB,IBB364,IBBPY,IBDA,IBDA1,IBDAY
N IBDENDUP,IBDIV,IBDT,IBDTN,IBEOBREV,IBEUT,IBEXPY,IBFND,IBHIS
N IBIFN,IBINS,IBINS1,IBINS2,IBMRACNT,IBMUT,IBNBAL,IBNDI1,IBNDI2
N IBNDI3,IBNDM,IBNDS,IBOAM,IBPTNM,IBPTRSP,IBPY,IBQ,IBSEQ,IBSRVC
N EOBTYPE,MSEFLG,Z,Z0
;
K ^TMP("IBCECOB",$J),^TMP("IBCECOB1",$J),^TMP("IBCOBST",$J),^TMP("IBCOBSTX",$J)
D CLEAN^VALM10 ; kill data and video control arrays
S (VALMCNT,MSEFLG)=0,IBHIS=""
; IB*2.0*432 IF not MRA, use new CAP index on 399 file
D:$G(IBMRANOT)=1 CAP^IBCAPP2
; since 0 is a valid Review Status, init w/null
S IBEOBREV=""
; get EOB's w/Review Status of 0, 1, 1.5 or 2; If 3 or higher, not needed
I $G(IBMRANOT)'=1 F S IBEOBREV=$O(^IBM(361.1,"AMRA",1,IBEOBREV)) Q:IBEOBREV="" Q:IBEOBREV>2 D
. S IBDA="A" F S IBDA=$O(^IBM(361.1,"AMRA",1,IBEOBREV,IBDA),-1) Q:'IBDA D BLD1
;
; no data accumulated
I $O(^TMP("IBCOBST",$J,""))="" D NMAT Q
;
; display accumulated data
D SCRN
Q
;
BLD1 ;
;
S MSEFLG=$$ELIG(IBDA) Q:'MSEFLG
S IBDENDUP=$$DENDUP^IBCEMU4(IBDA,$G(IBMRANOT))
I '$G(IBMRADUP),IBDENDUP Q ; don't include denied MRAs/EOBs for Duplicate Claim/Service
S IB3611=$G(^IBM(361.1,IBDA,0))
S IBIFN=+IB3611,IB364=$P(IB3611,U,19),IBDT=+$P(IB3611,U,6)
I $D(^TMP("IBCOBSTX",$J,IBIFN)) Q ;show each bill once on the worklist
S IBB=$G(^DGCR(399,IBIFN,0))
;
; MRD;IB*2.0*516 - User requested the ability to sort the COB Mgmt
; Worklist by Division. To enable this, the Division was added as
; a subscript to the ^TMP("IBCOBST") array. For now, that subscript
; will always be "UNKNOWN" when building the MRA Worklist. To turn
; on sort-by-division for the MRA Worklist, uncomment out the fol-
; lowing two lines and delete the line Setting IBDIV to "UNKNOWN".
;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 IBDIV="UNKNOWN"
;
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=$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)
. Q
; 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)
. Q
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)
. Q
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
.. 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
. Q
;
; 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
S IBEXPY=+$G(^IBM(361.1,IBDA,1)) ; payer paid amount
; IB*2.0*447 add excess indicator to MRW screen and adjust calcs to include percentages
S IBPTRSP=$S($$MSEDT^IBCEMU4(IBIFN)'="":$$MSPRE^IBCEMU4(IBIFN,1),1:$$PREOBTOT^IBCEU0(IBIFN)) ; patient resp. function
S IBPY=$S(IBAPY:IBAPY,1:IBEXPY)
S IBOAM=+$G(^DGCR(399,IBIFN,"U1")) ; total charges for bill
S IBNBAL=IBOAM-IBPY
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)
;
; MRD;IB*2.0*516 - Added Division as a subscript.
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="M")&(Z0="")) Z0="UNKNOWN" ;USE UNKNOWN IF NOT SET - BI;IB*2.0*432
;I $D(^TMP("IBCOBST",$J,Z0,IBIFN)),$P(^TMP("IBCOBST",$J,Z0,IBIFN),U,19)=-1 S MSEFLG=-1 ; If a MSE was previously found for IBIFN, we want to insure that we don't ignore that by resetting the 19th piece to something else.
I $D(^TMP("IBCOBST",$J,IBDIV,Z0,IBIFN)),$P(^TMP("IBCOBST",$J,IBDIV,Z0,IBIFN),U,19)=-1 S MSEFLG=-1 ; If a MSE was previously found for IBIFN, we want to insure that we don't ignore that by resetting the 19th piece to something else.
;
;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_IBDA_U_$$HIS(IBIFN)_U_IBDAY_U_IBDT_U_IBQ_U_IB364_U_IBSEQ_U_IBEXPY_U_IBPTRSP_U_MSEFLG
;S ^TMP("IBCOBST",$J,Z0,IBIFN,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_IBDA_U_$$HIS(IBIFN)_U_IBDAY_U_IBDT_U_IBQ_U_IB364_U_IBSEQ_U_IBEXPY_U_IBPTRSP_U_MSEFLG
S ^TMP("IBCOBST",$J,IBDIV,Z0,IBIFN,1)=$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13))_", "_$$FMTE^XLFDT($P($P(IB3611,"^",6),"."))_"^"_$P(IB3611,"^",16)
S ^TMP("IBCOBSTX",$J,IBIFN)=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
;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)=IBDENDUP
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)=IBDENDUP
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
Q IBHIS
;
NMAT ;No COB list
S VALMCNT=2,IBCNT=2
S ^TMP("IBCECOB",$J,1,0)=" "
S ^TMP("IBCECOB",$J,2,0)=" No "_$S($G(IBMRANOT)=1:"EOB's",1:"MRA's")_" Matching Selection Criteria Were Found"
Q
;
SCRN ;
N IB,IBCNT,IBDA,IBDIV,IBIFN,IBFORM,IBK,IBPAT,IBS1,IBX,MSEFLG,X,Z
;N IBMRANOTMSE ;TPF;EBILL-2436;IB*2.0*727
N IBMSEFOUND ;TPF;EBILL-3339;IB*2.0*759
;
S IBCNT=0
; IB*2.0*547 - Add primary insurance company sort, had to break into 2 lines
S IBS1=$S(IBSRT="B":"BILLER",IBSRT="D":"Days Since Last Transmission",IBSRT="L":"Date Last "_$S($G(IBMRANOT):"EOB",1:"MRA")_" Received",IBSRT="I":"SECONDARY INSURANCE COMPANY",IBSRT="M":$S($G(IBMRANOT):"EOB",1:"MRA")_" Status",1:"")
S:IBSRT="K" IBS1="PRIMARY INSURANCE COMPANY"
;
; MRD;IB*2.0*516 - Added Division as a subscript.
S IBDIV=""
F S IBDIV=$O(^TMP("IBCOBST",$J,IBDIV)) Q:IBDIV="" D
. I IBCNT D SET("",IBCNT+1)
. D SET("Division: "_$$GET1^DIQ(40.8,IBDIV_",",.01,"E"),IBCNT+1)
. ;
. ;S IBX="" F S IBX=$O(^TMP("IBCOBST",$J,IBX)) Q:IBX="" D
. S IBX="" F S IBX=$O(^TMP("IBCOBST",$J,IBDIV,IBX)) Q:IBX="" D
.. ; P547
.. ;I IBSRT="B"!(IBSRT="I")!(IBSRT="M") D
.. I IBSRT="B"!(IBSRT="I")!(IBSRT="M")!(IBSRT="K") D
... I IBCNT D SET("",IBCNT+1)
... D SET(IBS1_": "_$P(IBX,"~"),IBCNT+1)
... Q
.. ;
.. ;S IBIFN=0 F S IBIFN=$O(^TMP("IBCOBST",$J,IBX,IBIFN)) Q:'IBIFN D
.. S IBIFN=0 F S IBIFN=$O(^TMP("IBCOBST",$J,IBDIV,IBX,IBIFN)) Q:'IBIFN D
... ;S IB=$G(^TMP("IBCOBST",$J,IBX,IBIFN))
... S IB=$G(^TMP("IBCOBST",$J,IBDIV,IBX,IBIFN))
... S Z=$G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0))
... S IBPAT=$$LJ^XLFSTR($E($P(Z,U),1,18),18," ")_" "_$E($P(Z,U,9),6,9)
... S IBDA=$P(IB,U,10) ;361.1-ien
... S IBQ=$P(IB,U,14),IB364=$P(IB,U,15)
... ; IB*2.0*447 shorten form column to I for Instutional and P for Professional
... ;S IBFORM=$$EXTERNAL^DILFD(399,.19,,+$P(IB,U,6))
... ;I +$P(IB,U,6)=2 S IBFORM=1500 ; for space reasons
... ;JWS;IB*2.0*592;Add 'D' for Dental display
... S IBFORM=$S(+$P(IB,U,6)=2:"P",+$P(IB,U,6)=7:"D",1:"I")
... S IBPTRSP=$P(IB,U,18)
... S MSEFLG=$P(IB,U,19)
... S IBAMT=$P(IB,U,2)
... S IBCNT=IBCNT+1
... S X=""
... ;
... ;TPF;EBILL-2436;IB*2.0*727 ADD FLAG FOR MSE ERROR
... ;S IBMRANOTMSE=$$GET1^DIQ(399,IBIFN_",",36,"","","")="IB803" ;EOB CLAIM MSE ERROR?
... ;S IBMRANOTMSE=$$FILERR^IBCAPP2(IBIFN) ;TPF;EBILL-3061;IB*2.0*727 v15
... S IBMSEFOUND=$$FILERR^IBCAPP2(IBIFN) ;TPF;EBILL-3339;IB*2.0*759
... ;
... S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
... ;;;S X=$$SETFLD^VALM1($$BN1^PRCAFN(IBIFN)_$S($P($G(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL")
... ;S X=$$SETFLD^VALM1($S(MSEFLG=-1:"!",1:" ")_$$BN1^PRCAFN(IBIFN)_$S($P($G(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL") ; per IB*2.0*488
... ;S X=$$SETFLD^VALM1($S((MSEFLG=-1)!($G(IBMRANOT)&$G(IBMRANOTMSE)):"!",1:" ")_$$BN1^PRCAFN(IBIFN)_$S($P($G(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL") ; per IB*2.0*488
... S X=$$SETFLD^VALM1($S(($G(IBMSEFOUND)):"!",1:" ")_$$BN1^PRCAFN(IBIFN)_$S($P($G(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL") ;TPF;EBILL-3339;IB*2.0*759
... S X=$$SETFLD^VALM1($$DAT1^IBOUTL($P(IB,U)),X,"SERVICE")
... S X=$$SETFLD^VALM1(IBPAT,X,"PATNM")
... S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBPTRSP,"",2),9," "),X,"PTRESP")
... S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBAMT,"",2),9," "),X,"IBAMT")
... S X=$$SETFLD^VALM1($E($$TYPE^IBJTLA1($P(IB,U,5)))_"/"_IBFORM,X,"BTYPE")
... D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
... ;
... ;For R (Pt Resp), P (Pt Name) and S (Service Date) don't display sub-headers
... ;I "BIMRPS"'[IBSRT D IB*2.0*547
... I "BIMRPSK"'[IBSRT D
.... S Z=$S(IBSRT="L":$$DAT1^IBOUTL(IBX),IBSRT="D":-IBX,1:IBX)
.... D SET(" "_IBS1_": "_Z,IBCNT)
.... Q
... S X=$$SETSTR^VALM1("Insurers: "_$P(IB,U,9),"",7,74)
... D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
... ;
... ; line 3 of display: MRA status/date/split claim indicator
... S X=$$SETSTR^VALM1($S($G(IBMRANOT):"EOB",1:"MRA")_" Status: ","",5,13)
... ;S IBK=$G(^TMP("IBCOBST",$J,IBX,IBIFN,1))
... S IBK=$G(^TMP("IBCOBST",$J,IBDIV,IBX,IBIFN,1))
... S X=$$SETSTR^VALM1($P(IBK,U,1),X,18,63)
... I $P(IBK,U,2)=2 S X=$$SETSTR^VALM1("** SPLIT CLAIM **",X,63,18)
... I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 S X=$$SETSTR^VALM1("** Denied for Duplicate **",X,54,27)
... D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
... ; conditionally update video attributes of line 3
... I '$D(IOINHI) D ENS^%ZISS
... ; split claim
... I $P(IBK,U,2)=2 D CNTRL^VALM10(VALMCNT,63,17,IOINHI,IOINORM)
... ; multiple mra's on file
... I $P(IBK,U,3)>1 D CNTRL^VALM10(VALMCNT,18,22,IOINHI,IOINORM)
... ; Denied for Duplicate - no split claim and single MRA only
... I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 D CNTRL^VALM10(VALMCNT,54,26,IOINHI,IOINORM)
... Q
.. Q
. Q
;
Q
;
SET(X,CNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) ;set up list manager screen array
S VALMCNT=VALMCNT+1
S ^TMP("IBCECOB",$J,VALMCNT,0)=X
S ^TMP("IBCECOB",$J,"IDX",VALMCNT,CNT)=""
I $G(IBIFN),$G(^TMP("IBCECOB",$J,CNT))="" S ^TMP("IBCECOB",$J,CNT)=VALMCNT_U_IBIFN_U_IB364_U_IBDA_U_IBQ_U_IBX,^TMP("IBCECOB1",$J,CNT)=IB
Q
;
FTYPE(Y) ;type classification
Q $E($P($G(^IBE(353,Y,0)),U),1,8)
;
PTRESPI(IBEOB) ; Function - Computes the Patient's Responsibility based on IBEOB
; of 361.1 for Claims/Bills with form type 3=UB
; Input IBEOB - a single EOB ien; Required
; Output - Function Returns IBPTRES - Patient Responsibility Amount for the EOB
;
N IBPTRES,IBC,EOBADJ
S IBPTRES=0,IBEOB=+$G(IBEOB)
I 'IBEOB Q IBPTRES ;PTRESPI
; filing error
Q:$D(^IBM(361.1,IBEOB,"ERR")) IBPTRES
;
; get claim level adjustments
K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10)
S IBPTRES=$$CALCPR^IBCEU0(.EOBADJ)
;
; get line level adjustments
S IBC=0 F S IBC=$O(^IBM(361.1,IBEOB,15,IBC)) Q:'IBC D
. K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,15,IBC,1)
. S IBPTRES=IBPTRES+$$CALCPR^IBCEU0(.EOBADJ)
Q IBPTRES
;
ELIG(IBEOB) ; Function to determine if an EOB entry is eligible for
; inclusion on the MRA or COB management worklist or not.
; IBEOB - ien into file 361.1 (required)
; Returns 1 if EOB should appear on the worklist
; Returns 0 if EOB should not appear on the worklist
; Returns -1 if EOB contains Message Storage Errors
;
NEW ELIG,IB3611,IBIFN
S ELIG=0,IBEOB=+$G(IBEOB)
S IB3611=$G(^IBM(361.1,IBEOB,0))
I $P(IB3611,U,4)'=1 G ELIGX ; eob type must be correct for this worklist
I $P(IB3611,U,16)>2 G ELIGX ; review status must be <= 2
S IBIFN=+IB3611
I $P($G(^DGCR(399,IBIFN,0)),U,13)'=2 G ELIGX ; Request MRA bill status
I $D(^IBM(361.1,IBEOB,"ERR")) S ELIG=$S('$G(IBMRANOT):-1,1:ELIG) G ELIGX ; filing errors - contains Message Storage Errors
;
S ELIG=1 ; this EOB is eligible for the worklist
;
ELIGX ;
Q ELIG
;
WLRMV ; REMOVE FROM EOB WORK LIST
; IBDA(IBDA)=IBIFN^IB364^ien of 361.1^user selection seq^user name~duz#
N IBIFN,IBDA,DIR,DTOUT,DUOUT,DA,DIE,DR,X
D SEL^IBCECOB2(.IBDA,1)
S VALMBCK="R"
S IBDA=$O(IBDA(0)) I 'IBDA Q
S IBIFN=$P(IBDA(IBDA),U,1) I 'IBIFN Q
S DIR("A",1)=""
S DIR("A",2)=" Bill #: "_$$GET1^DIQ(399,IBIFN_", ",.01,"E")
S DIR("A",3)=" Patient: "_$$GET1^DIQ(399,IBIFN_", ",.02,"E")
S DIR("A",4)=" Bill Type: "_$$GET1^DIQ(399,IBIFN_", ",.05,"E")
S DIR("A",5)="Bill Dates: "_$$GET1^DIQ(399,IBIFN_", ",151,"E")_" - "_$$GET1^DIQ(399,IBIFN_", ",152,"E")
S DIR("A",6)=" "
S DIR("A")="Are you sure remove this claim from the worklist? "
S DIR("B")="NO"
S DIR(0)="YA" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!'Y Q
;FLAG IF USER ANSWERS YES
S X=$$WLRMVF^IBCECOB1(IBIFN,"RM")
D BLD^IBCECOB1
Q
;
WLRMVF(IBIFN,METHOD,BKFL) ;
; BFKL = 1 means background process, remove NOT initiated by a user
N SOC,SOCCNT,SOCLIST,STATUS,IBDUZ
S STATUS=0
Q:'$G(DUZ) STATUS_"^MISSING DUZ"
Q:'$G(IBIFN) STATUS_"^MISSING IBIFN"
Q:'$D(^DGCR(399,IBIFN)) STATUS_"^INVALID IBIFN"
; if this is a background process, set user who removed to AUTHORIZER,IB REG
S IBDUZ=$S($G(BKFL)=1:$$IBREG^IBCAPP(),1:$G(DUZ))
; GET DICTIONARY SET OF CODES.
; SOC("POINTER")="RM:REMOVE ACTION;PC:PROCESS COB ACTION;CL:CLONE ACTION;"
D FIELD^DID(399,38,"","POINTER","SOC")
S SOC=$G(SOC("POINTER"))
F SOCCNT=1:1:$L(SOC,";")-1 S SOCLIST($P($P(SOC,";",SOCCNT),":",1))=""
Q:$D(SOCLIST(METHOD))=0 STATUS_"^INVALID METHOD"
S DA=IBIFN
S DIE="^DGCR(399,"
S DR="35////4" ; AUTO PROCESS, NO LONGER ON WORKLIST
S:IBDUZ'=-1 DR=DR_";"_"37////"_IBDUZ ; WHO REMOVED FROM WORKLIST
S DR=DR_";"_"38////"_METHOD ; METHOD USED TO REMOVE FROM WORKLIST
S DR=DR_";"_"39///NOW" ; DATE STAMP WHEN REMOVED FOR WORKLIST
D ^DIE
S STATUS=1
Q STATUS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCECOB1 16344 printed Oct 16, 2024@18:10:19 Page 2
IBCECOB1 ;ALB/CXW - IB COB MANAGEMENT SCREEN/REPORT ;14-JUN-99
+1 ;;2.0;INTEGRATED BILLING;**137,155,288,348,377,417,432,447,488,516,547,592,727,759**;21-MAR-94;Build 24
+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 ;
BLD ; Build list entrypoint
+1 ;
+2 NEW I,IB3611,IB364,IBAMT,IBAPY,IBB,IBB364,IBBPY,IBDA,IBDA1,IBDAY
+3 NEW IBDENDUP,IBDIV,IBDT,IBDTN,IBEOBREV,IBEUT,IBEXPY,IBFND,IBHIS
+4 NEW IBIFN,IBINS,IBINS1,IBINS2,IBMRACNT,IBMUT,IBNBAL,IBNDI1,IBNDI2
+5 NEW IBNDI3,IBNDM,IBNDS,IBOAM,IBPTNM,IBPTRSP,IBPY,IBQ,IBSEQ,IBSRVC
+6 NEW EOBTYPE,MSEFLG,Z,Z0
+7 ;
+8 KILL ^TMP("IBCECOB",$JOB),^TMP("IBCECOB1",$JOB),^TMP("IBCOBST",$JOB),^TMP("IBCOBSTX",$JOB)
+9 ; kill data and video control arrays
DO CLEAN^VALM10
+10 SET (VALMCNT,MSEFLG)=0
SET IBHIS=""
+11 ; IB*2.0*432 IF not MRA, use new CAP index on 399 file
+12 if $GET(IBMRANOT)=1
DO CAP^IBCAPP2
+13 ; since 0 is a valid Review Status, init w/null
+14 SET IBEOBREV=""
+15 ; get EOB's w/Review Status of 0, 1, 1.5 or 2; If 3 or higher, not needed
+16 IF $GET(IBMRANOT)'=1
FOR
SET IBEOBREV=$ORDER(^IBM(361.1,"AMRA",1,IBEOBREV))
if IBEOBREV=""
QUIT
if IBEOBREV>2
QUIT
Begin DoDot:1
+17 SET IBDA="A"
FOR
SET IBDA=$ORDER(^IBM(361.1,"AMRA",1,IBEOBREV,IBDA),-1)
if 'IBDA
QUIT
DO BLD1
End DoDot:1
+18 ;
+19 ; no data accumulated
+20 IF $ORDER(^TMP("IBCOBST",$JOB,""))=""
DO NMAT
QUIT
+21 ;
+22 ; display accumulated data
+23 DO SCRN
+24 QUIT
+25 ;
BLD1 ;
+1 ;
+2 SET MSEFLG=$$ELIG(IBDA)
if 'MSEFLG
QUIT
+3 SET IBDENDUP=$$DENDUP^IBCEMU4(IBDA,$GET(IBMRANOT))
+4 ; don't include denied MRAs/EOBs for Duplicate Claim/Service
IF '$GET(IBMRADUP)
IF IBDENDUP
QUIT
+5 SET IB3611=$GET(^IBM(361.1,IBDA,0))
+6 SET IBIFN=+IB3611
SET IB364=$PIECE(IB3611,U,19)
SET IBDT=+$PIECE(IB3611,U,6)
+7 ;show each bill once on the worklist
IF $DATA(^TMP("IBCOBSTX",$JOB,IBIFN))
QUIT
+8 SET IBB=$GET(^DGCR(399,IBIFN,0))
+9 ;
+10 ; MRD;IB*2.0*516 - User requested the ability to sort the COB Mgmt
+11 ; Worklist by Division. To enable this, the Division was added as
+12 ; a subscript to the ^TMP("IBCOBST") array. For now, that subscript
+13 ; will always be "UNKNOWN" when building the MRA Worklist. To turn
+14 ; on sort-by-division for the MRA Worklist, uncomment out the fol-
+15 ; lowing two lines and delete the line Setting IBDIV to "UNKNOWN".
+16 ;S IBDIV=$P(IBB,U,22) I IBDIV="" S IBDIV="UNKNOWN"
+17 ;I $D(^TMP("IBBIL-DIV",$J)),'$D(^TMP("IBBIL-DIV",$J,IBDIV)) Q
+18 SET IBDIV="UNKNOWN"
+19 ;
+20 SET IBNDS=$GET(^DGCR(399,IBIFN,"S"))
SET IBNDI1=$GET(^("I1"))
SET IBNDI2=$GET(^("I2"))
SET IBNDI3=$GET(^("I3"))
SET IBNDM=$GET(^("M"))
+21 SET IBMUT=+$PIECE(IBNDS,U,8)
SET IBEUT=+$PIECE(IBNDS,U,2)
+22 SET IBINS=""
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)
+28 QUIT
End DoDot:1
+29 ; Get the payer/insurance company that comes after Medicare WNR
+30 ; If WNR is Primary, get the secondary ins. co.
+31 ; If WNR is secondary, get the tertiary ins. co.
+32 Begin DoDot:1
+33 IF $$WNRBILL^IBEFUNC(IBIFN,1)
SET IBINS2=+IBNDI2_U_$PIECE($GET(^DIC(36,+IBNDI2,0)),U)
QUIT
+34 SET IBINS2=+IBNDI3_U_$PIECE($GET(^DIC(36,+IBNDI3,0)),U)
+35 QUIT
End DoDot:1
IF $PIECE($GET(IBINS2),U,2)=""
SET $PIECE(IBINS2,U,2)="UNKNOWN"
+36 SET IBFND=0
+37 ; biller entry not ALL and no biller, then get entered/edited by user
+38 IF $DATA(^TMP("IBBIL",$JOB))
Begin DoDot:1
+39 SET IBFND=$SELECT($DATA(^TMP("IBBIL",$JOB,IBMUT)):IBMUT,$DATA(^TMP("IBBIL",$JOB,IBEUT)):IBEUT,1:0)
+40 QUIT
End DoDot:1
if 'IBFND
QUIT
+41 SET Z=$SELECT(IBFND:IBFND,IBMUT:IBMUT,1:IBEUT)
+42 SET IBMUT=$PIECE($GET(^VA(200,+Z,0)),U)_"~"_Z
+43 if '$PIECE(IBMUT,"~",2)
SET IBMUT="UNKNOWN~0"
+44 SET IBBPY=+$$COBN^IBCEF(IBIFN)
SET IBQ=1
+45 ;
+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
+52 QUIT
End DoDot:2
if 'IBQ
QUIT
+53 ;Check if next ins doesn't exist or next bill# already created
+54 SET Z="IBNDI"_(IBBPY+1)
SET Z=$GET(@Z)
+55 IF Z
IF '$PIECE($GET(^DGCR(399,IBIFN,"M1")),U,5+IBBPY)
SET IBQ=0
+56 QUIT
End DoDot:1
+57 ;
+58 ; Days since transmission of latest bill in COB - IBDAY
+59 SET IBDAY=+$PIECE($GET(^DGCR(399,IBIFN,"TX")),U,2)
IF IBDAY
SET IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1)
+60 ; if no Last Electronic Extract Date on file 399, get it from file 364
+61 ;calc. the difference
IF 'IBDAY
Begin DoDot:1
+62 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)
+63 ;
+64 ; payment on this bill from A/R
SET IBAPY=$$TPR^PRCAFN(IBIFN)
+65 ; payer paid amount
SET IBEXPY=+$GET(^IBM(361.1,IBDA,1))
+66 ; IB*2.0*447 add excess indicator to MRW screen and adjust calcs to include percentages
+67 ; patient resp. function
SET IBPTRSP=$SELECT($$MSEDT^IBCEMU4(IBIFN)'="":$$MSPRE^IBCEMU4(IBIFN,1),1:$$PREOBTOT^IBCEU0(IBIFN))
+68 SET IBPY=$SELECT(IBAPY:IBAPY,1:IBEXPY)
+69 ; total charges for bill
SET IBOAM=+$GET(^DGCR(399,IBIFN,"U1"))
+70 SET IBNBAL=IBOAM-IBPY
+71 IF IBNBAL'>0
SET IBQ=2
+72 SET IBPTNM=$PIECE($GET(^DPT(+$PIECE($GET(^DGCR(399,IBIFN,0)),U,2),0)),U)
IF IBPTNM=""
SET IBPTNM="UNKNOWN"
+73 SET IBSRVC=$PIECE($GET(^DGCR(399,IBIFN,"U")),U)
+74 ;
+75 ; MRD;IB*2.0*516 - Added Division as a subscript.
+76 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)
+77 ;USE UNKNOWN IF NOT SET - BI;IB*2.0*432
if ((IBSRT="M")&(Z0=""))
SET Z0="UNKNOWN"
+78 ;I $D(^TMP("IBCOBST",$J,Z0,IBIFN)),$P(^TMP("IBCOBST",$J,Z0,IBIFN),U,19)=-1 S MSEFLG=-1 ; If a MSE was previously found for IBIFN, we want to insure that we don't ignore that by resetting the 19th piece to something else.
+79 ; If a MSE was previously found for IBIFN, we want to insure that we don't ignore that by resetting the 19th piece to something else.
IF $DATA(^TMP("IBCOBST",$JOB,IBDIV,Z0,IBIFN))
IF $PIECE(^TMP("IBCOBST",$JOB,IBDIV,Z0,IBIFN),U,19)=-1
SET MSEFLG=-1
+80 ;
+81 ;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_IBDA_U_$$HIS(IBIFN)_U_IBDAY_U_IBDT_U_IBQ_U_IB364_U_IBSEQ_U_IBEXPY_U_IBPTRSP_U_MSEFLG
+82 ;S ^TMP("IBCOBST",$J,Z0,IBIFN,1)=$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13))_", "_$$FMTE^XLFDT($P($P(IB3611,"^",6),"."))_"^"_$P(IB3611,"^",16)
+83 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_IBDA_U_$$HIS(IBIFN)_U_IBDAY_U_IBDT_U_IBQ_U_IB364_U_IBSEQ_U_IBEXPY_U_IBPTRSP
_U_MSEFLG
+84 SET ^TMP("IBCOBST",$JOB,IBDIV,Z0,IBIFN,1)=$$EXTERNAL^DILFD(361.1,.13,"",$PIECE(IB3611,"^",13))_", "_$$FMTE^XLFDT($PIECE($PIECE(IB3611,"^",6),"."))_"^"_$PIECE(IB3611,"^",16)
+85 ;keep track of compiled IBIFN's
SET ^TMP("IBCOBSTX",$JOB,IBIFN)=IBDA
+86 ;
+87 ; Save some data when there are multiple MRA's on file for this bill
+88 ;WCJ IB*2.0*432
SET IBMRACNT=$$MRACNT^IBCEMU1(IBIFN,$GET(IBMRANOT))
+89 ;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
+90 ;S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,3)=IBMRACNT
+91 ;S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=IBDENDUP
+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)=IBDENDUP
+95 QUIT
+96 ;
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 QUIT IBHIS
+7 ;
NMAT ;No COB list
+1 SET VALMCNT=2
SET IBCNT=2
+2 SET ^TMP("IBCECOB",$JOB,1,0)=" "
+3 SET ^TMP("IBCECOB",$JOB,2,0)=" No "_$SELECT($GET(IBMRANOT)=1:"EOB's",1:"MRA's")_" Matching Selection Criteria Were Found"
+4 QUIT
+5 ;
SCRN ;
+1 NEW IB,IBCNT,IBDA,IBDIV,IBIFN,IBFORM,IBK,IBPAT,IBS1,IBX,MSEFLG,X,Z
+2 ;N IBMRANOTMSE ;TPF;EBILL-2436;IB*2.0*727
+3 ;TPF;EBILL-3339;IB*2.0*759
NEW IBMSEFOUND
+4 ;
+5 SET IBCNT=0
+6 ; IB*2.0*547 - Add primary insurance company sort, had to break into 2 lines
+7 SET IBS1=$SELECT(IBSRT="B":"BILLER",IBSRT="D":"Days Since Last Transmission",IBSRT="L":"Date Last "_$SELECT($GET(IBMRANOT):"EOB",1:"MRA")_" Received",IBSRT="I":"SECONDARY INSURANCE COMPANY",IBSRT="M":$SELECT(...
... $GET(IBMRANOT):"EOB",1:"MRA")_" Status",1:"")
+8 if IBSRT="K"
SET IBS1="PRIMARY INSURANCE COMPANY"
+9 ;
+10 ; MRD;IB*2.0*516 - Added Division as a subscript.
+11 SET IBDIV=""
+12 FOR
SET IBDIV=$ORDER(^TMP("IBCOBST",$JOB,IBDIV))
if IBDIV=""
QUIT
Begin DoDot:1
+13 IF IBCNT
DO SET("",IBCNT+1)
+14 DO SET("Division: "_$$GET1^DIQ(40.8,IBDIV_",",.01,"E"),IBCNT+1)
+15 ;
+16 ;S IBX="" F S IBX=$O(^TMP("IBCOBST",$J,IBX)) Q:IBX="" D
+17 SET IBX=""
FOR
SET IBX=$ORDER(^TMP("IBCOBST",$JOB,IBDIV,IBX))
if IBX=""
QUIT
Begin DoDot:2
+18 ; P547
+19 ;I IBSRT="B"!(IBSRT="I")!(IBSRT="M") D
+20 IF IBSRT="B"!(IBSRT="I")!(IBSRT="M")!(IBSRT="K")
Begin DoDot:3
+21 IF IBCNT
DO SET("",IBCNT+1)
+22 DO SET(IBS1_": "_$PIECE(IBX,"~"),IBCNT+1)
+23 QUIT
End DoDot:3
+24 ;
+25 ;S IBIFN=0 F S IBIFN=$O(^TMP("IBCOBST",$J,IBX,IBIFN)) Q:'IBIFN D
+26 SET IBIFN=0
FOR
SET IBIFN=$ORDER(^TMP("IBCOBST",$JOB,IBDIV,IBX,IBIFN))
if 'IBIFN
QUIT
Begin DoDot:3
+27 ;S IB=$G(^TMP("IBCOBST",$J,IBX,IBIFN))
+28 SET IB=$GET(^TMP("IBCOBST",$JOB,IBDIV,IBX,IBIFN))
+29 SET Z=$GET(^DPT(+$PIECE($GET(^DGCR(399,IBIFN,0)),U,2),0))
+30 SET IBPAT=$$LJ^XLFSTR($EXTRACT($PIECE(Z,U),1,18),18," ")_" "_$EXTRACT($PIECE(Z,U,9),6,9)
+31 ;361.1-ien
SET IBDA=$PIECE(IB,U,10)
+32 SET IBQ=$PIECE(IB,U,14)
SET IB364=$PIECE(IB,U,15)
+33 ; IB*2.0*447 shorten form column to I for Instutional and P for Professional
+34 ;S IBFORM=$$EXTERNAL^DILFD(399,.19,,+$P(IB,U,6))
+35 ;I +$P(IB,U,6)=2 S IBFORM=1500 ; for space reasons
+36 ;JWS;IB*2.0*592;Add 'D' for Dental display
+37 SET IBFORM=$SELECT(+$PIECE(IB,U,6)=2:"P",+$PIECE(IB,U,6)=7:"D",1:"I")
+38 SET IBPTRSP=$PIECE(IB,U,18)
+39 SET MSEFLG=$PIECE(IB,U,19)
+40 SET IBAMT=$PIECE(IB,U,2)
+41 SET IBCNT=IBCNT+1
+42 SET X=""
+43 ;
+44 ;TPF;EBILL-2436;IB*2.0*727 ADD FLAG FOR MSE ERROR
+45 ;S IBMRANOTMSE=$$GET1^DIQ(399,IBIFN_",",36,"","","")="IB803" ;EOB CLAIM MSE ERROR?
+46 ;S IBMRANOTMSE=$$FILERR^IBCAPP2(IBIFN) ;TPF;EBILL-3061;IB*2.0*727 v15
+47 ;TPF;EBILL-3339;IB*2.0*759
SET IBMSEFOUND=$$FILERR^IBCAPP2(IBIFN)
+48 ;
+49 SET X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
+50 ;;;S X=$$SETFLD^VALM1($$BN1^PRCAFN(IBIFN)_$S($P($G(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL")
+51 ;S X=$$SETFLD^VALM1($S(MSEFLG=-1:"!",1:" ")_$$BN1^PRCAFN(IBIFN)_$S($P($G(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL") ; per IB*2.0*488
+52 ;S X=$$SETFLD^VALM1($S((MSEFLG=-1)!($G(IBMRANOT)&$G(IBMRANOTMSE)):"!",1:" ")_$$BN1^PRCAFN(IBIFN)_$S($P($G(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL") ; per IB*2.0*488
+53 ;TPF;EBILL-3339;IB*2.0*759
SET X=$$SETFLD^VALM1($SELECT(($GET(IBMSEFOUND)):"!",1:" ")_$$BN1^PRCAFN(IBIFN)_$SELECT($PIECE($GET(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL")
+54 SET X=$$SETFLD^VALM1($$DAT1^IBOUTL($PIECE(IB,U)),X,"SERVICE")
+55 SET X=$$SETFLD^VALM1(IBPAT,X,"PATNM")
+56 SET X=$$SETFLD^VALM1($$RJ^XLFSTR($FNUMBER(IBPTRSP,"",2),9," "),X,"PTRESP")
+57 SET X=$$SETFLD^VALM1($$RJ^XLFSTR($FNUMBER(IBAMT,"",2),9," "),X,"IBAMT")
+58 SET X=$$SETFLD^VALM1($EXTRACT($$TYPE^IBJTLA1($PIECE(IB,U,5)))_"/"_IBFORM,X,"BTYPE")
+59 DO SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
+60 ;
+61 ;For R (Pt Resp), P (Pt Name) and S (Service Date) don't display sub-headers
+62 ;I "BIMRPS"'[IBSRT D IB*2.0*547
+63 IF "BIMRPSK"'[IBSRT
Begin DoDot:4
+64 SET Z=$SELECT(IBSRT="L":$$DAT1^IBOUTL(IBX),IBSRT="D":-IBX,1:IBX)
+65 DO SET(" "_IBS1_": "_Z,IBCNT)
+66 QUIT
End DoDot:4
+67 SET X=$$SETSTR^VALM1("Insurers: "_$PIECE(IB,U,9),"",7,74)
+68 DO SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
+69 ;
+70 ; line 3 of display: MRA status/date/split claim indicator
+71 SET X=$$SETSTR^VALM1($SELECT($GET(IBMRANOT):"EOB",1:"MRA")_" Status: ","",5,13)
+72 ;S IBK=$G(^TMP("IBCOBST",$J,IBX,IBIFN,1))
+73 SET IBK=$GET(^TMP("IBCOBST",$JOB,IBDIV,IBX,IBIFN,1))
+74 SET X=$$SETSTR^VALM1($PIECE(IBK,U,1),X,18,63)
+75 IF $PIECE(IBK,U,2)=2
SET X=$$SETSTR^VALM1("** SPLIT CLAIM **",X,63,18)
+76 IF $PIECE(IBK,U,4)
IF $PIECE(IBK,U,2)'=2
IF $PIECE(IBK,U,3)=1
SET X=$$SETSTR^VALM1("** Denied for Duplicate **",X,54,27)
+77 DO SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
+78 ; conditionally update video attributes of line 3
+79 IF '$DATA(IOINHI)
DO ENS^%ZISS
+80 ; split claim
+81 IF $PIECE(IBK,U,2)=2
DO CNTRL^VALM10(VALMCNT,63,17,IOINHI,IOINORM)
+82 ; multiple mra's on file
+83 IF $PIECE(IBK,U,3)>1
DO CNTRL^VALM10(VALMCNT,18,22,IOINHI,IOINORM)
+84 ; Denied for Duplicate - no split claim and single MRA only
+85 IF $PIECE(IBK,U,4)
IF $PIECE(IBK,U,2)'=2
IF $PIECE(IBK,U,3)=1
DO CNTRL^VALM10(VALMCNT,54,26,IOINHI,IOINORM)
+86 QUIT
End DoDot:3
+87 QUIT
End DoDot:2
+88 QUIT
End DoDot:1
+89 ;
+90 QUIT
+91 ;
SET(X,CNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) ;set up list manager screen array
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBCECOB",$JOB,VALMCNT,0)=X
+3 SET ^TMP("IBCECOB",$JOB,"IDX",VALMCNT,CNT)=""
+4 IF $GET(IBIFN)
IF $GET(^TMP("IBCECOB",$JOB,CNT))=""
SET ^TMP("IBCECOB",$JOB,CNT)=VALMCNT_U_IBIFN_U_IB364_U_IBDA_U_IBQ_U_IBX
SET ^TMP("IBCECOB1",$JOB,CNT)=IB
+5 QUIT
+6 ;
FTYPE(Y) ;type classification
+1 QUIT $EXTRACT($PIECE($GET(^IBE(353,Y,0)),U),1,8)
+2 ;
PTRESPI(IBEOB) ; Function - Computes the Patient's Responsibility based on IBEOB
+1 ; of 361.1 for Claims/Bills with form type 3=UB
+2 ; Input IBEOB - a single EOB ien; Required
+3 ; Output - Function Returns IBPTRES - Patient Responsibility Amount for the EOB
+4 ;
+5 NEW IBPTRES,IBC,EOBADJ
+6 SET IBPTRES=0
SET IBEOB=+$GET(IBEOB)
+7 ;PTRESPI
IF 'IBEOB
QUIT IBPTRES
+8 ; filing error
+9 if $DATA(^IBM(361.1,IBEOB,"ERR"))
QUIT IBPTRES
+10 ;
+11 ; get claim level adjustments
+12 KILL EOBADJ
MERGE EOBADJ=^IBM(361.1,IBEOB,10)
+13 SET IBPTRES=$$CALCPR^IBCEU0(.EOBADJ)
+14 ;
+15 ; get line level adjustments
+16 SET IBC=0
FOR
SET IBC=$ORDER(^IBM(361.1,IBEOB,15,IBC))
if 'IBC
QUIT
Begin DoDot:1
+17 KILL EOBADJ
MERGE EOBADJ=^IBM(361.1,IBEOB,15,IBC,1)
+18 SET IBPTRES=IBPTRES+$$CALCPR^IBCEU0(.EOBADJ)
End DoDot:1
+19 QUIT IBPTRES
+20 ;
ELIG(IBEOB) ; Function to determine if an EOB entry is eligible for
+1 ; inclusion on the MRA or COB management worklist or not.
+2 ; IBEOB - ien into file 361.1 (required)
+3 ; Returns 1 if EOB should appear on the worklist
+4 ; Returns 0 if EOB should not appear on the worklist
+5 ; Returns -1 if EOB contains Message Storage Errors
+6 ;
+7 NEW ELIG,IB3611,IBIFN
+8 SET ELIG=0
SET IBEOB=+$GET(IBEOB)
+9 SET IB3611=$GET(^IBM(361.1,IBEOB,0))
+10 ; eob type must be correct for this worklist
IF $PIECE(IB3611,U,4)'=1
GOTO ELIGX
+11 ; review status must be <= 2
IF $PIECE(IB3611,U,16)>2
GOTO ELIGX
+12 SET IBIFN=+IB3611
+13 ; Request MRA bill status
IF $PIECE($GET(^DGCR(399,IBIFN,0)),U,13)'=2
GOTO ELIGX
+14 ; filing errors - contains Message Storage Errors
IF $DATA(^IBM(361.1,IBEOB,"ERR"))
SET ELIG=$SELECT('$GET(IBMRANOT):-1,1:ELIG)
GOTO ELIGX
+15 ;
+16 ; this EOB is eligible for the worklist
SET ELIG=1
+17 ;
ELIGX ;
+1 QUIT ELIG
+2 ;
WLRMV ; REMOVE FROM EOB WORK LIST
+1 ; IBDA(IBDA)=IBIFN^IB364^ien of 361.1^user selection seq^user name~duz#
+2 NEW IBIFN,IBDA,DIR,DTOUT,DUOUT,DA,DIE,DR,X
+3 DO SEL^IBCECOB2(.IBDA,1)
+4 SET VALMBCK="R"
+5 SET IBDA=$ORDER(IBDA(0))
IF 'IBDA
QUIT
+6 SET IBIFN=$PIECE(IBDA(IBDA),U,1)
IF 'IBIFN
QUIT
+7 SET DIR("A",1)=""
+8 SET DIR("A",2)=" Bill #: "_$$GET1^DIQ(399,IBIFN_", ",.01,"E")
+9 SET DIR("A",3)=" Patient: "_$$GET1^DIQ(399,IBIFN_", ",.02,"E")
+10 SET DIR("A",4)=" Bill Type: "_$$GET1^DIQ(399,IBIFN_", ",.05,"E")
+11 SET DIR("A",5)="Bill Dates: "_$$GET1^DIQ(399,IBIFN_", ",151,"E")_" - "_$$GET1^DIQ(399,IBIFN_", ",152,"E")
+12 SET DIR("A",6)=" "
+13 SET DIR("A")="Are you sure remove this claim from the worklist? "
+14 SET DIR("B")="NO"
+15 SET DIR(0)="YA"
DO ^DIR
KILL DIR
+16 IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
QUIT
+17 ;FLAG IF USER ANSWERS YES
+18 SET X=$$WLRMVF^IBCECOB1(IBIFN,"RM")
+19 DO BLD^IBCECOB1
+20 QUIT
+21 ;
WLRMVF(IBIFN,METHOD,BKFL) ;
+1 ; BFKL = 1 means background process, remove NOT initiated by a user
+2 NEW SOC,SOCCNT,SOCLIST,STATUS,IBDUZ
+3 SET STATUS=0
+4 if '$GET(DUZ)
QUIT STATUS_"^MISSING DUZ"
+5 if '$GET(IBIFN)
QUIT STATUS_"^MISSING IBIFN"
+6 if '$DATA(^DGCR(399,IBIFN))
QUIT STATUS_"^INVALID IBIFN"
+7 ; if this is a background process, set user who removed to AUTHORIZER,IB REG
+8 SET IBDUZ=$SELECT($GET(BKFL)=1:$$IBREG^IBCAPP(),1:$GET(DUZ))
+9 ; GET DICTIONARY SET OF CODES.
+10 ; SOC("POINTER")="RM:REMOVE ACTION;PC:PROCESS COB ACTION;CL:CLONE ACTION;"
+11 DO FIELD^DID(399,38,"","POINTER","SOC")
+12 SET SOC=$GET(SOC("POINTER"))
+13 FOR SOCCNT=1:1:$LENGTH(SOC,";")-1
SET SOCLIST($PIECE($PIECE(SOC,";",SOCCNT),":",1))=""
+14 if $DATA(SOCLIST(METHOD))=0
QUIT STATUS_"^INVALID METHOD"
+15 SET DA=IBIFN
+16 SET DIE="^DGCR(399,"
+17 ; AUTO PROCESS, NO LONGER ON WORKLIST
SET DR="35////4"
+18 ; WHO REMOVED FROM WORKLIST
if IBDUZ'=-1
SET DR=DR_";"_"37////"_IBDUZ
+19 ; METHOD USED TO REMOVE FROM WORKLIST
SET DR=DR_";"_"38////"_METHOD
+20 ; DATE STAMP WHEN REMOVED FOR WORKLIST
SET DR=DR_";"_"39///NOW"
+21 DO ^DIE
+22 SET STATUS=1
+23 QUIT STATUS
