IBJTTB1 ;ALB/ARH - TPI AR TRANSACTION PROFILE BUILD ;07-APR-1995
;;2.0;INTEGRATED BILLING;**39,530,609**; 21-MAR-94;Build 26
;;Per VA Directive 6402, this routine should not be modified.
;
BLD ; build array for list manager AR TRANSACTION
; input: DFN, IBIFN - ptr to bill (399), IBTRNS - ptr to transaction (433)
N IBI,IBJ,IBX,IBRCT0,IBRCT1,IBRCT2,IBRCT3,IBRCT5,IBRCT8,IBLN,IBSTR,IBD,IBT,IBT1,IBT2,IBT3,IBLL,IBRL,IBLC,IBRC,IBLW,IBRW,IBTRTY,IBBC,IBADDM,STRG,IB12,IB32,IB20,IBEDAT,IBERR,IBERA,IBXRC
Q:'$G(IBTRNS)
S IBLL=16,IBRL=16,IBLC=2,IBRC=35,IBLW=12+IBLL,IBRW=25+IBRL,IB12=12,IB20=20,IB32=32
;
S IBRCT0=$$N0^RCJIBFN1(IBTRNS),IBRCT1=$$N1^RCJIBFN1(IBTRNS),IBRCT2=$$N2^RCJIBFN1(IBTRNS)
S IBRCT3=$$N3^RCJIBFN1(IBTRNS),IBRCT5=$$N5^RCJIBFN1(IBTRNS),IBRCT8=$$N8^RCJIBFN1(IBTRNS)
S IBTRTY=$P($$STNO^RCJIBFN2(+$P(IBRCT1,U,2)),U,3)
;
; IB*2.0*530 - Get ERA#, Trace# and 835 Payer/Tin from Receipt
D:$P(IBRCT1,U,3)]""
. S IBXRC=$$FIND1^DIC(344,"","",$P(IBRCT1,U,3),"B","","IBERR"),IBERA=$$GET1^DIQ(344,IBXRC_",",".18","I")
. D GETS^DIQ(344.4,IBERA_",",".01;.02;.03;.06","E","IBEDAT")
I $P(IBRCT1,U,3)="" S IBERA=0,IBEDAT(344.4,IBERA_",",.01,"E")="NO ERA#",IBEDAT(344.4,IBERA_",",.02,"E")="NO TRACE#",IBEDAT(344.4,IBERA_",",.03,"E")="NO TIN",IBEDAT(344.4,IBERA_",",.06,"E")="NO PAYER"
;
S IBLN=1,IBSTR=""
S IBD="TRANS. NO: ",IBD=$J(IBD,IBLL)_$P(IBRCT0,U,1) S IBSTR=$$SETLN(IBD,IBSTR,IBLC,IBLW)
S IBD="TRANS. TYPE: ",IBD=$J(IBD,IBLL)_$P($$STNO^RCJIBFN2(+$P(IBRCT1,U,2)),U,1) S IBSTR=$$SETLN(IBD,IBSTR,IBRC,IBRW)
S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
;
S IBD="TRANS. DATE: ",IBD=$J(IBD,IBLL)_$$DATE^IBJU1(+IBRCT1) S IBSTR=$$SETLN(IBD,IBSTR,IBLC,IBLW)
S IBD="DATE POSTED: ",IBD=$J(IBD,IBLL)_$$DATE^IBJU1(+$P(IBRCT1,U,7))
S IBD=IBD_" ("_$P($G(^VA(200,+$P(IBRCT0,U,3),0)),U,2)_")" S IBSTR=$$SETLN(IBD,IBSTR,IBRC,IBRW)
S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
;
; IB*2.0*530 - Add ERA#, Trace # and 835 Payer/TIN to screen
S IBD="TRANS. AMOUNT: ",IBD=$J(IBD,IBLL)_$FN($P(IBRCT1,U,5),",",2) S IBSTR=$$SETLN(IBD,IBSTR,IBLC,IBLW)
I IBTRTY=2!(IBTRTY=20) S IBD="ERA#: ",IBD=$J(IBD,8)_$G(IBEDAT(344.4,IBERA_",",.01,"E")) S IBSTR=$$SETLN(IBD,IBSTR,IB32,IB20)
I IBTRTY=2!(IBTRTY=20) S IBD="RECEIPT #: ",IBD=$J(IBD,IB12)_$P(IBRCT1,U,3) S IBSTR=$$SETLN(IBD,IBSTR,54,26)
S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
I IBTRTY=2!(IBTRTY=20) S IBD="PAYER NAME/TIN: ",IBD=$J(IBD,IBLL)_$G(IBEDAT(344.4,IBERA_",",.06,"E"))_"/"_$G(IBEDAT(344.4,IBERA_",",.03,"E")) S IBSTR=$$SETLN(IBD,IBSTR,IBLC,66)
S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
I IBTRTY=2!(IBTRTY=20) S IBD="TRACE#: ",IBD=$J(IBD,IBLL)_$G(IBEDAT(344.4,IBERA_",",.02,"E")) S IBSTR=$$SETLN(IBD,IBSTR,IBLC,66)
S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
; Display FMS Status IB*2.0*609 - Next 7 lines
I IBTRTY=2!(IBTRTY=20),$G(IBXRC) D
. N FMSDOC
. S FMSDOC=$$FMSSTAT^RCDPUREC(IBXRC)
. S IBD="FMS DOCUMENT: "_$TR($P(FMSDOC,"^")," ")_" FMS DOC STATUS: "_$P(FMSDOC,"^",2)
. S IBSTR=$$SETLN(IBD,IBSTR,IBLC,76)
. S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
;
I IBTRTY=21!(IBTRTY=1) S IBD="ADJUSTMENT #: ",IBD=$J(IBD,IBLL)_$P(IBRCT1,U,4) S IBSTR=$$SETLN(IBD,IBSTR,IBLC,IBLW)
I $P(IBRCT0,U,2)'="" I IBTRTY=1!((IBTRTY>7)&(IBTRTY<12))!(IBTRTY=21)!(IBTRTY=29)!(IBTRTY=30) D
. S IBD="DATE CALM DONE: ",IBD=$J(IBD,IBLL)_$$DATE^IBJU1($P(IBRCT0,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,IBRC,IBRW)
I IBSTR'="" S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
;
I IBTRTY=17!($P(IBRCT5,U,2)'="") S IBD="FOLLOW-UP DATE: ",IBD=$J(IBD,IBLL)_$$DATE^IBJU1($P(IBRCT5,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,IBLC,IBLW)
I IBSTR'="" S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
;
I $P(IBRCT0,U,4)["INCOMPLETE" S IBLN=$$SET(" ",IBLN) D
. S IBD="NOTE: ",IBD=$J(IBD,IBLL)_$P(IBRCT0,U,4) S IBSTR=$$SETLN(IBD,"",IBLC,79),IBLN=$$SET(IBSTR,IBLN) S IBSTR=""
;
I IBTRTY=8!(IBTRTY=9) S IBLN=$$SET(" ",IBLN) D S IBLN=$$SET(IBSTR,IBLN) S IBSTR=""
. S IBT=22,IBSTR="TERMINATION REASON: ",IBD=$P(IBRCT1,U,6) S IBSTR=$$SETLN(IBD,IBSTR,IBT,50)
;
; balance and collection amounts
D BCSCR^IBJTTB2
;
; administrative charges
I IBRCT2'="",IBTRTY=12 S IBLN=$$SET(" ",IBLN) S IBSTR="" D
. S IBT=2,IBD="ADMINISTRATIVE COST CHARGE: " S IBSTR=$$SETLN(IBD,IBSTR,IBT,29)
. D ADDM^IBJTTB2 S IBI=0 F S IBI=$O(IBADDM(IBI)) Q:'IBI D S IBLN=$$SET(IBSTR,IBLN) S IBSTR=""
.. S IBT=32,IBD=$P(IBADDM(IBI),U,1) S IBSTR=$$SETLN(IBD,IBSTR,IBT,17)
.. S IBT=50,IBD=$J($P(IBADDM(IBI),U,2),11,2) S IBSTR=$$SETLN(IBD,IBSTR,IBT,11)
;
K STRG D N4^RCJIBFN1(IBTRNS) S (IBI,IBJ)=0 F S IBI=$O(STRG(IBI)) Q:'IBI D S IBLN=$$SET(IBSTR,IBLN) S IBSTR=""
. S IBX=STRG(IBI) Q:IBX="" S IBJ=IBJ+1
. I IBJ=1 S IBLN=$$SET(" ",IBLN)
. S IBT=7,IBD=$S(IBJ=1:"FY: ",1:" ")_$P(IBX,U,1) S IBSTR=$$SETLN(IBD,IBSTR,IBT,8)
. S IBT=28,IBD=$S(IBJ=1:"PR AMT: ",1:" ")_$FN(+$P(IBX,U,2),",",2) S IBSTR=$$SETLN(IBD,IBSTR,IBT,21)
. S IBT=57,IBD=$S(IBJ=1:"FY TR AMT: ",1:" ")_$FN(+$P(IBX,U,4),",",2) S IBSTR=$$SETLN(IBD,IBSTR,IBT,22)
K STRG
;
S IBLN=$$SET(" ",IBLN),IBSTR="COMMENTS: "
S IBT=11,IBD=$P(IBRCT5,U,1) I IBD'="" S IBSTR=$$SETLN(IBD,IBSTR,IBT,45),IBLN=$$SET(IBSTR,IBLN) S IBSTR=""
D TRCOMM^IBJTTB2,COMM^IBJTTB2
;
S VALMCNT=IBLN-1
;
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
N IBX,IBI
D SET^VALM10(LN,STR)
S LN=LN+1
SETQ Q LN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJTTB1 5363 printed Jan 18, 2025@03:25:22 Page 2
IBJTTB1 ;ALB/ARH - TPI AR TRANSACTION PROFILE BUILD ;07-APR-1995
+1 ;;2.0;INTEGRATED BILLING;**39,530,609**; 21-MAR-94;Build 26
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
BLD ; build array for list manager AR TRANSACTION
+1 ; input: DFN, IBIFN - ptr to bill (399), IBTRNS - ptr to transaction (433)
+2 NEW IBI,IBJ,IBX,IBRCT0,IBRCT1,IBRCT2,IBRCT3,IBRCT5,IBRCT8,IBLN,IBSTR,IBD,IBT,IBT1,IBT2,IBT3,IBLL,IBRL,IBLC,IBRC,IBLW,IBRW,IBTRTY,IBBC,IBADDM,STRG,IB12,IB32,IB20,IBEDAT,IBERR,IBERA,IBXRC
+3 if '$GET(IBTRNS)
QUIT
+4 SET IBLL=16
SET IBRL=16
SET IBLC=2
SET IBRC=35
SET IBLW=12+IBLL
SET IBRW=25+IBRL
SET IB12=12
SET IB20=20
SET IB32=32
+5 ;
+6 SET IBRCT0=$$N0^RCJIBFN1(IBTRNS)
SET IBRCT1=$$N1^RCJIBFN1(IBTRNS)
SET IBRCT2=$$N2^RCJIBFN1(IBTRNS)
+7 SET IBRCT3=$$N3^RCJIBFN1(IBTRNS)
SET IBRCT5=$$N5^RCJIBFN1(IBTRNS)
SET IBRCT8=$$N8^RCJIBFN1(IBTRNS)
+8 SET IBTRTY=$PIECE($$STNO^RCJIBFN2(+$PIECE(IBRCT1,U,2)),U,3)
+9 ;
+10 ; IB*2.0*530 - Get ERA#, Trace# and 835 Payer/Tin from Receipt
+11 if $PIECE(IBRCT1,U,3)]""
Begin DoDot:1
+12 SET IBXRC=$$FIND1^DIC(344,"","",$PIECE(IBRCT1,U,3),"B","","IBERR")
SET IBERA=$$GET1^DIQ(344,IBXRC_",",".18","I")
+13 DO GETS^DIQ(344.4,IBERA_",",".01;.02;.03;.06","E","IBEDAT")
End DoDot:1
+14 IF $PIECE(IBRCT1,U,3)=""
SET IBERA=0
SET IBEDAT(344.4,IBERA_",",.01,"E")="NO ERA#"
SET IBEDAT(344.4,IBERA_",",.02,"E")="NO TRACE#"
SET IBEDAT(344.4,IBERA_",",.03,"E")="NO TIN"
SET IBEDAT(344.4,IBERA_",",.06,"E")="NO PAYER"
+15 ;
+16 SET IBLN=1
SET IBSTR=""
+17 SET IBD="TRANS. NO: "
SET IBD=$JUSTIFY(IBD,IBLL)_$PIECE(IBRCT0,U,1)
SET IBSTR=$$SETLN(IBD,IBSTR,IBLC,IBLW)
+18 SET IBD="TRANS. TYPE: "
SET IBD=$JUSTIFY(IBD,IBLL)_$PIECE($$STNO^RCJIBFN2(+$PIECE(IBRCT1,U,2)),U,1)
SET IBSTR=$$SETLN(IBD,IBSTR,IBRC,IBRW)
+19 SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
+20 ;
+21 SET IBD="TRANS. DATE: "
SET IBD=$JUSTIFY(IBD,IBLL)_$$DATE^IBJU1(+IBRCT1)
SET IBSTR=$$SETLN(IBD,IBSTR,IBLC,IBLW)
+22 SET IBD="DATE POSTED: "
SET IBD=$JUSTIFY(IBD,IBLL)_$$DATE^IBJU1(+$PIECE(IBRCT1,U,7))
+23 SET IBD=IBD_" ("_$PIECE($GET(^VA(200,+$PIECE(IBRCT0,U,3),0)),U,2)_")"
SET IBSTR=$$SETLN(IBD,IBSTR,IBRC,IBRW)
+24 SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
+25 ;
+26 ; IB*2.0*530 - Add ERA#, Trace # and 835 Payer/TIN to screen
+27 SET IBD="TRANS. AMOUNT: "
SET IBD=$JUSTIFY(IBD,IBLL)_$FNUMBER($PIECE(IBRCT1,U,5),",",2)
SET IBSTR=$$SETLN(IBD,IBSTR,IBLC,IBLW)
+28 IF IBTRTY=2!(IBTRTY=20)
SET IBD="ERA#: "
SET IBD=$JUSTIFY(IBD,8)_$GET(IBEDAT(344.4,IBERA_",",.01,"E"))
SET IBSTR=$$SETLN(IBD,IBSTR,IB32,IB20)
+29 IF IBTRTY=2!(IBTRTY=20)
SET IBD="RECEIPT #: "
SET IBD=$JUSTIFY(IBD,IB12)_$PIECE(IBRCT1,U,3)
SET IBSTR=$$SETLN(IBD,IBSTR,54,26)
+30 SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
+31 IF IBTRTY=2!(IBTRTY=20)
SET IBD="PAYER NAME/TIN: "
SET IBD=$JUSTIFY(IBD,IBLL)_$GET(IBEDAT(344.4,IBERA_",",.06,"E"))_"/"_$GET(IBEDAT(344.4,IBERA_",",.03,"E"))
SET IBSTR=$$SETLN(IBD,IBSTR,IBLC,66)
+32 SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
+33 IF IBTRTY=2!(IBTRTY=20)
SET IBD="TRACE#: "
SET IBD=$JUSTIFY(IBD,IBLL)_$GET(IBEDAT(344.4,IBERA_",",.02,"E"))
SET IBSTR=$$SETLN(IBD,IBSTR,IBLC,66)
+34 SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
+35 ; Display FMS Status IB*2.0*609 - Next 7 lines
+36 IF IBTRTY=2!(IBTRTY=20)
IF $GET(IBXRC)
Begin DoDot:1
+37 NEW FMSDOC
+38 SET FMSDOC=$$FMSSTAT^RCDPUREC(IBXRC)
+39 SET IBD="FMS DOCUMENT: "_$TRANSLATE($PIECE(FMSDOC,"^")," ")_" FMS DOC STATUS: "_$PIECE(FMSDOC,"^",2)
+40 SET IBSTR=$$SETLN(IBD,IBSTR,IBLC,76)
+41 SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:1
+42 ;
+43 IF IBTRTY=21!(IBTRTY=1)
SET IBD="ADJUSTMENT #: "
SET IBD=$JUSTIFY(IBD,IBLL)_$PIECE(IBRCT1,U,4)
SET IBSTR=$$SETLN(IBD,IBSTR,IBLC,IBLW)
+44 IF $PIECE(IBRCT0,U,2)'=""
IF IBTRTY=1!((IBTRTY>7)&(IBTRTY<12))!(IBTRTY=21)!(IBTRTY=29)!(IBTRTY=30)
Begin DoDot:1
+45 SET IBD="DATE CALM DONE: "
SET IBD=$JUSTIFY(IBD,IBLL)_$$DATE^IBJU1($PIECE(IBRCT0,U,2))
SET IBSTR=$$SETLN(IBD,IBSTR,IBRC,IBRW)
End DoDot:1
+46 IF IBSTR'=""
SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
+47 ;
+48 IF IBTRTY=17!($PIECE(IBRCT5,U,2)'="")
SET IBD="FOLLOW-UP DATE: "
SET IBD=$JUSTIFY(IBD,IBLL)_$$DATE^IBJU1($PIECE(IBRCT5,U,2))
SET IBSTR=$$SETLN(IBD,IBSTR,IBLC,IBLW)
+49 IF IBSTR'=""
SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
+50 ;
+51 IF $PIECE(IBRCT0,U,4)["INCOMPLETE"
SET IBLN=$$SET(" ",IBLN)
Begin DoDot:1
+52 SET IBD="NOTE: "
SET IBD=$JUSTIFY(IBD,IBLL)_$PIECE(IBRCT0,U,4)
SET IBSTR=$$SETLN(IBD,"",IBLC,79)
SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:1
+53 ;
+54 IF IBTRTY=8!(IBTRTY=9)
SET IBLN=$$SET(" ",IBLN)
Begin DoDot:1
+55 SET IBT=22
SET IBSTR="TERMINATION REASON: "
SET IBD=$PIECE(IBRCT1,U,6)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,50)
End DoDot:1
SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
+56 ;
+57 ; balance and collection amounts
+58 DO BCSCR^IBJTTB2
+59 ;
+60 ; administrative charges
+61 IF IBRCT2'=""
IF IBTRTY=12
SET IBLN=$$SET(" ",IBLN)
SET IBSTR=""
Begin DoDot:1
+62 SET IBT=2
SET IBD="ADMINISTRATIVE COST CHARGE: "
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,29)
+63 DO ADDM^IBJTTB2
SET IBI=0
FOR
SET IBI=$ORDER(IBADDM(IBI))
if 'IBI
QUIT
Begin DoDot:2
+64 SET IBT=32
SET IBD=$PIECE(IBADDM(IBI),U,1)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,17)
+65 SET IBT=50
SET IBD=$JUSTIFY($PIECE(IBADDM(IBI),U,2),11,2)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,11)
End DoDot:2
SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:1
+66 ;
+67 KILL STRG
DO N4^RCJIBFN1(IBTRNS)
SET (IBI,IBJ)=0
FOR
SET IBI=$ORDER(STRG(IBI))
if 'IBI
QUIT
Begin DoDot:1
+68 SET IBX=STRG(IBI)
if IBX=""
QUIT
SET IBJ=IBJ+1
+69 IF IBJ=1
SET IBLN=$$SET(" ",IBLN)
+70 SET IBT=7
SET IBD=$SELECT(IBJ=1:"FY: ",1:" ")_$PIECE(IBX,U,1)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,8)
+71 SET IBT=28
SET IBD=$SELECT(IBJ=1:"PR AMT: ",1:" ")_$FNUMBER(+$PIECE(IBX,U,2),",",2)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,21)
+72 SET IBT=57
SET IBD=$SELECT(IBJ=1:"FY TR AMT: ",1:" ")_$FNUMBER(+$PIECE(IBX,U,4),",",2)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,22)
End DoDot:1
SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
+73 KILL STRG
+74 ;
+75 SET IBLN=$$SET(" ",IBLN)
SET IBSTR="COMMENTS: "
+76 SET IBT=11
SET IBD=$PIECE(IBRCT5,U,1)
IF IBD'=""
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,45)
SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
+77 DO TRCOMM^IBJTTB2
DO COMM^IBJTTB2
+78 ;
+79 SET VALMCNT=IBLN-1
+80 ;
+81 QUIT
+82 ;
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
+1 NEW IBX,IBI
+2 DO SET^VALM10(LN,STR)
+3 SET LN=LN+1
SETQ QUIT LN
