IBCECSA5 ;ALB/CXW - VIEW EOB SCREEN ;01-OCT-1999
;;2.0;INTEGRATED BILLING;**137,135,263,280,155,349,489,488,547,592**;21-MAR-1994;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
; reference to $$VFILE^DILFD allowed with IA#2055 (IB*2.0*547)
;
EN ; -- main entry point for VIEW EOB
N VALMCNT,VALMBG,VALMHDR
S VALMCNT=0,VALMBG=1
D EN^VALM("IBCEM VIEW EOB")
Q
;
INIT ; -- init variables and list array
I '$G(IBIFN) S VALMQUIT="" G INITQ ; bill# is required
D HDR^IBCEOB2 ; build the VALMHDR array
K IBCNT,IBONE,^TMP("IBCECSD",$J) ; kill vars and scratch global
;
; 8/13/03 - If variable IBEOBIFN is set, then this is the 361.1 ien
; that the user selected from a list. Build the detail.
I $G(IBEOBIFN) S IBCNT=IBEOBIFN,IBONE=1 D BLD^IBCECSA6,EOBERR G INITQ
;
D BLD^IBCEOB2 ; build ^TMP("IBCEOB",$J) containing MRA/EOB lister
S IBONE=0
M ^TMP("IBCECSD",$J)=^TMP("IBCEOB",$J)
;
; 4/7/03 - If only 1 EOB record found for this bill, then set the
; IBCNT variable, the IBONE one-time flag, and build the
; detail sections of this list.
I $G(VALMCNT)=1 S IBCNT=$P($G(^TMP("IBCECSD",$J,1)),U,2),IBONE=1 I IBCNT D BLD^IBCECSA6
D EOBERR ; IB*2.0*488 (vd)
;
INITQ Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBCECSD",$J)
D CLEAR^VALM1,CLEAN^VALM10
Q
MIN ;
N IBREC1,IBRM1,IBRM2,IBRM3,IBRM4,IBRM5,IBRL,IBTYPE,IBT,IBTX,IBD
; flag for inpatient mra
S IBTYPE=$S($G(IBSRC):1,$$INPAT^IBCEF(+IBREC):1,1:0)
;
S IB=$$SETSTR^VALM1("MEDICARE INFORMATION:","",1,50)
D SET(IB)
I '$G(IBSRC) D
. D CNTRL^VALM10(VALMCNT,1,21,IORVON,IORVOFF)
. S ^TMP("IBCECSD",$J,"X",5)=VALMCNT
I $G(IBSRC),'$D(^IBM(361.1,IBCNT,4)) Q
I '$G(IBSRC),'$$INPAT^IBCEF(+IBREC) Q
D SET(" INPATIENT:")
S IBREC1=$G(^IBM(361.1,IBCNT,4)),(IB,IBRL)=""
;
F IBT=2:1 S IBTX=$P($T(MINDAT+IBT),";",3) Q:IBTX="" D
. S IBD=$P(IBREC1,"^",+IBTX)
. I $L($P(IBTX,"^",4)) X $P(IBTX,"^",4) E N IBFULL S IBFULL=1
. I $S(IBFULL:1,1:IBD) D
.. I $L($P(IBTX,"^",4)) X $P(IBTX,"^",4) I Q
.. X "S IBD="_$S($L($P(IBTX,"^",3)):$P(IBTX,"^",3),1:"$$A10(IBD)")
.. S IB=$$SETSTR^VALM1($P(IBTX,"^",2)_IBD,IB,$S('IBRL:4,1:37),$S('IBRL:41,1:38))
.. S IBRL=$S(IBRL:0,1:1)
.. I 'IBRL D SET(IB,IBRL) S IB=""
;
D:IBRL'="" SET(IB)
D REMARK
Q
;
MINDAT ; data for MIN tag
; format: piece^label^special format code^special decision for disp
;;1^Cov Days/Visit Ct : ^$$RJ(+IBD)^I $G(IBSRC)
;;3^Claim DRG Amt :
;;2^Lifetm Psych Dy Ct : ^$$RJ(IBD)
;;5^Disprop Share Amt : ^^I IBTYPE
;;4^Cap Exception Amt :
;;7^PPS Capital Amt : ^^I IBTYPE
;;6^MSP Pass Thru Amt :
;;9^PPS Cap HSP-DRG Amt: ^^I IBTYPE
;;8^PPS Cap FSP-DRG Amt: ^^I IBTYPE
;;11^Old Capital Amt : ^^I IBTYPE
;;10^PPS Cap DSH-DRG Amt: ^^I IBTYPE
;;13^PPS Op Hos DRG Amt :
;;12^PPS Capital IME Amt: ^^I IBTYPE
;;15^PPS Op Fed DRG Amt : ^^I IBTYPE
;;14^Cost Report Day Ct : ^$$RJ(IBD)^I IBTYPE
;;17^Indirect Teach Amt : ^^I IBTYPE
;;16^PPS Cap Outlier Amt: ^^I IBTYPE
;;18^Non-Pay Prof Comp : ^$$RJ(IBD)
;;19^Non-Covered Days Ct: ^$$RJ(+IBD)^I IBTYPE
;;
;
N IBREC1,IBP,IBT,IBX,RCODE,RDESC,REXIST
Q:$G(IBREM) S IBREM=1
D SET(" ")
D SET(" Claim Level Remark Information")
D SET(" Code Description")
I '$G(IBSRC) D
. D CNTRL^VALM10(VALMCNT,4,4,IOUON,IOUOFF)
. D CNTRL^VALM10(VALMCNT,13,11,IOUON,IOUOFF)
. Q
;
S IBREC1=$P($G(^IBM(361.1,IBCNT,3)),U,3,7)
I $P(IBREC1,U,1)="" S IBREC1=$P($G(^IBM(361.1,IBCNT,5)),U,1,5)
S REXIST=0
;
F IBP=1:1:5 D
. S RCODE=$P(IBREC1,U,IBP)
. S RDESC=$G(^IBM(361.1,IBCNT,"RM"_IBP))
. ; IB*2.0*547 - get RARC desription from new AR file 346 when available
. I '$$VFILE^DILFD(346),RCODE="",RDESC="" Q
. K IBT
. Q:RCODE=""
. I '$$VFILE^DILFD(346) S REXIST=1,IBT(IBP)=RDESC
. I $$VFILE^DILFD(346) S REXIST=$$CARC(RCODE,346,60,"IBT") Q:REXIST<1
. D TXT1(.IBT,0,60)
. D SET(" "_$$LJ^XLFSTR(RCODE,6)_"- "_$G(IBT(1)))
. S IBX=1
. F S IBX=$O(IBT(IBX)) Q:'IBX D SET($J("",12)_IBT(IBX))
. Q
;
I 'REXIST D SET(" No claim level remarks on file")
D SET(" ")
Q:$G(IBSRC) ; MRA Only
;
MRALLA S IB=$$SETSTR^VALM1("LINE LEVEL ADJUSTMENTS:","",1,50)
D SET(IB)
I '$G(IBSRC) D
. D CNTRL^VALM10(VALMCNT,1,23,IORVON,IORVOFF)
. S ^TMP("IBCECSD",$J,"X",7)=VALMCNT
I '$D(^IBM(361.1,IBCNT,15,0)) D SET(" NONE") Q ; only if there is info
;
; look up all billed data
N IBZDATA,IBFORM,IBX2,IBX3,IBREC2,IBREC3,IBTX,IBT,IBRC,IBZ,IBTXL
;JWS;IB*2.0*592:Dental form #7 do same as CMS-1500
S IBFORM=0 ; cms-1500 & J430D
I $$FT^IBCEF(+IBREC)=3 S IBFORM=1 ; UB-04
;JWS;IB*2.0*592:Dental form #7
D F^IBCEF("N-"_$S(IBFORM=1:"UB-04",$$FT^IBCEF(+IBREC)=7:"J430D",1:"HCFA 1500")_" SERVICE LINE (EDI)","IBZDATA",,+IBREC)
S IBX=0 F S IBX=$O(^IBM(361.1,IBCNT,15,IBX)) Q:IBX<1 S IBREC1=^IBM(361.1,IBCNT,15,IBX,0) D
. NEW RVL
. D SET(" # SV DT REVCD PROC MOD UNITS BILLED DEDUCT COINS ALLOW PYMT")
. S RVL=+$P(IBREC1,U,12) ; referenced Vista line#
. I 'RVL S RVL=IBX ; use the EOB line# if not there
. S IBT=$$RJ($P(IBREC1,"^"),3) ; line number
. S IBT=IBT_" "_$$RJ($$DAT1^IBOUTL($P($P(IBREC1,"^",16),".")),8) ; service date
. S IBT=IBT_" "_$$RJ($$EXTERNAL^DILFD(361.115,.1,"",$P(IBREC1,"^",10)),6) ; revcd
. S IBT=IBT_" "_$$RJ($P(IBREC1,"^",4),5) ; procedure
. S IBT=IBT_" "_$$RJ($P($G(^IBM(361.1,IBCNT,15,IBX,2,1,0)),"^"),3)_$S($D(^IBM(361.1,IBCNT,15,IBX,2,2,0)):"+",1:" ") ; modifiers
. S IBT=IBT_" "_$$RJ($FN($P(IBREC1,"^",11),"",0),5) ; units
. ;JWS;IB*2.0*592:Dental form #7 do same as CMS-1500 no change, just comment
. S IBT=IBT_" "_$$RJ($FN($S(IBFORM:$P($G(IBZDATA(RVL)),"^",5),1:$P($G(IBZDATA(RVL)),"^",8)*$P($G(IBZDATA(RVL)),"^",9)),"",2),8) ; billed
. S IBT=IBT_" "_$$RJ($FN($P($G(^IBM(361.1,IBCNT,15,IBX,1,+$O(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,+$O(^IBM(361.1,IBCNT,15,IBX,1,+$O(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,"B",1,0)),0)),"^",2),"",2),7) ; deduct
. S IBT=IBT_" "_$$RJ($FN($P($G(^IBM(361.1,IBCNT,15,IBX,1,+$O(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,+$O(^IBM(361.1,IBCNT,15,IBX,1,+$O(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,"B",2,0)),0)),"^",2),"",2),6) ; coins
. S IBT=IBT_" "_$$RJ($FN($P(IBREC1,"^",13),"",2),8) ; allow
. S IBT=IBT_" "_$$RJ($FN($P(IBREC1,"^",3),"",2),8) ; payment
. D SET(IBT)
. S IBX2=0 F S IBX2=$O(^IBM(361.1,IBCNT,15,IBX,1,IBX2)) Q:IBX2<1 D
.. S IBREC2=^IBM(361.1,IBCNT,15,IBX,1,IBX2,0),IBX3=0
.. F S IBX3=$O(^IBM(361.1,IBCNT,15,IBX,1,IBX2,1,IBX3)) Q:IBX3<1 D
... S IBREC3=^IBM(361.1,IBCNT,15,IBX,1,IBX2,1,IBX3,0)
... ; line level adjustments; don't display kludges (esg 10/23/03)
... I $P(IBREC2,U,1)="PR",$P(IBREC3,U,1)="AAA" Q
... I $P(IBREC2,U,1)="OA",$P(IBREC3,U,1)="AB3" Q
... I $P(IBREC2,U,1)="LQ" Q
... ; IB*2.0*547 - get CARC description from AR file 345, when ready
... I '$$VFILE^DILFD(345) S IBTX(1)="ADJ: "_$P(IBREC2,"^")_" "_$P(IBREC3,"^")_" "_$P(IBREC3,"^",4) D TXT1(.IBTX,0,79) S IBT=0 F S IBT=$O(IBTX(IBT)) Q:IBT<1 D SET(IBTX(IBT))
... I $$VFILE^DILFD(345) S IBT=$$CARC($P(IBREC3,"^"),345,79,"IBTX"),IBTX(1)="ADJ: "_$P(IBREC2,"^")_" "_$P(IBREC3,"^")_": "_$G(IBTX(1)) D TXT1(.IBTX,0,79) S IBT=0 F S IBT=$O(IBTX(IBT)) Q:IBT<1 D SET(IBTX(IBT))
... K IBTX
... D SET("ADJ AMT: "_$FN($P(IBREC3,"^",2),"",2))
. S IBRC=0
. F S IBRC=$O(^IBM(361.1,IBCNT,15,IBX,4,IBRC)) Q:'IBRC S IBREC2=$G(^(IBRC,0)) I IBREC2 K IBTX,IBZ S IBTX(1)=" -REMARK CODE("_+IBREC2_"): ",IBTXL=$L(IBTX(1)) D
.. ; IB*2.0*547 - get RARC description from AR file 346, when ready
.. I '$$VFILE^DILFD(346) S IBTX(1)=IBTX(1)_$P(IBREC2,U,2)_" "_$P(IBREC2,U,3)
.. I $$VFILE^DILFD(346) S IBT=$$CARC($P(IBREC2,U,2),346,79,"IBTX"),IBTX(1)=IBTX(1)_$P(IBREC2,U,2)_" "_$G(IBT(1))
.. I $L(IBTX(1))>79 D
... D TXT1(.IBTX,0,79) D SET(IBTX(1)) M IBZ=IBTX K IBTX S IBTX(1)="",IBT=1 F S IBT=$O(IBZ(IBT)) Q:'IBT S IBTX(1)=IBTX(1)_IBZ(IBT)_" "
.. E D
... S IBTXL=0
.. D TXT1(.IBTX,IBTXL,79) S IBT=0 F S IBT=$O(IBTX(IBT)) Q:IBT<1 D SET(IBTX(IBT))
. D SET(" ")
D SET(" ")
Q
;
;/Beginning IB*2.0*488 (vd)
EOBERR ; Display information about any 361.1 message storage or filing errors
N ERRTXT,DASHES,Z
S DASHES="---------------------------------------------------------------------"
I '$O(^IBM(361.1,IBCNT,"ERR",0)) Q
D SET("VistA could not match all of the Line Level data received in the EEOB")
D SET("(835 Record 40) to the claim in VistA.")
D SET(" ")
S Z=0 F S Z=$O(^IBM(361.1,IBCNT,"ERR",Z)) Q:'Z D
.S ERRTXT=$G(^IBM(361.1,IBCNT,"ERR",Z,0))
.I ERRTXT["##RAW DATA" S ERRTXT=DASHES
.D SET(ERRTXT)
Q
;/End of IB*2.0*488 (vd)
;
TXT(IBRM,IBLN,IBXY) ;display text over 79 chars
;IBRM - text, IBLN - length, IBXY - position
S IBRM=$E(IBRM,IBLN+1,999)
REP I $E(IBRM,1,IBLN)'="" S IB=$$SETSTR^VALM1($E(IBRM,1,IBLN),"",IBXY,IBLN) D SET(IB) S IBRM=$E(IBRM,IBLN+1,999) G REP
Q
;
SET(IB,IBSAV) ;
I '$G(IBSAV) D SET^IBCECSA6($G(IBSRC),IB,+$G(CNT),IBCNT)
Q
;
A10(X) ;
Q $$A10^IBCECSA6(X)
;
A7(X) ; returns a dollar amount right justified to 7 characters
Q $$RJ($FN(X,"",2),7)
;
TXT1(IBT,DIWL,DIWR) ; sets up text for over 79 chars
; IBT - pass by ref, array of text to be formatted back in array
; DIWL - left margin, DIWR = right margin
N IBX,X,DIWF,IBS K ^UTILITY($J,"W")
S DIWF="|I"_DIWL
S IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1 S X=IBT(IBX) D ^DIWP
K IBT F S IBX=$O(^UTILITY($J,"W",DIWL,IBX)) Q:IBX<1 S IBT(IBX)=^UTILITY($J,"W",DIWL,IBX,0)
K ^UTILITY($J,"W")
Q
;
RJ(X,Y) ; right just, default is 10
Q $$RJ^XLFSTR(X,$G(Y,10)," ")
;
CARC(IBCDE,IBF,IBML,IBARY) ;new CARC/RACR API for IB*2.0*547
; IBCDE = reason code from EOB to lookup in carc/rarc file (REQUIRED)
; IBF = file# to do lookup (either 345-CARC or 346-RARC) *REQUIRED*
; IBML = max length for each line (default is 79)
; IBARY = (required) subscripted array to return description data in:
; array(1)=first line of word-processed description
; array(2)= 2nd line of wp description, and so on
;
; Returns total # of lines in description
;
N IBY,IBX,IBC,IBI,IBN,IBALN,IBSTP,IBDSC
S IBC=0
Q:$G(IBARY)="" IBC
Q:$G(IBCDE)="" IBC
Q:$G(IBF)="" IBC
S:$G(IBML)="" IBML=79
S IBY=$$FIND1^DIC(IBF,,"BX",IBCDE) Q:IBY<1 IBC
S IBX=$$GET1^DIQ(IBF,IBY_",",4,"","IBDSC")
S IBI=0 F S IBI=$O(IBDSC(IBI)) Q:'IBI D
.S IBC=IBC+1,IBSTP=0,IBALN=$L(IBDSC(IBI))
.S @IBARY@(IBI)=$E(IBDSC(IBI),1,IBML) Q:IBML>IBALN
.S IBDSC(IBI+1)=($E(IBDSC(IBI),(IBML+1),IBALN)_" "_$G(IBDSC(IBI+1)))
.; make sure we don't break words in 2
.Q:$E(@IBARY@(IBI),IBML)=" "
.F IBN=IBML:-1:1 Q:$G(IBSTP)=1 D
..Q:$E(IBDSC(IBI),IBN)'=" "
..S @IBARY@(IBI)=$E(IBDSC(IBI),1,IBN),IBDSC(IBI+1)=($E(IBDSC(IBI),(IBN+1),IBML)_$G(IBDSC(IBI+1))),IBSTP=1 Q
Q IBC
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCECSA5 11082 printed Oct 16, 2024@18:10:30 Page 2
IBCECSA5 ;ALB/CXW - VIEW EOB SCREEN ;01-OCT-1999
+1 ;;2.0;INTEGRATED BILLING;**137,135,263,280,155,349,489,488,547,592**;21-MAR-1994;Build 58
+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 ;
EN ; -- main entry point for VIEW EOB
+1 NEW VALMCNT,VALMBG,VALMHDR
+2 SET VALMCNT=0
SET VALMBG=1
+3 DO EN^VALM("IBCEM VIEW EOB")
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 ; bill# is required
IF '$GET(IBIFN)
SET VALMQUIT=""
GOTO INITQ
+2 ; build the VALMHDR array
DO HDR^IBCEOB2
+3 ; kill vars and scratch global
KILL IBCNT,IBONE,^TMP("IBCECSD",$JOB)
+4 ;
+5 ; 8/13/03 - If variable IBEOBIFN is set, then this is the 361.1 ien
+6 ; that the user selected from a list. Build the detail.
+7 IF $GET(IBEOBIFN)
SET IBCNT=IBEOBIFN
SET IBONE=1
DO BLD^IBCECSA6
DO EOBERR
GOTO INITQ
+8 ;
+9 ; build ^TMP("IBCEOB",$J) containing MRA/EOB lister
DO BLD^IBCEOB2
+10 SET IBONE=0
+11 MERGE ^TMP("IBCECSD",$JOB)=^TMP("IBCEOB",$JOB)
+12 ;
+13 ; 4/7/03 - If only 1 EOB record found for this bill, then set the
+14 ; IBCNT variable, the IBONE one-time flag, and build the
+15 ; detail sections of this list.
+16 IF $GET(VALMCNT)=1
SET IBCNT=$PIECE($GET(^TMP("IBCECSD",$JOB,1)),U,2)
SET IBONE=1
IF IBCNT
DO BLD^IBCECSA6
+17 ; IB*2.0*488 (vd)
DO EOBERR
+18 ;
INITQ QUIT
+1 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBCECSD",$JOB)
+2 DO CLEAR^VALM1
DO CLEAN^VALM10
+3 QUIT
MIN ;
+1 NEW IBREC1,IBRM1,IBRM2,IBRM3,IBRM4,IBRM5,IBRL,IBTYPE,IBT,IBTX,IBD
+2 ; flag for inpatient mra
+3 SET IBTYPE=$SELECT($GET(IBSRC):1,$$INPAT^IBCEF(+IBREC):1,1:0)
+4 ;
+5 SET IB=$$SETSTR^VALM1("MEDICARE INFORMATION:","",1,50)
+6 DO SET(IB)
+7 IF '$GET(IBSRC)
Begin DoDot:1
+8 DO CNTRL^VALM10(VALMCNT,1,21,IORVON,IORVOFF)
+9 SET ^TMP("IBCECSD",$JOB,"X",5)=VALMCNT
End DoDot:1
+10 IF $GET(IBSRC)
IF '$DATA(^IBM(361.1,IBCNT,4))
QUIT
+11 IF '$GET(IBSRC)
IF '$$INPAT^IBCEF(+IBREC)
QUIT
+12 DO SET(" INPATIENT:")
+13 SET IBREC1=$GET(^IBM(361.1,IBCNT,4))
SET (IB,IBRL)=""
+14 ;
+15 FOR IBT=2:1
SET IBTX=$PIECE($TEXT(MINDAT+IBT),";",3)
if IBTX=""
QUIT
Begin DoDot:1
+16 SET IBD=$PIECE(IBREC1,"^",+IBTX)
+17 IF $LENGTH($PIECE(IBTX,"^",4))
XECUTE $PIECE(IBTX,"^",4)
IF '$TEST
NEW IBFULL
SET IBFULL=1
+18 IF $SELECT(IBFULL:1,1:IBD)
Begin DoDot:2
+19 IF $LENGTH($PIECE(IBTX,"^",4))
XECUTE $PIECE(IBTX,"^",4)
IF $TEST
QUIT
+20 XECUTE "S IBD="_$SELECT($LENGTH($PIECE(IBTX,"^",3)):$PIECE(IBTX,"^",3),1:"$$A10(IBD)")
+21 SET IB=$$SETSTR^VALM1($PIECE(IBTX,"^",2)_IBD,IB,$SELECT('IBRL:4,1:37),$SELECT('IBRL:41,1:38))
+22 SET IBRL=$SELECT(IBRL:0,1:1)
+23 IF 'IBRL
DO SET(IB,IBRL)
SET IB=""
End DoDot:2
End DoDot:1
+24 ;
+25 if IBRL'=""
DO SET(IB)
+26 DO REMARK
+27 QUIT
+28 ;
MINDAT ; data for MIN tag
+1 ; format: piece^label^special format code^special decision for disp
+2 ;;1^Cov Days/Visit Ct : ^$$RJ(+IBD)^I $G(IBSRC)
+3 ;;3^Claim DRG Amt :
+4 ;;2^Lifetm Psych Dy Ct : ^$$RJ(IBD)
+5 ;;5^Disprop Share Amt : ^^I IBTYPE
+6 ;;4^Cap Exception Amt :
+7 ;;7^PPS Capital Amt : ^^I IBTYPE
+8 ;;6^MSP Pass Thru Amt :
+9 ;;9^PPS Cap HSP-DRG Amt: ^^I IBTYPE
+10 ;;8^PPS Cap FSP-DRG Amt: ^^I IBTYPE
+11 ;;11^Old Capital Amt : ^^I IBTYPE
+12 ;;10^PPS Cap DSH-DRG Amt: ^^I IBTYPE
+13 ;;13^PPS Op Hos DRG Amt :
+14 ;;12^PPS Capital IME Amt: ^^I IBTYPE
+15 ;;15^PPS Op Fed DRG Amt : ^^I IBTYPE
+16 ;;14^Cost Report Day Ct : ^$$RJ(IBD)^I IBTYPE
+17 ;;17^Indirect Teach Amt : ^^I IBTYPE
+18 ;;16^PPS Cap Outlier Amt: ^^I IBTYPE
+19 ;;18^Non-Pay Prof Comp : ^$$RJ(IBD)
+20 ;;19^Non-Covered Days Ct: ^$$RJ(+IBD)^I IBTYPE
+21 ;;
+22 ;
+1 NEW IBREC1,IBP,IBT,IBX,RCODE,RDESC,REXIST
+2 if $GET(IBREM)
QUIT
SET IBREM=1
+3 DO SET(" ")
+4 DO SET(" Claim Level Remark Information")
+5 DO SET(" Code Description")
+6 IF '$GET(IBSRC)
Begin DoDot:1
+7 DO CNTRL^VALM10(VALMCNT,4,4,IOUON,IOUOFF)
+8 DO CNTRL^VALM10(VALMCNT,13,11,IOUON,IOUOFF)
+9 QUIT
End DoDot:1
+10 ;
+11 SET IBREC1=$PIECE($GET(^IBM(361.1,IBCNT,3)),U,3,7)
+12 IF $PIECE(IBREC1,U,1)=""
SET IBREC1=$PIECE($GET(^IBM(361.1,IBCNT,5)),U,1,5)
+13 SET REXIST=0
+14 ;
+15 FOR IBP=1:1:5
Begin DoDot:1
+16 SET RCODE=$PIECE(IBREC1,U,IBP)
+17 SET RDESC=$GET(^IBM(361.1,IBCNT,"RM"_IBP))
+18 ; IB*2.0*547 - get RARC desription from new AR file 346 when available
+19 IF '$$VFILE^DILFD(346)
IF RCODE=""
IF RDESC=""
QUIT
+20 KILL IBT
+21 if RCODE=""
QUIT
+22 IF '$$VFILE^DILFD(346)
SET REXIST=1
SET IBT(IBP)=RDESC
+23 IF $$VFILE^DILFD(346)
SET REXIST=$$CARC(RCODE,346,60,"IBT")
if REXIST<1
QUIT
+24 DO TXT1(.IBT,0,60)
+25 DO SET(" "_$$LJ^XLFSTR(RCODE,6)_"- "_$GET(IBT(1)))
+26 SET IBX=1
+27 FOR
SET IBX=$ORDER(IBT(IBX))
if 'IBX
QUIT
DO SET($JUSTIFY("",12)_IBT(IBX))
+28 QUIT
End DoDot:1
+29 ;
+30 IF 'REXIST
DO SET(" No claim level remarks on file")
+31 DO SET(" ")
+32 ; MRA Only
if $GET(IBSRC)
QUIT
+33 ;
MRALLA SET IB=$$SETSTR^VALM1("LINE LEVEL ADJUSTMENTS:","",1,50)
+1 DO SET(IB)
+2 IF '$GET(IBSRC)
Begin DoDot:1
+3 DO CNTRL^VALM10(VALMCNT,1,23,IORVON,IORVOFF)
+4 SET ^TMP("IBCECSD",$JOB,"X",7)=VALMCNT
End DoDot:1
+5 ; only if there is info
IF '$DATA(^IBM(361.1,IBCNT,15,0))
DO SET(" NONE")
QUIT
+6 ;
+7 ; look up all billed data
+8 NEW IBZDATA,IBFORM,IBX2,IBX3,IBREC2,IBREC3,IBTX,IBT,IBRC,IBZ,IBTXL
+9 ;JWS;IB*2.0*592:Dental form #7 do same as CMS-1500
+10 ; cms-1500 & J430D
SET IBFORM=0
+11 ; UB-04
IF $$FT^IBCEF(+IBREC)=3
SET IBFORM=1
+12 ;JWS;IB*2.0*592:Dental form #7
+13 DO F^IBCEF("N-"_$SELECT(IBFORM=1:"UB-04",$$FT^IBCEF(+IBREC)=7:"J430D",1:"HCFA 1500")_" SERVICE LINE (EDI)","IBZDATA",,+IBREC)
+14 SET IBX=0
FOR
SET IBX=$ORDER(^IBM(361.1,IBCNT,15,IBX))
if IBX<1
QUIT
SET IBREC1=^IBM(361.1,IBCNT,15,IBX,0)
Begin DoDot:1
+15 NEW RVL
+16 DO SET(" # SV DT REVCD PROC MOD UNITS BILLED DEDUCT COINS ALLOW PYMT")
+17 ; referenced Vista line#
SET RVL=+$PIECE(IBREC1,U,12)
+18 ; use the EOB line# if not there
IF 'RVL
SET RVL=IBX
+19 ; line number
SET IBT=$$RJ($PIECE(IBREC1,"^"),3)
+20 ; service date
SET IBT=IBT_" "_$$RJ($$DAT1^IBOUTL($PIECE($PIECE(IBREC1,"^",16),".")),8)
+21 ; revcd
SET IBT=IBT_" "_$$RJ($$EXTERNAL^DILFD(361.115,.1,"",$PIECE(IBREC1,"^",10)),6)
+22 ; procedure
SET IBT=IBT_" "_$$RJ($PIECE(IBREC1,"^",4),5)
+23 ; modifiers
SET IBT=IBT_" "_$$RJ($PIECE($GET(^IBM(361.1,IBCNT,15,IBX,2,1,0)),"^"),3)_$SELECT($DATA(^IBM(361.1,IBCNT,15,IBX,2,2,0)):"+",1:" ")
+24 ; units
SET IBT=IBT_" "_$$RJ($FNUMBER($PIECE(IBREC1,"^",11),"",0),5)
+25 ;JWS;IB*2.0*592:Dental form #7 do same as CMS-1500 no change, just comment
+26 ; billed
SET IBT=IBT_" "_$$RJ($FNUMBER($SELECT(IBFORM:$PIECE($GET(IBZDATA(RVL)),"^",5),1:$PIECE($GET(IBZDATA(RVL)),"^",8)*$PIECE($GET(IBZDATA(RVL)),"^",9)),"",2),8)
+27 ; deduct
SET IBT=IBT_" "_$$RJ($FNUMBER($PIECE($GET(^IBM(361.1,IBCNT,15,IBX,1,+$ORDER(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,+$ORDER(^IBM(361.1,IBCNT,15,IBX,1,+$ORDER(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,"B",1,0)),0)),"^",2),"",2),7)
+28 ; coins
SET IBT=IBT_" "_$$RJ($FNUMBER($PIECE($GET(^IBM(361.1,IBCNT,15,IBX,1,+$ORDER(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,+$ORDER(^IBM(361.1,IBCNT,15,IBX,1,+$ORDER(^IBM(361.1,IBCNT,15,IBX,1,"B","PR",0)),1,"B",2,0)),0)),"^",2),"",2),6)
+29 ; allow
SET IBT=IBT_" "_$$RJ($FNUMBER($PIECE(IBREC1,"^",13),"",2),8)
+30 ; payment
SET IBT=IBT_" "_$$RJ($FNUMBER($PIECE(IBREC1,"^",3),"",2),8)
+31 DO SET(IBT)
+32 SET IBX2=0
FOR
SET IBX2=$ORDER(^IBM(361.1,IBCNT,15,IBX,1,IBX2))
if IBX2<1
QUIT
Begin DoDot:2
+33 SET IBREC2=^IBM(361.1,IBCNT,15,IBX,1,IBX2,0)
SET IBX3=0
+34 FOR
SET IBX3=$ORDER(^IBM(361.1,IBCNT,15,IBX,1,IBX2,1,IBX3))
if IBX3<1
QUIT
Begin DoDot:3
+35 SET IBREC3=^IBM(361.1,IBCNT,15,IBX,1,IBX2,1,IBX3,0)
+36 ; line level adjustments; don't display kludges (esg 10/23/03)
+37 IF $PIECE(IBREC2,U,1)="PR"
IF $PIECE(IBREC3,U,1)="AAA"
QUIT
+38 IF $PIECE(IBREC2,U,1)="OA"
IF $PIECE(IBREC3,U,1)="AB3"
QUIT
+39 IF $PIECE(IBREC2,U,1)="LQ"
QUIT
+40 ; IB*2.0*547 - get CARC description from AR file 345, when ready
+41 IF '$$VFILE^DILFD(345)
SET IBTX(1)="ADJ: "_$PIECE(IBREC2,"^")_" "_$PIECE(IBREC3,"^")_" "_$PIECE(IBREC3,"^",4)
DO TXT1(.IBTX,0,79)
SET IBT=0
FOR
SET IBT=$ORDER(IBTX(IBT))
if IBT<1
QUIT
DO SET(IBTX(IBT))
+42 IF $$VFILE^DILFD(345)
SET IBT=$$CARC($PIECE(IBREC3,"^"),345,79,"IBTX")
SET IBTX(1)="ADJ: "_$PIECE(IBREC2,"^")_" "_$PIECE(IBREC3,"^")_": "_$GET(IBTX(1))
DO TXT1(.IBTX,0,79)
SET IBT=0
FOR
SET IBT=$ORDER(IBTX(IBT))
if IBT<1
QUIT
DO SET(IBTX(IBT))
+43 KILL IBTX
+44 DO SET("ADJ AMT: "_$FNUMBER($PIECE(IBREC3,"^",2),"",2))
End DoDot:3
End DoDot:2
+45 SET IBRC=0
+46 FOR
SET IBRC=$ORDER(^IBM(361.1,IBCNT,15,IBX,4,IBRC))
if 'IBRC
QUIT
SET IBREC2=$GET(^(IBRC,0))
IF IBREC2
KILL IBTX,IBZ
SET IBTX(1)=" -REMARK CODE("_+IBREC2_"): "
SET IBTXL=$LENGTH(IBTX(1))
Begin DoDot:2
+47 ; IB*2.0*547 - get RARC description from AR file 346, when ready
+48 IF '$$VFILE^DILFD(346)
SET IBTX(1)=IBTX(1)_$PIECE(IBREC2,U,2)_" "_$PIECE(IBREC2,U,3)
+49 IF $$VFILE^DILFD(346)
SET IBT=$$CARC($PIECE(IBREC2,U,2),346,79,"IBTX")
SET IBTX(1)=IBTX(1)_$PIECE(IBREC2,U,2)_" "_$GET(IBT(1))
+50 IF $LENGTH(IBTX(1))>79
Begin DoDot:3
+51 DO TXT1(.IBTX,0,79)
DO SET(IBTX(1))
MERGE IBZ=IBTX
KILL IBTX
SET IBTX(1)=""
SET IBT=1
FOR
SET IBT=$ORDER(IBZ(IBT))
if 'IBT
QUIT
SET IBTX(1)=IBTX(1)_IBZ(IBT)_" "
End DoDot:3
+52 IF '$TEST
Begin DoDot:3
+53 SET IBTXL=0
End DoDot:3
+54 DO TXT1(.IBTX,IBTXL,79)
SET IBT=0
FOR
SET IBT=$ORDER(IBTX(IBT))
if IBT<1
QUIT
DO SET(IBTX(IBT))
End DoDot:2
+55 DO SET(" ")
End DoDot:1
+56 DO SET(" ")
+57 QUIT
+58 ;
+59 ;/Beginning IB*2.0*488 (vd)
EOBERR ; Display information about any 361.1 message storage or filing errors
+1 NEW ERRTXT,DASHES,Z
+2 SET DASHES="---------------------------------------------------------------------"
+3 IF '$ORDER(^IBM(361.1,IBCNT,"ERR",0))
QUIT
+4 DO SET("VistA could not match all of the Line Level data received in the EEOB")
+5 DO SET("(835 Record 40) to the claim in VistA.")
+6 DO SET(" ")
+7 SET Z=0
FOR
SET Z=$ORDER(^IBM(361.1,IBCNT,"ERR",Z))
if 'Z
QUIT
Begin DoDot:1
+8 SET ERRTXT=$GET(^IBM(361.1,IBCNT,"ERR",Z,0))
+9 IF ERRTXT["##RAW DATA"
SET ERRTXT=DASHES
+10 DO SET(ERRTXT)
End DoDot:1
+11 QUIT
+12 ;/End of IB*2.0*488 (vd)
+13 ;
TXT(IBRM,IBLN,IBXY) ;display text over 79 chars
+1 ;IBRM - text, IBLN - length, IBXY - position
+2 SET IBRM=$EXTRACT(IBRM,IBLN+1,999)
REP IF $EXTRACT(IBRM,1,IBLN)'=""
SET IB=$$SETSTR^VALM1($EXTRACT(IBRM,1,IBLN),"",IBXY,IBLN)
DO SET(IB)
SET IBRM=$EXTRACT(IBRM,IBLN+1,999)
GOTO REP
+1 QUIT
+2 ;
SET(IB,IBSAV) ;
+1 IF '$GET(IBSAV)
DO SET^IBCECSA6($GET(IBSRC),IB,+$GET(CNT),IBCNT)
+2 QUIT
+3 ;
A10(X) ;
+1 QUIT $$A10^IBCECSA6(X)
+2 ;
A7(X) ; returns a dollar amount right justified to 7 characters
+1 QUIT $$RJ($FNUMBER(X,"",2),7)
+2 ;
TXT1(IBT,DIWL,DIWR) ; sets up text for over 79 chars
+1 ; IBT - pass by ref, array of text to be formatted back in array
+2 ; DIWL - left margin, DIWR = right margin
+3 NEW IBX,X,DIWF,IBS
KILL ^UTILITY($JOB,"W")
+4 SET DIWF="|I"_DIWL
+5 SET IBX=0
FOR
SET IBX=$ORDER(IBT(IBX))
if IBX<1
QUIT
SET X=IBT(IBX)
DO ^DIWP
+6 KILL IBT
FOR
SET IBX=$ORDER(^UTILITY($JOB,"W",DIWL,IBX))
if IBX<1
QUIT
SET IBT(IBX)=^UTILITY($JOB,"W",DIWL,IBX,0)
+7 KILL ^UTILITY($JOB,"W")
+8 QUIT
+9 ;
RJ(X,Y) ; right just, default is 10
+1 QUIT $$RJ^XLFSTR(X,$GET(Y,10)," ")
+2 ;
CARC(IBCDE,IBF,IBML,IBARY) ;new CARC/RACR API for IB*2.0*547
+1 ; IBCDE = reason code from EOB to lookup in carc/rarc file (REQUIRED)
+2 ; IBF = file# to do lookup (either 345-CARC or 346-RARC) *REQUIRED*
+3 ; IBML = max length for each line (default is 79)
+4 ; IBARY = (required) subscripted array to return description data in:
+5 ; array(1)=first line of word-processed description
+6 ; array(2)= 2nd line of wp description, and so on
+7 ;
+8 ; Returns total # of lines in description
+9 ;
+10 NEW IBY,IBX,IBC,IBI,IBN,IBALN,IBSTP,IBDSC
+11 SET IBC=0
+12 if $GET(IBARY)=""
QUIT IBC
+13 if $GET(IBCDE)=""
QUIT IBC
+14 if $GET(IBF)=""
QUIT IBC
+15 if $GET(IBML)=""
SET IBML=79
+16 SET IBY=$$FIND1^DIC(IBF,,"BX",IBCDE)
if IBY<1
QUIT IBC
+17 SET IBX=$$GET1^DIQ(IBF,IBY_",",4,"","IBDSC")
+18 SET IBI=0
FOR
SET IBI=$ORDER(IBDSC(IBI))
if 'IBI
QUIT
Begin DoDot:1
+19 SET IBC=IBC+1
SET IBSTP=0
SET IBALN=$LENGTH(IBDSC(IBI))
+20 SET @IBARY@(IBI)=$EXTRACT(IBDSC(IBI),1,IBML)
if IBML>IBALN
QUIT
+21 SET IBDSC(IBI+1)=($EXTRACT(IBDSC(IBI),(IBML+1),IBALN)_" "_$GET(IBDSC(IBI+1)))
+22 ; make sure we don't break words in 2
+23 if $EXTRACT(@IBARY@(IBI),IBML)=" "
QUIT
+24 FOR IBN=IBML:-1:1
if $GET(IBSTP)=1
QUIT
Begin DoDot:2
+25 if $EXTRACT(IBDSC(IBI),IBN)'=" "
QUIT
+26 SET @IBARY@(IBI)=$EXTRACT(IBDSC(IBI),1,IBN)
SET IBDSC(IBI+1)=($EXTRACT(IBDSC(IBI),(IBN+1),IBML)_$GET(IBDSC(IBI+1)))
SET IBSTP=1
QUIT
End DoDot:2
End DoDot:1
+27 QUIT IBC
+28 ;
