IBJTPE ;ALB/TJB - TP ERA/835 PRINT EEOB INFORMATIN SCREEN ;20-MAY-2015
;;2.0;INTEGRATED BILLING;**530,609,633,642**;21-MAR-94;Build 22
;;Per VA Directive 6402, this routine should not be modified.
;; ;
EN ; -- main entry point for IBJT 835 EEOB PRINT
D EN^VALM("IBJT 835 EEOB PRINT")
Q
;
HDR ; -- header code
S VALMHDR(1)="IBJT 835 EEOB PRINT."
S VALMHDR(2)="Print EEOBs for further investigation"
Q
;
INIT ; -- init variables and list array
; Array IBEBERA (From IBJTEP) contains the the EEOBs for this KBILL
N IBRP,IBEIEN,CT,DIR,EOBLST,IBEBERA,IBPERA,JJ,X,Y,DTOUT,DUOUT,DIROUT,DIRUT,IBNUM,IBPEOB,IBALL
S IBNUM=1,(CT,EOBLST,IBALL)=0,JJ=""
D FULL^VALM1
IN1 ;
S IBRP(U)=", "
; ERALST is from IBJTEP and will be cleaned up there
I $L(ERALST)=0 W !,"No ERA Information for Bill: "_EPBILL K DIR S DIR(0)="E" D ^DIR K DIR G INITQ
I $L(ERALST,U)=1 S IBPERA=ERALST G IN2
S DIR("A")="Enter a SINGLE ERA# or (A)LL ERAs/All EEOBs to print: ",DIR(0)="FA^1:15"
S DIR("A",1)="This claim has EEOBs on multiple ERAs. Enter a SINGLE ERA# from the following"
S DIR("A",2)="list or enter ALL to print ALL associated EEOBS from all ERAs in the list."
S DIR("A",3)="Available ERAs: "_$$REPLACE^XLFSTR(ERALST,.IBRP)
S DIR("PRE")="S X=$$UP^XLFSTR(X)"
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") S VALMQUIT="" G INITQ
I Y=$E("ALL",1,$L(Y)) S IBALL=1 G IND ; Print All EOBs for All ERAs
S IBPERA=Y I (U_ERALST_U)'[(U_Y_U) W !!,"ERA: "_Y_" not a valid selection. Please try again...",! S X="",IBPERA="" G IN1
IN2 ;
; EPBILL is from IBJTEP and will be cleaned up there
K IBEBERA D EEOB^IBJTEP1("IBEBERA",IBPERA,EPBILL,1) S JJ="" F S JJ=$O(IBEBERA(JJ)) Q:JJ="" S CT=CT+1,EOBLST(CT)=$O(IBEBERA(JJ,""))
I CT=1 S IBPEOB="1," G IND
; Get the EOB to Print if more than one.
S IBRNG="1-"_IBEBERA
S DIR("A")="Select EEOB# to Print ("_IBRNG_"), (A)ll EEOBs or (E)xit: ",DIR(0)="LA^1:"_IBEBERA
S DIR("PRE")="S X=$S(""Aa""[$E(X):"""_IBRNG_""",""Ee""[$E(X):""^"",1:X)"
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!(Y="") S VALMQUIT=1 G INITQ
; IBPEOB will be a list of numbers to print
S IBPEOB=Y
; Ask device
IND N POP S %ZIS="QM" D ^%ZIS I POP S VALMQUIT="" G INITQ
I $D(IO("Q")) D S VALMQUIT="" G INITQ
. S ZTRTN=$S(IBALL=1:"EOBALL^IBJTPE",1:"EOBOUT^IBJTPE"),ZTDESC="AR EDI - Print EEOB Detail from 835 Information"
. S ZTSAVE("IB*")="",ZTSAVE("EOB*")=""
. D ^%ZTLOAD
. W !!,$S($D(ZTSK):"Your task number "_ZTSK_" has been queued.",1:"Unable to queue this job.")
. K ZTSK,IO("Q") D HOME^%ZIS
U IO
; If IBALL set, print all EOBs on all ERAs otherwise print just selected EOBs/ERAs
G EOBALL:IBALL,EOBOUT
;
INITQ ;
S VALMQUIT=""
K IBEOB,EOBLST,IBRNG
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
Q
;
EXPND ; -- expand code
Q
;
EOBALL ; Entry point to print all ERAs and all EOBs
N ZQ,ZQL,IBPERA,JJ,IBEBERA,CT,IBSL,IBPG,BB,IBQUIT,IBREPG ; IB*2.0*609
S (IBPG,IBQUIT,IBREPG,IBSL)=0,ZQL=$L(ERALST,U)
F ZQ=1:1 S IBPERA=$P(ERALST,U,ZQ) Q:IBPERA="" S:IBPG>0 IBREPG=1 D Q:IBQUIT
. K IBEBERA D EEOB^IBJTEP1("IBEBERA",IBPERA,EPBILL,1) S JJ="",CT=0 F S JJ=$O(IBEBERA(JJ)) Q:JJ="" S CT=CT+1,EOBLST(CT)=$O(IBEBERA(JJ,""))
. S IBSL=0 ; Print new page because we are switching ERA #s
. ; IB*2.0*609 - eliminate use of IBPEOB variable to fix crash when printing ALL EEOBs
. S BB="" F S BB=$O(EOBLST(BB)) Q:BB="" S IBEIEN=EOBLST(BB) D EBO Q:IBQUIT
. I ZQ<ZQL D ASK(.IBQUIT)
I 'IBQUIT D SET(" *** END OF REPORT ***"),ASK(.IBQUIT)
G INITQ
Q
EOBOUT ; Entry for either queued or screen print of EEOB
N AA,AQ,BB,BC,CC,EE,II,QQ,IBDT,IBPG,IBSL,IBQUIT,IBEOB,IBGX,IBCL,IBSPL,IBEERR,IBDGCR,IBEPAR,ACNT,IBQUIT,IBRDC,IBPERR,XLN,XSP,RCBAMT,RCDED,RCMD,RCOIN
N RCPL,RCRC,RCRLN,RCXY,RMIEN,SP80,TDOS,TECME,TEDT,TRX,TSTAT,TSDT,XSP1,IBREPG
S (IBQUIT,IBSL,IBPG,IBREPG)=0
S BB="" F BC=1:1 S BB=$P(IBPEOB,",",BC) Q:BB="" S IBEIEN=EOBLST(BB) D EBO Q:IBQUIT
I 'IBQUIT D SET(" *** END OF REPORT ***"),ASK(.IBQUIT)
G INITQ
Q
EBO ; Display the EOB DATA for IBEIEN
S SP80=$J("",IOM),IBDT=$$FMTE^XLFDT($$NOW^XLFDT,1) ; Date format Mon dd, yyyy@hh:mm:ss see kernel documentation
I (IBSL=0)&(IBPG=0) D RHDR(IBPERA,IBDT,.IBPG)
I IBREPG=1 S IBREPG=0 D RHDR(IBPERA,IBDT,.IBPG)
K IBEOB,IBGX,IBCL,IBDGCR,IBEPAR,IBSPL,IBEERR
D GETS^DIQ(361.1,IBEIEN_",",".01;.02;.03;.04;.06;.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;","EI","IBEOB")
D GETS^DIQ(361.1,IBEIEN_",","10*;","EI","IBGX"),RESORT^IBJTEP1("IBGX",361.111),RESORT^IBJTEP1("IBGX",361.11) ; Claim Level Adjustments
D GETS^DIQ(361.1,IBEIEN_",","15*;","EI","IBCL") ; Line Level Adjustments
D GETS^DIQ(361.1,IBEIEN_",","8*;","EI","IBSPL") ; ERA Splits for this EEOB
D GETS^DIQ(361.1,IBEIEN_",","20;","","IBEERR") ; EOB Errors if they exist
N IBAR,IBCOL ; IB*2.0*609
S IBAR=$$BILL^RCJIBFN2($G(IBEOB(361.1,IBEIEN_",",.01,"I"))),IBCOL=$P(IBAR,U,5) ; IB*2.0*609
; 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,IBEIEN_",",.01,"I")_",","460;","EI","IBDGCR")
D GETS^DIQ(344.4,IBPERA_",",".01;.02;.03;.04;.05;.06;.07;.08;.09;.1;.11;.12;.13;.14;.15;4.02;","E","IBEPAR")
;
D SET("********** EOB/835 INFORMATION ("_BB_" of "_IBEBERA_") **********") Q:IBQUIT
S XLN=" EOB Type: "_$G(IBEOB("361.1",IBEIEN_",",".04","E")),XSP=$E(SP80,1,(40-$L(XLN)))
D SET(XLN_XSP_"EOB Paid Date: "_$G(IBEOB("361.1",IBEIEN_",",".06","E"))) Q:IBQUIT
S TSDT=$$FMTE^XLFDT($G(IBEOB("361.1",IBEIEN_",","1.1","I")),"2Z"),TEDT=$$FMTE^XLFDT($G(IBEOB("361.1",IBEIEN_",","1.11","I")),"2Z"),XLN=" Svc From Date: "_TSDT,XSP=$E(SP80,1,(40-$L(XLN)))
D SET(XLN_XSP_"Svc to Date: "_TEDT) Q:IBQUIT
D SET(" ICN: "_$G(IBEOB("361.1",IBEIEN_",",".14","E"))) Q:IBQUIT
D SET(" Payer Name/TIN: "_$G(IBEOB("361.1",IBEIEN_",",".02","E"))_"/"_$G(IBEOB("361.1",IBEIEN_",",".03","E"))) Q:IBQUIT
S XLN=" ERA #: "_$G(IBEPAR("344.4",IBPERA_",",".01","E")),XSP=$E(SP80,1,(40-$L(XLN)))
D SET(XLN_XSP_"Auto-Post Status: "_$G(IBEPAR("344.4",IBPERA_",","4.02","E"))) Q:IBQUIT
D SET(" Trace #: "_$G(IBEPAR("344.4",IBPERA_",",".02","E"))) Q:IBQUIT
; Access to PSOORDER supported by DBIA #1878
S TECME=$P($G(IBDGCR(399,IBEOB(361.1,IBEIEN_",",.01,"I")_",",460,"E")),";",1),TDOS=$$FMTE^XLFDT($$DOS^PSOBPSU1(+TECME),"2Z")
;Reference to $$STATUS^BPSOSRX supported by IA 4412
S TRX=$$GET1^DIQ(52,+TECME_",",".01")
S TSTAT=$P($$STATUS^BPSOSRX(TRX,$$LSTRFL^PSOBPSU1(+TECME)),"^")
S TRX=TRX_"/"_$$LSTRFL^PSOBPSU1(+TECME)_"/"_TSTAT
I TECME="" S TDOS="",TRX=""
S XLN=" ECME #: "_TECME,XSP=$E(SP80,1,(25-$L(XLN))),XSP1=$E(SP80,1,(39-$L(XLN_XSP_"DOS: "_TDOS)))
D SET(XLN_XSP_"DOS: "_TDOS_XSP1_"Rx/Fill/Release Status: "_TRX) Q:IBQUIT
D SET("--------------------------------------------------------------------------------") Q:IBQUIT
D:$D(IBSPL)>1 Q:IBQUIT ; This EEOB was split display split payment information
. N SPL
. D SET("** A/R CORRECTED PAYMENT DATA:") Q:IBQUIT
. D SET(" TOTAL AMT PD: "_$J(IBEOB(361.1,IBEIEN_",",1.01,"E"),9,2)) Q:IBQUIT
. S SPL="" F S SPL=$O(IBSPL(361.18,SPL)) Q:SPL="" D Q:IBQUIT
.. D SET(" "_$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)) Q:IBQUIT
. D SET(" ") Q:IBQUIT
D SET("CLAIM LEVEL PAY STATUS:") Q:IBQUIT
D SET(" Total Submitted Charges :"_$J($G(IBEOB("361.1",IBEIEN_",","2.04","E")),11,2)_" Payer Covered Amount :"_$J($G(IBEOB("361.1",IBEIEN_",","1.03","E")),11,2)) Q:IBQUIT
D SET(" Payer Paid Amount :"_$J($G(IBEOB("361.1",IBEIEN_",","1.01","E")),11,2)_" MEDICARE Allowed Amount :"_$J($G(IBEOB("361.1",IBEIEN_",","2.03","E")),11,2)) Q:IBQUIT
D SET(" Patient Responsibility :"_$J($G(IBEOB("361.1",IBEIEN_",","1.02","E")),11,2)_" % Collected :"_$J(+IBCOL,11,0)_" %") Q:IBQUIT ; IB*2.0*609
D SET("--------------------------------------------------------------------------------") Q:IBQUIT
D SET("CLAIM LEVEL ADJUSTMENTS:") Q:IBQUIT
S AA="",ACNT=0 F S AA=$O(IBGX(361.11,AA)) Q:AA="" S ACNT=ACNT+1,AQ="" D Q:IBQUIT
. S CC=AA F S CC=$O(IBGX(361.111,CC)) Q:$E(CC,1,$L(AA))'=AA D Q:IBQUIT
.. I AQ="" S AQ=$J(ACNT,3)_") "
.. E S ACNT=ACNT+1,AQ=$J(ACNT,3)_") "
.. D SET(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")) Q:IBQUIT
.. S RMIEN=$$FIND1^DIC(345,"","BX",IBGX(361.111,CC,.01,"E"),"","","IBPERR")
.. I RMIEN'="" K IBPERR,RCRDC,RCFLD S RCXY=$$GET1^DIQ(345,RMIEN_",",4,"","RCRDC","IBPERR") D DLN^IBJTEP1("RCRDC","RCFLD",57,69)
.. D SET(" ADJ. CODE: "_IBGX(361.111,CC,.01,"E")_" => "_RCFLD(1)) Q:IBQUIT
.. I RCFLD>1 F II=2:1:RCFLD D SET(" "_RCFLD(II)) Q:IBQUIT
I ACNT=0 D SET(" -- None --") Q:IBQUIT
D:'IBQUIT SET("CLAIM LEVEL REMARKS: ") Q:IBQUIT
S RCRC=0 F II="3.03","3.04","3.05","3.06","3.07" D:IBEOB("361.1",IBEIEN_",",II,"E")'="" Q:IBQUIT
. ; 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",IBEIEN_",",II,"E"),"","","IBPERR")
. I RMIEN'="" K IBPERR,RCRDC,RCFLD S RCXY=$$GET1^DIQ(346,RMIEN_",",4,"","RCRDC","IBPERR") D DLN^IBJTEP1("RCRDC","RCFLD",50,68)
. 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,IBEIEN_",",RCFLD)
. S RCRC=RCRC+1 D SET(" --- REMARK CODE("_RCRC_"): "_IBEOB("361.1",IBEIEN_",",II,"E")_" => "_RCFLD(1)) Q:IBQUIT
. I RCFLD>1 F II=2:1:RCFLD D SET(" "_RCFLD(II)) Q:IBQUIT
I RCRC=0 D SET(" -- None --") Q:IBQUIT
D:'IBQUIT SET("--------------------------------------------------------------------------------") Q:IBQUIT
; Walk through the line level information...
D SET("EEOB LINE LEVEL ADJUSTMENTS:") Q:IBQUIT
S RCPL=0,EE="" F S EE=$O(IBCL(361.115,EE)) Q:EE="" S RCPL=RCPL+1 D Q:IBQUIT
. 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(" # SV DT REVCD PROC MOD UNITS BILLED DEDUCT COINS ALLOW PYMT") Q:IBQUIT
. S RCBAMT=$$BILLN^IBJTEP1(IBEOB(361.1,IBEIEN_",",.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(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)) Q:IBQUIT
. D SET(" ") Q:IBQUIT
. D SET(" Product/Service Description:"_IBCL(361.115,EE,.09,"E")) Q:IBQUIT
. D SET(" Payer Policy Reference:"_$G(IBCL(361.11512,EE,.01,"E"))) Q:IBQUIT
. D SET(" ") Q:IBQUIT
. S ACNT=0,AA=EE F S AA=$O(IBCL(361.1151,AA)) Q:$E(AA,1,$L(EE))'=EE D Q:IBQUIT
.. 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 Q:IBQUIT
... S RCRC=RCRC+1 D SET(" -> 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)) Q:IBQUIT
... 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(" ADJ CODE: "_$$CJ^XLFSTR(IBCL(361.11511,CC,.01,"E"),5)_" "_RCFLD(1)) Q:IBQUIT
... I RCFLD>1 F II=2:1:RCFLD D SET(" "_RCFLD(II)) Q:IBQUIT
. ; 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 Q:IBQUIT
.. K IBERR,RCRDC,RCFLD
.. S RMIEN=$$FIND1^DIC(346,"","BX",IBCL(361.1154,QQ,.02,"E"),"","","IBERR")
.. ; 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","IBPERR") D DLN^IBJTEP1("RCRDC","RCFLD",50,68)
.. D SET(" --- RARC: "_IBCL(361.1154,QQ,.02,"E")_" - "_RCFLD(1)) Q:IBQUIT
.. I RCFLD>1 F II=2:1:RCFLD D SET(" "_RCFLD(II)) Q:IBQUIT
. D:ACNT'=0 SET(" ") Q:IBQUIT
I ACNT=0 D SET(" -- No Line Level Adjustments --") Q:IBQUIT
; If there are EOB Errors add them to the Report
D:$D(IBEERR(361.1,IBEIEN_",",20))>9
. D SET(" ") Q:IBQUIT D SET("EEOB MESSAGE ERRORS:") Q:IBQUIT
. N II S II=0 F S II=$O(IBEERR(361.1,IBEIEN_",",20,II)) Q:II="" D SET($G(IBEERR(361.1,IBEIEN_",",20,II))) Q:IBQUIT
D:'IBQUIT SET("================================================================================") Q:IBQUIT
;
Q
SET(DATA,NEW) ;
I $G(NEW)="" S NEW=1
W DATA,! S IBSL=IBSL+1
I IBSL'<(IOSL-4) S IBQUIT=$$NEWPG(.IBPG,NEW,.IBSL,IBPERA)
Q
RHDR(IBSCR,IBDT,IBPG) ;Prints EOB detail report heading
; IBSCR - IEN of the ERA; IBDT - Report Date; IBPG - page #, passed by reference.
N Z
S Z=$G(^RCY(344.4,IBSCR,0))
I IBPG!($E(IOST,1,2)="C-") W @IOF,*13
S IBPG=IBPG+1
D HDRP("EDI EEOB DETAIL - 835 INFORMATION SCREEN "_$$FMTE^XLFDT(IBDT,2),1,"Page: "_IBPG)
D HDRP($E(" ERA NUMBER: "_IBSCR_$J("",25),1,25)_" ERA DATE: "_$$FMTE^XLFDT($P(Z,U,4)),1)
D HDRP("INS COMPANY: "_$P(Z,U,6)_"/"_$P(Z,U,3),1)
D HDRP("ERA TRACE #: "_$P(Z,U,2),1)
W !,$TR($J("",IOM)," ","="),!
S IBSL=5
Q
;
NEWPG(IBPG,IBNEW,IBSL,IBSCR) ; Check for new page needed, output header
; IBPG = Page number passwd by referece
; IBNEW = 1 to force new page
; IBSL = page length passed by reference
; Function returns 1 if user chooses to stop output
N IBSTOP S IBSTOP=0
I IBNEW!'IBPG!(IBSL'<(IOSL-4)) D
. D:IBPG ASK(.IBSTOP) I IBSTOP Q
. W @IOF
. D RHDR(IBSCR,IBDT,.IBPG)
Q IBSTOP
;
ASK(IBSTOP) ; User if you want to quit or continue
S IBSTOP=0
I $E(IOST,1,2)'["C-" Q
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="E" W ! D ^DIR
I ($D(DIRUT))!($D(DUOUT)) S IBSTOP=1 Q
Q
;
HDRP(Z,X,Z1) ; Print Header (Z=String, X=1 (line feed) X=0 (no LF), Z1 (page number right justified)
I X=1 W !
W ?(IOM-$L(Z)\2),Z W:$G(Z1)]"" ?(IOM-$L(Z1)),Z1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJTPE 14685 printed Oct 16, 2024@18:24:41 Page 2
IBJTPE ;ALB/TJB - TP ERA/835 PRINT EEOB INFORMATIN SCREEN ;20-MAY-2015
+1 ;;2.0;INTEGRATED BILLING;**530,609,633,642**;21-MAR-94;Build 22
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;; ;
EN ; -- main entry point for IBJT 835 EEOB PRINT
+1 DO EN^VALM("IBJT 835 EEOB PRINT")
+2 QUIT
+3 ;
HDR ; -- header code
+1 SET VALMHDR(1)="IBJT 835 EEOB PRINT."
+2 SET VALMHDR(2)="Print EEOBs for further investigation"
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 ; Array IBEBERA (From IBJTEP) contains the the EEOBs for this KBILL
+2 NEW IBRP,IBEIEN,CT,DIR,EOBLST,IBEBERA,IBPERA,JJ,X,Y,DTOUT,DUOUT,DIROUT,DIRUT,IBNUM,IBPEOB,IBALL
+3 SET IBNUM=1
SET (CT,EOBLST,IBALL)=0
SET JJ=""
+4 DO FULL^VALM1
IN1 ;
+1 SET IBRP(U)=", "
+2 ; ERALST is from IBJTEP and will be cleaned up there
+3 IF $LENGTH(ERALST)=0
WRITE !,"No ERA Information for Bill: "_EPBILL
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
GOTO INITQ
+4 IF $LENGTH(ERALST,U)=1
SET IBPERA=ERALST
GOTO IN2
+5 SET DIR("A")="Enter a SINGLE ERA# or (A)LL ERAs/All EEOBs to print: "
SET DIR(0)="FA^1:15"
+6 SET DIR("A",1)="This claim has EEOBs on multiple ERAs. Enter a SINGLE ERA# from the following"
+7 SET DIR("A",2)="list or enter ALL to print ALL associated EEOBS from all ERAs in the list."
+8 SET DIR("A",3)="Available ERAs: "_$$REPLACE^XLFSTR(ERALST,.IBRP)
+9 SET DIR("PRE")="S X=$$UP^XLFSTR(X)"
+10 DO ^DIR
KILL DIR
+11 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET VALMQUIT=""
GOTO INITQ
+12 ; Print All EOBs for All ERAs
IF Y=$EXTRACT("ALL",1,$LENGTH(Y))
SET IBALL=1
GOTO IND
+13 SET IBPERA=Y
IF (U_ERALST_U)'[(U_Y_U)
WRITE !!,"ERA: "_Y_" not a valid selection. Please try again...",!
SET X=""
SET IBPERA=""
GOTO IN1
IN2 ;
+1 ; EPBILL is from IBJTEP and will be cleaned up there
+2 KILL IBEBERA
DO EEOB^IBJTEP1("IBEBERA",IBPERA,EPBILL,1)
SET JJ=""
FOR
SET JJ=$ORDER(IBEBERA(JJ))
if JJ=""
QUIT
SET CT=CT+1
SET EOBLST(CT)=$ORDER(IBEBERA(JJ,""))
+3 IF CT=1
SET IBPEOB="1,"
GOTO IND
+4 ; Get the EOB to Print if more than one.
+5 SET IBRNG="1-"_IBEBERA
+6 SET DIR("A")="Select EEOB# to Print ("_IBRNG_"), (A)ll EEOBs or (E)xit: "
SET DIR(0)="LA^1:"_IBEBERA
+7 SET DIR("PRE")="S X=$S(""Aa""[$E(X):"""_IBRNG_""",""Ee""[$E(X):""^"",1:X)"
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
SET VALMQUIT=1
GOTO INITQ
+10 ; IBPEOB will be a list of numbers to print
+11 SET IBPEOB=Y
+12 ; Ask device
IND NEW POP
SET %ZIS="QM"
DO ^%ZIS
IF POP
SET VALMQUIT=""
GOTO INITQ
+1 IF $DATA(IO("Q"))
Begin DoDot:1
+2 SET ZTRTN=$SELECT(IBALL=1:"EOBALL^IBJTPE",1:"EOBOUT^IBJTPE")
SET ZTDESC="AR EDI - Print EEOB Detail from 835 Information"
+3 SET ZTSAVE("IB*")=""
SET ZTSAVE("EOB*")=""
+4 DO ^%ZTLOAD
+5 WRITE !!,$SELECT($DATA(ZTSK):"Your task number "_ZTSK_" has been queued.",1:"Unable to queue this job.")
+6 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
SET VALMQUIT=""
GOTO INITQ
+7 USE IO
+8 ; If IBALL set, print all EOBs on all ERAs otherwise print just selected EOBs/ERAs
+9 if IBALL
GOTO EOBALL
GOTO EOBOUT
+10 ;
INITQ ;
+1 SET VALMQUIT=""
+2 KILL IBEOB,EOBLST,IBRNG
+3 QUIT
+4 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
EOBALL ; Entry point to print all ERAs and all EOBs
+1 ; IB*2.0*609
NEW ZQ,ZQL,IBPERA,JJ,IBEBERA,CT,IBSL,IBPG,BB,IBQUIT,IBREPG
+2 SET (IBPG,IBQUIT,IBREPG,IBSL)=0
SET ZQL=$LENGTH(ERALST,U)
+3 FOR ZQ=1:1
SET IBPERA=$PIECE(ERALST,U,ZQ)
if IBPERA=""
QUIT
if IBPG>0
SET IBREPG=1
Begin DoDot:1
+4 KILL IBEBERA
DO EEOB^IBJTEP1("IBEBERA",IBPERA,EPBILL,1)
SET JJ=""
SET CT=0
FOR
SET JJ=$ORDER(IBEBERA(JJ))
if JJ=""
QUIT
SET CT=CT+1
SET EOBLST(CT)=$ORDER(IBEBERA(JJ,""))
+5 ; Print new page because we are switching ERA #s
SET IBSL=0
+6 ; IB*2.0*609 - eliminate use of IBPEOB variable to fix crash when printing ALL EEOBs
+7 SET BB=""
FOR
SET BB=$ORDER(EOBLST(BB))
if BB=""
QUIT
SET IBEIEN=EOBLST(BB)
DO EBO
if IBQUIT
QUIT
+8 IF ZQ<ZQL
DO ASK(.IBQUIT)
End DoDot:1
if IBQUIT
QUIT
+9 IF 'IBQUIT
DO SET(" *** END OF REPORT ***")
DO ASK(.IBQUIT)
+10 GOTO INITQ
+11 QUIT
EOBOUT ; Entry for either queued or screen print of EEOB
+1 NEW AA,AQ,BB,BC,CC,EE,II,QQ,IBDT,IBPG,IBSL,IBQUIT,IBEOB,IBGX,IBCL,IBSPL,IBEERR,IBDGCR,IBEPAR,ACNT,IBQUIT,IBRDC,IBPERR,XLN,XSP,RCBAMT,RCDED,RCMD,RCOIN
+2 NEW RCPL,RCRC,RCRLN,RCXY,RMIEN,SP80,TDOS,TECME,TEDT,TRX,TSTAT,TSDT,XSP1,IBREPG
+3 SET (IBQUIT,IBSL,IBPG,IBREPG)=0
+4 SET BB=""
FOR BC=1:1
SET BB=$PIECE(IBPEOB,",",BC)
if BB=""
QUIT
SET IBEIEN=EOBLST(BB)
DO EBO
if IBQUIT
QUIT
+5 IF 'IBQUIT
DO SET(" *** END OF REPORT ***")
DO ASK(.IBQUIT)
+6 GOTO INITQ
+7 QUIT
EBO ; Display the EOB DATA for IBEIEN
+1 ; Date format Mon dd, yyyy@hh:mm:ss see kernel documentation
SET SP80=$JUSTIFY("",IOM)
SET IBDT=$$FMTE^XLFDT($$NOW^XLFDT,1)
+2 IF (IBSL=0)&(IBPG=0)
DO RHDR(IBPERA,IBDT,.IBPG)
+3 IF IBREPG=1
SET IBREPG=0
DO RHDR(IBPERA,IBDT,.IBPG)
+4 KILL IBEOB,IBGX,IBCL,IBDGCR,IBEPAR,IBSPL,IBEERR
+5 DO GETS^DIQ(361.1,IBEIEN_",",".01;.02;.03;.04;.06;.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;","EI","IBEOB")
+6 ; Claim Level Adjustments
DO GETS^DIQ(361.1,IBEIEN_",","10*;","EI","IBGX")
DO RESORT^IBJTEP1("IBGX",361.111)
DO RESORT^IBJTEP1("IBGX",361.11)
+7 ; Line Level Adjustments
DO GETS^DIQ(361.1,IBEIEN_",","15*;","EI","IBCL")
+8 ; ERA Splits for this EEOB
DO GETS^DIQ(361.1,IBEIEN_",","8*;","EI","IBSPL")
+9 ; EOB Errors if they exist
DO GETS^DIQ(361.1,IBEIEN_",","20;","","IBEERR")
+10 ; IB*2.0*609
NEW IBAR,IBCOL
+11 ; IB*2.0*609
SET IBAR=$$BILL^RCJIBFN2($GET(IBEOB(361.1,IBEIEN_",",.01,"I")))
SET IBCOL=$PIECE(IBAR,U,5)
+12 ; Make it easier to walk the data
+13 DO RESORT^IBJTEP1("IBCL",361.11511)
DO RESORT^IBJTEP1("IBCL",361.115)
DO RESORT^IBJTEP1("IBCL",361.1151)
+14 DO RESORT^IBJTEP1("IBCL",361.1152)
DO RESORT^IBJTEP1("IBCL",361.1154)
+15 DO GETS^DIQ(399,IBEOB(361.1,IBEIEN_",",.01,"I")_",","460;","EI","IBDGCR")
+16 DO GETS^DIQ(344.4,IBPERA_",",".01;.02;.03;.04;.05;.06;.07;.08;.09;.1;.11;.12;.13;.14;.15;4.02;","E","IBEPAR")
+17 ;
+18 DO SET("********** EOB/835 INFORMATION ("_BB_" of "_IBEBERA_") **********")
if IBQUIT
QUIT
+19 SET XLN=" EOB Type: "_$GET(IBEOB("361.1",IBEIEN_",",".04","E"))
SET XSP=$EXTRACT(SP80,1,(40-$LENGTH(XLN)))
+20 DO SET(XLN_XSP_"EOB Paid Date: "_$GET(IBEOB("361.1",IBEIEN_",",".06","E")))
if IBQUIT
QUIT
+21 SET TSDT=$$FMTE^XLFDT($GET(IBEOB("361.1",IBEIEN_",","1.1","I")),"2Z")
SET TEDT=$$FMTE^XLFDT($GET(IBEOB("361.1",IBEIEN_",","1.11","I")),"2Z")
SET XLN=" Svc From Date: "_TSDT
SET XSP=$EXTRACT(SP80,1,(40-$LENGTH(XLN)))
+22 DO SET(XLN_XSP_"Svc to Date: "_TEDT)
if IBQUIT
QUIT
+23 DO SET(" ICN: "_$GET(IBEOB("361.1",IBEIEN_",",".14","E")))
if IBQUIT
QUIT
+24 DO SET(" Payer Name/TIN: "_$GET(IBEOB("361.1",IBEIEN_",",".02","E"))_"/"_$GET(IBEOB("361.1",IBEIEN_",",".03","E")))
if IBQUIT
QUIT
+25 SET XLN=" ERA #: "_$GET(IBEPAR("344.4",IBPERA_",",".01","E"))
SET XSP=$EXTRACT(SP80,1,(40-$LENGTH(XLN)))
+26 DO SET(XLN_XSP_"Auto-Post Status: "_$GET(IBEPAR("344.4",IBPERA_",","4.02","E")))
if IBQUIT
QUIT
+27 DO SET(" Trace #: "_$GET(IBEPAR("344.4",IBPERA_",",".02","E")))
if IBQUIT
QUIT
+28 ; Access to PSOORDER supported by DBIA #1878
+29 SET TECME=$PIECE($GET(IBDGCR(399,IBEOB(361.1,IBEIEN_",",.01,"I")_",",460,"E")),";",1)
SET TDOS=$$FMTE^XLFDT($$DOS^PSOBPSU1(+TECME),"2Z")
+30 ;Reference to $$STATUS^BPSOSRX supported by IA 4412
+31 SET TRX=$$GET1^DIQ(52,+TECME_",",".01")
+32 SET TSTAT=$PIECE($$STATUS^BPSOSRX(TRX,$$LSTRFL^PSOBPSU1(+TECME)),"^")
+33 SET TRX=TRX_"/"_$$LSTRFL^PSOBPSU1(+TECME)_"/"_TSTAT
+34 IF TECME=""
SET TDOS=""
SET TRX=""
+35 SET XLN=" ECME #: "_TECME
SET XSP=$EXTRACT(SP80,1,(25-$LENGTH(XLN)))
SET XSP1=$EXTRACT(SP80,1,(39-$LENGTH(XLN_XSP_"DOS: "_TDOS)))
+36 DO SET(XLN_XSP_"DOS: "_TDOS_XSP1_"Rx/Fill/Release Status: "_TRX)
if IBQUIT
QUIT
+37 DO SET("--------------------------------------------------------------------------------")
if IBQUIT
QUIT
+38 ; This EEOB was split display split payment information
if $DATA(IBSPL)>1
Begin DoDot:1
+39 NEW SPL
+40 DO SET("** A/R CORRECTED PAYMENT DATA:")
if IBQUIT
QUIT
+41 DO SET(" TOTAL AMT PD: "_$JUSTIFY(IBEOB(361.1,IBEIEN_",",1.01,"E"),9,2))
if IBQUIT
QUIT
+42 SET SPL=""
FOR
SET SPL=$ORDER(IBSPL(361.18,SPL))
if SPL=""
QUIT
Begin DoDot:2
+43 DO SET(" "_$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))
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
+44 DO SET(" ")
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+45 DO SET("CLAIM LEVEL PAY STATUS:")
if IBQUIT
QUIT
+46 DO SET(" Total Submitted Charges :"_$JUSTIFY($GET(IBEOB("361.1",IBEIEN_",","2.04","E")),11,2)_" Payer Covered Amount :"_$JUSTIFY($GET(IBEOB("361.1",IBEIEN_",","1.03","E")),11,2))
if IBQUIT
QUIT
+47 DO SET(" Payer Paid Amount :"_$JUSTIFY($GET(IBEOB("361.1",IBEIEN_",","1.01","E")),11,2)_" MEDICARE Allowed Amount :"_$JUSTIFY($GET(IBEOB("361.1",IBEIEN_",","2.03","E")),11,2))
if IBQUIT
QUIT
+48 ; IB*2.0*609
DO SET(" Patient Responsibility :"_$JUSTIFY($GET(IBEOB("361.1",IBEIEN_",","1.02","E")),11,2)_" % Collected :"_$JUSTIFY(+IBCOL,11,0)_" %")
if IBQUIT
QUIT
+49 DO SET("--------------------------------------------------------------------------------")
if IBQUIT
QUIT
+50 DO SET("CLAIM LEVEL ADJUSTMENTS:")
if IBQUIT
QUIT
+51 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
+52 SET CC=AA
FOR
SET CC=$ORDER(IBGX(361.111,CC))
if $EXTRACT(CC,1,$LENGTH(AA))'=AA
QUIT
Begin DoDot:2
+53 IF AQ=""
SET AQ=$JUSTIFY(ACNT,3)_") "
+54 IF '$TEST
SET ACNT=ACNT+1
SET AQ=$JUSTIFY(ACNT,3)_") "
+55 DO SET(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"))
if IBQUIT
QUIT
+56 SET RMIEN=$$FIND1^DIC(345,"","BX",IBGX(361.111,CC,.01,"E"),"","","IBPERR")
+57 IF RMIEN'=""
KILL IBPERR,RCRDC,RCFLD
SET RCXY=$$GET1^DIQ(345,RMIEN_",",4,"","RCRDC","IBPERR")
DO DLN^IBJTEP1("RCRDC","RCFLD",57,69)
+58 DO SET(" ADJ. CODE: "_IBGX(361.111,CC,.01,"E")_" => "_RCFLD(1))
if IBQUIT
QUIT
+59 IF RCFLD>1
FOR II=2:1:RCFLD
DO SET(" "_RCFLD(II))
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+60 IF ACNT=0
DO SET(" -- None --")
if IBQUIT
QUIT
+61 if 'IBQUIT
DO SET("CLAIM LEVEL REMARKS: ")
if IBQUIT
QUIT
+62 SET RCRC=0
FOR II="3.03","3.04","3.05","3.06","3.07"
if IBEOB("361.1",IBEIEN_",",II,"E")'=""
Begin DoDot:1
+63 ; Get IEN for this remark code - if no IEN then need to look at the data "RM1" to "RM5"
+64 SET RMIEN=$$FIND1^DIC(346,"","BX",IBEOB("361.1",IBEIEN_",",II,"E"),"","","IBPERR")
+65 IF RMIEN'=""
KILL IBPERR,RCRDC,RCFLD
SET RCXY=$$GET1^DIQ(346,RMIEN_",",4,"","RCRDC","IBPERR")
DO DLN^IBJTEP1("RCRDC","RCFLD",50,68)
+66 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,IBEIEN_",",RCFLD)
+67 SET RCRC=RCRC+1
DO SET(" --- REMARK CODE("_RCRC_"): "_IBEOB("361.1",IBEIEN_",",II,"E")_" => "_RCFLD(1))
if IBQUIT
QUIT
+68 IF RCFLD>1
FOR II=2:1:RCFLD
DO SET(" "_RCFLD(II))
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+69 IF RCRC=0
DO SET(" -- None --")
if IBQUIT
QUIT
+70 if 'IBQUIT
DO SET("--------------------------------------------------------------------------------")
if IBQUIT
QUIT
+71 ; Walk through the line level information...
+72 DO SET("EEOB LINE LEVEL ADJUSTMENTS:")
if IBQUIT
QUIT
+73 SET RCPL=0
SET EE=""
FOR
SET EE=$ORDER(IBCL(361.115,EE))
if EE=""
QUIT
SET RCPL=RCPL+1
Begin DoDot:1
+74 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")
+75 DO SET(" # SV DT REVCD PROC MOD UNITS BILLED DEDUCT COINS ALLOW PYMT")
if IBQUIT
QUIT
+76 SET RCBAMT=$$BILLN^IBJTEP1(IBEOB(361.1,IBEIEN_",",.01,"I"),IBCL(361.115,EE,.1,"E"),IBCL(361.115,EE,.04,"E"))
+77 ; Get Deductable and Co-Insurance amts.
SET RCDED=$$ADJU^IBJTEP1("DEDUCT",.IBCL,EE)
SET RCOIN=$$ADJU^IBJTEP1("COINS",.IBCL,EE)
+78 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)
+79 DO SET(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))
if IBQUIT
QUIT
+80 DO SET(" ")
if IBQUIT
QUIT
+81 DO SET(" Product/Service Description:"_IBCL(361.115,EE,.09,"E"))
if IBQUIT
QUIT
+82 DO SET(" Payer Policy Reference:"_$GET(IBCL(361.11512,EE,.01,"E")))
if IBQUIT
QUIT
+83 DO SET(" ")
if IBQUIT
QUIT
+84 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
+85 SET ACNT=ACNT+1
+86 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
+87 SET RCRC=RCRC+1
DO SET(" -> 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))
if IBQUIT
QUIT
+88 SET RCXY=$$FIND1^DIC(345,"","BX",IBCL(361.11511,CC,.01,"E"),"","","RCERR")
+89 KILL RCRDC,RCERR
SET RCXY=$$GET1^DIQ(345,RCXY_",",4,"","RCRDC","RCERR")
+90 IF $DATA(RCRDC)>0
KILL RCFLD
DO DLN^IBJTEP1("RCRDC","RCFLD",57,57)
+91 ; 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)
+92 DO SET(" ADJ CODE: "_$$CJ^XLFSTR(IBCL(361.11511,CC,.01,"E"),5)_" "_RCFLD(1))
if IBQUIT
QUIT
+93 IF RCFLD>1
FOR II=2:1:RCFLD
DO SET(" "_RCFLD(II))
if IBQUIT
QUIT
End DoDot:3
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
+94 ; Display RARC Codes for this Line Item
+95 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
+96 KILL IBERR,RCRDC,RCFLD
+97 SET RMIEN=$$FIND1^DIC(346,"","BX",IBCL(361.1154,QQ,.02,"E"),"","","IBERR")
+98 ; avoid "undefined" if RMIEN could not be found *642
+99 IF 'RMIEN
SET RCFLD=1
SET RCFLD(1)="*["_IBCL(361.1154,QQ,.02,"E")_"] code is not on file."
+100 IF RMIEN
SET RCXY=$$GET1^DIQ(346,RMIEN_",",4,"","RCRDC","IBPERR")
DO DLN^IBJTEP1("RCRDC","RCFLD",50,68)
+101 DO SET(" --- RARC: "_IBCL(361.1154,QQ,.02,"E")_" - "_RCFLD(1))
if IBQUIT
QUIT
+102 IF RCFLD>1
FOR II=2:1:RCFLD
DO SET(" "_RCFLD(II))
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
+103 if ACNT'=0
DO SET(" ")
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+104 IF ACNT=0
DO SET(" -- No Line Level Adjustments --")
if IBQUIT
QUIT
+105 ; If there are EOB Errors add them to the Report
+106 if $DATA(IBEERR(361.1,IBEIEN_",",20))>9
Begin DoDot:1
+107 DO SET(" ")
if IBQUIT
QUIT
DO SET("EEOB MESSAGE ERRORS:")
if IBQUIT
QUIT
+108 NEW II
SET II=0
FOR
SET II=$ORDER(IBEERR(361.1,IBEIEN_",",20,II))
if II=""
QUIT
DO SET($GET(IBEERR(361.1,IBEIEN_",",20,II)))
if IBQUIT
QUIT
End DoDot:1
+109 if 'IBQUIT
DO SET("================================================================================")
if IBQUIT
QUIT
+110 ;
+111 QUIT
SET(DATA,NEW) ;
+1 IF $GET(NEW)=""
SET NEW=1
+2 WRITE DATA,!
SET IBSL=IBSL+1
+3 IF IBSL'<(IOSL-4)
SET IBQUIT=$$NEWPG(.IBPG,NEW,.IBSL,IBPERA)
+4 QUIT
RHDR(IBSCR,IBDT,IBPG) ;Prints EOB detail report heading
+1 ; IBSCR - IEN of the ERA; IBDT - Report Date; IBPG - page #, passed by reference.
+2 NEW Z
+3 SET Z=$GET(^RCY(344.4,IBSCR,0))
+4 IF IBPG!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF,*13
+5 SET IBPG=IBPG+1
+6 DO HDRP("EDI EEOB DETAIL - 835 INFORMATION SCREEN "_$$FMTE^XLFDT(IBDT,2),1,"Page: "_IBPG)
+7 DO HDRP($EXTRACT(" ERA NUMBER: "_IBSCR_$JUSTIFY("",25),1,25)_" ERA DATE: "_$$FMTE^XLFDT($PIECE(Z,U,4)),1)
+8 DO HDRP("INS COMPANY: "_$PIECE(Z,U,6)_"/"_$PIECE(Z,U,3),1)
+9 DO HDRP("ERA TRACE #: "_$PIECE(Z,U,2),1)
+10 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","="),!
+11 SET IBSL=5
+12 QUIT
+13 ;
NEWPG(IBPG,IBNEW,IBSL,IBSCR) ; Check for new page needed, output header
+1 ; IBPG = Page number passwd by referece
+2 ; IBNEW = 1 to force new page
+3 ; IBSL = page length passed by reference
+4 ; Function returns 1 if user chooses to stop output
+5 NEW IBSTOP
SET IBSTOP=0
+6 IF IBNEW!'IBPG!(IBSL'<(IOSL-4))
Begin DoDot:1
+7 if IBPG
DO ASK(.IBSTOP)
IF IBSTOP
QUIT
+8 WRITE @IOF
+9 DO RHDR(IBSCR,IBDT,.IBPG)
End DoDot:1
+10 QUIT IBSTOP
+11 ;
ASK(IBSTOP) ; User if you want to quit or continue
+1 SET IBSTOP=0
+2 IF $EXTRACT(IOST,1,2)'["C-"
QUIT
+3 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+4 SET DIR(0)="E"
WRITE !
DO ^DIR
+5 IF ($DATA(DIRUT))!($DATA(DUOUT))
SET IBSTOP=1
QUIT
+6 QUIT
+7 ;
HDRP(Z,X,Z1) ; Print Header (Z=String, X=1 (line feed) X=0 (no LF), Z1 (page number right justified)
+1 IF X=1
WRITE !
+2 WRITE ?(IOM-$LENGTH(Z)\2),Z
if $GET(Z1)]""
WRITE ?(IOM-$LENGTH(Z1)),Z1
+3 QUIT
