IBCAPR2 ;ALB/BI - PRINT EOB/MRA ;20-SEP-2010
;;2.0;INTEGRATED BILLING;**432**;21-MAR-94;Build 192
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;
EN(IBIFN) ; -- main entry point for IBCAPR2
N IBI,IBICNT,EOBDATE
N FRMTYP,INPAT,IBALL,IBSHEOB
;
S VALMBCK="R"
I '$G(IBIFN),$D(VALMBG),$D(VALMLST) S IBIFN=$$GETIBIFN
Q:$G(IBIFN)=""
S FRMTYP=$$FT^IBCEF(IBIFN) ;Form Type
S INPAT=$$INPAT^IBCEF(IBIFN) ;Inpatient Flag
;
D GETEOBCL^IBCAPR(IBIFN,.IBALL) ; get all associated claims
D GETEOBS(.IBALL,.IBSHEOB) ; get all eobs associated with these claims
S IBICNT=$$MRACNT^IBCEMU1(IBIFN,0) ; count of MRAs
I $D(IBSHEOB) S IBI="",IBICNT="" F S IBI=$O(IBSHEOB(IBI)) Q:IBI="" S IBICNT=IBICNT+1 ; count of EOBs (reset counter since MRAs are in here)
;
I IBICNT<1 D Q
. D FULL^VALM1
. W !!?5,"There is no electronic EOB for this claim."
. D PAUSE^VALM1
. Q
I IBICNT=1 D Q
.S EOBDATE=$O(^IBM(361.1,"ABD",IBIFN,"")) Q:'EOBDATE
.S IBI=$O(^IBM(361.1,"ABD",IBIFN,EOBDATE,0)) Q:'IBI
.I $$MRACNT^IBCEMU1(IBIFN,0) D MRAPRINT(IBI) Q
.I $$MRACNT^IBCEMU1(IBIFN,1) D EOBPRINT(IBI) Q
;
S IBI=$$SEL(.IBSHEOB)
I +IBI=0 Q
;
I $P($G(^IBM(361.1,IBI,0)),U,4)=1 D MRAPRINT(IBI) Q
;
I $P($G(^IBM(361.1,IBI,0)),U,4)'=1 D EOBPRINT(IBI) Q
;
Q
;
EOBPRINT(IBI,IBSHEOB) ; PRINT THE REQUESTED EOB
N %ZIS,POP,FULLSTOP
S FULLSTOP=0
S %ZIS("A")="EOB Device: "
S %ZIS="QM" D ^%ZIS Q:POP
I $D(IO("Q")) D G EOBQUIT
. S ZTRTN="REGION0^IBCAPR2(IBI,.IBSHEOB)"
. S ZTSAVE("IB*")="",ZTSAVE("IEN")="",ZTSAVE("FRMTYP")="",ZTSAVE("INPAT")="",ZTSAVE("EOBDATE")=""
. S ZTDESC="IB - EOB PRINTING"
. D ^%ZTLOAD
. W !!,$S($D(ZTSK):"Your task number "_ZTSK_" has been queued.",1:"Unable to queue this job.")
. K IO("Q"),ZTSK D HOME^%ZIS
U IO D REGION0(IBI,.IBSHEOB)
EOBQUIT ;
I $D(ZTQUEUED) S ZTREQ="@"
I FULLSTOP=0,$E(IOST,1,2)["C-" D PAUSE^VALM1
D ^%ZISC
Q
;
MRAPRINT(IBI) ; PRINT THE REQUESTED MRA
N IEN,%ZIS,POP
N IBQUIT,IBPGN S IBQUIT=0
S IEN=IBI
S %ZIS("A")="MRA Device: "
S %ZIS="QM" D ^%ZIS Q:POP
I $D(IO("Q")) D G MRAQUIT
. S ZTRTN="PRNTMRA^IBCEMRAA"
. S ZTSAVE("IB*")="",ZTSAVE("IEN")="",ZTSAVE("FRMTYP")="",ZTSAVE("INPAT")="",ZTSAVE("EOBDATE")=""
. S ZTDESC="IB - MRA PRINTING"
. D ^%ZTLOAD
. W !!,$S($D(ZTSK):"Your task number "_ZTSK_" has been queued.",1:"Unable to queue this job.")
. K IO("Q"),ZTSK D HOME^%ZIS
U IO D PRNTMRA^IBCEMRAA
MRAQUIT ;
I $D(ZTQUEUED) S ZTREQ="@"
I $E(IOST,1,2)["C-" D PAUSE^VALM1
D ^%ZISC
Q
;
GETIBIFN() ; Get Internal Claim Pointer
N DIR,IBDA,IBIFN S IBIFN=""
D FULL^VALM1
D EN^VALM2($G(XQORNOD(0)),"S")
S IBDA=$O(VALMY(0))
S:IBDA IBIFN=$P($G(^TMP("IBCECOB",$J,IBDA)),U,2)
Q IBIFN
;
WRITE(IBSTR) ;
W IBSTR,!
Q $$PAUSE
;
PAUSE() ;
Q:$E(IOST,1,2)'["C-" 0
I $Y>(IOSL-5) D W @IOF,*13 I $D(DIRUT)!($D(DUOUT)) S FULLSTOP=1 K DIRUT,DTOUT,DUOUT Q 1
. S DIR(0)="E" D ^DIR K DIR
Q 0
;
; ---------- Start of EOB Printing Section ----------
REGION0(IBI,IBSHEOB) ; Print one or several EOBS depending what is passed in.
; Input: IEN to EOB file 361.1 if only one to be printed
; Input: IBSHEOB (optional) array of EOBs to be printed
I $G(IBI) D REGION1(IBI) Q
S IBI=0 F S IBI=$O(IBSHEOB(IBI)) Q:'+IBI D REGION1(IBI) I $O(IBSHEOB(IBI)) W @IOF
Q
REGION1(IBI) ; EOB Claim Header Information
N IBD,IBSTR,IBX,IBM,IBM1,IBM2,IBCA,IBCN
N IBPR,IBPT,IBPY,IBST,IBTA,IBTS,IBTY,IBSPL
;
; Line 1
S IBD="EOB/MRA Information"
S IBSTR=$$SETLN(IBD,"",30,45) Q:$$WRITE(IBSTR)
;
; Line 2
; IBSPL = 0 if EOB represents one bill's payment
; = 1 if AR had to split the EOB between multiple bills
S IBSPL=+$O(^IBM(361.1,IBI,8,0)),IBSPL=(+$O(^(IBSPL))'=IBSPL)
S IBM=$G(^IBM(361.1,IBI,0))
S IBTY=$P(IBM,U,4),IBTY=$S(IBTY:"MEDICARE MRA",1:"NORMAL EOB")
I IBTY'["MRA",IBSPL S IBTY="A/R SPLIT/COVERS MORE THAN 1 BILL"
I $P(IBM,U,13)>1,$P(IBM,U,13)<5 S IBTY=IBTY_" ("_$$EXTERNAL^DILFD(361.1,.13,,$P(IBM,U,13))_")"
S IBD="EOB Type: "_IBTY,IBSTR=$$SETLN(IBD,"",5,25)
S IBD="Claim Number: "_$$GET1^DIQ(399,IBIFN_", ",.01),IBSTR=$$SETLN(IBD,IBSTR,51,25)
Q:$$WRITE(IBSTR)
;
; Line 3
S IBCN=$P(IBM,U,14)
S IBX="0.00"
S IBD="ICN: "_IBCN,IBSTR=$$SETLN(IBD,"",10,30)
S IBM1=$G(^IBM(361.1,IBI,1))
S IBPT=$P(IBM1,U,2) ; patient responsibility 1.02 field
I $P(IBM,U,4),$D(^IBM(361.1,IBI,"ERR")) S IBPT=0 ; filing error
; If MRA & UB, then calculate patient responsiblity value
I $P(IBM,U,4),$$FT^IBCEF(+$P(IBM,U,1))=3 S IBPT=$$PTRESPI^IBCECOB1(IBI)
S IBD="Patient Resp Amount: "_$S('IBPT:IBX,1:IBPT)
S IBSTR=$$SETLN(IBD,IBSTR,44,35)
Q:$$WRITE(IBSTR)
;
; Line 4
S IBPY=$$GET1^DIQ(36,+$P(IBM,U,2)_", ",.01)
S IBM2=$G(^IBM(361.1,IBI,2)),IBTA=$P(IBM2,U,3)
; if no Total Allowed Amount, sum up amounts on Line Level Adjustment
I IBTA="" S IBTA=$$ALLOWED^IBCEMU2(IBI)
S IBD="Payer Name: "_IBPY,IBSTR=$$SETLN(IBD,"",3,40)
S IBD="Total Allowed Amount: "_$S('IBTA:IBX,1:IBTA)
S IBSTR=$$SETLN(IBD,IBSTR,43,36)
Q:$$WRITE(IBSTR)
;
; Line 5
S IBTS=$P(IBM2,U,4)
S IBPR=$$FMTE^XLFDT($P(IBM,U,6))
S IBD="EOB Date: "_IBPR,IBSTR=$$SETLN(IBD,"",5,35)
S IBD="Total Submitted Charges: "_$S('IBTS:IBX,1:IBTS)
S IBSTR=$$SETLN(IBD,IBSTR,40,39)
Q:$$WRITE(IBSTR)
;
; Line 6
S IBD="Svc From Dt: "_$$DAT1^IBOUTL($P(IBM1,U,10))
S IBSTR=$$SETLN(IBD,"",2,38)
S IBD="Svc To Dt: "_$$DAT1^IBOUTL($P(IBM1,U,11))
S IBSTR=$$SETLN(IBD,IBSTR,54,25)
Q:$$WRITE(IBSTR)
;
; Line 7
S IBCA=$P(IBM1,U)
S IBST=$P(IBM,U,16),IBST=$$EXPAND^IBTRE(361.1,.16,+IBST)
S IBSTR=""
I IBTY["MRA" S IBD="MRA Review Status: "_IBST,IBSTR=$$SETLN(IBD,"",2,38)
S IBD=$S('$G(IBSPL):" ",1:"**")_"Reported Payment Amt: "_$S('IBCA:$J(IBX,"",2),1:$J(+IBCA,"",2))
S IBSTR=$$SETLN(IBD,IBSTR,41,37)
Q:$$WRITE(IBSTR)
;
REGION2 ; EOB MEDICARE RA Information
;
I IBTY["MRA",$D(^IBM(361.1,IBI,21)) D
. S IBD=$TR($J("",35)," ","-")_"Review"_$TR($J("",38)," ","-")
. S IBSTR=$$SETLN(IBD,"",1,79) W IBSTR,!
. S (IBST,IBCN)=0 F S IBCN=$O(^IBM(361.1,IBI,21,IBCN)) Q:'IBCN S X=$G(^(IBCN,0)) D
.. S IBST=0
.. S IBD="Review Date: "_$$DAT1^IBOUTL($P(X,U))
.. S IBSTR=$$SETLN(IBD,"",1,30)
.. S IBD="Reviewed By: "_$$GET1^DIQ(200,+$P(X,U,2)_", ",.01) ; DBIA 10060
.. S IBSTR=$$SETLN(IBD,IBSTR,40,39)
.. Q:$$WRITE(IBSTR)
.. S IBD=0 F S IBD=$O(^IBM(361.1,IBI,21,IBCN,1,IBD)) Q:'IBD S IBSTR=$$SETLN($S('IBST:"Comments: ",1:"")_$G(^(IBD,0)),"",1,$S('IBST:69,1:79)),IBST=1 Q:$$WRITE(IBSTR)
. I 'IBST D
.. S IBSTR=$$SETLN("None","",1,10)
.. Q:$$WRITE(IBSTR)
;
REGION3 ; EOB CLAIM and LINE level Information
N Z
K ^TMP("PRCA_EOB",$J)
D GETEOB^IBCECSA6(IBI,2)
S Z="" F S Z=$O(^TMP("PRCA_EOB",$J,IBI,Z),-1) Q:Z="" Q:$TR($G(^TMP("PRCA_EOB",$J,IBI,Z))," ","")'="" D
. K ^TMP("PRCA_EOB",$J,IBI,Z)
S Z=0 F S Z=$O(^TMP("PRCA_EOB",$J,IBI,Z)) Q:'Z S IBSTR=$$SETLN($G(^TMP("PRCA_EOB",$J,IBI,Z)),"",1,79) Q:$$WRITE(IBSTR)
K ^TMP("PRCA_EOB",$J)
;
REGION4 ; EOB Display information about any 361.1 message storage or filing errors
N Z
I '$O(^IBM(361.1,IBI,"ERR",0)) Q
S IBSTR=$$SETLN(" ** MESSAGE STORAGE ERRORS **","",1,79) Q:$$WRITE(IBSTR)
S Z=0 F S Z=$O(^IBM(361.1,IBI,"ERR",Z)) Q:'Z S IBSTR=$$SETLN($G(^(Z,0)),"",1,79) Q:$$WRITE(IBSTR)
Q
;
SETLN(S,V,X,L) ; -- insert text(S) into variable(V)
; S := string to insert
; V := destination string
; X := insert @ col X
; L := clear # of chars (length)
Q $E(V_$J("",X-1),1,X-1)_$E(S_$J("",L),1,L)_$E(V,X+L,999)
;
; ---------- End of EOB Printing Section ----------
;
EOBALL(IBIFN) ;
;
; This is passed in a claim and prints all EOBs associated with the claim.
; Only ask the device once.
; It prints EOB for current payer sequence and works backwards.
;
N IBALL,IBSHEOB,IBI,Z
D GETEOBCL^IBCAPR(IBIFN,.IBALL)
;
D GETEOBS(.IBALL,.IBSHEOB)
Q:'$D(IBSHEOB) ; nothing to print
;
Q:'$$OKTOPRT()
D EOBPRINT("",.IBSHEOB)
Q
;
OKTOPRT() ; This procedure is called when the user is printing bills
; and we know that one or more EOBs exist for this bill. We ask the
; user if the EOB(s) should be printed at this time too.
;
NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
;
S DIR(0)="YO",DIR("B")="YES"
S DIR("A",1)="There are one or more EOBs associated with this bill."
S DIR("A")="Do you want to print them now"
S DIR("?")="Please answer Yes or No. If you answer Yes, then you will be asked to supply the output device and all EOBs associated with this bill will then be printed."
W !!
D ^DIR
Q $S(Y:1,1:0)
;
GETEOBS(IBALL,IBSHEOB) ; Get all the EOBS
; INPUT - IBALL array of claim numbers (IEN to 399)
; OUTPUT - IBSHEOB array of EOBs (IEN to 361.1)
;
N IBIFN
S IBIFN=0
F S IBIFN=$O(IBALL(IBIFN)) Q:IBIFN="" D
.S IBI=0 F S IBI=$O(^IBM(361.1,"B",IBIFN,IBI)) Q:'IBI S Z=+$O(^IBM(361.1,IBI,8,0)) I '$O(^(Z)) S IBSHEOB(IBI)=0 ; Entire EOB belongs to the bill
.;
.S IBI=0 F S IBI=$O(^IBM(361.1,"C",IBIFN,IBI)) Q:'IBI S IBSHEOB(IBI)=1 ; EOB has been reapportioned at the site
;
Q
;
SEL(IBSHEOB) ; Function to display and allow user selection
; of an EOB/MRA on file in 361.1 for a sequence of bills.
;
; Input: IBSHEOB - array of internal bill numbers (required)
; ex IBSHEOB(361.1 IEN1)=""
; IBSHEOB(361.1 IEN2)=""
;
; Function Value: IEN to file 361.1 or nil if no selection made
;
NEW IBEOB,EOBDATE,COUNT,IEN,IBM,INSCO,SEQ,EOBDT,EOBTYP,CLMSTAT,LIST
NEW J,A,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBM1
;
S IBEOB=""
Q:'$D(IBSHEOB) IBEOB
S IEN="",COUNT=0
F S IEN=$O(IBSHEOB(IEN)) Q:'+IEN D
. S IBM=$G(^IBM(361.1,IEN,0))
. S INSCO=$$EXTERNAL^DILFD(361.1,.02,,$P(IBM,U,2))
. S SEQ=$E($$EXTERNAL^DILFD(361.1,.15,,$P(IBM,U,15)),1)
. S EOBDT=$$FMTE^XLFDT($P($P(IBM,U,6),".",1),"2Z")
. S EOBTYP=$P("EOB^MRA",U,$P(IBM,U,4)+1)
. S CLMSTAT=$$EXTERNAL^DILFD(361.1,.13,"",$P(IBM,U,13))
. S COUNT=COUNT+1
. S LIST(COUNT)=IEN_U_SEQ_U_INSCO_U_EOBDT_U_EOBTYP_U_CLMSTAT
;
I 'COUNT G SELX ; no mra/eob data found
;
; Display mra/eob data
S J="EOB's/MRA's"
I COUNT>1 W !!,"The selected bill has multiple ",J," on file. Please choose one."
W !!?7,"#",?11,"Seq",?17,"Insurance Company",?40,"EOB Date"
W ?51,"Type",?57,"Claim Status"
F J=1:1:COUNT S A=LIST(J) D
. W !?5,$J(J,3),?11,"(",$P(A,U,2),")",?17,$E($P(A,U,3),1,20)
. W ?40,$P(A,U,4),?51,$P(A,U,5),?57,$P(A,U,6)
. Q
;
; User Selection
W ! S DIR(0)="NO^1:"_COUNT,DIR("A")="Select an EOB/MRA"
D ^DIR K DIR
I 'Y G SELX ; no selection made
S IBEOB=+$G(LIST(Y))
;
SELX ;
Q IBEOB
;
PRINTOPT ; PRINT EOB OPTION
N DIC,IBIFN,Y
S DIC="^IBM(361.1,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,4)='1"
S DIC("W")="D EOBLST^IBCEMU1(Y)" ; modify generic lister
D ^DIC
I Y<1!$D(DTOUT)!$D(DUOUT) S IBQUIT=1 Q
S IBI=$P(Y,U,1),IBIFN=$P(Y,U,2)
D EOBPRINT(IBI) ; PRINT THE REQUESTED EOB
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCAPR2 10981 printed Dec 13, 2024@02:08:38 Page 2
IBCAPR2 ;ALB/BI - PRINT EOB/MRA ;20-SEP-2010
+1 ;;2.0;INTEGRATED BILLING;**432**;21-MAR-94;Build 192
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
EN(IBIFN) ; -- main entry point for IBCAPR2
+1 NEW IBI,IBICNT,EOBDATE
+2 NEW FRMTYP,INPAT,IBALL,IBSHEOB
+3 ;
+4 SET VALMBCK="R"
+5 IF '$GET(IBIFN)
IF $DATA(VALMBG)
IF $DATA(VALMLST)
SET IBIFN=$$GETIBIFN
+6 if $GET(IBIFN)=""
QUIT
+7 ;Form Type
SET FRMTYP=$$FT^IBCEF(IBIFN)
+8 ;Inpatient Flag
SET INPAT=$$INPAT^IBCEF(IBIFN)
+9 ;
+10 ; get all associated claims
DO GETEOBCL^IBCAPR(IBIFN,.IBALL)
+11 ; get all eobs associated with these claims
DO GETEOBS(.IBALL,.IBSHEOB)
+12 ; count of MRAs
SET IBICNT=$$MRACNT^IBCEMU1(IBIFN,0)
+13 ; count of EOBs (reset counter since MRAs are in here)
IF $DATA(IBSHEOB)
SET IBI=""
SET IBICNT=""
FOR
SET IBI=$ORDER(IBSHEOB(IBI))
if IBI=""
QUIT
SET IBICNT=IBICNT+1
+14 ;
+15 IF IBICNT<1
Begin DoDot:1
+16 DO FULL^VALM1
+17 WRITE !!?5,"There is no electronic EOB for this claim."
+18 DO PAUSE^VALM1
+19 QUIT
End DoDot:1
QUIT
+20 IF IBICNT=1
Begin DoDot:1
+21 SET EOBDATE=$ORDER(^IBM(361.1,"ABD",IBIFN,""))
if 'EOBDATE
QUIT
+22 SET IBI=$ORDER(^IBM(361.1,"ABD",IBIFN,EOBDATE,0))
if 'IBI
QUIT
+23 IF $$MRACNT^IBCEMU1(IBIFN,0)
DO MRAPRINT(IBI)
QUIT
+24 IF $$MRACNT^IBCEMU1(IBIFN,1)
DO EOBPRINT(IBI)
QUIT
End DoDot:1
QUIT
+25 ;
+26 SET IBI=$$SEL(.IBSHEOB)
+27 IF +IBI=0
QUIT
+28 ;
+29 IF $PIECE($GET(^IBM(361.1,IBI,0)),U,4)=1
DO MRAPRINT(IBI)
QUIT
+30 ;
+31 IF $PIECE($GET(^IBM(361.1,IBI,0)),U,4)'=1
DO EOBPRINT(IBI)
QUIT
+32 ;
+33 QUIT
+34 ;
EOBPRINT(IBI,IBSHEOB) ; PRINT THE REQUESTED EOB
+1 NEW %ZIS,POP,FULLSTOP
+2 SET FULLSTOP=0
+3 SET %ZIS("A")="EOB Device: "
+4 SET %ZIS="QM"
DO ^%ZIS
if POP
QUIT
+5 IF $DATA(IO("Q"))
Begin DoDot:1
+6 SET ZTRTN="REGION0^IBCAPR2(IBI,.IBSHEOB)"
+7 SET ZTSAVE("IB*")=""
SET ZTSAVE("IEN")=""
SET ZTSAVE("FRMTYP")=""
SET ZTSAVE("INPAT")=""
SET ZTSAVE("EOBDATE")=""
+8 SET ZTDESC="IB - EOB PRINTING"
+9 DO ^%ZTLOAD
+10 WRITE !!,$SELECT($DATA(ZTSK):"Your task number "_ZTSK_" has been queued.",1:"Unable to queue this job.")
+11 KILL IO("Q"),ZTSK
DO HOME^%ZIS
End DoDot:1
GOTO EOBQUIT
+12 USE IO
DO REGION0(IBI,.IBSHEOB)
EOBQUIT ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF FULLSTOP=0
IF $EXTRACT(IOST,1,2)["C-"
DO PAUSE^VALM1
+3 DO ^%ZISC
+4 QUIT
+5 ;
MRAPRINT(IBI) ; PRINT THE REQUESTED MRA
+1 NEW IEN,%ZIS,POP
+2 NEW IBQUIT,IBPGN
SET IBQUIT=0
+3 SET IEN=IBI
+4 SET %ZIS("A")="MRA Device: "
+5 SET %ZIS="QM"
DO ^%ZIS
if POP
QUIT
+6 IF $DATA(IO("Q"))
Begin DoDot:1
+7 SET ZTRTN="PRNTMRA^IBCEMRAA"
+8 SET ZTSAVE("IB*")=""
SET ZTSAVE("IEN")=""
SET ZTSAVE("FRMTYP")=""
SET ZTSAVE("INPAT")=""
SET ZTSAVE("EOBDATE")=""
+9 SET ZTDESC="IB - MRA PRINTING"
+10 DO ^%ZTLOAD
+11 WRITE !!,$SELECT($DATA(ZTSK):"Your task number "_ZTSK_" has been queued.",1:"Unable to queue this job.")
+12 KILL IO("Q"),ZTSK
DO HOME^%ZIS
End DoDot:1
GOTO MRAQUIT
+13 USE IO
DO PRNTMRA^IBCEMRAA
MRAQUIT ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF $EXTRACT(IOST,1,2)["C-"
DO PAUSE^VALM1
+3 DO ^%ZISC
+4 QUIT
+5 ;
GETIBIFN() ; Get Internal Claim Pointer
+1 NEW DIR,IBDA,IBIFN
SET IBIFN=""
+2 DO FULL^VALM1
+3 DO EN^VALM2($GET(XQORNOD(0)),"S")
+4 SET IBDA=$ORDER(VALMY(0))
+5 if IBDA
SET IBIFN=$PIECE($GET(^TMP("IBCECOB",$JOB,IBDA)),U,2)
+6 QUIT IBIFN
+7 ;
WRITE(IBSTR) ;
+1 WRITE IBSTR,!
+2 QUIT $$PAUSE
+3 ;
PAUSE() ;
+1 if $EXTRACT(IOST,1,2)'["C-"
QUIT 0
+2 IF $Y>(IOSL-5)
Begin DoDot:1
+3 SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
WRITE @IOF,*13
IF $DATA(DIRUT)!($DATA(DUOUT))
SET FULLSTOP=1
KILL DIRUT,DTOUT,DUOUT
QUIT 1
+4 QUIT 0
+5 ;
+6 ; ---------- Start of EOB Printing Section ----------
REGION0(IBI,IBSHEOB) ; Print one or several EOBS depending what is passed in.
+1 ; Input: IEN to EOB file 361.1 if only one to be printed
+2 ; Input: IBSHEOB (optional) array of EOBs to be printed
+3 IF $GET(IBI)
DO REGION1(IBI)
QUIT
+4 SET IBI=0
FOR
SET IBI=$ORDER(IBSHEOB(IBI))
if '+IBI
QUIT
DO REGION1(IBI)
IF $ORDER(IBSHEOB(IBI))
WRITE @IOF
+5 QUIT
REGION1(IBI) ; EOB Claim Header Information
+1 NEW IBD,IBSTR,IBX,IBM,IBM1,IBM2,IBCA,IBCN
+2 NEW IBPR,IBPT,IBPY,IBST,IBTA,IBTS,IBTY,IBSPL
+3 ;
+4 ; Line 1
+5 SET IBD="EOB/MRA Information"
+6 SET IBSTR=$$SETLN(IBD,"",30,45)
if $$WRITE(IBSTR)
QUIT
+7 ;
+8 ; Line 2
+9 ; IBSPL = 0 if EOB represents one bill's payment
+10 ; = 1 if AR had to split the EOB between multiple bills
+11 SET IBSPL=+$ORDER(^IBM(361.1,IBI,8,0))
SET IBSPL=(+$ORDER(^(IBSPL))'=IBSPL)
+12 SET IBM=$GET(^IBM(361.1,IBI,0))
+13 SET IBTY=$PIECE(IBM,U,4)
SET IBTY=$SELECT(IBTY:"MEDICARE MRA",1:"NORMAL EOB")
+14 IF IBTY'["MRA"
IF IBSPL
SET IBTY="A/R SPLIT/COVERS MORE THAN 1 BILL"
+15 IF $PIECE(IBM,U,13)>1
IF $PIECE(IBM,U,13)<5
SET IBTY=IBTY_" ("_$$EXTERNAL^DILFD(361.1,.13,,$PIECE(IBM,U,13))_")"
+16 SET IBD="EOB Type: "_IBTY
SET IBSTR=$$SETLN(IBD,"",5,25)
+17 SET IBD="Claim Number: "_$$GET1^DIQ(399,IBIFN_", ",.01)
SET IBSTR=$$SETLN(IBD,IBSTR,51,25)
+18 if $$WRITE(IBSTR)
QUIT
+19 ;
+20 ; Line 3
+21 SET IBCN=$PIECE(IBM,U,14)
+22 SET IBX="0.00"
+23 SET IBD="ICN: "_IBCN
SET IBSTR=$$SETLN(IBD,"",10,30)
+24 SET IBM1=$GET(^IBM(361.1,IBI,1))
+25 ; patient responsibility 1.02 field
SET IBPT=$PIECE(IBM1,U,2)
+26 ; filing error
IF $PIECE(IBM,U,4)
IF $DATA(^IBM(361.1,IBI,"ERR"))
SET IBPT=0
+27 ; If MRA & UB, then calculate patient responsiblity value
+28 IF $PIECE(IBM,U,4)
IF $$FT^IBCEF(+$PIECE(IBM,U,1))=3
SET IBPT=$$PTRESPI^IBCECOB1(IBI)
+29 SET IBD="Patient Resp Amount: "_$SELECT('IBPT:IBX,1:IBPT)
+30 SET IBSTR=$$SETLN(IBD,IBSTR,44,35)
+31 if $$WRITE(IBSTR)
QUIT
+32 ;
+33 ; Line 4
+34 SET IBPY=$$GET1^DIQ(36,+$PIECE(IBM,U,2)_", ",.01)
+35 SET IBM2=$GET(^IBM(361.1,IBI,2))
SET IBTA=$PIECE(IBM2,U,3)
+36 ; if no Total Allowed Amount, sum up amounts on Line Level Adjustment
+37 IF IBTA=""
SET IBTA=$$ALLOWED^IBCEMU2(IBI)
+38 SET IBD="Payer Name: "_IBPY
SET IBSTR=$$SETLN(IBD,"",3,40)
+39 SET IBD="Total Allowed Amount: "_$SELECT('IBTA:IBX,1:IBTA)
+40 SET IBSTR=$$SETLN(IBD,IBSTR,43,36)
+41 if $$WRITE(IBSTR)
QUIT
+42 ;
+43 ; Line 5
+44 SET IBTS=$PIECE(IBM2,U,4)
+45 SET IBPR=$$FMTE^XLFDT($PIECE(IBM,U,6))
+46 SET IBD="EOB Date: "_IBPR
SET IBSTR=$$SETLN(IBD,"",5,35)
+47 SET IBD="Total Submitted Charges: "_$SELECT('IBTS:IBX,1:IBTS)
+48 SET IBSTR=$$SETLN(IBD,IBSTR,40,39)
+49 if $$WRITE(IBSTR)
QUIT
+50 ;
+51 ; Line 6
+52 SET IBD="Svc From Dt: "_$$DAT1^IBOUTL($PIECE(IBM1,U,10))
+53 SET IBSTR=$$SETLN(IBD,"",2,38)
+54 SET IBD="Svc To Dt: "_$$DAT1^IBOUTL($PIECE(IBM1,U,11))
+55 SET IBSTR=$$SETLN(IBD,IBSTR,54,25)
+56 if $$WRITE(IBSTR)
QUIT
+57 ;
+58 ; Line 7
+59 SET IBCA=$PIECE(IBM1,U)
+60 SET IBST=$PIECE(IBM,U,16)
SET IBST=$$EXPAND^IBTRE(361.1,.16,+IBST)
+61 SET IBSTR=""
+62 IF IBTY["MRA"
SET IBD="MRA Review Status: "_IBST
SET IBSTR=$$SETLN(IBD,"",2,38)
+63 SET IBD=$SELECT('$GET(IBSPL):" ",1:"**")_"Reported Payment Amt: "_$SELECT('IBCA:$JUSTIFY(IBX,"",2),1:$JUSTIFY(+IBCA,"",2))
+64 SET IBSTR=$$SETLN(IBD,IBSTR,41,37)
+65 if $$WRITE(IBSTR)
QUIT
+66 ;
REGION2 ; EOB MEDICARE RA Information
+1 ;
+2 IF IBTY["MRA"
IF $DATA(^IBM(361.1,IBI,21))
Begin DoDot:1
+3 SET IBD=$TRANSLATE($JUSTIFY("",35)," ","-")_"Review"_$TRANSLATE($JUSTIFY("",38)," ","-")
+4 SET IBSTR=$$SETLN(IBD,"",1,79)
WRITE IBSTR,!
+5 SET (IBST,IBCN)=0
FOR
SET IBCN=$ORDER(^IBM(361.1,IBI,21,IBCN))
if 'IBCN
QUIT
SET X=$GET(^(IBCN,0))
Begin DoDot:2
+6 SET IBST=0
+7 SET IBD="Review Date: "_$$DAT1^IBOUTL($PIECE(X,U))
+8 SET IBSTR=$$SETLN(IBD,"",1,30)
+9 ; DBIA 10060
SET IBD="Reviewed By: "_$$GET1^DIQ(200,+$PIECE(X,U,2)_", ",.01)
+10 SET IBSTR=$$SETLN(IBD,IBSTR,40,39)
+11 if $$WRITE(IBSTR)
QUIT
+12 SET IBD=0
FOR
SET IBD=$ORDER(^IBM(361.1,IBI,21,IBCN,1,IBD))
if 'IBD
QUIT
SET IBSTR=$$SETLN($SELECT('IBST:"Comments: ",1:"")_$GET(^(IBD,0)),"",1,$SELECT('IBST:69,1:79))
SET IBST=1
if $$WRITE(IBSTR)
QUIT
End DoDot:2
+13 IF 'IBST
Begin DoDot:2
+14 SET IBSTR=$$SETLN("None","",1,10)
+15 if $$WRITE(IBSTR)
QUIT
End DoDot:2
End DoDot:1
+16 ;
REGION3 ; EOB CLAIM and LINE level Information
+1 NEW Z
+2 KILL ^TMP("PRCA_EOB",$JOB)
+3 DO GETEOB^IBCECSA6(IBI,2)
+4 SET Z=""
FOR
SET Z=$ORDER(^TMP("PRCA_EOB",$JOB,IBI,Z),-1)
if Z=""
QUIT
if $TRANSLATE($GET(^TMP("PRCA_EOB",$JOB,IBI,Z))," ","")'=""
QUIT
Begin DoDot:1
+5 KILL ^TMP("PRCA_EOB",$JOB,IBI,Z)
End DoDot:1
+6 SET Z=0
FOR
SET Z=$ORDER(^TMP("PRCA_EOB",$JOB,IBI,Z))
if 'Z
QUIT
SET IBSTR=$$SETLN($GET(^TMP("PRCA_EOB",$JOB,IBI,Z)),"",1,79)
if $$WRITE(IBSTR)
QUIT
+7 KILL ^TMP("PRCA_EOB",$JOB)
+8 ;
REGION4 ; EOB Display information about any 361.1 message storage or filing errors
+1 NEW Z
+2 IF '$ORDER(^IBM(361.1,IBI,"ERR",0))
QUIT
+3 SET IBSTR=$$SETLN(" ** MESSAGE STORAGE ERRORS **","",1,79)
if $$WRITE(IBSTR)
QUIT
+4 SET Z=0
FOR
SET Z=$ORDER(^IBM(361.1,IBI,"ERR",Z))
if 'Z
QUIT
SET IBSTR=$$SETLN($GET(^(Z,0)),"",1,79)
if $$WRITE(IBSTR)
QUIT
+5 QUIT
+6 ;
SETLN(S,V,X,L) ; -- insert text(S) into variable(V)
+1 ; S := string to insert
+2 ; V := destination string
+3 ; X := insert @ col X
+4 ; L := clear # of chars (length)
+5 QUIT $EXTRACT(V_$JUSTIFY("",X-1),1,X-1)_$EXTRACT(S_$JUSTIFY("",L),1,L)_$EXTRACT(V,X+L,999)
+6 ;
+7 ; ---------- End of EOB Printing Section ----------
+8 ;
EOBALL(IBIFN) ;
+1 ;
+2 ; This is passed in a claim and prints all EOBs associated with the claim.
+3 ; Only ask the device once.
+4 ; It prints EOB for current payer sequence and works backwards.
+5 ;
+6 NEW IBALL,IBSHEOB,IBI,Z
+7 DO GETEOBCL^IBCAPR(IBIFN,.IBALL)
+8 ;
+9 DO GETEOBS(.IBALL,.IBSHEOB)
+10 ; nothing to print
if '$DATA(IBSHEOB)
QUIT
+11 ;
+12 if '$$OKTOPRT()
QUIT
+13 DO EOBPRINT("",.IBSHEOB)
+14 QUIT
+15 ;
OKTOPRT() ; This procedure is called when the user is printing bills
+1 ; and we know that one or more EOBs exist for this bill. We ask the
+2 ; user if the EOB(s) should be printed at this time too.
+3 ;
+4 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+5 ;
+6 SET DIR(0)="YO"
SET DIR("B")="YES"
+7 SET DIR("A",1)="There are one or more EOBs associated with this bill."
+8 SET DIR("A")="Do you want to print them now"
+9 SET DIR("?")="Please answer Yes or No. If you answer Yes, then you will be asked to supply the output device and all EOBs associated with this bill will then be printed."
+10 WRITE !!
+11 DO ^DIR
+12 QUIT $SELECT(Y:1,1:0)
+13 ;
GETEOBS(IBALL,IBSHEOB) ; Get all the EOBS
+1 ; INPUT - IBALL array of claim numbers (IEN to 399)
+2 ; OUTPUT - IBSHEOB array of EOBs (IEN to 361.1)
+3 ;
+4 NEW IBIFN
+5 SET IBIFN=0
+6 FOR
SET IBIFN=$ORDER(IBALL(IBIFN))
if IBIFN=""
QUIT
Begin DoDot:1
+7 ; Entire EOB belongs to the bill
SET IBI=0
FOR
SET IBI=$ORDER(^IBM(361.1,"B",IBIFN,IBI))
if 'IBI
QUIT
SET Z=+$ORDER(^IBM(361.1,IBI,8,0))
IF '$ORDER(^(Z))
SET IBSHEOB(IBI)=0
+8 ;
+9 ; EOB has been reapportioned at the site
SET IBI=0
FOR
SET IBI=$ORDER(^IBM(361.1,"C",IBIFN,IBI))
if 'IBI
QUIT
SET IBSHEOB(IBI)=1
End DoDot:1
+10 ;
+11 QUIT
+12 ;
SEL(IBSHEOB) ; Function to display and allow user selection
+1 ; of an EOB/MRA on file in 361.1 for a sequence of bills.
+2 ;
+3 ; Input: IBSHEOB - array of internal bill numbers (required)
+4 ; ex IBSHEOB(361.1 IEN1)=""
+5 ; IBSHEOB(361.1 IEN2)=""
+6 ;
+7 ; Function Value: IEN to file 361.1 or nil if no selection made
+8 ;
+9 NEW IBEOB,EOBDATE,COUNT,IEN,IBM,INSCO,SEQ,EOBDT,EOBTYP,CLMSTAT,LIST
+10 NEW J,A,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBM1
+11 ;
+12 SET IBEOB=""
+13 if '$DATA(IBSHEOB)
QUIT IBEOB
+14 SET IEN=""
SET COUNT=0
+15 FOR
SET IEN=$ORDER(IBSHEOB(IEN))
if '+IEN
QUIT
Begin DoDot:1
+16 SET IBM=$GET(^IBM(361.1,IEN,0))
+17 SET INSCO=$$EXTERNAL^DILFD(361.1,.02,,$PIECE(IBM,U,2))
+18 SET SEQ=$EXTRACT($$EXTERNAL^DILFD(361.1,.15,,$PIECE(IBM,U,15)),1)
+19 SET EOBDT=$$FMTE^XLFDT($PIECE($PIECE(IBM,U,6),".",1),"2Z")
+20 SET EOBTYP=$PIECE("EOB^MRA",U,$PIECE(IBM,U,4)+1)
+21 SET CLMSTAT=$$EXTERNAL^DILFD(361.1,.13,"",$PIECE(IBM,U,13))
+22 SET COUNT=COUNT+1
+23 SET LIST(COUNT)=IEN_U_SEQ_U_INSCO_U_EOBDT_U_EOBTYP_U_CLMSTAT
End DoDot:1
+24 ;
+25 ; no mra/eob data found
IF 'COUNT
GOTO SELX
+26 ;
+27 ; Display mra/eob data
+28 SET J="EOB's/MRA's"
+29 IF COUNT>1
WRITE !!,"The selected bill has multiple ",J," on file. Please choose one."
+30 WRITE !!?7,"#",?11,"Seq",?17,"Insurance Company",?40,"EOB Date"
+31 WRITE ?51,"Type",?57,"Claim Status"
+32 FOR J=1:1:COUNT
SET A=LIST(J)
Begin DoDot:1
+33 WRITE !?5,$JUSTIFY(J,3),?11,"(",$PIECE(A,U,2),")",?17,$EXTRACT($PIECE(A,U,3),1,20)
+34 WRITE ?40,$PIECE(A,U,4),?51,$PIECE(A,U,5),?57,$PIECE(A,U,6)
+35 QUIT
End DoDot:1
+36 ;
+37 ; User Selection
+38 WRITE !
SET DIR(0)="NO^1:"_COUNT
SET DIR("A")="Select an EOB/MRA"
+39 DO ^DIR
KILL DIR
+40 ; no selection made
IF 'Y
GOTO SELX
+41 SET IBEOB=+$GET(LIST(Y))
+42 ;
SELX ;
+1 QUIT IBEOB
+2 ;
PRINTOPT ; PRINT EOB OPTION
+1 NEW DIC,IBIFN,Y
+2 SET DIC="^IBM(361.1,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $P(^(0),U,4)='1"
+3 ; modify generic lister
SET DIC("W")="D EOBLST^IBCEMU1(Y)"
+4 DO ^DIC
+5 IF Y<1!$DATA(DTOUT)!$DATA(DUOUT)
SET IBQUIT=1
QUIT
+6 SET IBI=$PIECE(Y,U,1)
SET IBIFN=$PIECE(Y,U,2)
+7 ; PRINT THE REQUESTED EOB
DO EOBPRINT(IBI)
+8 QUIT
