- 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 Jan 18, 2025@03:25:06 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