IBJTEP ;ALB/TJB - TP ERA/835 INFORMATION SCREEN ;20 Dec 2018 14:47:23
;;2.0;INTEGRATED BILLING;**530,609,633,639,642**;21-MAR-94;Build 22
;Per VA Directive 6402, this routine should not be modified.
;
EN ; -- main entry point for IBJT ERA 835 INFORMATION
D EN^VALM("IBJT ERA 835 INFORMATION")
Q
;
HDR ; -- header code
N IBRP,IBREJ S IBRP(U)=", "
; Add the EEOB, Reject and ECME indicators to the Bill
S IBREJ=$S($$BILLREJ^IBJTU6(EPBILL):"c",1:"")
S VALMHDR(1)=$$EEOB^IBJTLA1(IBIFN)_IBREJ_EPBILL_$$ECME^IBTRE(IBIFN)_" "_$E(EPNM,1,20)_" "_EPSS_" DOB: "_EPDOB_" Subsc ID: "_EPSID
S VALMHDR(2)="Svc Date: "_EPDOS_" Orig Amt: "_EPAMT_" ERA#: "_$$REPLACE^XLFSTR(ERALST,.IBRP)
Q
;
INIT ; -- init variables and list array
N AQ,EPIEN,EPTN,ERADA,ERAIEN,EPARR,EPPCT,EOBCT,EOBLST,EOBMX,FL,IBAR,IBI,IBCOL,IBEBERA,IBRX,IBSHEOB,IBSPEOB ; IB*2.0*633
N II,LINE,QQ,RCBAMT,RCCOPY,RCRC,RCOIN,RCDED,RCERR,RCFLD,RMIEN,RCRDC,RCRLN,RCXY,RCMD,REMOVED,X,XX,Z
S EOBMX=0
S ERALST="",$P(SP80," ",80)=" "
; IBIFN comes in from the TPJI screen and will be cleaned up there
I '$G(IBIFN) S VALMQUIT="" G INITQ
K EPARR D BILL^IBRFN3(IBIFN,.EPARR) ; Get Bill information
S EPBILL=EPARR("BN") ; K-Bill
S EPPAT=$$GET1^DIQ(399,IBIFN_",",.02,"I") ; Get Patient IEN
S EPNM=$$GET1^DIQ(399,IBIFN_",",.02) ; Get Patient Name
; Get Total Charges and justify the amount
S EPAMT=$J(+EPARR("TCG"),$L(+EPARR("TCG")),2)
S EPSS=$E(EPNM)_$$GET1^DIQ(2,EPPAT_",",.364) ; Get Short SSN
S EPDOB=$$GET1^DIQ(2,EPPAT_",",.03) ; Get DOB
S EPSID=$P(EPARR("PIN"),U,6) ; Get Subscriber ID
S EPDOS=$$FMTE^XLFDT(EPARR("STF"),"5DZ") ; Get Date of Service
S:EPARR("STF")'=EPARR("STT") EPDOS=EPDOS_" - "_$$FMTE^XLFDT(EPARR("STT"),"5DZ") ; If Bill for date range
; Check to see if we may have an EEOB if not report no ERA Information for this K-Bill
S EPIEN=$O(^IBM(361.1,"B",$G(IBIFN),"")) I EPIEN="" S VALMCNT=2 D SET^VALM10(1," "),SET^VALM10(2,"No ERA Information for Bill: "_EPBILL) G INITQ
; Get % Collected from AR claim - IA 1452 - IB*2.0*609
S IBAR=$$BILL^RCJIBFN2(IBIFN),IBCOL=$P(IBAR,U,5)
; Collect all possible EOBs associated with this Claim
S ERAIEN=""
; IB*2.0*633 - Start modified block
S IBSHEOB=0,IBI=0,RCCOPY=0
F S IBI=$O(^IBM(361.1,"B",IBIFN,IBI)) Q:'IBI D ;
. S IBSHEOB=IBSHEOB+1,IBSHEOB(IBI)=0
. ; For each EOB get the associated ERAs from ADET index
. S ERAIEN="" F S ERAIEN=$O(^RCY(344.4,"ADET",IBI,ERAIEN)) Q:'ERAIEN D ;
. . S IBSHEOB(IBI,ERAIEN)=""
. ; PRCA*4.5*332 - Start modified code block
. I $O(IBSHEOB(IBI,""))="" D ; EOB not assocated with an ERA. Check if it was copied.
. . I $$GET1^DIQ(361.1,IBI_",",.17,"I") Q ; Ignore manually entered EOB
. . S X=$O(^IBM(361.1,IBI,101,"A"),-1)
. . I X,$$GET1^DIQ(361.1101,X_","_IBI_",",.05,"I")="C" D ; EOB is a copy
. . . S RCCOPY=RCCOPY+1
. . . S RCCOPY(RCCOPY)=IBI
; IB*2.0*633 - End modified block
; Loop on the IEN for the EEOBs - exclude MRAs, but include all insurances
S EPIEN="",LINE=0,EOBCT=0
F S EPIEN=$O(IBSHEOB(EPIEN)) Q:EPIEN="" S ERADA="" F S ERADA=$O(IBSHEOB(EPIEN,ERADA)) Q:'ERADA D ; IB*2.0*633
. Q:$P($G(^IBM(361.1,EPIEN,0)),U,4)=1 ; Get next because this is an MRA
. S EPTN=$$GET1^DIQ(361.1,EPIEN_",",.07),ERAIEN=ERADA_"," ; IB*2.0*633
. Q:U_ERALST_U[(U_ERAIEN_U) ; Quit if we have already reported this ERA #
. K IBEPAR,IBPLB
. D GETS^DIQ(344.4,ERAIEN,".01;.02;.03;.04;.05;.06;.07;.08;.09;.1;.11;.12;.13;.14;.15;4.02;","E","IBEPAR")
. D GETS^DIQ(344.4,ERAIEN,"2*;","E","IBPLB") ; ERA Level Adjustments
. Q:$D(IBEPAR)'>0 ; No IBEPAR - no data done with this record.
. S ERALST=$$PUSH(ERALST,ERAIEN) S XLN="ERA#: "_$G(IBEPAR("344.4",ERAIEN,".01","E")),XSP=$E(SP80,1,(22-$L(XLN)))
. S EPPCT=$S($G(EPARR("TCG"))>0:($G(IBEPAR("344.4",ERAIEN,".05","E"))/EPARR("TCG"))*100,1:0)
. D SET(.LINE,"** ERA SUMMARY DATA ** ")
. D SET(.LINE,XLN_XSP_"TRACE#: "_$G(IBEPAR("344.4",ERAIEN,".02","E")))
. ; Holding onto the line below because the change of calculation
. ; S XLN="ERA DATE (PAYER): "_$G(IBEPAR("344.4",ERAIEN,".04","E"))_" TOTAL AMT PD: "_$J($G(IBEPAR("344.4",ERAIEN,".05","E")),9)_" % COLLECTED: "_$J(EPPCT,6,2)
. S XLN="ERA DATE (PAYER): "_$G(IBEPAR("344.4",ERAIEN,".04","E"))_" TOTAL AMT PD: "_$J($G(IBEPAR("344.4",ERAIEN,".05","E")),9)
. D SET(.LINE,XLN)
. D SET(.LINE,"PAYER NAME/TIN: "_$G(IBEPAR("344.4",ERAIEN,".06","E"))_"/"_$G(IBEPAR("344.4",ERAIEN,".03","E")))
. D SET(.LINE,"FILE DATE/TIME: "_$G(IBEPAR("344.4",ERAIEN,".07","E")))
. D SET(.LINE,"EFT MATCH STATUS: "_$G(IBEPAR("344.4",ERAIEN,".09","E")))
. S XLN="ERA TYPE: "_$G(IBEPAR("344.4",ERAIEN,".1","E")),XSP=$E(SP80,1,(40-$L(XLN)))
. D SET(.LINE,XLN_XSP_"INDIVIDUAL EOB COUNT: "_$G(IBEPAR("344.4",ERAIEN,".11","E")))
. S XLN="MAIL MESSAGE: "_$G(IBEPAR("344.4",ERAIEN,".12","E")),XSP=$E(SP80,1,(40-$L(XLN)))
. D SET(.LINE,XLN_XSP_"CHECK#: "_$G(IBEPAR("344.4",ERAIEN,".13","E")))
. S XLN="DETAIL POST STATUS: "_$G(IBEPAR("344.4",ERAIEN,".14","E")),XSP=$E(SP80,1,(40-$L(XLN)))
. D SET(.LINE,XLN_XSP_"EXPECTED PAYMENT METHOD CODE: "_$G(IBEPAR("344.4",ERAIEN,".15","E")))
. D SET(.LINE," ")
. D SET(.LINE,"********** ERA LEVEL ADJUSTMENTS **********")
. I $D(IBPLB)=0 D SET(.LINE," -- NONE --")
. D:$D(IBPLB)'=0 ; If we have PLB Data report it
.. S FL="",RCF=0 F S FL=$O(IBPLB(344.42,FL)) Q:FL="" D
... I RCF'=0 D SET(.LINE," ")
... S RCF=RCF+1
... S XLN=" ADJUSTMENT REASON CODE: "_IBPLB(344.42,FL,.02,"E"),XSP=$E(SP80,1,(45-$L(XLN)))
... I $G(IBPLB(344.42,FL,.02,"E"))'="" S ACT=$$FIND1^DIC(345.1,,"B",IBPLB(344.42,FL,.02,"E")),ACT=$$GET1^DIQ(345.1,ACT,.05)
... D SET(.LINE,XLN_XSP_"ADJUSTMENT AMOUNT: "_$J(IBPLB(344.42,FL,.03,"E"),9))
... D SET(.LINE," ADJUSTMENT CODE TEXT: "_ACT)
... D SET(.LINE," REFERENCE: "_IBPLB(344.42,FL,.01,"E"))
. D SET(.LINE," ")
. K IBEBERA S ZZEPIEN=EPIEN D EEOB^IBJTEP1("IBEBERA",ERAIEN,EPBILL,1)
. F EOBCT=1:1:IBEBERA D
.. S EPIEN=$O(IBEBERA(EOBCT,""))
.. I EPIEN,'$D(EOBLST(EPIEN)) D ;
... D EOBDET(EPIEN,0,EOBCT,IBEBERA,ERAIEN) ; PRCA*4.5*332
... S EOBLST(EPIEN)=""
. D SET(.LINE,$TR(SP80," ","="))
. S EPIEN=ZZEPIEN
I RCCOPY D ;
. S (X,XX)=0 F S X=$O(RCCOPY(X)) Q:'X D ; Display copied EOBs - PRCA*4.5*332
. . I '$D(EOBLST(RCCOPY(X))) D ;
. . . D EOBDET(RCCOPY(X),1,X,RCCOPY,"")
. . . S EOBLST(RCCOPY(X))="",XX=XX+1
. I XX D SET(.LINE,$TR(SP80," ","="))
; No EEOB IEN, then report that No ERA recieved for this bill
I LINE=0 S VALMCNT=2 D SET^VALM10(1," "),SET^VALM10(2,"No ERA Information for Bill: "_EPBILL) G INITQ
S VALMCNT=LINE
;
INITQ K IBEPAR,IBPLB,IBEOB,IBDGCR,IBGX,IBSPL,IBEERR,TT,AA,EE,RCPL,ACT,ACNT,CC,XLN,XSP,XSP1,TSDT,TEDT,TRX,TECME,RCF,SP80,X,ZZEPIEN
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K EPBILL,EPEOB,ERALST,EPPAT,EPNM,EPSS,EPDOB,EPDOS,EPSID,EPAMT,EPARR
D CLEAR^VALM1,CLEAN^VALM10
Q
;
EXPND ; -- expand code
Q
;
PUSH(VAR,VALUE) ;
S VALUE=$TR(VALUE,",") ; Remove Commas from string
Q:$G(VAR)="" VALUE ; Empty variable
; If this VALUE is on the list don't add it a second time
I U_VAR_U[(U_VALUE_U) Q VAR
Q VAR_U_VALUE
;
; IB*2.0*642 - 2020/02/05:DM removed to meet SAC line limit
; Get the code modifier description
;MODC(MCD) ;
; Q:$G(MCD)="" "No Modifier Code Description"
; N ZZIEN,ZZDEC
; S ZZIEN=$$FIND1^DIC(81.3,,"BX","26","","","")
; S ZZDEC=$$GET1^DIQ(81.3,ZZIEN_",",.02)
; Q:ZZDEC="" "No Modifier Code Description"
; Q ZZDEC
;
SET(LINE,DATA) ; -- set arrays
; LINE = line number passed by reference
; DATA = string to add to displayed data
S LINE=LINE+1
D SET^VALM10(LINE,$G(DATA))
Q
; PRCA*4.5*332 - Move EOB display into its own subroutine
EOBDET(EPIEN,TYPE,EOBCT,IBEBERA,ERAIEN) ; Add EOB detail to List Manager Array
; Input: EPIEN - Internal entry number to file 361.1
; TYPE - 0 - EEOB associated with an ERA, 1 - Copied EOB created by split/edit or link payment
; EOBCT - Count# of this EOB within the ERA
; IBEBERA - Number of EOBs for this bill in this ERA
; ERAIEN - Internal entry number from file 344.4
;
N IBEOB,IBGX,IBCL,IBDGCR,IBRX,IBSPL,IBEERR,RCTRACE
D GETS^DIQ(361.1,EPIEN_",",".01;.02;.03;.04;.06;.07;.14;1.01;1.02;1.03;1.1;1.11;2.03;2.04;3.03;3.04;3.05;3.06;3.07;102;104","EI","IBEOB")
D GETS^DIQ(361.1,EPIEN_",","10*;","EI","IBGX"),RESORT^IBJTEP1("IBGX",361.111),RESORT^IBJTEP1("IBGX",361.11) ; Claim Level Adjustments
D GETS^DIQ(361.1,EPIEN_",","15*;","EI","IBCL") ; Line Level Adjustments
D GETS^DIQ(361.1,EPIEN_",","8*;","EI","IBSPL") ; ERA Splits for this EEOB
D GETS^DIQ(361.1,EPIEN_",","20;","","IBEERR") ; EOB Errors if they exist
; Make it easier to walk the data
D RESORT^IBJTEP1("IBCL",361.11511),RESORT^IBJTEP1("IBCL",361.115),RESORT^IBJTEP1("IBCL",361.1151)
D RESORT^IBJTEP1("IBCL",361.1152),RESORT^IBJTEP1("IBCL",361.1154)
D GETS^DIQ(399,IBEOB(361.1,EPIEN_",",.01,"I")_",","460;","EI","IBDGCR")
S RCTRACE=$G(IBEOB("361.1",EPIEN_",",".07","E"))
I ERAIEN="",RCTRACE'="" S ERAIEN=$O(^RCY(344.4,"D",RCTRACE,""))
D SET(.LINE,"********** "_$S(TYPE=0:"",1:"COPIED ")_"EOB/835 INFORMATION ("_EOBCT_" of "_IBEBERA_") **********")
I $G(IBEOB("361.1",EPIEN_",","102","I")) D Q ; EOB Removed
. D EOBREM^IBJTEP1(EPIEN,.LINE)
. D SET(.LINE,$TR(SP80," ","-"))
;
I $G(ERADA) D ; ORIGINAL PATIENT NAME added in IB*2.0*639
. S ERAIEN("p344.41")=$O(^RCY(344.4,ERADA,1,"AC",EPIEN,0))
. I ERAIEN("p344.41") D ; POINTER TO ERA DETAIL 344.41
. . S XLN=" Free Text Patient Name: "_$$GET1^DIQ(344.41,ERAIEN("p344.41")_","_ERADA_",",.15,"E")
. . D SET(.LINE,XLN)
E D ;
. S ERAIEN("p344.41")=$G(IBEOB("361.1",EPIEN_",","104","E"))
. I ERAIEN("p344.41")'="" D ;
. . S XLN=" Free Text Patient Name: "_$$GET1^DIQ(344.41,ERAIEN("p344.41"),.15,"E")
. . D SET(.LINE,XLN)
;
S XLN=" EOB Type: "_$G(IBEOB("361.1",EPIEN_",",".04","E")),XSP=$E(SP80,1,(40-$L(XLN)))
D SET(.LINE,XLN_XSP_"EOB Paid Date: "_$G(IBEOB("361.1",EPIEN_",",".06","E")))
S TSDT=$$FMTE^XLFDT($G(IBEOB("361.1",EPIEN_",","1.1","I")),"2Z"),TEDT=$$FMTE^XLFDT($G(IBEOB("361.1",EPIEN_",","1.11","I")),"2Z"),XLN=" Svc From Date: "_TSDT,XSP=$E(SP80,1,(40-$L(XLN)))
D SET(.LINE,XLN_XSP_"Svc to Date: "_TEDT)
D SET(.LINE," ICN: "_$G(IBEOB("361.1",EPIEN_",",".14","E")))
D SET(.LINE," Payer Name/TIN: "_$G(IBEOB("361.1",EPIEN_",",".02","E"))_"/"_$G(IBEOB("361.1",EPIEN_",",".03","E")))
I ERAIEN D ;
. S XLN=" ERA #: "_$$GET1^DIQ(344.4,ERAIEN_",",".01","E"),XSP=$E(SP80,1,(40-$L(XLN)))
. D SET(.LINE,XLN_XSP_"Auto-Post Status: "_$$GET1^DIQ(344.4,ERAIEN_",","4.02","E"))
. D SET(.LINE," Trace #: "_$$GET1^DIQ(344.4,ERAIEN_",",".02","E"))
E D ;
. D SET(.LINE," Trace #: "_RCTRACE)
S TECME=$P($G(IBDGCR(399,IBEOB(361.1,EPIEN_",",.01,"I")_",",460,"E")),";",1)
D GETRX^IBJTEP1(EPIEN,.IBRX)
S TRX=$$GET1^DIQ(52,+TECME_",",".01")_"/"_$G(IBRX("FILL"))_"/"_$G(IBRX("RELEASED STATUS"))
I TECME="" S TRX=""
S XLN=" ECME #: "_TECME,XSP=$E(SP80,1,(25-$L(XLN))),XSP1=$E(SP80,1,(39-$L(XLN_XSP_"DOS: "_$G(IBRX("DOS")))))
D SET(.LINE,XLN_XSP_"DOS: "_$G(IBRX("DOS"))_XSP1_"Rx/Fill/Release Status: "_TRX)
D SET(.LINE,"--------------------------------------------------------------------------------")
D:$D(IBSPL)>1 ; This EEOB was split display split payment information
. N SPL
. D SET(.LINE,"** A/R CORRECTED PAYMENT DATA:")
. D SET(.LINE," TOTAL AMT PD: "_$J(IBEOB(361.1,EPIEN_",",1.01,"E"),9,2))
. S SPL="" F S SPL=$O(IBSPL(361.18,SPL)) Q:SPL="" D
.. D SET(.LINE," "_$S(IBSPL(361.18,SPL,.03,"I")'="":$$BN1^PRCAFN(IBSPL(361.18,SPL,.03,"I"))_$J("",8),1:"[suspense] "_IBSPL(361.18,SPL,.01,"E"))_" "_$J(IBSPL(361.18,SPL,.02,"E"),9,2))
. D SET(.LINE," ")
D SET(.LINE,"CLAIM LEVEL PAY STATUS:")
D SET(.LINE," Total Submitted Charges :"_$J($G(IBEOB("361.1",EPIEN_",","2.04","E")),11,2)_" Payer Covered Amount :"_$J($G(IBEOB("361.1",EPIEN_",","1.03","E")),11,2))
D SET(.LINE," Payer Paid Amount :"_$J($G(IBEOB("361.1",EPIEN_",","1.01","E")),11,2)_" MEDICARE Allowed Amount :"_$J($G(IBEOB("361.1",EPIEN_",","2.03","E")),11,2))
D SET(.LINE," Patient Responsibility :"_$J($G(IBEOB("361.1",EPIEN_",","1.02","E")),11,2)_" % Collected :"_$J(+IBCOL,11,0)_" %") ; IB*2.0*609
D SET(.LINE,$TR(SP80," ","-"))
D SET(.LINE,"CLAIM LEVEL ADJUSTMENTS:")
S AA="",ACNT=0 F S AA=$O(IBGX(361.11,AA)) Q:AA="" S ACNT=ACNT+1,AQ="" D
. S CC=AA F S CC=$O(IBGX(361.111,CC)) Q:$E(CC,1,$L(AA))'=AA D
.. I AQ="" S AQ=$J(ACNT,3)_") "
.. E S ACNT=ACNT+1,AQ=$J(ACNT,3)_") "
.. D SET(.LINE,AQ_"ADJ. AMT: "_$J(IBGX(361.111,CC,.02,"E"),9,2)_" ADJ GROUP: "_IBGX(361.11,AA,.01,"I")_" => "_IBGX(361.11,AA,.01,"E"))
.. S RMIEN=$$FIND1^DIC(345,"","BX",IBGX(361.111,CC,.01,"E"),"","","RCERR")
.. I RMIEN'="" K RCERR,RCRDC,RCFLD S RCXY=$$GET1^DIQ(345,RMIEN_",",4,"","RCRDC","RCERR") D DLN^IBJTEP1("RCRDC","RCFLD",55,69)
.. D SET(.LINE," ADJ. CODE: "_IBGX(361.111,CC,.01,"E")_" => "_RCFLD(1))
.. I RCFLD>1 F II=2:1:RCFLD D SET(.LINE," "_RCFLD(II))
I ACNT=0 D SET(.LINE," -- None --")
D SET(.LINE,"CLAIM LEVEL REMARKS: ")
S RCRC=0 F II="3.03","3.04","3.05","3.06","3.07" D:IBEOB("361.1",EPIEN_",",II,"E")'=""
. ; Get IEN for this remark code - if no IEN then need to look at the data "RM1" to "RM5"
. S RMIEN=$$FIND1^DIC(346,"","BX",IBEOB("361.1",EPIEN_",",II,"E"),"","","RCERR")
. I RMIEN'="" K RCERR,RCRDC,RCFLD S RCXY=$$GET1^DIQ(346,RMIEN_",",4,"","RCRDC","RCERR") D DLN^IBJTEP1("RCRDC","RCFLD",57,69)
. I RMIEN="" S RCFLD=$S(II="3.03":5.011,II="3.04":5.021,II="3.05":5.031,II="3.06":5.041,II="3.07":5.051,1:5.011) S RCRLN=$$GET1^DIQ(361.1,EPIEN_",",RCFLD)
. S RCRC=RCRC+1 D SET(.LINE," --- REMARK CODE("_RCRC_"): "_IBEOB("361.1",EPIEN_",",II,"E")_" => "_RCFLD(1))
. I RCFLD>1 F II=2:1:RCFLD D SET(.LINE," "_RCFLD(II))
I RCRC=0 D SET(.LINE," -- None --")
D SET(.LINE,$TR(SP80," ","-"))
; Walk through the line level information...
D SET(.LINE,"EEOB LINE LEVEL ADJUSTMENTS:")
K ^XTMP("IBJTEP",$J) M ^XTMP("IBJTEP",$J)=IBCL
S RCPL=0,EE="" F S EE=$O(IBCL(361.115,EE)) Q:EE="" S RCPL=RCPL+1 D
. S QQ=EE,RCMD="" F S QQ=$O(IBCL(361.1152,QQ)) Q:$E(QQ,1,$L(EE))'=EE S RCMD=IBCL(361.1152,QQ,.01,"I")
. D SET(.LINE," # SV DT REVCD PROC MOD UNITS BILLED DEDUCT COINS ALLOW PYMT")
. S RCBAMT=$$BILLN^IBJTEP1(IBEOB(361.1,EPIEN_",",.01,"I"),IBCL(361.115,EE,.1,"E"),IBCL(361.115,EE,.04,"E"))
. S RCDED=$$ADJU^IBJTEP1("DEDUCT",.IBCL,EE),RCOIN=$$ADJU^IBJTEP1("COINS",.IBCL,EE) ; Get Deductable and Co-Insurance amts.
. S XLN=$J(RCPL,2,0)_" "_$$FMTE^XLFDT(IBCL(361.115,EE,.16,"I"),"2Z")_" "_$$CJ^XLFSTR(IBCL(361.115,EE,.1,"E"),5)_" "_$$CJ^XLFSTR(IBCL(361.115,EE,.04,"E"),8)_$$CJ^XLFSTR(RCMD,5)_" "_$$CJ^XLFSTR(IBCL(361.115,EE,.11,"E"),3)
. D SET(.LINE,XLN_" "_$J(RCBAMT,9,2)_$J(RCDED,8,2)_$J(RCOIN,8,2)_$J(IBCL(361.115,EE,.13,"E"),9,2)_$J(IBCL(361.115,EE,.03,"E"),9,2))
. ; IB*2.0*642 - Add logic to display DRG/GRP Adjustment Weight
. ; N SPL S SPL=$$SUPL^IBCECSA7($P(EE,",",2),$P(EE,",")) I SPL]"" D SET(.LINE,SPL)
. D SET(.LINE," ")
. D SET(.LINE," Product/Service Description:"_IBCL(361.115,EE,.09,"E"))
. D SET(.LINE," Payer Policy Reference:"_$G(IBCL(361.11512,EE,.01,"E")))
. D SET(.LINE," ")
. S ACNT=0,AA=EE F S AA=$O(IBCL(361.1151,AA)) Q:$E(AA,1,$L(EE))'=EE D
.. S ACNT=ACNT+1
.. S CC=AA,RCRC=0 F S CC=$O(IBCL(361.11511,CC)) Q:$E(CC,1,$L(AA))'=AA D
... S RCRC=RCRC+1 D SET(.LINE," -> ADJ AMT: "_$J(IBCL(361.11511,CC,.02,"E"),9,2)_" ADJ GROUP: "_IBCL(361.1151,AA,.01,"I")_" - "_IBCL(361.1151,AA,.01,"E")_" "_$$CJ^XLFSTR("QTY: "_+$G(IBCL(361.11511,CC,.03,"E")),8))
... S RCXY=$$FIND1^DIC(345,"","BX",IBCL(361.11511,CC,.01,"E"),"","","RCERR")
... K RCRDC,RCERR S RCXY=$$GET1^DIQ(345,RCXY_",",4,"","RCRDC","RCERR")
... I $D(RCRDC)>0 K RCFLD D DLN^IBJTEP1("RCRDC","RCFLD",57,57)
... I $D(RCRDC)=0 K RCFLD S RCRDC(1)=IBCL(361.11511,CC,.04,"E") D DLN^IBJTEP1("RCRDC","RCFLD",57,57) ; If no data from file 345 use data from FMS
... D SET(.LINE," ADJ CODE: "_$$CJ^XLFSTR(IBCL(361.11511,CC,.01,"E"),5)_" "_RCFLD(1))
... I RCFLD>1 F II=2:1:RCFLD D SET(.LINE," "_RCFLD(II))
. ; Display RARC Codes for this Line Item
. I $D(IBCL(361.1154))'=0 S QQ=EE,RCMD="" F S QQ=$O(IBCL(361.1154,QQ)) Q:$E(QQ,1,$L(EE))'=EE D
.. K RCERR,RCRDC,RCFLD
.. S RMIEN=$$FIND1^DIC(346,"","BX",IBCL(361.1154,QQ,.02,"E"),"","","RCERR")
.. ; avoid "undefined" if RMIEN could not be found *642
.. I 'RMIEN S RCFLD=1,RCFLD(1)="*["_IBCL(361.1154,QQ,.02,"E")_"] code is not on file."
.. I RMIEN S RCXY=$$GET1^DIQ(346,RMIEN_",",4,"","RCRDC","RCERR") D DLN^IBJTEP1("RCRDC","RCFLD",57,68)
.. D SET(.LINE," --- RARC: "_IBCL(361.1154,QQ,.02,"E")_" - "_RCFLD(1))
.. I RCFLD>1 F II=2:1:RCFLD D SET(.LINE," "_RCFLD(II))
. D SET(.LINE," ")
I ACNT=0 D SET(.LINE," -- No Line Level Adjustments --")
; If there are EOB Errors add them to the screen
D:$D(IBEERR(361.1,EPIEN_",",20))>9
. D SET(.LINE," "),SET(.LINE,"EEOB MESSAGE ERRORS:")
. N II S II=0 F S II=$O(IBEERR(361.1,EPIEN_",",20,II)) Q:(II="")!(II'=+II) D SET(.LINE,$G(IBEERR(361.1,EPIEN_",",20,II)))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJTEP 17307 printed Sep 23, 2025@20:00:11 Page 2
IBJTEP ;ALB/TJB - TP ERA/835 INFORMATION SCREEN ;20 Dec 2018 14:47:23
+1 ;;2.0;INTEGRATED BILLING;**530,609,633,639,642**;21-MAR-94;Build 22
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; -- main entry point for IBJT ERA 835 INFORMATION
+1 DO EN^VALM("IBJT ERA 835 INFORMATION")
+2 QUIT
+3 ;
HDR ; -- header code
+1 NEW IBRP,IBREJ
SET IBRP(U)=", "
+2 ; Add the EEOB, Reject and ECME indicators to the Bill
+3 SET IBREJ=$SELECT($$BILLREJ^IBJTU6(EPBILL):"c",1:"")
+4 SET VALMHDR(1)=$$EEOB^IBJTLA1(IBIFN)_IBREJ_EPBILL_$$ECME^IBTRE(IBIFN)_" "_$EXTRACT(EPNM,1,20)_" "_EPSS_" DOB: "_EPDOB_" Subsc ID: "_EPSID
+5 SET VALMHDR(2)="Svc Date: "_EPDOS_" Orig Amt: "_EPAMT_" ERA#: "_$$REPLACE^XLFSTR(ERALST,.IBRP)
+6 QUIT
+7 ;
INIT ; -- init variables and list array
+1 ; IB*2.0*633
NEW AQ,EPIEN,EPTN,ERADA,ERAIEN,EPARR,EPPCT,EOBCT,EOBLST,EOBMX,FL,IBAR,IBI,IBCOL,IBEBERA,IBRX,IBSHEOB,IBSPEOB
+2 NEW II,LINE,QQ,RCBAMT,RCCOPY,RCRC,RCOIN,RCDED,RCERR,RCFLD,RMIEN,RCRDC,RCRLN,RCXY,RCMD,REMOVED,X,XX,Z
+3 SET EOBMX=0
+4 SET ERALST=""
SET $PIECE(SP80," ",80)=" "
+5 ; IBIFN comes in from the TPJI screen and will be cleaned up there
+6 IF '$GET(IBIFN)
SET VALMQUIT=""
GOTO INITQ
+7 ; Get Bill information
KILL EPARR
DO BILL^IBRFN3(IBIFN,.EPARR)
+8 ; K-Bill
SET EPBILL=EPARR("BN")
+9 ; Get Patient IEN
SET EPPAT=$$GET1^DIQ(399,IBIFN_",",.02,"I")
+10 ; Get Patient Name
SET EPNM=$$GET1^DIQ(399,IBIFN_",",.02)
+11 ; Get Total Charges and justify the amount
+12 SET EPAMT=$JUSTIFY(+EPARR("TCG"),$LENGTH(+EPARR("TCG")),2)
+13 ; Get Short SSN
SET EPSS=$EXTRACT(EPNM)_$$GET1^DIQ(2,EPPAT_",",.364)
+14 ; Get DOB
SET EPDOB=$$GET1^DIQ(2,EPPAT_",",.03)
+15 ; Get Subscriber ID
SET EPSID=$PIECE(EPARR("PIN"),U,6)
+16 ; Get Date of Service
SET EPDOS=$$FMTE^XLFDT(EPARR("STF"),"5DZ")
+17 ; If Bill for date range
if EPARR("STF")'=EPARR("STT")
SET EPDOS=EPDOS_" - "_$$FMTE^XLFDT(EPARR("STT"),"5DZ")
+18 ; Check to see if we may have an EEOB if not report no ERA Information for this K-Bill
+19 SET EPIEN=$ORDER(^IBM(361.1,"B",$GET(IBIFN),""))
IF EPIEN=""
SET VALMCNT=2
DO SET^VALM10(1," ")
DO SET^VALM10(2,"No ERA Information for Bill: "_EPBILL)
GOTO INITQ
+20 ; Get % Collected from AR claim - IA 1452 - IB*2.0*609
+21 SET IBAR=$$BILL^RCJIBFN2(IBIFN)
SET IBCOL=$PIECE(IBAR,U,5)
+22 ; Collect all possible EOBs associated with this Claim
+23 SET ERAIEN=""
+24 ; IB*2.0*633 - Start modified block
+25 SET IBSHEOB=0
SET IBI=0
SET RCCOPY=0
+26 ;
FOR
SET IBI=$ORDER(^IBM(361.1,"B",IBIFN,IBI))
if 'IBI
QUIT
Begin DoDot:1
+27 SET IBSHEOB=IBSHEOB+1
SET IBSHEOB(IBI)=0
+28 ; For each EOB get the associated ERAs from ADET index
+29 ;
SET ERAIEN=""
FOR
SET ERAIEN=$ORDER(^RCY(344.4,"ADET",IBI,ERAIEN))
if 'ERAIEN
QUIT
Begin DoDot:2
+30 SET IBSHEOB(IBI,ERAIEN)=""
End DoDot:2
+31 ; PRCA*4.5*332 - Start modified code block
+32 ; EOB not assocated with an ERA. Check if it was copied.
IF $ORDER(IBSHEOB(IBI,""))=""
Begin DoDot:2
+33 ; Ignore manually entered EOB
IF $$GET1^DIQ(361.1,IBI_",",.17,"I")
QUIT
+34 SET X=$ORDER(^IBM(361.1,IBI,101,"A"),-1)
+35 ; EOB is a copy
IF X
IF $$GET1^DIQ(361.1101,X_","_IBI_",",.05,"I")="C"
Begin DoDot:3
+36 SET RCCOPY=RCCOPY+1
+37 SET RCCOPY(RCCOPY)=IBI
End DoDot:3
End DoDot:2
End DoDot:1
+38 ; IB*2.0*633 - End modified block
+39 ; Loop on the IEN for the EEOBs - exclude MRAs, but include all insurances
+40 SET EPIEN=""
SET LINE=0
SET EOBCT=0
+41 ; IB*2.0*633
FOR
SET EPIEN=$ORDER(IBSHEOB(EPIEN))
if EPIEN=""
QUIT
SET ERADA=""
FOR
SET ERADA=$ORDER(IBSHEOB(EPIEN,ERADA))
if 'ERADA
QUIT
Begin DoDot:1
+42 ; Get next because this is an MRA
if $PIECE($GET(^IBM(361.1,EPIEN,0)),U,4)=1
QUIT
+43 ; IB*2.0*633
SET EPTN=$$GET1^DIQ(361.1,EPIEN_",",.07)
SET ERAIEN=ERADA_","
+44 ; Quit if we have already reported this ERA #
if U_ERALST_U[(U_ERAIEN_U)
QUIT
+45 KILL IBEPAR,IBPLB
+46 DO GETS^DIQ(344.4,ERAIEN,".01;.02;.03;.04;.05;.06;.07;.08;.09;.1;.11;.12;.13;.14;.15;4.02;","E","IBEPAR")
+47 ; ERA Level Adjustments
DO GETS^DIQ(344.4,ERAIEN,"2*;","E","IBPLB")
+48 ; No IBEPAR - no data done with this record.
if $DATA(IBEPAR)'>0
QUIT
+49 SET ERALST=$$PUSH(ERALST,ERAIEN)
SET XLN="ERA#: "_$GET(IBEPAR("344.4",ERAIEN,".01","E"))
SET XSP=$EXTRACT(SP80,1,(22-$LENGTH(XLN)))
+50 SET EPPCT=$SELECT($GET(EPARR("TCG"))>0:($GET(IBEPAR("344.4",ERAIEN,".05","E"))/EPARR("TCG"))*100,1:0)
+51 DO SET(.LINE,"** ERA SUMMARY DATA ** ")
+52 DO SET(.LINE,XLN_XSP_"TRACE#: "_$GET(IBEPAR("344.4",ERAIEN,".02","E")))
+53 ; Holding onto the line below because the change of calculation
+54 ; S XLN="ERA DATE (PAYER): "_$G(IBEPAR("344.4",ERAIEN,".04","E"))_" TOTAL AMT PD: "_$J($G(IBEPAR("344.4",ERAIEN,".05","E")),9)_" % COLLECTED: "_$J(EPPCT,6,2)
+55 SET XLN="ERA DATE (PAYER): "_$GET(IBEPAR("344.4",ERAIEN,".04","E"))_" TOTAL AMT PD: "_$JUSTIFY($GET(IBEPAR("344.4",ERAIEN,".05","E")),9)
+56 DO SET(.LINE,XLN)
+57 DO SET(.LINE,"PAYER NAME/TIN: "_$GET(IBEPAR("344.4",ERAIEN,".06","E"))_"/"_$GET(IBEPAR("344.4",ERAIEN,".03","E")))
+58 DO SET(.LINE,"FILE DATE/TIME: "_$GET(IBEPAR("344.4",ERAIEN,".07","E")))
+59 DO SET(.LINE,"EFT MATCH STATUS: "_$GET(IBEPAR("344.4",ERAIEN,".09","E")))
+60 SET XLN="ERA TYPE: "_$GET(IBEPAR("344.4",ERAIEN,".1","E"))
SET XSP=$EXTRACT(SP80,1,(40-$LENGTH(XLN)))
+61 DO SET(.LINE,XLN_XSP_"INDIVIDUAL EOB COUNT: "_$GET(IBEPAR("344.4",ERAIEN,".11","E")))
+62 SET XLN="MAIL MESSAGE: "_$GET(IBEPAR("344.4",ERAIEN,".12","E"))
SET XSP=$EXTRACT(SP80,1,(40-$LENGTH(XLN)))
+63 DO SET(.LINE,XLN_XSP_"CHECK#: "_$GET(IBEPAR("344.4",ERAIEN,".13","E")))
+64 SET XLN="DETAIL POST STATUS: "_$GET(IBEPAR("344.4",ERAIEN,".14","E"))
SET XSP=$EXTRACT(SP80,1,(40-$LENGTH(XLN)))
+65 DO SET(.LINE,XLN_XSP_"EXPECTED PAYMENT METHOD CODE: "_$GET(IBEPAR("344.4",ERAIEN,".15","E")))
+66 DO SET(.LINE," ")
+67 DO SET(.LINE,"********** ERA LEVEL ADJUSTMENTS **********")
+68 IF $DATA(IBPLB)=0
DO SET(.LINE," -- NONE --")
+69 ; If we have PLB Data report it
if $DATA(IBPLB)'=0
Begin DoDot:2
+70 SET FL=""
SET RCF=0
FOR
SET FL=$ORDER(IBPLB(344.42,FL))
if FL=""
QUIT
Begin DoDot:3
+71 IF RCF'=0
DO SET(.LINE," ")
+72 SET RCF=RCF+1
+73 SET XLN=" ADJUSTMENT REASON CODE: "_IBPLB(344.42,FL,.02,"E")
SET XSP=$EXTRACT(SP80,1,(45-$LENGTH(XLN)))
+74 IF $GET(IBPLB(344.42,FL,.02,"E"))'=""
SET ACT=$$FIND1^DIC(345.1,,"B",IBPLB(344.42,FL,.02,"E"))
SET ACT=$$GET1^DIQ(345.1,ACT,.05)
+75 DO SET(.LINE,XLN_XSP_"ADJUSTMENT AMOUNT: "_$JUSTIFY(IBPLB(344.42,FL,.03,"E"),9))
+76 DO SET(.LINE," ADJUSTMENT CODE TEXT: "_ACT)
+77 DO SET(.LINE," REFERENCE: "_IBPLB(344.42,FL,.01,"E"))
End DoDot:3
End DoDot:2
+78 DO SET(.LINE," ")
+79 KILL IBEBERA
SET ZZEPIEN=EPIEN
DO EEOB^IBJTEP1("IBEBERA",ERAIEN,EPBILL,1)
+80 FOR EOBCT=1:1:IBEBERA
Begin DoDot:2
+81 SET EPIEN=$ORDER(IBEBERA(EOBCT,""))
+82 ;
IF EPIEN
IF '$DATA(EOBLST(EPIEN))
Begin DoDot:3
+83 ; PRCA*4.5*332
DO EOBDET(EPIEN,0,EOBCT,IBEBERA,ERAIEN)
+84 SET EOBLST(EPIEN)=""
End DoDot:3
End DoDot:2
+85 DO SET(.LINE,$TRANSLATE(SP80," ","="))
+86 SET EPIEN=ZZEPIEN
End DoDot:1
+87 ;
IF RCCOPY
Begin DoDot:1
+88 ; Display copied EOBs - PRCA*4.5*332
SET (X,XX)=0
FOR
SET X=$ORDER(RCCOPY(X))
if 'X
QUIT
Begin DoDot:2
+89 ;
IF '$DATA(EOBLST(RCCOPY(X)))
Begin DoDot:3
+90 DO EOBDET(RCCOPY(X),1,X,RCCOPY,"")
+91 SET EOBLST(RCCOPY(X))=""
SET XX=XX+1
End DoDot:3
End DoDot:2
+92 IF XX
DO SET(.LINE,$TRANSLATE(SP80," ","="))
End DoDot:1
+93 ; No EEOB IEN, then report that No ERA recieved for this bill
+94 IF LINE=0
SET VALMCNT=2
DO SET^VALM10(1," ")
DO SET^VALM10(2,"No ERA Information for Bill: "_EPBILL)
GOTO INITQ
+95 SET VALMCNT=LINE
+96 ;
INITQ KILL IBEPAR,IBPLB,IBEOB,IBDGCR,IBGX,IBSPL,IBEERR,TT,AA,EE,RCPL,ACT,ACNT,CC,XLN,XSP,XSP1,TSDT,TEDT,TRX,TECME,RCF,SP80,X,ZZEPIEN
+1 QUIT
+2 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL EPBILL,EPEOB,ERALST,EPPAT,EPNM,EPSS,EPDOB,EPDOS,EPSID,EPAMT,EPARR
+2 DO CLEAR^VALM1
DO CLEAN^VALM10
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
PUSH(VAR,VALUE) ;
+1 ; Remove Commas from string
SET VALUE=$TRANSLATE(VALUE,",")
+2 ; Empty variable
if $GET(VAR)=""
QUIT VALUE
+3 ; If this VALUE is on the list don't add it a second time
+4 IF U_VAR_U[(U_VALUE_U)
QUIT VAR
+5 QUIT VAR_U_VALUE
+6 ;
+7 ; IB*2.0*642 - 2020/02/05:DM removed to meet SAC line limit
+8 ; Get the code modifier description
+9 ;MODC(MCD) ;
+10 ; Q:$G(MCD)="" "No Modifier Code Description"
+11 ; N ZZIEN,ZZDEC
+12 ; S ZZIEN=$$FIND1^DIC(81.3,,"BX","26","","","")
+13 ; S ZZDEC=$$GET1^DIQ(81.3,ZZIEN_",",.02)
+14 ; Q:ZZDEC="" "No Modifier Code Description"
+15 ; Q ZZDEC
+16 ;
SET(LINE,DATA) ; -- set arrays
+1 ; LINE = line number passed by reference
+2 ; DATA = string to add to displayed data
+3 SET LINE=LINE+1
+4 DO SET^VALM10(LINE,$GET(DATA))
+5 QUIT
+6 ; PRCA*4.5*332 - Move EOB display into its own subroutine
EOBDET(EPIEN,TYPE,EOBCT,IBEBERA,ERAIEN) ; Add EOB detail to List Manager Array
+1 ; Input: EPIEN - Internal entry number to file 361.1
+2 ; TYPE - 0 - EEOB associated with an ERA, 1 - Copied EOB created by split/edit or link payment
+3 ; EOBCT - Count# of this EOB within the ERA
+4 ; IBEBERA - Number of EOBs for this bill in this ERA
+5 ; ERAIEN - Internal entry number from file 344.4
+6 ;
+7 NEW IBEOB,IBGX,IBCL,IBDGCR,IBRX,IBSPL,IBEERR,RCTRACE
+8 DO GETS^DIQ(361.1,EPIEN_",",".01;.02;.03;.04;.06;.07;.14;1.01;1.02;1.03;1.1;1.11;2.03;2.04;3.03;3.04;3.05;3.06;3.07;102;104","EI","IBEOB")
+9 ; Claim Level Adjustments
DO GETS^DIQ(361.1,EPIEN_",","10*;","EI","IBGX")
DO RESORT^IBJTEP1("IBGX",361.111)
DO RESORT^IBJTEP1("IBGX",361.11)
+10 ; Line Level Adjustments
DO GETS^DIQ(361.1,EPIEN_",","15*;","EI","IBCL")
+11 ; ERA Splits for this EEOB
DO GETS^DIQ(361.1,EPIEN_",","8*;","EI","IBSPL")
+12 ; EOB Errors if they exist
DO GETS^DIQ(361.1,EPIEN_",","20;","","IBEERR")
+13 ; Make it easier to walk the data
+14 DO RESORT^IBJTEP1("IBCL",361.11511)
DO RESORT^IBJTEP1("IBCL",361.115)
DO RESORT^IBJTEP1("IBCL",361.1151)
+15 DO RESORT^IBJTEP1("IBCL",361.1152)
DO RESORT^IBJTEP1("IBCL",361.1154)
+16 DO GETS^DIQ(399,IBEOB(361.1,EPIEN_",",.01,"I")_",","460;","EI","IBDGCR")
+17 SET RCTRACE=$GET(IBEOB("361.1",EPIEN_",",".07","E"))
+18 IF ERAIEN=""
IF RCTRACE'=""
SET ERAIEN=$ORDER(^RCY(344.4,"D",RCTRACE,""))
+19 DO SET(.LINE,"********** "_$SELECT(TYPE=0:"",1:"COPIED ")_"EOB/835 INFORMATION ("_EOBCT_" of "_IBEBERA_") **********")
+20 ; EOB Removed
IF $GET(IBEOB("361.1",EPIEN_",","102","I"))
Begin DoDot:1
+21 DO EOBREM^IBJTEP1(EPIEN,.LINE)
+22 DO SET(.LINE,$TRANSLATE(SP80," ","-"))
End DoDot:1
QUIT
+23 ;
+24 ; ORIGINAL PATIENT NAME added in IB*2.0*639
IF $GET(ERADA)
Begin DoDot:1
+25 SET ERAIEN("p344.41")=$ORDER(^RCY(344.4,ERADA,1,"AC",EPIEN,0))
+26 ; POINTER TO ERA DETAIL 344.41
IF ERAIEN("p344.41")
Begin DoDot:2
+27 SET XLN=" Free Text Patient Name: "_$$GET1^DIQ(344.41,ERAIEN("p344.41")_","_ERADA_",",.15,"E")
+28 DO SET(.LINE,XLN)
End DoDot:2
End DoDot:1
+29 ;
IF '$TEST
Begin DoDot:1
+30 SET ERAIEN("p344.41")=$GET(IBEOB("361.1",EPIEN_",","104","E"))
+31 ;
IF ERAIEN("p344.41")'=""
Begin DoDot:2
+32 SET XLN=" Free Text Patient Name: "_$$GET1^DIQ(344.41,ERAIEN("p344.41"),.15,"E")
+33 DO SET(.LINE,XLN)
End DoDot:2
End DoDot:1
+34 ;
+35 SET XLN=" EOB Type: "_$GET(IBEOB("361.1",EPIEN_",",".04","E"))
SET XSP=$EXTRACT(SP80,1,(40-$LENGTH(XLN)))
+36 DO SET(.LINE,XLN_XSP_"EOB Paid Date: "_$GET(IBEOB("361.1",EPIEN_",",".06","E")))
+37 SET TSDT=$$FMTE^XLFDT($GET(IBEOB("361.1",EPIEN_",","1.1","I")),"2Z")
SET TEDT=$$FMTE^XLFDT($GET(IBEOB("361.1",EPIEN_",","1.11","I")),"2Z")
SET XLN=" Svc From Date: "_TSDT
SET XSP=$EXTRACT(SP80,1,(40-$LENGTH(XLN)))
+38 DO SET(.LINE,XLN_XSP_"Svc to Date: "_TEDT)
+39 DO SET(.LINE," ICN: "_$GET(IBEOB("361.1",EPIEN_",",".14","E")))
+40 DO SET(.LINE," Payer Name/TIN: "_$GET(IBEOB("361.1",EPIEN_",",".02","E"))_"/"_$GET(IBEOB("361.1",EPIEN_",",".03","E")))
+41 ;
IF ERAIEN
Begin DoDot:1
+42 SET XLN=" ERA #: "_$$GET1^DIQ(344.4,ERAIEN_",",".01","E")
SET XSP=$EXTRACT(SP80,1,(40-$LENGTH(XLN)))
+43 DO SET(.LINE,XLN_XSP_"Auto-Post Status: "_$$GET1^DIQ(344.4,ERAIEN_",","4.02","E"))
+44 DO SET(.LINE," Trace #: "_$$GET1^DIQ(344.4,ERAIEN_",",".02","E"))
End DoDot:1
+45 ;
IF '$TEST
Begin DoDot:1
+46 DO SET(.LINE," Trace #: "_RCTRACE)
End DoDot:1
+47 SET TECME=$PIECE($GET(IBDGCR(399,IBEOB(361.1,EPIEN_",",.01,"I")_",",460,"E")),";",1)
+48 DO GETRX^IBJTEP1(EPIEN,.IBRX)
+49 SET TRX=$$GET1^DIQ(52,+TECME_",",".01")_"/"_$GET(IBRX("FILL"))_"/"_$GET(IBRX("RELEASED STATUS"))
+50 IF TECME=""
SET TRX=""
+51 SET XLN=" ECME #: "_TECME
SET XSP=$EXTRACT(SP80,1,(25-$LENGTH(XLN)))
SET XSP1=$EXTRACT(SP80,1,(39-$LENGTH(XLN_XSP_"DOS: "_$GET(IBRX("DOS")))))
+52 DO SET(.LINE,XLN_XSP_"DOS: "_$GET(IBRX("DOS"))_XSP1_"Rx/Fill/Release Status: "_TRX)
+53 DO SET(.LINE,"--------------------------------------------------------------------------------")
+54 ; This EEOB was split display split payment information
if $DATA(IBSPL)>1
Begin DoDot:1
+55 NEW SPL
+56 DO SET(.LINE,"** A/R CORRECTED PAYMENT DATA:")
+57 DO SET(.LINE," TOTAL AMT PD: "_$JUSTIFY(IBEOB(361.1,EPIEN_",",1.01,"E"),9,2))
+58 SET SPL=""
FOR
SET SPL=$ORDER(IBSPL(361.18,SPL))
if SPL=""
QUIT
Begin DoDot:2
+59 DO SET(.LINE," "_$SELECT(IBSPL(361.18,SPL,.03,"I")'="":$$BN1^PRCAFN(IBSPL(361.18,SPL,.03,"I"))_$JUSTIFY("",8),1:"[suspense] "_IBSPL(361.18,SPL,.01,"E"))_" "_$JUSTIFY(IBSPL(361.18,SPL,.02,"E"),9,2))
End DoDot:2
+60 DO SET(.LINE," ")
End DoDot:1
+61 DO SET(.LINE,"CLAIM LEVEL PAY STATUS:")
+62 DO SET(.LINE," Total Submitted Charges :"_$JUSTIFY($GET(IBEOB("361.1",EPIEN_",","2.04","E")),11,2)_" Payer Covered Amount :"_$JUSTIFY($GET(IBEOB("361.1",EPIEN_",","1.03","E")),11,2))
+63 DO SET(.LINE," Payer Paid Amount :"_$JUSTIFY($GET(IBEOB("361.1",EPIEN_",","1.01","E")),11,2)_" MEDICARE Allowed Amount :"_$JUSTIFY($GET(IBEOB("361.1",EPIEN_",","2.03","E")),11,2))
+64 ; IB*2.0*609
DO SET(.LINE," Patient Responsibility :"_$JUSTIFY($GET(IBEOB("361.1",EPIEN_",","1.02","E")),11,2)_" % Collected :"_$JUSTIFY(+IBCOL,11,0)_" %")
+65 DO SET(.LINE,$TRANSLATE(SP80," ","-"))
+66 DO SET(.LINE,"CLAIM LEVEL ADJUSTMENTS:")
+67 SET AA=""
SET ACNT=0
FOR
SET AA=$ORDER(IBGX(361.11,AA))
if AA=""
QUIT
SET ACNT=ACNT+1
SET AQ=""
Begin DoDot:1
+68 SET CC=AA
FOR
SET CC=$ORDER(IBGX(361.111,CC))
if $EXTRACT(CC,1,$LENGTH(AA))'=AA
QUIT
Begin DoDot:2
+69 IF AQ=""
SET AQ=$JUSTIFY(ACNT,3)_") "
+70 IF '$TEST
SET ACNT=ACNT+1
SET AQ=$JUSTIFY(ACNT,3)_") "
+71 DO SET(.LINE,AQ_"ADJ. AMT: "_$JUSTIFY(IBGX(361.111,CC,.02,"E"),9,2)_" ADJ GROUP: "_IBGX(361.11,AA,.01,"I")_" => "_IBGX(361.11,AA,.01,"E"))
+72 SET RMIEN=$$FIND1^DIC(345,"","BX",IBGX(361.111,CC,.01,"E"),"","","RCERR")
+73 IF RMIEN'=""
KILL RCERR,RCRDC,RCFLD
SET RCXY=$$GET1^DIQ(345,RMIEN_",",4,"","RCRDC","RCERR")
DO DLN^IBJTEP1("RCRDC","RCFLD",55,69)
+74 DO SET(.LINE," ADJ. CODE: "_IBGX(361.111,CC,.01,"E")_" => "_RCFLD(1))
+75 IF RCFLD>1
FOR II=2:1:RCFLD
DO SET(.LINE," "_RCFLD(II))
End DoDot:2
End DoDot:1
+76 IF ACNT=0
DO SET(.LINE," -- None --")
+77 DO SET(.LINE,"CLAIM LEVEL REMARKS: ")
+78 SET RCRC=0
FOR II="3.03","3.04","3.05","3.06","3.07"
if IBEOB("361.1",EPIEN_",",II,"E")'=""
Begin DoDot:1
+79 ; Get IEN for this remark code - if no IEN then need to look at the data "RM1" to "RM5"
+80 SET RMIEN=$$FIND1^DIC(346,"","BX",IBEOB("361.1",EPIEN_",",II,"E"),"","","RCERR")
+81 IF RMIEN'=""
KILL RCERR,RCRDC,RCFLD
SET RCXY=$$GET1^DIQ(346,RMIEN_",",4,"","RCRDC","RCERR")
DO DLN^IBJTEP1("RCRDC","RCFLD",57,69)
+82 IF RMIEN=""
SET RCFLD=$SELECT(II="3.03":5.011,II="3.04":5.021,II="3.05":5.031,II="3.06":5.041,II="3.07":5.051,1:5.011)
SET RCRLN=$$GET1^DIQ(361.1,EPIEN_",",RCFLD)
+83 SET RCRC=RCRC+1
DO SET(.LINE," --- REMARK CODE("_RCRC_"): "_IBEOB("361.1",EPIEN_",",II,"E")_" => "_RCFLD(1))
+84 IF RCFLD>1
FOR II=2:1:RCFLD
DO SET(.LINE," "_RCFLD(II))
End DoDot:1
+85 IF RCRC=0
DO SET(.LINE," -- None --")
+86 DO SET(.LINE,$TRANSLATE(SP80," ","-"))
+87 ; Walk through the line level information...
+88 DO SET(.LINE,"EEOB LINE LEVEL ADJUSTMENTS:")
+89 KILL ^XTMP("IBJTEP",$JOB)
MERGE ^XTMP("IBJTEP",$JOB)=IBCL
+90 SET RCPL=0
SET EE=""
FOR
SET EE=$ORDER(IBCL(361.115,EE))
if EE=""
QUIT
SET RCPL=RCPL+1
Begin DoDot:1
+91 SET QQ=EE
SET RCMD=""
FOR
SET QQ=$ORDER(IBCL(361.1152,QQ))
if $EXTRACT(QQ,1,$LENGTH(EE))'=EE
QUIT
SET RCMD=IBCL(361.1152,QQ,.01,"I")
+92 DO SET(.LINE," # SV DT REVCD PROC MOD UNITS BILLED DEDUCT COINS ALLOW PYMT")
+93 SET RCBAMT=$$BILLN^IBJTEP1(IBEOB(361.1,EPIEN_",",.01,"I"),IBCL(361.115,EE,.1,"E"),IBCL(361.115,EE,.04,"E"))
+94 ; Get Deductable and Co-Insurance amts.
SET RCDED=$$ADJU^IBJTEP1("DEDUCT",.IBCL,EE)
SET RCOIN=$$ADJU^IBJTEP1("COINS",.IBCL,EE)
+95 SET XLN=$JUSTIFY(RCPL,2,0)_" "_$$FMTE^XLFDT(IBCL(361.115,EE,.16,"I"),"2Z")_" "_$$CJ^XLFSTR(IBCL(361.115,EE,.1,"E"),5)_" "_$$CJ^XLFSTR(IBCL(361.115,EE,.04,"E"),8)_$$CJ^XLFSTR(RCMD,5)_" "_$$CJ^XLFSTR(IBCL(361.115,EE,.11,"E"),3)
+96 DO SET(.LINE,XLN_" "_$JUSTIFY(RCBAMT,9,2)_$JUSTIFY(RCDED,8,2)_$JUSTIFY(RCOIN,8,2)_$JUSTIFY(IBCL(361.115,EE,.13,"E"),9,2)_$JUSTIFY(IBCL(361.115,EE,.03,"E"),9,2))
+97 ; IB*2.0*642 - Add logic to display DRG/GRP Adjustment Weight
+98 ; N SPL S SPL=$$SUPL^IBCECSA7($P(EE,",",2),$P(EE,",")) I SPL]"" D SET(.LINE,SPL)
+99 DO SET(.LINE," ")
+100 DO SET(.LINE," Product/Service Description:"_IBCL(361.115,EE,.09,"E"))
+101 DO SET(.LINE," Payer Policy Reference:"_$GET(IBCL(361.11512,EE,.01,"E")))
+102 DO SET(.LINE," ")
+103 SET ACNT=0
SET AA=EE
FOR
SET AA=$ORDER(IBCL(361.1151,AA))
if $EXTRACT(AA,1,$LENGTH(EE))'=EE
QUIT
Begin DoDot:2
+104 SET ACNT=ACNT+1
+105 SET CC=AA
SET RCRC=0
FOR
SET CC=$ORDER(IBCL(361.11511,CC))
if $EXTRACT(CC,1,$LENGTH(AA))'=AA
QUIT
Begin DoDot:3
+106 SET RCRC=RCRC+1
DO SET(.LINE," -> ADJ AMT: "_$JUSTIFY(IBCL(361.11511,CC,.02,"E"),9,2)_" ADJ GROUP: "_IBCL(361.1151,AA,.01,"I")_" - "_IBCL(361.1151,AA,.01,"E")_" "_$$CJ^XLFSTR("QTY: "_+$GET(IBCL(361.11511,CC,.03,"E")),8))
+107 SET RCXY=$$FIND1^DIC(345,"","BX",IBCL(361.11511,CC,.01,"E"),"","","RCERR")
+108 KILL RCRDC,RCERR
SET RCXY=$$GET1^DIQ(345,RCXY_",",4,"","RCRDC","RCERR")
+109 IF $DATA(RCRDC)>0
KILL RCFLD
DO DLN^IBJTEP1("RCRDC","RCFLD",57,57)
+110 ; If no data from file 345 use data from FMS
IF $DATA(RCRDC)=0
KILL RCFLD
SET RCRDC(1)=IBCL(361.11511,CC,.04,"E")
DO DLN^IBJTEP1("RCRDC","RCFLD",57,57)
+111 DO SET(.LINE," ADJ CODE: "_$$CJ^XLFSTR(IBCL(361.11511,CC,.01,"E"),5)_" "_RCFLD(1))
+112 IF RCFLD>1
FOR II=2:1:RCFLD
DO SET(.LINE," "_RCFLD(II))
End DoDot:3
End DoDot:2
+113 ; Display RARC Codes for this Line Item
+114 IF $DATA(IBCL(361.1154))'=0
SET QQ=EE
SET RCMD=""
FOR
SET QQ=$ORDER(IBCL(361.1154,QQ))
if $EXTRACT(QQ,1,$LENGTH(EE))'=EE
QUIT
Begin DoDot:2
+115 KILL RCERR,RCRDC,RCFLD
+116 SET RMIEN=$$FIND1^DIC(346,"","BX",IBCL(361.1154,QQ,.02,"E"),"","","RCERR")
+117 ; avoid "undefined" if RMIEN could not be found *642
+118 IF 'RMIEN
SET RCFLD=1
SET RCFLD(1)="*["_IBCL(361.1154,QQ,.02,"E")_"] code is not on file."
+119 IF RMIEN
SET RCXY=$$GET1^DIQ(346,RMIEN_",",4,"","RCRDC","RCERR")
DO DLN^IBJTEP1("RCRDC","RCFLD",57,68)
+120 DO SET(.LINE," --- RARC: "_IBCL(361.1154,QQ,.02,"E")_" - "_RCFLD(1))
+121 IF RCFLD>1
FOR II=2:1:RCFLD
DO SET(.LINE," "_RCFLD(II))
End DoDot:2
+122 DO SET(.LINE," ")
End DoDot:1
+123 IF ACNT=0
DO SET(.LINE," -- No Line Level Adjustments --")
+124 ; If there are EOB Errors add them to the screen
+125 if $DATA(IBEERR(361.1,EPIEN_",",20))>9
Begin DoDot:1
+126 DO SET(.LINE," ")
DO SET(.LINE,"EEOB MESSAGE ERRORS:")
+127 NEW II
SET II=0
FOR
SET II=$ORDER(IBEERR(361.1,EPIEN_",",20,II))
if (II="")!(II'=+II)
QUIT
DO SET(.LINE,$GET(IBEERR(361.1,EPIEN_",",20,II)))
End DoDot:1
+128 QUIT
