IBCECSA6 ;ALB/CXW/PJH - VIEW EOB SCREEN ;01-OCT-1999
;;2.0;INTEGRATED BILLING;**137,135,155,417,431,451,488,547**;21-MAR-1994;Build 119
;;Per VA Directive 6402, this routine should not be modified.
;
; reference to $$VFILE^DILFD allowed with IA#2055 (IB*2.0*547)
;
BLD ;build EOB data display
D GETEOB(IBCNT,0)
Q
;
GETEOB(IBCNT,IBSRC,IBFULL,IBJTIBLN) ; Get EOB data in display format
; IBCNT = the ien of the entry in file 361.1
; IBSRC = 1 if called from AR, 0 if List Manager format needed
; = 2 if called from AR and header data is desired
; If IBSRC > 0 ^TMP("PRCA_EOB",$J,IBCNT,n)=line n's text is ret'd
; IBFULL = 1 if no check should be made to eliminate a fld whose value=0
; IBJTIBLN = line number to start VALMCNT with (optional)
; used by IBJTBA1
;
N IBREC,IBTYP,CNT,IBREM
S IBFULL=$G(IBFULL),IBSRC=$G(IBSRC)
I IBSRC N VALMBG,VALMCNT
S VALMCNT=0,VALMBG=1,CNT=0
I $G(IBJTIBLN)>0 S VALMCNT=IBJTIBLN
S IBREC=$G(^IBM(361.1,IBCNT,0)),IBTYP=$P(IBREC,U,4)
I IBSRC K ^TMP("PRCA_EOB",$J,IBCNT)
; Once we're displaying a single EOB, remove the multiple EOB header of
; the View EOB screen that was set in HDR^IBCEOB2 - VALMHDR(4).
I 'IBSRC,$G(VALMHDR(4))'="" S VALMHDR(4)=""
D GEN,PAY,ARCP^IBCECSA7,CLVL,CLVLA,MIN^IBCECSA5,MOUT,LLVLA^IBCECSA7,RDATA^IBCECSA7
Q
;
SEL(IB,ONE) ;
N IBDA
D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S"))
S IBDA=0 S IBDA=$O(VALMY(IBDA)) Q:'IBDA D
. S IB=$P($G(^TMP("IBCECSD",$J,IBDA)),U,2)
. S IBONE=1
Q
;
ACT ; Reposition display using actions
I '$G(IBONE) D SEL(.IBCNT,1) D BLD:$G(IBCNT)
S VALMBG=$G(^TMP("IBCECSD",$J,"X",+$G(IBACT))) S:'VALMBG VALMBG=1
S VALMBCK="R"
Q
;
SET(IBSRC,X,CNT,IBCNT) ;set list manager arrays
S VALMCNT=VALMCNT+1,IBSRC=$G(IBSRC)
;
I IBSRC D Q
. S ^TMP("PRCA_EOB",$J,IBCNT,VALMCNT)=X
;
S ^TMP("IBCECSD",$J,VALMCNT,0)=X
S ^TMP("IBCECSD",$J,"IDX",VALMCNT,CNT)=""
S ^TMP("IBCECSD",$J,CNT)=VALMCNT_U_IBCNT
Q
;
GEN ;
S IBSRC=$G(IBSRC) Q:IBSRC=1
N IBREC1,IBTMP,IBSPL
S IBSPL=+$O(^IBM(361.1,IBCNT,8,0)),IBSPL=(+$O(^(IBSPL))'=IBSPL)
S IB=$$SETSTR^VALM1("EOB GENERAL INFORMATION:","",1,50)
D SET(IBSRC,IB,CNT,IBCNT)
I 'IBSRC D
. D CNTRL^VALM10(VALMCNT,1,24,IORVON,IORVOFF)
. S ^TMP("IBCECSD",$J,"X",1)=VALMCNT
S IB=$$SETSTR^VALM1("Type : "_$S(IBTYP:"MEDICARE MRA",1:"NORMAL EOB")_$S(IBSPL:" (SPLIT IN A/R)",1:""),"",2,39)
S IB=$$SETSTR^VALM1("EOB Paid DT : "_$$DAT1^IBOUTL($P(IBREC,U,6),1),IB,41,38)
D SET(IBSRC,IB,CNT,IBCNT)
I IBSRC D
. S IB=$$SETSTR^VALM1($S(IBSRC:"Entry Dt/Tm :"_$$DAT1^IBOUTL($P(IBREC,U,5),1),1:""),"",2,39)
. S IBTMP=$P(IBREC,U,13)
. S IB=$$SETSTR^VALM1("Claim Status : "_$$EXTERNAL^DILFD(361.1,.13,"",IBTMP),IB,41,38)
. D SET(IBSRC,IB,CNT,IBCNT)
. S IBTMP=$P(IBREC,U,16)
. S IB=$$SETSTR^VALM1("Review Status: "_$$EXTERNAL^DILFD(361.1,.16,"",IBTMP),IB,41,38)
. D SET(IBSRC,IB,CNT,IBCNT)
. S IB=$$SETSTR^VALM1("Entered By : "_$P($G(^VA(200,+$P(IBREC,U,18),0)),U),"",2,39)
. S IBTMP=$P(IBREC,U,15)
. S IB=$$SETSTR^VALM1("Insurance Seq: "_$$EXTERNAL^DILFD(361.1,.15,"",IBTMP),IB,41,38)
. D SET(IBSRC,IB,CNT,IBCNT)
I 'IBSRC D
. S IB=$$SETSTR^VALM1($S($P(IBREC,U,17):"Manual Entry: YES",1:""),"",2,39)
. S IBTMP=$P(IBREC,U,13)
. S IB=$$SETSTR^VALM1("Claim Status : "_$$EXTERNAL^DILFD(361.1,.13,"",IBTMP),IB,41,38)
. D SET(IBSRC,IB,CNT,IBCNT)
. S IBTMP=$P(IBREC,U,15)
. S IB=$$SETSTR^VALM1("Insurance Seq: "_$$EXTERNAL^DILFD(361.1,.15,"",IBTMP),"",41,38)
. D SET(IBSRC,IB,CNT,IBCNT)
S IBREC1=$G(^IBM(361.1,IBCNT,100))
I $S($G(IBFULL):1,1:$P(IBREC1,U,4)'=""!($P(IBREC1,U,3)'="")) D
. S IB=$$SETSTR^VALM1("Last Edited : "_$$DAT1^IBOUTL($P(IBREC1,U,4),1),"",2,39)
. S IB=$$SETSTR^VALM1("Last Edit By : "_$P($G(^VA(200,+$P(IBREC1,U,3),0)),U),IB,41,38)
. D SET(IBSRC,IB,CNT,IBCNT)
;
D INSINF^IBCECSA7(+IBREC,CNT,IBCNT)
;
;Additional fields for HIPAA 5010
I IBSRC D
.N IBOSN,IBOSN1,IBREC50,IBREC51
.S IBREC50=$G(^IBM(361.1,IBCNT,50)),IBREC51=$G(^IBM(361.1,IBCNT,51))
.S IB=$$SETSTR^VALM1("Claim Rec'd Date : "_$$DAT1^IBOUTL($P(IBREC50,U),1),"",2,39)
.D SET(IBSRC,IB,CNT,IBCNT)
.S IBOSN=$E($P(IBREC51,U),1,56),IBOSN1=$E($P(IBREC51,U),57,112)
.S IB=$$SETSTR^VALM1("Other Subscriber Name: "_IBOSN,"",2,79)
.D SET(IBSRC,IB,CNT,IBCNT) Q:IBOSN1=""
.S IB=$$SETSTR^VALM1(" "_IBOSN1,"",2,79)
.D SET(IBSRC,IB,CNT,IBCNT)
;
I $S($G(IBFULL):1,1:$P($G(^IBM(361.1,IBCNT,6)),U)'=""!($P($G(^IBM(361.1,IBCNT,6)),U,2)'="")) D
. S IB=$$SETSTR^VALM1("New Pat. Nm.: "_$P($G(^IBM(361.1,IBCNT,6)),U),"",2,39)
. S IB=$$SETSTR^VALM1("New Pat. Id : "_$P($G(^IBM(361.1,IBCNT,6)),U,2),IB,41,38)
. D SET(IBSRC,IB,CNT,IBCNT)
D:IBSRC SET(IBSRC,"",CNT,IBCNT)
Q
;
PAY ;
S IBSRC=$G(IBSRC) Q:IBSRC=1
N IBREC1,IBTMP
S IB=$$SETSTR^VALM1("PAYER INFORMATION:","",1,50)
D SET(IBSRC,IB,CNT,IBCNT)
I 'IBSRC D
. D CNTRL^VALM10(VALMCNT,1,18,IORVON,IORVOFF)
. S ^TMP("IBCECSD",$J,"X",2)=VALMCNT
; KL - HIPAA 5010 - moved the write of the Payer ID on the next line down from the payer name to accommodate
; the increased length of the PAYER NAME from 35 to 60 characters. modified length parameter to $$SETSTR function for
; Payer ID and ICN to accommodate increased length of additional 20 characters.
S IB=$$SETSTR^VALM1("Payer Name : "_$P($G(^DIC(36,+$P(IBREC,U,2),0)),U),"",2,60)
D SET(IBSRC,IB,CNT,IBCNT)
S IB=$$SETSTR^VALM1("Payer Id : "_$P(IBREC,U,3),IB,2,38)
D SET(IBSRC,IB,CNT,IBCNT)
S IB=$$SETSTR^VALM1("ICN : "_$P(IBREC,U,14),"",2,60)
D SET(IBSRC,IB,CNT,IBCNT)
;Additional fields for HIPA 5010
N I,IBREC25,IBCON,IBCONTXT,IBCTYP,IBPAYNAM,IBWEB3,IBWEB
; Display PAYER CONTACT NAME, file #361.1, or CONTACT NAME, file #344; .4, (whichever is available)
S IBREC25=$G(^IBM(361.1,IBCNT,25))
S IBPAYNAM=$P(IBREC25,U)
I IBPAYNAM="",+$G(RCSCR)>0 S IBPAYNAM=$P($G(^RCY(344.4,RCSCR,3)),U)
I IBPAYNAM'="" D
.S IB=$$SETSTR^VALM1("Payer Contact: "_IBPAYNAM,IB,2,60)
.D SET(IBSRC,IB,CNT,IBCNT)
I $TR($P(IBREC25,U,2,7),U,"")'="" D
.F I=2,4,6 D
..S IBCON=$P(IBREC25,U,I),IBCTYP=$P(IBREC25,U,I+1) Q:IBCON=""
..S IBCONTXT=$S(IBCTYP="TE":"Contact Phone : ",IBCTYP="FX":"Contact Fax : ",IBCTYP="EM":"Contact e-Mail : ",1:"Invalid type :")
..S IB=$$SETSTR^VALM1(IBCONTXT_IBCON,"",2,50)
..D SET(IBSRC,IB,CNT,IBCNT)
I $G(RCSCR)'="" D
.S IBWEB=$P($G(^RCY(344.4,RCSCR,5)),U) Q:IBWEB=""
.S IB=$$SETSTR^VALM1("Payer Web Site : "_$E(IBWEB,1,60),"",2,78)
.D SET(IBSRC,IB,CNT,IBCNT) Q:$L(IBWEB)<61
.S IB=$$SETSTR^VALM1($E(IBWEB,61,115),"",19,78)
.D SET(IBSRC,IB,CNT,IBCNT)
;Payer Policy References
D PPR
N IBREC51
S IBREC51=$G(^IBM(361.1,IBCNT,51))
I $P(IBREC,U,9)'=""!($P(IBREC51,U,2)'="") D
. S IB=$$SETSTR^VALM1("Cross Ovr ID : "_$P(IBREC,U,9),"",2,39)
. D SET(IBSRC,IB,CNT,IBCNT)
. S IB=$$SETSTR^VALM1("Cross Ovr Nm: "_$P(IBREC51,U,2),"",2,76)
. D SET(IBSRC,IB,CNT,IBCNT)
D:IBSRC SET(IBSRC,"",CNT,IBCNT)
;Audit Details
D AUDIT
Q
;
CLVL ;
N IBREC1,IBTMP,IBRL
S IB=$$SETSTR^VALM1("CLAIM LEVEL PAY STATUS:","",1,50),IBSRC=$G(IBSRC)
D SET(IBSRC,IB,CNT,IBCNT)
I 'IBSRC D
. D CNTRL^VALM10(VALMCNT,1,23,IORVON,IORVOFF)
. S ^TMP("IBCECSD",$J,"X",3)=VALMCNT
I '$D(^IBM(361.1,IBCNT,2)),'$D(^IBM(361.1,IBCNT,1)) D SET(IBSRC," NONE",CNT,IBCNT) Q
S IB=$$SETSTR^VALM1("Tot Submitted Chrg: "_$$A10($P($G(^IBM(361.1,IBCNT,2)),U,4)),"",2,39)
S IBREC1=$G(^IBM(361.1,IBCNT,1))
S IB=$$SETSTR^VALM1("Covered Amt : "_$$A10($P(IBREC1,U,3)),IB,41,38)
D SET(IBSRC,IB,CNT,IBCNT)
S IB=$$SETSTR^VALM1("Payer Paid Amt : "_$$A10($P(IBREC1,U)),"",2,39)
S IB=$$SETSTR^VALM1("Patient Resp. Amt : "_$$A10($S($D(^IBM(361.1,IBCNT,"ERR")):0,IBSRC:$P(IBREC1,U,2),$$FT^IBCEF(+IBREC)=3:$$PTRESPI^IBCECOB1(IBCNT),1:$P($G(^IBM(361.1,IBCNT,1)),"^",2))),IB,41,38)
D SET(IBSRC,IB,CNT,IBCNT)
S (IB,IBRL)=""
I $S(IBFULL:1,1:$P(IBREC1,U,4)) S IB=$$SETSTR^VALM1("Discount Amt : "_$$A10($P(IBREC1,U,4)),"",2,39),IBRL=1
I $S(IBFULL:1,1:$P(IBREC1,U,5)) S IB=$$SETSTR^VALM1("Per Day Limit Amt : "_$$A10($P(IBREC1,U,5)),IB,$S('IBRL:2,1:41),$S('IBRL:39,1:38)),IBRL=$S(IBRL:0,1:1) I IBRL=0 D SET(IBSRC,IB,CNT,IBCNT) S IB=""
I $S(IBFULL:1,1:$P(IBREC1,U,8)) S IB=$$SETSTR^VALM1("Tax Amt : "_$$A10($P(IBREC1,U,8)),IB,$S('IBRL:2,1:41),$S('IBRL:39,1:38)),IBRL=$S(IBRL:0,1:1) I IBRL=0 D SET(IBSRC,IB,CNT,IBCNT) S IB=""
I $S(IBFULL:1,1:$P(IBREC1,U,9)) S IB=$$SETSTR^VALM1("Tot Before Tax Amt: "_$$A10($P(IBREC1,U,9)),IB,$S('IBRL:2,1:41),$S('IBRL:39,1:38)),IBRL=$S(IBRL:0,1:1) I IBRL=0 D SET(IBSRC,IB,CNT,IBCNT) S IB=""
I $S(IBFULL:1,1:$P($G(^IBM(361.1,IBCNT,2)),U,3)) S IB=$$SETSTR^VALM1("Total Allowed Amt : "_$$A10($P($G(^IBM(361.1,IBCNT,2)),U,3)),IB,$S('IBRL:2,1:41),$S('IBRL:39,1:38)),IBRL=$S(IBRL:0,1:1) I IBRL=0 D SET(IBSRC,IB,CNT,IBCNT) S IB=""
I $S(IBFULL:1,1:$P($G(^IBM(361.1,IBCNT,2)),U,5)) S IB=$$SETSTR^VALM1("Negative Reimb Amt: "_$$A10($P($G(^IBM(361.1,IBCNT,2)),U,5)),IB,$S('IBRL:2,1:41),$S('IBRL:39,1:38)),IBRL=$S(IBRL:0,1:1) I IBRL=0 D SET(IBSRC,IB,CNT,IBCNT) S IB=""
I $G(IBSRC) I $S(IBFULL:1,1:$P(IBREC,U,12)) S IB=$$SETSTR^VALM1("Discharge Fraction: "_$$A10($P(IBREC,U,12)),IB,$S('IBRL:2,1:41),$S('IBRL:39,1:38)),IBRL=$S(IBRL:0,1:1) I IBRL=0 D SET(IBSRC,IB,CNT,IBCNT) S IB=""
I $S(IBFULL:1,1:$P(IBREC,U,10)) S IB=$$SETSTR^VALM1("DRG Code Used :"_$$RJ^XLFSTR($P(IBREC,U,10),11," "),IB,$S('IBRL:2,1:41),$S('IBRL:39,1:38)),IBRL=$S(IBRL:0,1:1) I IBRL=0 D SET(IBSRC,IB,CNT,IBCNT) S IB=""
I $S(IBFULL:1,1:$P(IBREC,U,11)) S IB=$$SETSTR^VALM1("DRG Weight Used :"_$$RJ^XLFSTR($P(IBREC,U,11),11," "),IB,$S('IBRL:2,1:41),$S('IBRL:39,1:38)),IBRL=$S(IBRL:0,1:1)
D:IBRL'="" SET(IBSRC,IB,CNT,IBCNT)
D:IBSRC SET(IBSRC,"",CNT,IBCNT)
Q
;
MOUT ;
N IBREC1,IBRL
S IBREC1=$G(^IBM(361.1,IBCNT,3)),IBSRC=$G(IBSRC)
I 'IBSRC,$$INPAT^IBCEF(+IBREC),$TR(IBREC1,"0^")="" Q
I IBREC1="" D:'$D(^IBM(361.1,IBCNT,4)) SET(IBSRC," NONE",CNT,IBCNT) D:'IBSRC SET(IBSRC,"",CNT,IBCNT),REMARK^IBCECSA5 Q
D SET(IBSRC," OUTPATIENT:",CNT,IBCNT)
S IBRL=""
I $S(IBFULL:1,1:$P(IBREC1,U)) S IB=$$SETSTR^VALM1("Reimburse Rate : "_$$P10($P(IBREC1,U)),"",$S('IBRL:4,1:40),$S('IBRL:41,1:38)),IBRL=$S(IBRL:0,1:1)
I $S(IBFULL:1,1:$P(IBREC1,U,2)) S IB=$$SETSTR^VALM1("HCPCS Pay Amt : "_$$A10($P(IBREC1,U,2)),IB,$S('IBRL:4,1:40),$S('IBRL:41,1:38)),IBRL=$S(IBRL:0,1:1)
D:IBRL=0 SET(IBSRC,IB,CNT,IBCNT)
I $S(IBFULL:1,1:$P(IBREC1,U,8)) S IB=$$SETSTR^VALM1("Esrd Paid Amt : "_$$A10($P(IBREC1,U,8)),"",$S('IBRL:4,1:40),$S('IBRL:41,1:38)),IBRL=$S(IBRL:0,1:1)
D:IBRL=0 SET(IBSRC,IB,CNT,IBCNT)
I $S(IBFULL:1,1:$P(IBREC1,U,9)) S IB=$$SETSTR^VALM1("Non-Pay Prof Comp : "_$$A10($P(IBREC1,U,9)),IB,$S('IBRL:4,1:40),$S('IBRL:41,1:38)),IBRL=$S(IBRL:0,1:1)
D:IBRL'="" SET(IBSRC,IB,CNT,IBCNT)
D REMARK^IBCECSA5
D SET(IBSRC,"",CNT,IBCNT)
Q
;
CLVLA ;
N IBREC,IBFLG,GR,RSN,Z,I,IBCARC,IBN
S IB=$$SETSTR^VALM1("CLAIM LEVEL ADJUSTMENTS:","",1,50),IBSRC=$G(IBSRC)
D SET(IBSRC,IB,CNT,IBCNT)
I 'IBSRC D
. D CNTRL^VALM10(VALMCNT,1,24,IORVON,IORVOFF)
. S ^TMP("IBCECSD",$J,"X",4)=VALMCNT
S (Y,IBFLG)=0 F S Y=$O(^IBM(361.1,IBCNT,10,Y)) Q:'Y D
. S IBREC=$G(^IBM(361.1,IBCNT,10,Y,0)),GR=$P(IBREC,U,1)
. I GR="OA",$P($G(^IBM(361.1,IBCNT,10,Y,1,0)),U,4)=1,$D(^IBM(361.1,IBCNT,10,Y,1,"B","AB3")) Q ; kludge
. S IBREC=$$EXTERNAL^DILFD(361.11,.01,"",GR),IBFLG=1
. D SET(IBSRC," GROUP CODE: "_IBREC,CNT,IBCNT)
. S Z=0 F S Z=$O(^IBM(361.1,IBCNT,10,Y,1,Z)) Q:'Z D
.. S IBREC=$G(^IBM(361.1,IBCNT,10,Y,1,Z,0)),RSN=$P(IBREC,U,1)
.. I GR="OA",RSN="AB3" Q ; kludge
.. ; ib*2.0*547 - get CARC/RARC descriptions from new AR files 345/346 when available
.. S:'$$VFILE^DILFD(345) IB=$$SETSTR^VALM1("REASON CODE: "_RSN_" "_$P(IBREC,U,4),"",3,77)
.. S:$$VFILE^DILFD(345) IB=$$SETSTR^VALM1("REASON CODE: "_RSN,"",3,77)
.. D SET(IBSRC,IB,CNT,IBCNT)
.. I $$VFILE^DILFD(345) D
... S IBN=$$CARC^IBCECSA5(RSN,345,74,"IBCARC")
... F I=1:1:IBN S IB=$$SETSTR^VALM1(IBCARC(I),"",3,77) D SET(IBSRC,IB,CNT,IBCNT)
.. ; end IB*2.0*547 changes
.. S IB=$$SETSTR^VALM1("Amount: "_$$A10($P(IBREC,U,2)),"",3,40)
.. S IB=$$SETSTR^VALM1("Quantity: "_$P(IBREC,U,3),IB,41,38)
.. D SET(IBSRC,IB,CNT,IBCNT)
.. ;D:IBSRC SET(IBSRC,"",CNT,IBCNT) ;IB*2.0*488 (vd) REMOVED EXTRA BLANK LINE.
I 'IBFLG D SET(IBSRC," NONE",CNT,IBCNT)
Q
;
A10(X) ; returns a dollar amount right justified to 10 characters
Q $$RJ^XLFSTR($FN(X,"",2),10," ")
;
P10(X) ; returns a % right just 10
; X is a decimal between 0-1
Q $$RJ^XLFSTR((X*100)_"%",10," ")
;
PPR ;Display Payer Policy References
;
N I,IBARR,IBX,IBX2,IBX3,IBPY,IBPCNT,IBDISP,IBTXT
S IBX=0
;Get next Adjustment
F S IBX=$O(^IBM(361.1,IBCNT,15,IBX)) Q:'IBX D
.;Get next Line Level
.S IBX2=0
.F S IBX2=$O(^IBM(361.1,IBCNT,15,IBX,1,IBX2)) Q:'IBX2 D
..;Get Adjustment line references (up to 5)
..S IBX3=0
..F S IBX3=$O(^IBM(361.1,IBCNT,15,IBX,1,IBX2,2,IBX3)) Q:'IBX3 D
...S IBPY=$P($G(^IBM(361.1,IBCNT,15,IBX,1,IBX2,2,IBX3,0)),U) Q:IBPY=""
...S IBARR(IBPY)=""
;Concatenate Adjustment references
S IBPY="",IBPCNT=0
F S IBPY=$O(IBARR(IBPY)) Q:IBPY="" D Q:IBPCNT=5
.S IBPCNT=IBPCNT+1,$P(IBDISP,";",IBPCNT)=IBPY
;Format display
Q:'IBPCNT
S IB=$$SETSTR^VALM1("Policy Reference: Check Payer policies referenced on Payer website","",2,78)
D SET(IBSRC,IB,CNT,IBCNT)
S IB=$$SETSTR^VALM1("for the following: "_$E(IBDISP,1,50),"",2,78)
D SET(IBSRC,IB,CNT,IBCNT)
F I=50:50:250 S IBTXT=$E(IBDISP,I+1,I+50) Q:IBTXT="" D
.S IB=$$SETSTR^VALM1($J("",19)_IBTXT,"",2,78)
.D SET(IBSRC,IB,CNT,IBCNT)
Q
;
AUDIT ;Display details of any EEOB MOVE/COPY
;
N IEN101,FIRST101
S IEN101=0,FIRST101=1
F S IEN101=$O(^IBM(361.1,IBCNT,101,IEN101)) Q:'IEN101 D
.N IB101,IBDATE,IBUSER,IBJUST,IBJUST1,IBORIG,IBDIR
.S IB101=$G(^IBM(361.1,IBCNT,101,IEN101,0)) Q:IB101=""
.S IBDATE=$$EXTERNAL^DILFD(361.1101,.01,,$P(IB101,U,1))
.S IBUSER=$$EXTERNAL^DILFD(361.1101,.02,,$P(IB101,U,2))
.S IBJUST=$E($P(IB101,U,3),1,78),IBJUST1=$E($P(IB101,U,3),79,100)
.S IBORIG=$$EXTERNAL^DILFD(361.1101,.04,,$P(IB101,U,4))
.S IBDIR=$$EXTERNAL^DILFD(361.1101,.05,,$P(IB101,U,5)) ; kl - added MOVE/COPY field
.S:IBDIR']"" IBDIR="Move"
.I FIRST101 D
..S IB=$$SETSTR^VALM1("MOVE/COPY HISTORY","",1,78),FIRST101=0
..D SET(IBSRC,IB,CNT,IBCNT)
.D SET(IBSRC,"",CNT,IBCNT)
.S IB=$$SETSTR^VALM1("Date/Time of EEOB "_IBDIR_": "_IBDATE,"",1,78) ;kl 8/23/11
.D SET(IBSRC,IB,CNT,IBCNT)
.S IB=$$SETSTR^VALM1(IBDIR_" of EEOB performed by: "_IBUSER,"",1,78) ;kl 8/23/11
.D SET(IBSRC,IB,CNT,IBCNT)
.S IB=$$SETSTR^VALM1(IBDIR_" Justification Comments: ","",1,78)
.D SET(IBSRC,IB,CNT,IBCNT)
.S IB=$$SETSTR^VALM1(IBJUST,"",1,78)
.D SET(IBSRC,IB,CNT,IBCNT)
.I IBJUST1]"" D
..S IB=$$SETSTR^VALM1(IBJUST1,"",1,78)
..D SET(IBSRC,IB,CNT,IBCNT)
.I IBORIG]"" D
..S IB=$$SETSTR^VALM1("Original Claim Number: "_IBORIG,"",1,78)
..D SET(IBSRC,IB,CNT,IBCNT)
.;Other claim numbers
.N SUB,IBOTH,OTEXT
.S SUB=0,OTEXT=""
.F S SUB=$O(^IBM(361.1,IBCNT,101,IEN101,1,SUB)) Q:'SUB D
..S IBOTH=$P($G(^IBM(361.1,IBCNT,101,IEN101,1,SUB,0)),U) Q:'IBOTH
..S IBOTH=$$EXTERNAL^DILFD(361.11016,.01,,IBOTH) Q:IBOTH=""
..S OTEXT=OTEXT_","_IBOTH
.S OTEXT=$P(OTEXT,",",2,99)
.I OTEXT]"" D
..S IB=$$SETSTR^VALM1("Other Claims: "_OTEXT,"",1,78)
..D SET(IBSRC,IB,CNT,IBCNT)
.D SET(IBSRC,"",CNT,IBCNT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCECSA6 15427 printed Sep 23, 2025@19:46:04 Page 2
IBCECSA6 ;ALB/CXW/PJH - VIEW EOB SCREEN ;01-OCT-1999
+1 ;;2.0;INTEGRATED BILLING;**137,135,155,417,431,451,488,547**;21-MAR-1994;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; reference to $$VFILE^DILFD allowed with IA#2055 (IB*2.0*547)
+5 ;
BLD ;build EOB data display
+1 DO GETEOB(IBCNT,0)
+2 QUIT
+3 ;
GETEOB(IBCNT,IBSRC,IBFULL,IBJTIBLN) ; Get EOB data in display format
+1 ; IBCNT = the ien of the entry in file 361.1
+2 ; IBSRC = 1 if called from AR, 0 if List Manager format needed
+3 ; = 2 if called from AR and header data is desired
+4 ; If IBSRC > 0 ^TMP("PRCA_EOB",$J,IBCNT,n)=line n's text is ret'd
+5 ; IBFULL = 1 if no check should be made to eliminate a fld whose value=0
+6 ; IBJTIBLN = line number to start VALMCNT with (optional)
+7 ; used by IBJTBA1
+8 ;
+9 NEW IBREC,IBTYP,CNT,IBREM
+10 SET IBFULL=$GET(IBFULL)
SET IBSRC=$GET(IBSRC)
+11 IF IBSRC
NEW VALMBG,VALMCNT
+12 SET VALMCNT=0
SET VALMBG=1
SET CNT=0
+13 IF $GET(IBJTIBLN)>0
SET VALMCNT=IBJTIBLN
+14 SET IBREC=$GET(^IBM(361.1,IBCNT,0))
SET IBTYP=$PIECE(IBREC,U,4)
+15 IF IBSRC
KILL ^TMP("PRCA_EOB",$JOB,IBCNT)
+16 ; Once we're displaying a single EOB, remove the multiple EOB header of
+17 ; the View EOB screen that was set in HDR^IBCEOB2 - VALMHDR(4).
+18 IF 'IBSRC
IF $GET(VALMHDR(4))'=""
SET VALMHDR(4)=""
+19 DO GEN
DO PAY
DO ARCP^IBCECSA7
DO CLVL
DO CLVLA
DO MIN^IBCECSA5
DO MOUT
DO LLVLA^IBCECSA7
DO RDATA^IBCECSA7
+20 QUIT
+21 ;
SEL(IB,ONE) ;
+1 NEW IBDA
+2 DO EN^VALM2($GET(XQORNOD(0)),$SELECT('$GET(ONE):"",1:"S"))
+3 SET IBDA=0
SET IBDA=$ORDER(VALMY(IBDA))
if 'IBDA
QUIT
Begin DoDot:1
+4 SET IB=$PIECE($GET(^TMP("IBCECSD",$JOB,IBDA)),U,2)
+5 SET IBONE=1
End DoDot:1
+6 QUIT
+7 ;
ACT ; Reposition display using actions
+1 IF '$GET(IBONE)
DO SEL(.IBCNT,1)
if $GET(IBCNT)
DO BLD
+2 SET VALMBG=$GET(^TMP("IBCECSD",$JOB,"X",+$GET(IBACT)))
if 'VALMBG
SET VALMBG=1
+3 SET VALMBCK="R"
+4 QUIT
+5 ;
SET(IBSRC,X,CNT,IBCNT) ;set list manager arrays
+1 SET VALMCNT=VALMCNT+1
SET IBSRC=$GET(IBSRC)
+2 ;
+3 IF IBSRC
Begin DoDot:1
+4 SET ^TMP("PRCA_EOB",$JOB,IBCNT,VALMCNT)=X
End DoDot:1
QUIT
+5 ;
+6 SET ^TMP("IBCECSD",$JOB,VALMCNT,0)=X
+7 SET ^TMP("IBCECSD",$JOB,"IDX",VALMCNT,CNT)=""
+8 SET ^TMP("IBCECSD",$JOB,CNT)=VALMCNT_U_IBCNT
+9 QUIT
+10 ;
GEN ;
+1 SET IBSRC=$GET(IBSRC)
if IBSRC=1
QUIT
+2 NEW IBREC1,IBTMP,IBSPL
+3 SET IBSPL=+$ORDER(^IBM(361.1,IBCNT,8,0))
SET IBSPL=(+$ORDER(^(IBSPL))'=IBSPL)
+4 SET IB=$$SETSTR^VALM1("EOB GENERAL INFORMATION:","",1,50)
+5 DO SET(IBSRC,IB,CNT,IBCNT)
+6 IF 'IBSRC
Begin DoDot:1
+7 DO CNTRL^VALM10(VALMCNT,1,24,IORVON,IORVOFF)
+8 SET ^TMP("IBCECSD",$JOB,"X",1)=VALMCNT
End DoDot:1
+9 SET IB=$$SETSTR^VALM1("Type : "_$SELECT(IBTYP:"MEDICARE MRA",1:"NORMAL EOB")_$SELECT(IBSPL:" (SPLIT IN A/R)",1:""),"",2,39)
+10 SET IB=$$SETSTR^VALM1("EOB Paid DT : "_$$DAT1^IBOUTL($PIECE(IBREC,U,6),1),IB,41,38)
+11 DO SET(IBSRC,IB,CNT,IBCNT)
+12 IF IBSRC
Begin DoDot:1
+13 SET IB=$$SETSTR^VALM1($SELECT(IBSRC:"Entry Dt/Tm :"_$$DAT1^IBOUTL($PIECE(IBREC,U,5),1),1:""),"",2,39)
+14 SET IBTMP=$PIECE(IBREC,U,13)
+15 SET IB=$$SETSTR^VALM1("Claim Status : "_$$EXTERNAL^DILFD(361.1,.13,"",IBTMP),IB,41,38)
+16 DO SET(IBSRC,IB,CNT,IBCNT)
+17 SET IBTMP=$PIECE(IBREC,U,16)
+18 SET IB=$$SETSTR^VALM1("Review Status: "_$$EXTERNAL^DILFD(361.1,.16,"",IBTMP),IB,41,38)
+19 DO SET(IBSRC,IB,CNT,IBCNT)
+20 SET IB=$$SETSTR^VALM1("Entered By : "_$PIECE($GET(^VA(200,+$PIECE(IBREC,U,18),0)),U),"",2,39)
+21 SET IBTMP=$PIECE(IBREC,U,15)
+22 SET IB=$$SETSTR^VALM1("Insurance Seq: "_$$EXTERNAL^DILFD(361.1,.15,"",IBTMP),IB,41,38)
+23 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:1
+24 IF 'IBSRC
Begin DoDot:1
+25 SET IB=$$SETSTR^VALM1($SELECT($PIECE(IBREC,U,17):"Manual Entry: YES",1:""),"",2,39)
+26 SET IBTMP=$PIECE(IBREC,U,13)
+27 SET IB=$$SETSTR^VALM1("Claim Status : "_$$EXTERNAL^DILFD(361.1,.13,"",IBTMP),IB,41,38)
+28 DO SET(IBSRC,IB,CNT,IBCNT)
+29 SET IBTMP=$PIECE(IBREC,U,15)
+30 SET IB=$$SETSTR^VALM1("Insurance Seq: "_$$EXTERNAL^DILFD(361.1,.15,"",IBTMP),"",41,38)
+31 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:1
+32 SET IBREC1=$GET(^IBM(361.1,IBCNT,100))
+33 IF $SELECT($GET(IBFULL):1,1:$PIECE(IBREC1,U,4)'=""!($PIECE(IBREC1,U,3)'=""))
Begin DoDot:1
+34 SET IB=$$SETSTR^VALM1("Last Edited : "_$$DAT1^IBOUTL($PIECE(IBREC1,U,4),1),"",2,39)
+35 SET IB=$$SETSTR^VALM1("Last Edit By : "_$PIECE($GET(^VA(200,+$PIECE(IBREC1,U,3),0)),U),IB,41,38)
+36 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:1
+37 ;
+38 DO INSINF^IBCECSA7(+IBREC,CNT,IBCNT)
+39 ;
+40 ;Additional fields for HIPAA 5010
+41 IF IBSRC
Begin DoDot:1
+42 NEW IBOSN,IBOSN1,IBREC50,IBREC51
+43 SET IBREC50=$GET(^IBM(361.1,IBCNT,50))
SET IBREC51=$GET(^IBM(361.1,IBCNT,51))
+44 SET IB=$$SETSTR^VALM1("Claim Rec'd Date : "_$$DAT1^IBOUTL($PIECE(IBREC50,U),1),"",2,39)
+45 DO SET(IBSRC,IB,CNT,IBCNT)
+46 SET IBOSN=$EXTRACT($PIECE(IBREC51,U),1,56)
SET IBOSN1=$EXTRACT($PIECE(IBREC51,U),57,112)
+47 SET IB=$$SETSTR^VALM1("Other Subscriber Name: "_IBOSN,"",2,79)
+48 DO SET(IBSRC,IB,CNT,IBCNT)
if IBOSN1=""
QUIT
+49 SET IB=$$SETSTR^VALM1(" "_IBOSN1,"",2,79)
+50 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:1
+51 ;
+52 IF $SELECT($GET(IBFULL):1,1:$PIECE($GET(^IBM(361.1,IBCNT,6)),U)'=""!($PIECE($GET(^IBM(361.1,IBCNT,6)),U,2)'=""))
Begin DoDot:1
+53 SET IB=$$SETSTR^VALM1("New Pat. Nm.: "_$PIECE($GET(^IBM(361.1,IBCNT,6)),U),"",2,39)
+54 SET IB=$$SETSTR^VALM1("New Pat. Id : "_$PIECE($GET(^IBM(361.1,IBCNT,6)),U,2),IB,41,38)
+55 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:1
+56 if IBSRC
DO SET(IBSRC,"",CNT,IBCNT)
+57 QUIT
+58 ;
PAY ;
+1 SET IBSRC=$GET(IBSRC)
if IBSRC=1
QUIT
+2 NEW IBREC1,IBTMP
+3 SET IB=$$SETSTR^VALM1("PAYER INFORMATION:","",1,50)
+4 DO SET(IBSRC,IB,CNT,IBCNT)
+5 IF 'IBSRC
Begin DoDot:1
+6 DO CNTRL^VALM10(VALMCNT,1,18,IORVON,IORVOFF)
+7 SET ^TMP("IBCECSD",$JOB,"X",2)=VALMCNT
End DoDot:1
+8 ; KL - HIPAA 5010 - moved the write of the Payer ID on the next line down from the payer name to accommodate
+9 ; the increased length of the PAYER NAME from 35 to 60 characters. modified length parameter to $$SETSTR function for
+10 ; Payer ID and ICN to accommodate increased length of additional 20 characters.
+11 SET IB=$$SETSTR^VALM1("Payer Name : "_$PIECE($GET(^DIC(36,+$PIECE(IBREC,U,2),0)),U),"",2,60)
+12 DO SET(IBSRC,IB,CNT,IBCNT)
+13 SET IB=$$SETSTR^VALM1("Payer Id : "_$PIECE(IBREC,U,3),IB,2,38)
+14 DO SET(IBSRC,IB,CNT,IBCNT)
+15 SET IB=$$SETSTR^VALM1("ICN : "_$PIECE(IBREC,U,14),"",2,60)
+16 DO SET(IBSRC,IB,CNT,IBCNT)
+17 ;Additional fields for HIPA 5010
+18 NEW I,IBREC25,IBCON,IBCONTXT,IBCTYP,IBPAYNAM,IBWEB3,IBWEB
+19 ; Display PAYER CONTACT NAME, file #361.1, or CONTACT NAME, file #344; .4, (whichever is available)
+20 SET IBREC25=$GET(^IBM(361.1,IBCNT,25))
+21 SET IBPAYNAM=$PIECE(IBREC25,U)
+22 IF IBPAYNAM=""
IF +$GET(RCSCR)>0
SET IBPAYNAM=$PIECE($GET(^RCY(344.4,RCSCR,3)),U)
+23 IF IBPAYNAM'=""
Begin DoDot:1
+24 SET IB=$$SETSTR^VALM1("Payer Contact: "_IBPAYNAM,IB,2,60)
+25 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:1
+26 IF $TRANSLATE($PIECE(IBREC25,U,2,7),U,"")'=""
Begin DoDot:1
+27 FOR I=2,4,6
Begin DoDot:2
+28 SET IBCON=$PIECE(IBREC25,U,I)
SET IBCTYP=$PIECE(IBREC25,U,I+1)
if IBCON=""
QUIT
+29 SET IBCONTXT=$SELECT(IBCTYP="TE":"Contact Phone : ",IBCTYP="FX":"Contact Fax : ",IBCTYP="EM":"Contact e-Mail : ",1:"Invalid type :")
+30 SET IB=$$SETSTR^VALM1(IBCONTXT_IBCON,"",2,50)
+31 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:2
End DoDot:1
+32 IF $GET(RCSCR)'=""
Begin DoDot:1
+33 SET IBWEB=$PIECE($GET(^RCY(344.4,RCSCR,5)),U)
if IBWEB=""
QUIT
+34 SET IB=$$SETSTR^VALM1("Payer Web Site : "_$EXTRACT(IBWEB,1,60),"",2,78)
+35 DO SET(IBSRC,IB,CNT,IBCNT)
if $LENGTH(IBWEB)<61
QUIT
+36 SET IB=$$SETSTR^VALM1($EXTRACT(IBWEB,61,115),"",19,78)
+37 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:1
+38 ;Payer Policy References
+39 DO PPR
+40 NEW IBREC51
+41 SET IBREC51=$GET(^IBM(361.1,IBCNT,51))
+42 IF $PIECE(IBREC,U,9)'=""!($PIECE(IBREC51,U,2)'="")
Begin DoDot:1
+43 SET IB=$$SETSTR^VALM1("Cross Ovr ID : "_$PIECE(IBREC,U,9),"",2,39)
+44 DO SET(IBSRC,IB,CNT,IBCNT)
+45 SET IB=$$SETSTR^VALM1("Cross Ovr Nm: "_$PIECE(IBREC51,U,2),"",2,76)
+46 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:1
+47 if IBSRC
DO SET(IBSRC,"",CNT,IBCNT)
+48 ;Audit Details
+49 DO AUDIT
+50 QUIT
+51 ;
CLVL ;
+1 NEW IBREC1,IBTMP,IBRL
+2 SET IB=$$SETSTR^VALM1("CLAIM LEVEL PAY STATUS:","",1,50)
SET IBSRC=$GET(IBSRC)
+3 DO SET(IBSRC,IB,CNT,IBCNT)
+4 IF 'IBSRC
Begin DoDot:1
+5 DO CNTRL^VALM10(VALMCNT,1,23,IORVON,IORVOFF)
+6 SET ^TMP("IBCECSD",$JOB,"X",3)=VALMCNT
End DoDot:1
+7 IF '$DATA(^IBM(361.1,IBCNT,2))
IF '$DATA(^IBM(361.1,IBCNT,1))
DO SET(IBSRC," NONE",CNT,IBCNT)
QUIT
+8 SET IB=$$SETSTR^VALM1("Tot Submitted Chrg: "_$$A10($PIECE($GET(^IBM(361.1,IBCNT,2)),U,4)),"",2,39)
+9 SET IBREC1=$GET(^IBM(361.1,IBCNT,1))
+10 SET IB=$$SETSTR^VALM1("Covered Amt : "_$$A10($PIECE(IBREC1,U,3)),IB,41,38)
+11 DO SET(IBSRC,IB,CNT,IBCNT)
+12 SET IB=$$SETSTR^VALM1("Payer Paid Amt : "_$$A10($PIECE(IBREC1,U)),"",2,39)
+13 SET IB=$$SETSTR^VALM1("Patient Resp. Amt : "_$$A10($SELECT($DATA(^IBM(361.1,IBCNT,"ERR")):0,IBSRC:$PIECE(IBREC1,U,2),$$FT^IBCEF(+IBREC)=3:$$PTRESPI^IBCECOB1(IBCNT),1:$PIECE($GET(^IBM(361.1,IBCNT,1)),"^",2))),IB,41,38)
+14 DO SET(IBSRC,IB,CNT,IBCNT)
+15 SET (IB,IBRL)=""
+16 IF $SELECT(IBFULL:1,1:$PIECE(IBREC1,U,4))
SET IB=$$SETSTR^VALM1("Discount Amt : "_$$A10($PIECE(IBREC1,U,4)),"",2,39)
SET IBRL=1
+17 IF $SELECT(IBFULL:1,1:$PIECE(IBREC1,U,5))
SET IB=$$SETSTR^VALM1("Per Day Limit Amt : "_$$A10($PIECE(IBREC1,U,5)),IB,$SELECT('IBRL:2,1:41),$SELECT('IBRL:39,1:38))
SET IBRL=$SELECT(IBRL:0,1:1)
IF IBRL=0
DO SET(IBSRC,IB,CNT,IBCNT)
SET IB=""
+18 IF $SELECT(IBFULL:1,1:$PIECE(IBREC1,U,8))
SET IB=$$SETSTR^VALM1("Tax Amt : "_$$A10($PIECE(IBREC1,U,8)),IB,$SELECT('IBRL:2,1:41),$SELECT('IBRL:39,1:38))
SET IBRL=$SELECT(IBRL:0,1:1)
IF IBRL=0
DO SET(IBSRC,IB,CNT,IBCNT)
SET IB=""
+19 IF $SELECT(IBFULL:1,1:$PIECE(IBREC1,U,9))
SET IB=$$SETSTR^VALM1("Tot Before Tax Amt: "_$$A10($PIECE(IBREC1,U,9)),IB,$SELECT('IBRL:2,1:41),$SELECT('IBRL:39,1:38))
SET IBRL=$SELECT(IBRL:0,1:1)
IF IBRL=0
DO SET(IBSRC,IB,CNT,IBCNT)
SET IB=""
+20 IF $SELECT(IBFULL:1,1:$PIECE($GET(^IBM(361.1,IBCNT,2)),U,3))
SET IB=$$SETSTR^VALM1("Total Allowed Amt : "_$$A10($PIECE($GET(^IBM(361.1,IBCNT,2)),U,3)),IB,$SELECT('IBRL:2,1:41),$SELECT('IBRL:39,1:38))
SET IBRL=$SELECT(IBRL:0,1:1)
IF IBRL=0
DO SET(IBSRC,IB,CNT,IBCNT)
SET IB=""
+21 IF $SELECT(IBFULL:1,1:$PIECE($GET(^IBM(361.1,IBCNT,2)),U,5))
SET IB=$$SETSTR^VALM1("Negative Reimb Amt: "_$$A10($PIECE($GET(^IBM(361.1,IBCNT,2)),U,5)),IB,$SELECT('IBRL:2,1:41),$SELECT('IBRL:39,1:38))
SET IBRL=$SELECT(IBRL:0,1:1)
IF IBRL=0
DO SET(IBSRC,IB,CNT,IBCNT)
SET IB=""
+22 IF $GET(IBSRC)
IF $SELECT(IBFULL:1,1:$PIECE(IBREC,U,12))
SET IB=$$SETSTR^VALM1("Discharge Fraction: "_$$A10($PIECE(IBREC,U,12)),IB,$SELECT('IBRL:2,1:41),$SELECT('IBRL:39,1:38))
SET IBRL=$SELECT(IBRL:0,1:1)
IF IBRL=0
DO SET(IBSRC,IB,CNT,IBCNT)
SET IB=""
+23 IF $SELECT(IBFULL:1,1:$PIECE(IBREC,U,10))
SET IB=$$SETSTR^VALM1("DRG Code Used :"_$$RJ^XLFSTR($PIECE(IBREC,U,10),11," "),IB,$SELECT('IBRL:2,1:41),$SELECT('IBRL:39,1:38))
SET IBRL=$SELECT(IBRL:0,1:1)
IF IBRL=0
DO SET(IBSRC,IB,CNT,IBCNT)
SET IB=""
+24 IF $SELECT(IBFULL:1,1:$PIECE(IBREC,U,11))
SET IB=$$SETSTR^VALM1("DRG Weight Used :"_$$RJ^XLFSTR($PIECE(IBREC,U,11),11," "),IB,$SELECT('IBRL:2,1:41),$SELECT('IBRL:39,1:38))
SET IBRL=$SELECT(IBRL:0,1:1)
+25 if IBRL'=""
DO SET(IBSRC,IB,CNT,IBCNT)
+26 if IBSRC
DO SET(IBSRC,"",CNT,IBCNT)
+27 QUIT
+28 ;
MOUT ;
+1 NEW IBREC1,IBRL
+2 SET IBREC1=$GET(^IBM(361.1,IBCNT,3))
SET IBSRC=$GET(IBSRC)
+3 IF 'IBSRC
IF $$INPAT^IBCEF(+IBREC)
IF $TRANSLATE(IBREC1,"0^")=""
QUIT
+4 IF IBREC1=""
if '$DATA(^IBM(361.1,IBCNT,4))
DO SET(IBSRC," NONE",CNT,IBCNT)
if 'IBSRC
DO SET(IBSRC,"",CNT,IBCNT)
DO REMARK^IBCECSA5
QUIT
+5 DO SET(IBSRC," OUTPATIENT:",CNT,IBCNT)
+6 SET IBRL=""
+7 IF $SELECT(IBFULL:1,1:$PIECE(IBREC1,U))
SET IB=$$SETSTR^VALM1("Reimburse Rate : "_$$P10($PIECE(IBREC1,U)),"",$SELECT('IBRL:4,1:40),$SELECT('IBRL:41,1:38))
SET IBRL=$SELECT(IBRL:0,1:1)
+8 IF $SELECT(IBFULL:1,1:$PIECE(IBREC1,U,2))
SET IB=$$SETSTR^VALM1("HCPCS Pay Amt : "_$$A10($PIECE(IBREC1,U,2)),IB,$SELECT('IBRL:4,1:40),$SELECT('IBRL:41,1:38))
SET IBRL=$SELECT(IBRL:0,1:1)
+9 if IBRL=0
DO SET(IBSRC,IB,CNT,IBCNT)
+10 IF $SELECT(IBFULL:1,1:$PIECE(IBREC1,U,8))
SET IB=$$SETSTR^VALM1("Esrd Paid Amt : "_$$A10($PIECE(IBREC1,U,8)),"",$SELECT('IBRL:4,1:40),$SELECT('IBRL:41,1:38))
SET IBRL=$SELECT(IBRL:0,1:1)
+11 if IBRL=0
DO SET(IBSRC,IB,CNT,IBCNT)
+12 IF $SELECT(IBFULL:1,1:$PIECE(IBREC1,U,9))
SET IB=$$SETSTR^VALM1("Non-Pay Prof Comp : "_$$A10($PIECE(IBREC1,U,9)),IB,$SELECT('IBRL:4,1:40),$SELECT('IBRL:41,1:38))
SET IBRL=$SELECT(IBRL:0,1:1)
+13 if IBRL'=""
DO SET(IBSRC,IB,CNT,IBCNT)
+14 DO REMARK^IBCECSA5
+15 DO SET(IBSRC,"",CNT,IBCNT)
+16 QUIT
+17 ;
CLVLA ;
+1 NEW IBREC,IBFLG,GR,RSN,Z,I,IBCARC,IBN
+2 SET IB=$$SETSTR^VALM1("CLAIM LEVEL ADJUSTMENTS:","",1,50)
SET IBSRC=$GET(IBSRC)
+3 DO SET(IBSRC,IB,CNT,IBCNT)
+4 IF 'IBSRC
Begin DoDot:1
+5 DO CNTRL^VALM10(VALMCNT,1,24,IORVON,IORVOFF)
+6 SET ^TMP("IBCECSD",$JOB,"X",4)=VALMCNT
End DoDot:1
+7 SET (Y,IBFLG)=0
FOR
SET Y=$ORDER(^IBM(361.1,IBCNT,10,Y))
if 'Y
QUIT
Begin DoDot:1
+8 SET IBREC=$GET(^IBM(361.1,IBCNT,10,Y,0))
SET GR=$PIECE(IBREC,U,1)
+9 ; kludge
IF GR="OA"
IF $PIECE($GET(^IBM(361.1,IBCNT,10,Y,1,0)),U,4)=1
IF $DATA(^IBM(361.1,IBCNT,10,Y,1,"B","AB3"))
QUIT
+10 SET IBREC=$$EXTERNAL^DILFD(361.11,.01,"",GR)
SET IBFLG=1
+11 DO SET(IBSRC," GROUP CODE: "_IBREC,CNT,IBCNT)
+12 SET Z=0
FOR
SET Z=$ORDER(^IBM(361.1,IBCNT,10,Y,1,Z))
if 'Z
QUIT
Begin DoDot:2
+13 SET IBREC=$GET(^IBM(361.1,IBCNT,10,Y,1,Z,0))
SET RSN=$PIECE(IBREC,U,1)
+14 ; kludge
IF GR="OA"
IF RSN="AB3"
QUIT
+15 ; ib*2.0*547 - get CARC/RARC descriptions from new AR files 345/346 when available
+16 if '$$VFILE^DILFD(345)
SET IB=$$SETSTR^VALM1("REASON CODE: "_RSN_" "_$PIECE(IBREC,U,4),"",3,77)
+17 if $$VFILE^DILFD(345)
SET IB=$$SETSTR^VALM1("REASON CODE: "_RSN,"",3,77)
+18 DO SET(IBSRC,IB,CNT,IBCNT)
+19 IF $$VFILE^DILFD(345)
Begin DoDot:3
+20 SET IBN=$$CARC^IBCECSA5(RSN,345,74,"IBCARC")
+21 FOR I=1:1:IBN
SET IB=$$SETSTR^VALM1(IBCARC(I),"",3,77)
DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:3
+22 ; end IB*2.0*547 changes
+23 SET IB=$$SETSTR^VALM1("Amount: "_$$A10($PIECE(IBREC,U,2)),"",3,40)
+24 SET IB=$$SETSTR^VALM1("Quantity: "_$PIECE(IBREC,U,3),IB,41,38)
+25 DO SET(IBSRC,IB,CNT,IBCNT)
+26 ;D:IBSRC SET(IBSRC,"",CNT,IBCNT) ;IB*2.0*488 (vd) REMOVED EXTRA BLANK LINE.
End DoDot:2
End DoDot:1
+27 IF 'IBFLG
DO SET(IBSRC," NONE",CNT,IBCNT)
+28 QUIT
+29 ;
A10(X) ; returns a dollar amount right justified to 10 characters
+1 QUIT $$RJ^XLFSTR($FNUMBER(X,"",2),10," ")
+2 ;
P10(X) ; returns a % right just 10
+1 ; X is a decimal between 0-1
+2 QUIT $$RJ^XLFSTR((X*100)_"%",10," ")
+3 ;
PPR ;Display Payer Policy References
+1 ;
+2 NEW I,IBARR,IBX,IBX2,IBX3,IBPY,IBPCNT,IBDISP,IBTXT
+3 SET IBX=0
+4 ;Get next Adjustment
+5 FOR
SET IBX=$ORDER(^IBM(361.1,IBCNT,15,IBX))
if 'IBX
QUIT
Begin DoDot:1
+6 ;Get next Line Level
+7 SET IBX2=0
+8 FOR
SET IBX2=$ORDER(^IBM(361.1,IBCNT,15,IBX,1,IBX2))
if 'IBX2
QUIT
Begin DoDot:2
+9 ;Get Adjustment line references (up to 5)
+10 SET IBX3=0
+11 FOR
SET IBX3=$ORDER(^IBM(361.1,IBCNT,15,IBX,1,IBX2,2,IBX3))
if 'IBX3
QUIT
Begin DoDot:3
+12 SET IBPY=$PIECE($GET(^IBM(361.1,IBCNT,15,IBX,1,IBX2,2,IBX3,0)),U)
if IBPY=""
QUIT
+13 SET IBARR(IBPY)=""
End DoDot:3
End DoDot:2
End DoDot:1
+14 ;Concatenate Adjustment references
+15 SET IBPY=""
SET IBPCNT=0
+16 FOR
SET IBPY=$ORDER(IBARR(IBPY))
if IBPY=""
QUIT
Begin DoDot:1
+17 SET IBPCNT=IBPCNT+1
SET $PIECE(IBDISP,";",IBPCNT)=IBPY
End DoDot:1
if IBPCNT=5
QUIT
+18 ;Format display
+19 if 'IBPCNT
QUIT
+20 SET IB=$$SETSTR^VALM1("Policy Reference: Check Payer policies referenced on Payer website","",2,78)
+21 DO SET(IBSRC,IB,CNT,IBCNT)
+22 SET IB=$$SETSTR^VALM1("for the following: "_$EXTRACT(IBDISP,1,50),"",2,78)
+23 DO SET(IBSRC,IB,CNT,IBCNT)
+24 FOR I=50:50:250
SET IBTXT=$EXTRACT(IBDISP,I+1,I+50)
if IBTXT=""
QUIT
Begin DoDot:1
+25 SET IB=$$SETSTR^VALM1($JUSTIFY("",19)_IBTXT,"",2,78)
+26 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:1
+27 QUIT
+28 ;
AUDIT ;Display details of any EEOB MOVE/COPY
+1 ;
+2 NEW IEN101,FIRST101
+3 SET IEN101=0
SET FIRST101=1
+4 FOR
SET IEN101=$ORDER(^IBM(361.1,IBCNT,101,IEN101))
if 'IEN101
QUIT
Begin DoDot:1
+5 NEW IB101,IBDATE,IBUSER,IBJUST,IBJUST1,IBORIG,IBDIR
+6 SET IB101=$GET(^IBM(361.1,IBCNT,101,IEN101,0))
if IB101=""
QUIT
+7 SET IBDATE=$$EXTERNAL^DILFD(361.1101,.01,,$PIECE(IB101,U,1))
+8 SET IBUSER=$$EXTERNAL^DILFD(361.1101,.02,,$PIECE(IB101,U,2))
+9 SET IBJUST=$EXTRACT($PIECE(IB101,U,3),1,78)
SET IBJUST1=$EXTRACT($PIECE(IB101,U,3),79,100)
+10 SET IBORIG=$$EXTERNAL^DILFD(361.1101,.04,,$PIECE(IB101,U,4))
+11 ; kl - added MOVE/COPY field
SET IBDIR=$$EXTERNAL^DILFD(361.1101,.05,,$PIECE(IB101,U,5))
+12 if IBDIR']""
SET IBDIR="Move"
+13 IF FIRST101
Begin DoDot:2
+14 SET IB=$$SETSTR^VALM1("MOVE/COPY HISTORY","",1,78)
SET FIRST101=0
+15 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:2
+16 DO SET(IBSRC,"",CNT,IBCNT)
+17 ;kl 8/23/11
SET IB=$$SETSTR^VALM1("Date/Time of EEOB "_IBDIR_": "_IBDATE,"",1,78)
+18 DO SET(IBSRC,IB,CNT,IBCNT)
+19 ;kl 8/23/11
SET IB=$$SETSTR^VALM1(IBDIR_" of EEOB performed by: "_IBUSER,"",1,78)
+20 DO SET(IBSRC,IB,CNT,IBCNT)
+21 SET IB=$$SETSTR^VALM1(IBDIR_" Justification Comments: ","",1,78)
+22 DO SET(IBSRC,IB,CNT,IBCNT)
+23 SET IB=$$SETSTR^VALM1(IBJUST,"",1,78)
+24 DO SET(IBSRC,IB,CNT,IBCNT)
+25 IF IBJUST1]""
Begin DoDot:2
+26 SET IB=$$SETSTR^VALM1(IBJUST1,"",1,78)
+27 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:2
+28 IF IBORIG]""
Begin DoDot:2
+29 SET IB=$$SETSTR^VALM1("Original Claim Number: "_IBORIG,"",1,78)
+30 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:2
+31 ;Other claim numbers
+32 NEW SUB,IBOTH,OTEXT
+33 SET SUB=0
SET OTEXT=""
+34 FOR
SET SUB=$ORDER(^IBM(361.1,IBCNT,101,IEN101,1,SUB))
if 'SUB
QUIT
Begin DoDot:2
+35 SET IBOTH=$PIECE($GET(^IBM(361.1,IBCNT,101,IEN101,1,SUB,0)),U)
if 'IBOTH
QUIT
+36 SET IBOTH=$$EXTERNAL^DILFD(361.11016,.01,,IBOTH)
if IBOTH=""
QUIT
+37 SET OTEXT=OTEXT_","_IBOTH
End DoDot:2
+38 SET OTEXT=$PIECE(OTEXT,",",2,99)
+39 IF OTEXT]""
Begin DoDot:2
+40 SET IB=$$SETSTR^VALM1("Other Claims: "_OTEXT,"",1,78)
+41 DO SET(IBSRC,IB,CNT,IBCNT)
End DoDot:2
+42 DO SET(IBSRC,"",CNT,IBCNT)
End DoDot:1
+43 QUIT
