IBACCWLEE2 ;EDE/TPF - ACC (Automated Community Care) Encounters - Action Item Expand Encounter Display (Cont.) ; 12-SEP-2023 ; 12-SEP-2023
;;2.0;INTEGRATED BILLING;**770**;21-MAR-2024;Build 119
;;Per VA Directive 6402, this routine should not be modified.
Q
;
; Reference to $$BN1^PRCAFN in ICR #2024
;
;CLONED FROM RTN IBJTBA - TPI BILL CHARGE INFO SCREEN
BLD(IBIFN,IBLN,VALMCNT) ; charges, as they would display on the bill
N IBEOBDET,IBOK,IBXDATA,IBXSAVE,IBFT ;TPF XINDEX
;JWS:IB*2.0*592:Dental form#7 as professional
S IBFT=+$P($G(^DGCR(399,+IBIFN,0)),U,19),IBOK=1,IBEOBDET=1 ;TPF;ADDED FROM INIT
;
I $P($G(^DGCR(399,+IBIFN,0)),U,19)=2!($P($G(^(0)),U,19)=7) D H1500(.IBLN,.VALMCNT) Q
;D UB04
D UB04(.IBLN,.VALMCNT) ;TPF RETAIN COUNT VARS
K ^TMP("IBXSAVE",$J)
Q
;
H1500(IBLN,VALMCNT) ; block 24
;N X,IBI,IBJ,IBLN,IBX,IBSTR,IBLKLN,IBPFORM,IBLIN
N X,IBI,IBJ,IBX,IBSTR,IBLKLN,IBPFORM,IBLIN ;TPF MODIFIED TO KEEP IBLN INTACT
K ^TMP("IBXSAVE",$J)
S IBLIN=$$BOX24D^IBCEF11("",1),IBLKLN=0 ;,IBLN=1
Q:'$G(IBIFN) K ^TMP("IBXDISP",$J)
S IBPFORM=$S($P($G(^IBE(353,2,2)),U,8):$P(^(2),U,8),1:2) ;,IBLN=1
S IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM)
S IBI=$O(^TMP("IBXDISP",$J,""),-1)
S IBJ="" F S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ),-1) Q:$S('IBJ:1,1:$TR($G(^(IBJ))," ")'="") K ^TMP("IBXDISP",$J,IBI,IBJ)
;JWS;8/13/25;EBILL-5747;don't want to set VALMQUIT="", jumps out of display as a result of being defined (removed set of VALMQUIT="" before G H1500Q below)
I '$O(^TMP("IBXDISP",$J,IBI,0)) S VALMSG="No charges or procedures defined." G H1500Q
S IBI="" F S IBI=$O(^TMP("IBXDISP",$J,IBI)) Q:'IBI S IBJ=0 F S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ)) Q:'IBJ D
. S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)),IBLN=$$SET(IBX,IBLN)
K ^TMP("IBXDISP",$J)
D COB,MRA
I $$ISRX^IBCEF1(IBIFN) D RX
I $$ISPROS^IBCEF1(IBIFN) D PROS
S VALMCNT=IBLN-1
H1500Q Q
;
;UB04 ;form locator 42-49, IBIFN required
UB04(IBLN,VALMCNT) ;EP - TPF RETAIN COUNT VARS
;N X,Y,DIR,IBI,IBJ,IBX,IBLN,IBLC,IBLIN,IBPFORM,IBSTATE,IBCBILL,IBINPAT,IBQ,Z,Z0
N X,Y,DIR,IBI,IBJ,IBX,IBLC,IBLIN,IBPFORM,IBSTATE,IBCBILL,IBINPAT,IBQ,Z,Z0 ;TPF MODIFIED TO KEEP IBLN INTACT
K ^TMP("IBXSAVE",$J)
S IBLIN=$$RCBOX^IBCEF11()
S IBQ=0,IBLC=9 Q:'$G(IBIFN) K ^TMP("IBXDISP",$J)
S IBPFORM=$S($P($G(^IBE(353,3,2)),U,8):$P(^(2),U,8),1:3)
;
;SAVE OFF IBLN BILLN^IBCEFG0
N TEMPIBLN S TEMPIBLN=IBLN
;
S IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM)
;RESTORE IBLN
S IBLN=TEMPIBLN
;JWS;8/13/25;EBILL-5747;don't want to set VALMQUIT="", jumps out of display as a result of being defined (removed set of VALMQUIT="" before G H1500Q below)
I '$O(^TMP("IBXDISP",$J,0)) S VALMSG="No charges defined." G UB04Q
S Z="" F S Z=$O(^TMP("IBXDISP",$J,1,Z),-1) Q:Z="" S Z0=$G(^(Z)) Q:$TR(Z0," ")'="" K ^(Z)
S:Z ^TMP("IBXDISP",$J,1,Z+1)=" "
S IBINPAT=$$INPAT^IBCEF(IBIFN,1)
S IBSTATE=$G(^DGCR(399,IBIFN,"U")),IBCBILL=$G(^DGCR(399,IBIFN,0))
;
;S (VALMCNT,IBLN)=1,IBLKLN=0
S IBLKLN=0 ;TPF KEEP IBLN INTACT
I +IBINPAT D S IBLN=$$SET(IBSTR,IBLN)
. S IBX=$P(IBSTATE,U,15),IBSTR=+IBX_" DAY"_$S(IBX'=1:"S",1:"")_" INPATIENT CARE"
. S IBX=$$LOS^IBCU64(+IBSTATE,+$P(IBSTATE,U,2),+$P(IBCBILL,U,6)),IBX=IBX-$$LOS1^IBCU64(IBIFN) I IBX>0 S IBSTR=IBSTR_$J("Pass Days: "_IBX,55)
;
S IBI="" F S IBI=$O(^TMP("IBXDISP",$J,IBI)) Q:'IBI S IBJ=0 F S IBJ=$O(^TMP("IBXDISP",$J,IBI,IBJ)) Q:'IBJ D
. ;S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)),IBLN=$$SET(IBX,IBLN)
. S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)) I IBX'="" S IBLN=$$SET(IBX,IBLN) ;TPF GET RID OF WAY TOO MANY BLANK LINES
. I $E(IBX,1,3)="001" D COB
;
K ^TMP("IBXDISP",$J)
;
D MRA
S VALMCNT=IBLN-1
UB04Q Q
;
SETLN(STR,IBX,COL,WD) ;
S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
Q IBX
;
SET(STR,LN) ; set up TMP array with screen data (allows 2 blank lines, if not at end of array)
N IBX,IBI I STR?80" " S IBLKLN=IBLKLN+1 G SETQ
F IBI=1:1:IBLKLN D SET^VALM10(LN," ") S LN=LN+1 Q:IBI>1
D SET^VALM10(LN,STR)
S LN=LN+1,IBLKLN=0
SETQ Q LN
;
COB ; if there is an offset or a secondary/tertiary payer add it to the display, with ins co, and prior bill #
; IBIFN and IBLN must exist upon entry, IBLN is updated with new line count
N IBM,IBM1,IBI,IBJ,IBD,IBSTR,IBCU2,IBCU1 Q:'$G(IBIFN)
S IBM=$G(^DGCR(399,IBIFN,"M")),IBM1=$G(^DGCR(399,IBIFN,"M1"))
S IBCU2=$G(^DGCR(399,IBIFN,"U2")),IBCU1=$G(^DGCR(399,IBIFN,"U1"))
S IBJ=$P($G(^DGCR(399,IBIFN,0)),U,21),IBJ=$S(IBJ="P":3,IBJ="S":3,IBJ="T":3,1:0),IBSTR=""
I +$P(IBM,U,2)!(+$P(IBM,U,3)) F IBI=1:1:IBJ I +$P(IBM,U,IBI) D S IBLN=$$SET(IBSTR,IBLN)
. I IBSTR="" S IBLN=$$SET("",IBLN)
. S IBD=$S(IBI=1:"Primary",IBI=2:"Secondary",1:"Tertiary")_": " S IBSTR=$$SETLN(IBD,"",5,11)
. S IBD=$P($G(^DIC(36,+$P(IBM,U,IBI),0)),U,1) S IBSTR=$$SETLN(IBD,IBSTR,17,25)
. I $P(IBCU2,U,(IBI+3))'="" S IBD=$J(+$P(IBCU2,U,(IBI+3)),9,2) S IBSTR=$$SETLN(IBD,IBSTR,44,11)
. I $P(IBM1,U,(IBI+4))'="" S IBD=$$BN1^PRCAFN(+$P(IBM1,U,(IBI+4))) S IBSTR=$$SETLN(IBD,IBSTR,60,11) ;ICR #2024
I +$P(IBCU1,U,2) D S IBLN=$$SET(IBSTR,IBLN)
. I IBSTR="" S IBLN=$$SET("",IBLN)
. S IBD="Offset: " S IBSTR=$$SETLN(IBD,"",5,11)
. S IBD=$P(IBCU1,U,3) S IBSTR=$$SETLN(IBD,IBSTR,17,25)
. S IBD=$J($P(IBCU1,U,2),9,2) S IBSTR=$$SETLN(IBD,IBSTR,44,11)
. S IBD=$P(IBCU1,U,1)-$P(IBCU1,U,2),IBD="Billed: "_$J(IBD,0,2) S IBSTR=$$SETLN(IBD,IBSTR,60,17)
Q
;
RX ;RX refill info for CMS-1500 TPJI display
N Z,Z0,Z1,IBSPC,IBD,IBI,IBSTR,IBARRAY,IBRXX
S IBLN=IBLN+1
S IBSPC=$J("",5)
D SET^IBCSC5A(IBIFN,.IBARRAY)
I $D(IBARRAY) D
. S (Z,Z0)=0 F S Z0=$O(IBARRAY(Z0)) Q:Z0="" S Z1=0 F S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1 S Z=Z+1 S IBXDATA(Z)=$$DAT1^IBOUTL(Z1)_U_$G(IBARRAY(Z0,Z1))
S IBD=$$SET("",IBLN)
S IBD="PRESCRIPTION REFILLS: (For TPJI display only)"
S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
S IBI=0 F S IBI=$O(IBXDATA(IBI)) Q:IBI="" D
. S IBRXX=$G(IBXDATA(IBI))
. D ZERO^IBRXUTL($P(IBRXX,U,3))
. S IBD=$J($P(IBRXX,U,7),9,2)_IBSPC_$P(IBRXX,U)_IBSPC_$G(^TMP($J,"IBDRUG",+$P(IBRXX,U,3),.01))
. K ^TMP($J,"IBDRUG")
. S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
. S IBD="QTY: "_$P(IBRXX,U,5)_" for "_$P(IBRXX,U,4)_" days supply "_"NDC# "_$P(IBRXX,U,6)
. S IBSTR=$$SETLN(IBD,"",23,79),IBLN=$$SET(IBSTR,IBLN)
Q
;
PROS ;prosthetic info for CMS-1500 TPJI display
N Z,Z0,Z1,IBARRAY,IBSPC,IBD,IBI,IBSTR
S IBSPC=$J("",10),IBLN=IBLN+1
D SET^IBCSC5B(IBIFN,.IBARRAY)
I $D(IBARRAY) D
. S (Z,Z0)=0 F S Z0=$O(IBARRAY(Z0)) Q:Z0="" S Z1=0 F S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1 S Z=Z+1,IBXDATA(Z)=$$DAT1^IBOUTL(Z0)_U_$E($$PINB^IBCSC5B(+IBARRAY(Z0,Z1)),1,39)
S IBD=$$SET("",IBLN)
S IBD="PROSTHETIC REFILLS: (For TPJI display only)"
S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
S IBI=0 F S IBI=$O(IBXDATA(IBI)) Q:IBI="" D
. S IBD=$P(IBXDATA(IBI),U)_IBSPC_$P(IBXDATA(IBI),U,2)
. S IBSTR=$$SETLN(IBD,"",1,79),IBLN=$$SET(IBSTR,IBLN)
Q
;
MRA ; -- mra/eob
N IBI,Z,IBSTR,IBSHEOB,IBCT
S IBCT=0
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 IBCT=IBCT+1,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 IBCT=IBCT+1,IBSHEOB(IBI)=1 ; EOB has been reapportioned at the site
I 'IBCT D
. S IBSTR=$$SETLN("No EEOB/MRA Information","",1,79)
. S IBLN=$$SET(IBSTR,IBLN)
I IBCT D
. S Z=0
. S IBI=0 F S IBI=$O(IBSHEOB(IBI)) Q:'IBI S Z=Z+1 D SHEOB^IBJTBA1(IBI,+IBSHEOB(IBI),Z,IBCT)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACCWLEE2 7515 printed May 25, 2026@12:09:59 Page 2
IBACCWLEE2 ;EDE/TPF - ACC (Automated Community Care) Encounters - Action Item Expand Encounter Display (Cont.) ; 12-SEP-2023 ; 12-SEP-2023
+1 ;;2.0;INTEGRATED BILLING;**770**;21-MAR-2024;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; Reference to $$BN1^PRCAFN in ICR #2024
+6 ;
+7 ;CLONED FROM RTN IBJTBA - TPI BILL CHARGE INFO SCREEN
BLD(IBIFN,IBLN,VALMCNT) ; charges, as they would display on the bill
+1 ;TPF XINDEX
NEW IBEOBDET,IBOK,IBXDATA,IBXSAVE,IBFT
+2 ;JWS:IB*2.0*592:Dental form#7 as professional
+3 ;TPF;ADDED FROM INIT
SET IBFT=+$PIECE($GET(^DGCR(399,+IBIFN,0)),U,19)
SET IBOK=1
SET IBEOBDET=1
+4 ;
+5 IF $PIECE($GET(^DGCR(399,+IBIFN,0)),U,19)=2!($PIECE($GET(^(0)),U,19)=7)
DO H1500(.IBLN,.VALMCNT)
QUIT
+6 ;D UB04
+7 ;TPF RETAIN COUNT VARS
DO UB04(.IBLN,.VALMCNT)
+8 KILL ^TMP("IBXSAVE",$JOB)
+9 QUIT
+10 ;
H1500(IBLN,VALMCNT) ; block 24
+1 ;N X,IBI,IBJ,IBLN,IBX,IBSTR,IBLKLN,IBPFORM,IBLIN
+2 ;TPF MODIFIED TO KEEP IBLN INTACT
NEW X,IBI,IBJ,IBX,IBSTR,IBLKLN,IBPFORM,IBLIN
+3 KILL ^TMP("IBXSAVE",$JOB)
+4 ;,IBLN=1
SET IBLIN=$$BOX24D^IBCEF11("",1)
SET IBLKLN=0
+5 if '$GET(IBIFN)
QUIT
KILL ^TMP("IBXDISP",$JOB)
+6 ;,IBLN=1
SET IBPFORM=$SELECT($PIECE($GET(^IBE(353,2,2)),U,8):$PIECE(^(2),U,8),1:2)
+7 SET IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM)
+8 SET IBI=$ORDER(^TMP("IBXDISP",$JOB,""),-1)
+9 SET IBJ=""
FOR
SET IBJ=$ORDER(^TMP("IBXDISP",$JOB,IBI,IBJ),-1)
if $SELECT('IBJ
QUIT
KILL ^TMP("IBXDISP",$JOB,IBI,IBJ)
+10 ;JWS;8/13/25;EBILL-5747;don't want to set VALMQUIT="", jumps out of display as a result of being defined (removed set of VALMQUIT="" before G H1500Q below)
+11 IF '$ORDER(^TMP("IBXDISP",$JOB,IBI,0))
SET VALMSG="No charges or procedures defined."
GOTO H1500Q
+12 SET IBI=""
FOR
SET IBI=$ORDER(^TMP("IBXDISP",$JOB,IBI))
if 'IBI
QUIT
SET IBJ=0
FOR
SET IBJ=$ORDER(^TMP("IBXDISP",$JOB,IBI,IBJ))
if 'IBJ
QUIT
Begin DoDot:1
+13 SET IBX=$GET(^TMP("IBXDISP",$JOB,IBI,IBJ))
SET IBLN=$$SET(IBX,IBLN)
End DoDot:1
+14 KILL ^TMP("IBXDISP",$JOB)
+15 DO COB
DO MRA
+16 IF $$ISRX^IBCEF1(IBIFN)
DO RX
+17 IF $$ISPROS^IBCEF1(IBIFN)
DO PROS
+18 SET VALMCNT=IBLN-1
H1500Q QUIT
+1 ;
+2 ;UB04 ;form locator 42-49, IBIFN required
UB04(IBLN,VALMCNT) ;EP - TPF RETAIN COUNT VARS
+1 ;N X,Y,DIR,IBI,IBJ,IBX,IBLN,IBLC,IBLIN,IBPFORM,IBSTATE,IBCBILL,IBINPAT,IBQ,Z,Z0
+2 ;TPF MODIFIED TO KEEP IBLN INTACT
NEW X,Y,DIR,IBI,IBJ,IBX,IBLC,IBLIN,IBPFORM,IBSTATE,IBCBILL,IBINPAT,IBQ,Z,Z0
+3 KILL ^TMP("IBXSAVE",$JOB)
+4 SET IBLIN=$$RCBOX^IBCEF11()
+5 SET IBQ=0
SET IBLC=9
if '$GET(IBIFN)
QUIT
KILL ^TMP("IBXDISP",$JOB)
+6 SET IBPFORM=$SELECT($PIECE($GET(^IBE(353,3,2)),U,8):$PIECE(^(2),U,8),1:3)
+7 ;
+8 ;SAVE OFF IBLN BILLN^IBCEFG0
+9 NEW TEMPIBLN
SET TEMPIBLN=IBLN
+10 ;
+11 SET IBX=$$BILLN^IBCEFG0(1,"1^99",IBLIN,+IBIFN,IBPFORM)
+12 ;RESTORE IBLN
+13 SET IBLN=TEMPIBLN
+14 ;JWS;8/13/25;EBILL-5747;don't want to set VALMQUIT="", jumps out of display as a result of being defined (removed set of VALMQUIT="" before G H1500Q below)
+15 IF '$ORDER(^TMP("IBXDISP",$JOB,0))
SET VALMSG="No charges defined."
GOTO UB04Q
+16 SET Z=""
FOR
SET Z=$ORDER(^TMP("IBXDISP",$JOB,1,Z),-1)
if Z=""
QUIT
SET Z0=$GET(^(Z))
if $TRANSLATE(Z0," ")'=""
QUIT
KILL ^(Z)
+17 if Z
SET ^TMP("IBXDISP",$JOB,1,Z+1)=" "
+18 SET IBINPAT=$$INPAT^IBCEF(IBIFN,1)
+19 SET IBSTATE=$GET(^DGCR(399,IBIFN,"U"))
SET IBCBILL=$GET(^DGCR(399,IBIFN,0))
+20 ;
+21 ;S (VALMCNT,IBLN)=1,IBLKLN=0
+22 ;TPF KEEP IBLN INTACT
SET IBLKLN=0
+23 IF +IBINPAT
Begin DoDot:1
+24 SET IBX=$PIECE(IBSTATE,U,15)
SET IBSTR=+IBX_" DAY"_$SELECT(IBX'=1:"S",1:"")_" INPATIENT CARE"
+25 SET IBX=$$LOS^IBCU64(+IBSTATE,+$PIECE(IBSTATE,U,2),+$PIECE(IBCBILL,U,6))
SET IBX=IBX-$$LOS1^IBCU64(IBIFN)
IF IBX>0
SET IBSTR=IBSTR_$JUSTIFY("Pass Days: "_IBX,55)
End DoDot:1
SET IBLN=$$SET(IBSTR,IBLN)
+26 ;
+27 SET IBI=""
FOR
SET IBI=$ORDER(^TMP("IBXDISP",$JOB,IBI))
if 'IBI
QUIT
SET IBJ=0
FOR
SET IBJ=$ORDER(^TMP("IBXDISP",$JOB,IBI,IBJ))
if 'IBJ
QUIT
Begin DoDot:1
+28 ;S IBX=$G(^TMP("IBXDISP",$J,IBI,IBJ)),IBLN=$$SET(IBX,IBLN)
+29 ;TPF GET RID OF WAY TOO MANY BLANK LINES
SET IBX=$GET(^TMP("IBXDISP",$JOB,IBI,IBJ))
IF IBX'=""
SET IBLN=$$SET(IBX,IBLN)
+30 IF $EXTRACT(IBX,1,3)="001"
DO COB
End DoDot:1
+31 ;
+32 KILL ^TMP("IBXDISP",$JOB)
+33 ;
+34 DO MRA
+35 SET VALMCNT=IBLN-1
UB04Q QUIT
+1 ;
SETLN(STR,IBX,COL,WD) ;
+1 SET IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
+2 QUIT IBX
+3 ;
SET(STR,LN) ; set up TMP array with screen data (allows 2 blank lines, if not at end of array)
+1 NEW IBX,IBI
IF STR?80" "
SET IBLKLN=IBLKLN+1
GOTO SETQ
+2 FOR IBI=1:1:IBLKLN
DO SET^VALM10(LN," ")
SET LN=LN+1
if IBI>1
QUIT
+3 DO SET^VALM10(LN,STR)
+4 SET LN=LN+1
SET IBLKLN=0
SETQ QUIT LN
+1 ;
COB ; if there is an offset or a secondary/tertiary payer add it to the display, with ins co, and prior bill #
+1 ; IBIFN and IBLN must exist upon entry, IBLN is updated with new line count
+2 NEW IBM,IBM1,IBI,IBJ,IBD,IBSTR,IBCU2,IBCU1
if '$GET(IBIFN)
QUIT
+3 SET IBM=$GET(^DGCR(399,IBIFN,"M"))
SET IBM1=$GET(^DGCR(399,IBIFN,"M1"))
+4 SET IBCU2=$GET(^DGCR(399,IBIFN,"U2"))
SET IBCU1=$GET(^DGCR(399,IBIFN,"U1"))
+5 SET IBJ=$PIECE($GET(^DGCR(399,IBIFN,0)),U,21)
SET IBJ=$SELECT(IBJ="P":3,IBJ="S":3,IBJ="T":3,1:0)
SET IBSTR=""
+6 IF +$PIECE(IBM,U,2)!(+$PIECE(IBM,U,3))
FOR IBI=1:1:IBJ
IF +$PIECE(IBM,U,IBI)
Begin DoDot:1
+7 IF IBSTR=""
SET IBLN=$$SET("",IBLN)
+8 SET IBD=$SELECT(IBI=1:"Primary",IBI=2:"Secondary",1:"Tertiary")_": "
SET IBSTR=$$SETLN(IBD,"",5,11)
+9 SET IBD=$PIECE($GET(^DIC(36,+$PIECE(IBM,U,IBI),0)),U,1)
SET IBSTR=$$SETLN(IBD,IBSTR,17,25)
+10 IF $PIECE(IBCU2,U,(IBI+3))'=""
SET IBD=$JUSTIFY(+$PIECE(IBCU2,U,(IBI+3)),9,2)
SET IBSTR=$$SETLN(IBD,IBSTR,44,11)
+11 ;ICR #2024
IF $PIECE(IBM1,U,(IBI+4))'=""
SET IBD=$$BN1^PRCAFN(+$PIECE(IBM1,U,(IBI+4)))
SET IBSTR=$$SETLN(IBD,IBSTR,60,11)
End DoDot:1
SET IBLN=$$SET(IBSTR,IBLN)
+12 IF +$PIECE(IBCU1,U,2)
Begin DoDot:1
+13 IF IBSTR=""
SET IBLN=$$SET("",IBLN)
+14 SET IBD="Offset: "
SET IBSTR=$$SETLN(IBD,"",5,11)
+15 SET IBD=$PIECE(IBCU1,U,3)
SET IBSTR=$$SETLN(IBD,IBSTR,17,25)
+16 SET IBD=$JUSTIFY($PIECE(IBCU1,U,2),9,2)
SET IBSTR=$$SETLN(IBD,IBSTR,44,11)
+17 SET IBD=$PIECE(IBCU1,U,1)-$PIECE(IBCU1,U,2)
SET IBD="Billed: "_$JUSTIFY(IBD,0,2)
SET IBSTR=$$SETLN(IBD,IBSTR,60,17)
End DoDot:1
SET IBLN=$$SET(IBSTR,IBLN)
+18 QUIT
+19 ;
RX ;RX refill info for CMS-1500 TPJI display
+1 NEW Z,Z0,Z1,IBSPC,IBD,IBI,IBSTR,IBARRAY,IBRXX
+2 SET IBLN=IBLN+1
+3 SET IBSPC=$JUSTIFY("",5)
+4 DO SET^IBCSC5A(IBIFN,.IBARRAY)
+5 IF $DATA(IBARRAY)
Begin DoDot:1
+6 SET (Z,Z0)=0
FOR
SET Z0=$ORDER(IBARRAY(Z0))
if Z0=""
QUIT
SET Z1=0
FOR
SET Z1=$ORDER(IBARRAY(Z0,Z1))
if 'Z1
QUIT
SET Z=Z+1
SET IBXDATA(Z)=$$DAT1^IBOUTL(Z1)_U_$GET(IBARRAY(Z0,Z1))
End DoDot:1
+7 SET IBD=$$SET("",IBLN)
+8 SET IBD="PRESCRIPTION REFILLS: (For TPJI display only)"
+9 SET IBSTR=$$SETLN(IBD,"",1,79)
SET IBLN=$$SET(IBSTR,IBLN)
+10 SET IBI=0
FOR
SET IBI=$ORDER(IBXDATA(IBI))
if IBI=""
QUIT
Begin DoDot:1
+11 SET IBRXX=$GET(IBXDATA(IBI))
+12 DO ZERO^IBRXUTL($PIECE(IBRXX,U,3))
+13 SET IBD=$JUSTIFY($PIECE(IBRXX,U,7),9,2)_IBSPC_$PIECE(IBRXX,U)_IBSPC_$GET(^TMP($JOB,"IBDRUG",+$PIECE(IBRXX,U,3),.01))
+14 KILL ^TMP($JOB,"IBDRUG")
+15 SET IBSTR=$$SETLN(IBD,"",1,79)
SET IBLN=$$SET(IBSTR,IBLN)
+16 SET IBD="QTY: "_$PIECE(IBRXX,U,5)_" for "_$PIECE(IBRXX,U,4)_" days supply "_"NDC# "_$PIECE(IBRXX,U,6)
+17 SET IBSTR=$$SETLN(IBD,"",23,79)
SET IBLN=$$SET(IBSTR,IBLN)
End DoDot:1
+18 QUIT
+19 ;
PROS ;prosthetic info for CMS-1500 TPJI display
+1 NEW Z,Z0,Z1,IBARRAY,IBSPC,IBD,IBI,IBSTR
+2 SET IBSPC=$JUSTIFY("",10)
SET IBLN=IBLN+1
+3 DO SET^IBCSC5B(IBIFN,.IBARRAY)
+4 IF $DATA(IBARRAY)
Begin DoDot:1
+5 SET (Z,Z0)=0
FOR
SET Z0=$ORDER(IBARRAY(Z0))
if Z0=""
QUIT
SET Z1=0
FOR
SET Z1=$ORDER(IBARRAY(Z0,Z1))
if 'Z1
QUIT
SET Z=Z+1
SET IBXDATA(Z)=$$DAT1^IBOUTL(Z0)_U_$EXTRACT($$PINB^IBCSC5B(+IBARRAY(Z0,Z1)),1,39)
End DoDot:1
+6 SET IBD=$$SET("",IBLN)
+7 SET IBD="PROSTHETIC REFILLS: (For TPJI display only)"
+8 SET IBSTR=$$SETLN(IBD,"",1,79)
SET IBLN=$$SET(IBSTR,IBLN)
+9 SET IBI=0
FOR
SET IBI=$ORDER(IBXDATA(IBI))
if IBI=""
QUIT
Begin DoDot:1
+10 SET IBD=$PIECE(IBXDATA(IBI),U)_IBSPC_$PIECE(IBXDATA(IBI),U,2)
+11 SET IBSTR=$$SETLN(IBD,"",1,79)
SET IBLN=$$SET(IBSTR,IBLN)
End DoDot:1
+12 QUIT
+13 ;
MRA ; -- mra/eob
+1 NEW IBI,Z,IBSTR,IBSHEOB,IBCT
+2 SET IBCT=0
+3 ; 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 IBCT=IBCT+1
SET IBSHEOB(IBI)=0
+4 ; EOB has been reapportioned at the site
SET IBI=0
FOR
SET IBI=$ORDER(^IBM(361.1,"C",IBIFN,IBI))
if 'IBI
QUIT
SET IBCT=IBCT+1
SET IBSHEOB(IBI)=1
+5 IF 'IBCT
Begin DoDot:1
+6 SET IBSTR=$$SETLN("No EEOB/MRA Information","",1,79)
+7 SET IBLN=$$SET(IBSTR,IBLN)
End DoDot:1
+8 IF IBCT
Begin DoDot:1
+9 SET Z=0
+10 SET IBI=0
FOR
SET IBI=$ORDER(IBSHEOB(IBI))
if 'IBI
QUIT
SET Z=Z+1
DO SHEOB^IBJTBA1(IBI,+IBSHEOB(IBI),Z,IBCT)
End DoDot:1
+11 ;
+12 QUIT
