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

IBCECOB1.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; IBMRANOT = 1 when dealing with the COB Management Worklist.
  1. ; It is set by the entry action in the option file.
  1. ;
  1. BLD ; Build list entrypoint
  1. ;
  1. N I,IB3611,IB364,IBAMT,IBAPY,IBB,IBB364,IBBPY,IBDA,IBDA1,IBDAY
  1. N IBDENDUP,IBDIV,IBDT,IBDTN,IBEOBREV,IBEUT,IBEXPY,IBFND,IBHIS
  1. N IBIFN,IBINS,IBINS1,IBINS2,IBMRACNT,IBMUT,IBNBAL,IBNDI1,IBNDI2
  1. N IBNDI3,IBNDM,IBNDS,IBOAM,IBPTNM,IBPTRSP,IBPY,IBQ,IBSEQ,IBSRVC
  1. N EOBTYPE,MSEFLG,Z,Z0
  1. ;
  1. K ^TMP("IBCECOB",$J),^TMP("IBCECOB1",$J),^TMP("IBCOBST",$J),^TMP("IBCOBSTX",$J)
  1. D CLEAN^VALM10 ; kill data and video control arrays
  1. S (VALMCNT,MSEFLG)=0,IBHIS=""
  1. ; IB*2.0*432 IF not MRA, use new CAP index on 399 file
  1. D:$G(IBMRANOT)=1 CAP^IBCAPP2
  1. ; since 0 is a valid Review Status, init w/null
  1. S IBEOBREV=""
  1. ; get EOB's w/Review Status of 0, 1, 1.5 or 2; If 3 or higher, not needed
  1. I $G(IBMRANOT)'=1 F S IBEOBREV=$O(^IBM(361.1,"AMRA",1,IBEOBREV)) Q:IBEOBREV="" Q:IBEOBREV>2 D
  1. . S IBDA="A" F S IBDA=$O(^IBM(361.1,"AMRA",1,IBEOBREV,IBDA),-1) Q:'IBDA D BLD1
  1. ;
  1. ; no data accumulated
  1. I $O(^TMP("IBCOBST",$J,""))="" D NMAT Q
  1. ;
  1. ; display accumulated data
  1. D SCRN
  1. Q
  1. ;
  1. BLD1 ;
  1. ;
  1. S MSEFLG=$$ELIG(IBDA) Q:'MSEFLG
  1. S IBDENDUP=$$DENDUP^IBCEMU4(IBDA,$G(IBMRANOT))
  1. I '$G(IBMRADUP),IBDENDUP Q ; don't include denied MRAs/EOBs for Duplicate Claim/Service
  1. S IB3611=$G(^IBM(361.1,IBDA,0))
  1. S IBIFN=+IB3611,IB364=$P(IB3611,U,19),IBDT=+$P(IB3611,U,6)
  1. I $D(^TMP("IBCOBSTX",$J,IBIFN)) Q ;show each bill once on the worklist
  1. S IBB=$G(^DGCR(399,IBIFN,0))
  1. ;
  1. ; MRD;IB*2.0*516 - User requested the ability to sort the COB Mgmt
  1. ; Worklist by Division. To enable this, the Division was added as
  1. ; a subscript to the ^TMP("IBCOBST") array. For now, that subscript
  1. ; will always be "UNKNOWN" when building the MRA Worklist. To turn
  1. ; on sort-by-division for the MRA Worklist, uncomment out the fol-
  1. ; lowing two lines and delete the line Setting IBDIV to "UNKNOWN".
  1. ;S IBDIV=$P(IBB,U,22) I IBDIV="" S IBDIV="UNKNOWN"
  1. ;I $D(^TMP("IBBIL-DIV",$J)),'$D(^TMP("IBBIL-DIV",$J,IBDIV)) Q
  1. S IBDIV="UNKNOWN"
  1. ;
  1. S IBNDS=$G(^DGCR(399,IBIFN,"S")),IBNDI1=$G(^("I1")),IBNDI2=$G(^("I2")),IBNDI3=$G(^("I3")),IBNDM=$G(^("M"))
  1. S IBMUT=+$P(IBNDS,U,8),IBEUT=+$P(IBNDS,U,2)
  1. S IBINS="",IBSEQ=$P(IB3611,U,15)
  1. F I=1:1:3 S Z="IBNDI"_I I @Z D
  1. . N Q
  1. . S Q=(IBSEQ=I)
  1. . I Q S IBINS1=+@Z_U_$P($G(^DIC(36,+@Z,0)),U)
  1. . S IBINS=IBINS_$S(IBINS="":"",1:", ")_$P($G(^DIC(36,+@Z,0)),U)
  1. . Q
  1. ; Get the payer/insurance company that comes after Medicare WNR
  1. ; If WNR is Primary, get the secondary ins. co.
  1. ; If WNR is secondary, get the tertiary ins. co.
  1. D I $P($G(IBINS2),U,2)="" S $P(IBINS2,U,2)="UNKNOWN"
  1. . I $$WNRBILL^IBEFUNC(IBIFN,1) S IBINS2=+IBNDI2_U_$P($G(^DIC(36,+IBNDI2,0)),U) Q
  1. . S IBINS2=+IBNDI3_U_$P($G(^DIC(36,+IBNDI3,0)),U)
  1. . Q
  1. S IBFND=0
  1. ; biller entry not ALL and no biller, then get entered/edited by user
  1. I $D(^TMP("IBBIL",$J)) D Q:'IBFND
  1. . S IBFND=$S($D(^TMP("IBBIL",$J,IBMUT)):IBMUT,$D(^TMP("IBBIL",$J,IBEUT)):IBEUT,1:0)
  1. . Q
  1. S Z=$S(IBFND:IBFND,IBMUT:IBMUT,1:IBEUT)
  1. S IBMUT=$P($G(^VA(200,+Z,0)),U)_"~"_Z
  1. S:'$P(IBMUT,"~",2) IBMUT="UNKNOWN~0"
  1. S IBBPY=+$$COBN^IBCEF(IBIFN),IBQ=1
  1. ;
  1. ;IBQ;1=EOB without subsequent insurer,0=COB,2=0 balance
  1. D ;I IBQ Q
  1. . ;Check for no reimbursable subsequent insurance
  1. . F I=IBBPY+1:1:3 D Q:'IBQ
  1. .. S Z="IBNDI"_I,Z=$G(@Z)
  1. .. I $P($G(^DIC(36,+Z,0)),U,2)="N" S IBQ=0 Q
  1. .. Q
  1. . ;Check if next ins doesn't exist or next bill# already created
  1. . S Z="IBNDI"_(IBBPY+1),Z=$G(@Z)
  1. . I Z,'$P($G(^DGCR(399,IBIFN,"M1")),U,5+IBBPY) S IBQ=0
  1. . Q
  1. ;
  1. ; Days since transmission of latest bill in COB - IBDAY
  1. S IBDAY=+$P($G(^DGCR(399,IBIFN,"TX")),U,2) I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1)
  1. ; if no Last Electronic Extract Date on file 399, get it from file 364
  1. I 'IBDAY D I IBDAY S IBDAY=$$FMDIFF^XLFDT(DT,IBDAY,1) ;calc. the difference
  1. . S IBB364=$$LAST364^IBCEF4(IBIFN) I IBB364'="" S IBDAY=+$P($P($G(^IBA(364,IBB364,0)),U,4),".",1)
  1. ;
  1. S IBAPY=$$TPR^PRCAFN(IBIFN) ; payment on this bill from A/R
  1. S IBEXPY=+$G(^IBM(361.1,IBDA,1)) ; payer paid amount
  1. ; IB*2.0*447 add excess indicator to MRW screen and adjust calcs to include percentages
  1. S IBPTRSP=$S($$MSEDT^IBCEMU4(IBIFN)'="":$$MSPRE^IBCEMU4(IBIFN,1),1:$$PREOBTOT^IBCEU0(IBIFN)) ; patient resp. function
  1. S IBPY=$S(IBAPY:IBAPY,1:IBEXPY)
  1. S IBOAM=+$G(^DGCR(399,IBIFN,"U1")) ; total charges for bill
  1. S IBNBAL=IBOAM-IBPY
  1. I IBNBAL'>0 S IBQ=2
  1. S IBPTNM=$P($G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0)),U) I IBPTNM="" S IBPTNM="UNKNOWN"
  1. S IBSRVC=$P($G(^DGCR(399,IBIFN,"U")),U)
  1. ;
  1. ; MRD;IB*2.0*516 - Added Division as a subscript.
  1. 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)
  1. S:((IBSRT="M")&(Z0="")) Z0="UNKNOWN" ;USE UNKNOWN IF NOT SET - BI;IB*2.0*432
  1. ;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.
  1. 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.
  1. ;
  1. ;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
  1. ;S ^TMP("IBCOBST",$J,Z0,IBIFN,1)=$$EXTERNAL^DILFD(361.1,.13,"",$P(IB3611,"^",13))_", "_$$FMTE^XLFDT($P($P(IB3611,"^",6),"."))_"^"_$P(IB3611,"^",16)
  1. 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
  1. 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)
  1. S ^TMP("IBCOBSTX",$J,IBIFN)=IBDA ;keep track of compiled IBIFN's
  1. ;
  1. ; Save some data when there are multiple MRA's on file for this bill
  1. S IBMRACNT=$$MRACNT^IBCEMU1(IBIFN,$G(IBMRANOT)) ;WCJ IB*2.0*432
  1. ;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
  1. ;S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,3)=IBMRACNT
  1. ;S $P(^TMP("IBCOBST",$J,Z0,IBIFN,1),U,4)=IBDENDUP
  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
  1. S $P(^TMP("IBCOBST",$J,IBDIV,Z0,IBIFN,1),U,3)=IBMRACNT
  1. S $P(^TMP("IBCOBST",$J,IBDIV,Z0,IBIFN,1),U,4)=IBDENDUP
  1. Q
  1. ;
  1. HIS(IBIFN) ; COB history
  1. N A,B,IBST,IBBIL,IBHIS
  1. 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
  1. . 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
  1. . Q:IBBIL=""
  1. . S IBHIS=IBHIS_$S(IBHIS="":"",1:";")_$S(A=1:"PRIMARY",A=2:"SECONDARY",1:"TERTIARY")_" "_$S(IBST:"MRA",1:"EOB")_" RECEIVED - "_IBBIL
  1. Q IBHIS
  1. ;
  1. NMAT ;No COB list
  1. S VALMCNT=2,IBCNT=2
  1. S ^TMP("IBCECOB",$J,1,0)=" "
  1. S ^TMP("IBCECOB",$J,2,0)=" No "_$S($G(IBMRANOT)=1:"EOB's",1:"MRA's")_" Matching Selection Criteria Were Found"
  1. Q
  1. ;
  1. SCRN ;
  1. N IB,IBCNT,IBDA,IBDIV,IBIFN,IBFORM,IBK,IBPAT,IBS1,IBX,MSEFLG,X,Z
  1. ;N IBMRANOTMSE ;TPF;EBILL-2436;IB*2.0*727
  1. N IBMSEFOUND ;TPF;EBILL-3339;IB*2.0*759
  1. ;
  1. S IBCNT=0
  1. ; IB*2.0*547 - Add primary insurance company sort, had to break into 2 lines
  1. 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:"")
  1. S:IBSRT="K" IBS1="PRIMARY INSURANCE COMPANY"
  1. ;
  1. ; MRD;IB*2.0*516 - Added Division as a subscript.
  1. S IBDIV=""
  1. F S IBDIV=$O(^TMP("IBCOBST",$J,IBDIV)) Q:IBDIV="" D
  1. . I IBCNT D SET("",IBCNT+1)
  1. . D SET("Division: "_$$GET1^DIQ(40.8,IBDIV_",",.01,"E"),IBCNT+1)
  1. . ;
  1. . ;S IBX="" F S IBX=$O(^TMP("IBCOBST",$J,IBX)) Q:IBX="" D
  1. . S IBX="" F S IBX=$O(^TMP("IBCOBST",$J,IBDIV,IBX)) Q:IBX="" D
  1. .. ; P547
  1. .. ;I IBSRT="B"!(IBSRT="I")!(IBSRT="M") D
  1. .. I IBSRT="B"!(IBSRT="I")!(IBSRT="M")!(IBSRT="K") D
  1. ... I IBCNT D SET("",IBCNT+1)
  1. ... D SET(IBS1_": "_$P(IBX,"~"),IBCNT+1)
  1. ... Q
  1. .. ;
  1. .. ;S IBIFN=0 F S IBIFN=$O(^TMP("IBCOBST",$J,IBX,IBIFN)) Q:'IBIFN D
  1. .. S IBIFN=0 F S IBIFN=$O(^TMP("IBCOBST",$J,IBDIV,IBX,IBIFN)) Q:'IBIFN D
  1. ... ;S IB=$G(^TMP("IBCOBST",$J,IBX,IBIFN))
  1. ... S IB=$G(^TMP("IBCOBST",$J,IBDIV,IBX,IBIFN))
  1. ... S Z=$G(^DPT(+$P($G(^DGCR(399,IBIFN,0)),U,2),0))
  1. ... S IBPAT=$$LJ^XLFSTR($E($P(Z,U),1,18),18," ")_" "_$E($P(Z,U,9),6,9)
  1. ... S IBDA=$P(IB,U,10) ;361.1-ien
  1. ... S IBQ=$P(IB,U,14),IB364=$P(IB,U,15)
  1. ... ; IB*2.0*447 shorten form column to I for Instutional and P for Professional
  1. ... ;S IBFORM=$$EXTERNAL^DILFD(399,.19,,+$P(IB,U,6))
  1. ... ;I +$P(IB,U,6)=2 S IBFORM=1500 ; for space reasons
  1. ... ;JWS;IB*2.0*592;Add 'D' for Dental display
  1. ... S IBFORM=$S(+$P(IB,U,6)=2:"P",+$P(IB,U,6)=7:"D",1:"I")
  1. ... S IBPTRSP=$P(IB,U,18)
  1. ... S MSEFLG=$P(IB,U,19)
  1. ... S IBAMT=$P(IB,U,2)
  1. ... S IBCNT=IBCNT+1
  1. ... S X=""
  1. ... ;
  1. ... ;TPF;EBILL-2436;IB*2.0*727 ADD FLAG FOR MSE ERROR
  1. ... ;S IBMRANOTMSE=$$GET1^DIQ(399,IBIFN_",",36,"","","")="IB803" ;EOB CLAIM MSE ERROR?
  1. ... ;S IBMRANOTMSE=$$FILERR^IBCAPP2(IBIFN) ;TPF;EBILL-3061;IB*2.0*727 v15
  1. ... S IBMSEFOUND=$$FILERR^IBCAPP2(IBIFN) ;TPF;EBILL-3339;IB*2.0*759
  1. ... ;
  1. ... S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
  1. ... ;;;S X=$$SETFLD^VALM1($$BN1^PRCAFN(IBIFN)_$S($P($G(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL")
  1. ... ;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
  1. ... ;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
  1. ... 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
  1. ... S X=$$SETFLD^VALM1($$DAT1^IBOUTL($P(IB,U)),X,"SERVICE")
  1. ... S X=$$SETFLD^VALM1(IBPAT,X,"PATNM")
  1. ... S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBPTRSP,"",2),9," "),X,"PTRESP")
  1. ... S X=$$SETFLD^VALM1($$RJ^XLFSTR($FN(IBAMT,"",2),9," "),X,"IBAMT")
  1. ... S X=$$SETFLD^VALM1($E($$TYPE^IBJTLA1($P(IB,U,5)))_"/"_IBFORM,X,"BTYPE")
  1. ... D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
  1. ... ;
  1. ... ;For R (Pt Resp), P (Pt Name) and S (Service Date) don't display sub-headers
  1. ... ;I "BIMRPS"'[IBSRT D IB*2.0*547
  1. ... I "BIMRPSK"'[IBSRT D
  1. .... S Z=$S(IBSRT="L":$$DAT1^IBOUTL(IBX),IBSRT="D":-IBX,1:IBX)
  1. .... D SET(" "_IBS1_": "_Z,IBCNT)
  1. .... Q
  1. ... S X=$$SETSTR^VALM1("Insurers: "_$P(IB,U,9),"",7,74)
  1. ... D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
  1. ... ;
  1. ... ; line 3 of display: MRA status/date/split claim indicator
  1. ... S X=$$SETSTR^VALM1($S($G(IBMRANOT):"EOB",1:"MRA")_" Status: ","",5,13)
  1. ... ;S IBK=$G(^TMP("IBCOBST",$J,IBX,IBIFN,1))
  1. ... S IBK=$G(^TMP("IBCOBST",$J,IBDIV,IBX,IBIFN,1))
  1. ... S X=$$SETSTR^VALM1($P(IBK,U,1),X,18,63)
  1. ... I $P(IBK,U,2)=2 S X=$$SETSTR^VALM1("** SPLIT CLAIM **",X,63,18)
  1. ... 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)
  1. ... D SET(X,IBCNT,IBIFN,IBDA,IBQ,IB364,IBX,IB)
  1. ... ; conditionally update video attributes of line 3
  1. ... I '$D(IOINHI) D ENS^%ZISS
  1. ... ; split claim
  1. ... I $P(IBK,U,2)=2 D CNTRL^VALM10(VALMCNT,63,17,IOINHI,IOINORM)
  1. ... ; multiple mra's on file
  1. ... I $P(IBK,U,3)>1 D CNTRL^VALM10(VALMCNT,18,22,IOINHI,IOINORM)
  1. ... ; Denied for Duplicate - no split claim and single MRA only
  1. ... I $P(IBK,U,4),$P(IBK,U,2)'=2,$P(IBK,U,3)=1 D CNTRL^VALM10(VALMCNT,54,26,IOINHI,IOINORM)
  1. ... Q
  1. .. Q
  1. . Q
  1. ;
  1. Q
  1. ;
  1. SET(X,CNT,IBIFN,IBDA,IBQ,IB364,IBX,IB) ;set up list manager screen array
  1. S VALMCNT=VALMCNT+1
  1. S ^TMP("IBCECOB",$J,VALMCNT,0)=X
  1. S ^TMP("IBCECOB",$J,"IDX",VALMCNT,CNT)=""
  1. 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
  1. Q
  1. ;
  1. FTYPE(Y) ;type classification
  1. Q $E($P($G(^IBE(353,Y,0)),U),1,8)
  1. ;
  1. PTRESPI(IBEOB) ; Function - Computes the Patient's Responsibility based on IBEOB
  1. ; of 361.1 for Claims/Bills with form type 3=UB
  1. ; Input IBEOB - a single EOB ien; Required
  1. ; Output - Function Returns IBPTRES - Patient Responsibility Amount for the EOB
  1. ;
  1. N IBPTRES,IBC,EOBADJ
  1. S IBPTRES=0,IBEOB=+$G(IBEOB)
  1. I 'IBEOB Q IBPTRES ;PTRESPI
  1. ; filing error
  1. Q:$D(^IBM(361.1,IBEOB,"ERR")) IBPTRES
  1. ;
  1. ; get claim level adjustments
  1. K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10)
  1. S IBPTRES=$$CALCPR^IBCEU0(.EOBADJ)
  1. ;
  1. ; get line level adjustments
  1. S IBC=0 F S IBC=$O(^IBM(361.1,IBEOB,15,IBC)) Q:'IBC D
  1. . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,15,IBC,1)
  1. . S IBPTRES=IBPTRES+$$CALCPR^IBCEU0(.EOBADJ)
  1. Q IBPTRES
  1. ;
  1. ELIG(IBEOB) ; Function to determine if an EOB entry is eligible for
  1. ; inclusion on the MRA or COB management worklist or not.
  1. ; IBEOB - ien into file 361.1 (required)
  1. ; Returns 1 if EOB should appear on the worklist
  1. ; Returns 0 if EOB should not appear on the worklist
  1. ; Returns -1 if EOB contains Message Storage Errors
  1. ;
  1. NEW ELIG,IB3611,IBIFN
  1. S ELIG=0,IBEOB=+$G(IBEOB)
  1. S IB3611=$G(^IBM(361.1,IBEOB,0))
  1. I $P(IB3611,U,4)'=1 G ELIGX ; eob type must be correct for this worklist
  1. I $P(IB3611,U,16)>2 G ELIGX ; review status must be <= 2
  1. S IBIFN=+IB3611
  1. I $P($G(^DGCR(399,IBIFN,0)),U,13)'=2 G ELIGX ; Request MRA bill status
  1. I $D(^IBM(361.1,IBEOB,"ERR")) S ELIG=$S('$G(IBMRANOT):-1,1:ELIG) G ELIGX ; filing errors - contains Message Storage Errors
  1. ;
  1. S ELIG=1 ; this EOB is eligible for the worklist
  1. ;
  1. ELIGX ;
  1. Q ELIG
  1. ;
  1. WLRMV ; REMOVE FROM EOB WORK LIST
  1. ; IBDA(IBDA)=IBIFN^IB364^ien of 361.1^user selection seq^user name~duz#
  1. N IBIFN,IBDA,DIR,DTOUT,DUOUT,DA,DIE,DR,X
  1. D SEL^IBCECOB2(.IBDA,1)
  1. S VALMBCK="R"
  1. S IBDA=$O(IBDA(0)) I 'IBDA Q
  1. S IBIFN=$P(IBDA(IBDA),U,1) I 'IBIFN Q
  1. S DIR("A",1)=""
  1. S DIR("A",2)=" Bill #: "_$$GET1^DIQ(399,IBIFN_", ",.01,"E")
  1. S DIR("A",3)=" Patient: "_$$GET1^DIQ(399,IBIFN_", ",.02,"E")
  1. S DIR("A",4)=" Bill Type: "_$$GET1^DIQ(399,IBIFN_", ",.05,"E")
  1. S DIR("A",5)="Bill Dates: "_$$GET1^DIQ(399,IBIFN_", ",151,"E")_" - "_$$GET1^DIQ(399,IBIFN_", ",152,"E")
  1. S DIR("A",6)=" "
  1. S DIR("A")="Are you sure remove this claim from the worklist? "
  1. S DIR("B")="NO"
  1. S DIR(0)="YA" D ^DIR K DIR
  1. I $D(DTOUT)!$D(DUOUT)!'Y Q
  1. ;FLAG IF USER ANSWERS YES
  1. S X=$$WLRMVF^IBCECOB1(IBIFN,"RM")
  1. D BLD^IBCECOB1
  1. Q
  1. ;
  1. WLRMVF(IBIFN,METHOD,BKFL) ;
  1. ; BFKL = 1 means background process, remove NOT initiated by a user
  1. N SOC,SOCCNT,SOCLIST,STATUS,IBDUZ
  1. S STATUS=0
  1. Q:'$G(DUZ) STATUS_"^MISSING DUZ"
  1. Q:'$G(IBIFN) STATUS_"^MISSING IBIFN"
  1. Q:'$D(^DGCR(399,IBIFN)) STATUS_"^INVALID IBIFN"
  1. ; if this is a background process, set user who removed to AUTHORIZER,IB REG
  1. S IBDUZ=$S($G(BKFL)=1:$$IBREG^IBCAPP(),1:$G(DUZ))
  1. ; GET DICTIONARY SET OF CODES.
  1. ; SOC("POINTER")="RM:REMOVE ACTION;PC:PROCESS COB ACTION;CL:CLONE ACTION;"
  1. D FIELD^DID(399,38,"","POINTER","SOC")
  1. S SOC=$G(SOC("POINTER"))
  1. F SOCCNT=1:1:$L(SOC,";")-1 S SOCLIST($P($P(SOC,";",SOCCNT),":",1))=""
  1. Q:$D(SOCLIST(METHOD))=0 STATUS_"^INVALID METHOD"
  1. S DA=IBIFN
  1. S DIE="^DGCR(399,"
  1. S DR="35////4" ; AUTO PROCESS, NO LONGER ON WORKLIST
  1. S:IBDUZ'=-1 DR=DR_";"_"37////"_IBDUZ ; WHO REMOVED FROM WORKLIST
  1. S DR=DR_";"_"38////"_METHOD ; METHOD USED TO REMOVE FROM WORKLIST
  1. S DR=DR_";"_"39///NOW" ; DATE STAMP WHEN REMOVED FOR WORKLIST
  1. D ^DIE
  1. S STATUS=1
  1. Q STATUS