- 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 Jan 18, 2025@03:10:52 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