IBACCWLEE1 ;EDE/TPF - ACC (Automated Community Care) Encounters - Action Item Expand Encounter Display Formats ; 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.
;
; Reference to $$NABP^BPSBUTL(IBBPSRX,IBBPSFL) in ICR #4719
; Reference to $$BILL^RCJIBFN2(IBK) in ICR# 1452
; Reference to $$STNO^RCJIBFN2(+$P(IBY,U,2)),U,2) in ICR# 1452
Q
;
;CLONED FROM IBJTCA1 PER REQUEST OF SQA
;CALLED FROM IBACCWLEE
BLD(IBIFN,IBLN,VALMCNT) ; build array for Third Party Joint Inquiry Claims Info screen, IBIFN must be defined
;
N I
K IBPOLICY F I="IBJTCA","IBJTBA","IBJTBB","IBJTBC","IBJTBD","IBJTEA","IBJTRA","IBJTTA","IBJTTB","IBJTTC","IBTRCD","IBTRDD","IBCNSA","IBCNSC","IBCNSVP" K ^TMP(I,$J)
;
N X,IBY,IBZ,IBZ0,IBI,IBT,IBD,IBLR,IBD0,IBDI1,IBDM,IBDM1,IBDU,IBDS,IBDU2,IBID0,IBID13,IBNC,IBTC,IBTW,IBSW,IBGRPB,IBGRPE,IBWNR,IBDTX,IBBX19,IBPRVO,IBNABP,IBLVL,IBCNT,IBPRVTYP,IBVL
N IBXSAVE ; IB*2.0*473 bi
N BPSBINFO,IBBPS,IBBPSRX,IBBPSFL
S X="",IBD0=$G(^DGCR(399,+$G(IBIFN),0)) I IBD0="" S VALMQUIT="" G BLDQ
F IBI="M","M1","U","S","U2","TX" S @("IBD"_IBI)=$G(^DGCR(399,+IBIFN,IBI))
S IBDI1=$P(IBD0,U,21),IBDI1=$S(IBDI1="S":2,IBDI1="T":3,1:1) S IBDI1=$$POLICY^IBCEF(IBIFN,,IBDI1)
S IBID0=$G(^DIC(36,+IBDI1,0)),IBID13=$G(^DIC(36,+IBDI1,.13))
;
S IBNC(1)=2,IBTC(1)=2,IBTW(1)=15,IBSW(1)=23
S IBNC(2)=42,IBTC(2)=42,IBTW(2)=16,IBSW(2)=21
S IBNC(3)=35
S IBTC(4)=2,IBTW(4)=12,IBSW(4)=60
S IBTC(5)=78,IBTW(5)=1,IBSW(5)=1
S IBTC(6)=2,IBTW(6)=20,IBSW(6)=49
S IBTC(7)=2,IBTW(7)=20,IBSW(7)=58
;
S IBLR=1
;
S IBT="Insurance Demographics" S IBLN=$$SETN(IBT,IBLN,IBLR,1)
S IBWNR=$$WNRBILL^IBEFUNC(IBIFN)
S IBNABP=$$NABP^IBNCPDPU(IBIFN)
I IBNABP="" D
. S IBBPS=$$BILINF^IBNCPUT3(IBIFN,.BPSBINFO)
. S IBBPSRX=$G(BPSBINFO("PRESCRIPTION"))
. S IBBPSFL=$G(BPSBINFO("FILL NUMBER"))
. S IBNABP=$$NABP^BPSBUTL(IBBPSRX,IBBPSFL) ; IA# 4719
S IBT=$S(IBWNR:" *",1:" ")_"Bill Payer: ",IBD=$P(IBID0,U,1) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Claim Address: " D S IBD=$P(IBDM,U,5) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
. I $P(IBID0,U,1)'=$P(IBDM,U,4) S IBD=$P(IBDM,U,4) S IBLN=$$SET(IBT,IBD,IBLN,IBLR) S IBT=""
I $P(IBDM,U,6)'="" S IBT="",IBD=$P(IBDM,U,6) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
I $P(IBDM1,U,1)'="" S IBT="",IBD=$P(IBDM1,U,1) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="",IBD=$P(IBDM,U,7),IBD=IBD_$S(IBD'="":", ",1:"")_$P($G(^DIC(5,+$P(IBDM,U,8),0)),U,2)_" "_$P(IBDM,U,9),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Claim Phone: ",IBD=$P($$BADD^IBJTU3(+IBIFN),U,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBLN=$$SET("","",IBLN,5)
;
; MRD;IB*2.0*516 - Use an IBLR of 7 for this section, then reset below.
S IBLR=7
S IBT="Subscriber Demographics" S IBLN=$$SETN(IBT,IBLN,1,1)
S IBT="Group Number: ",IBD=$P(IBDI1,U,3) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Group Name: ",IBD=$P(IBDI1,U,15) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Subscriber ID: ",IBD=$P(IBDI1,U,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Employer: ",IBD=$$EMPL^IBACCWLEE4(+DFN) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Insured's Name: ",IBD=$P(IBDI1,U,17) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Relationship: ",IBD=$$EXSET^IBJU1($P(IBDI1,U,16),2.312,16) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBLR=1
;
S (IBNC(1),IBTC(1))=2,(IBNC(2),IBTC(2))=42,IBNC(3)=29,IBTW(1)=12,IBTW(2)=16,IBSW(1)=26,IBSW(2)=22
S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
;JWS:IB*2.0*592:US131 - added dental claim #7
I $$FT^IBCEF(IBIFN)=2!($$FT^IBCEF(IBIFN)=7) D
. N IBXDATA,IBXSAVE K ^TMP("IBXSAVE",$J)
. D F^IBCEF("N-HCFA 1500 BOX 19",,,IBIFN)
. I IBXDATA'="" S IBBX19(1)=$E(IBXDATA,1,40) S:$E(IBXDATA,41,$L(IBXDATA))'="" IBBX19(2)=$E(IBXDATA,41,$L(IBXDATA))
;
S IBGRPB=IBLN,IBLR=1
S IBT="Claim Information" S IBLN=$$SETN(IBT,IBLN,3,1)
S IBT="Bill Type: ",IBD=$$EXSET^IBJU1($P(IBD0,U,5),399,.05) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Time Frame: ",IBD=$$EXSET^IBJU1($P(IBD0,U,6),399,.06) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Rate Type: ",IBD=$P($G(^DGCR(399.3,+$P(IBD0,U,7),0)),U,1) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="AR Status: ",IBD=$P($$ARSTATA^IBJTU4(IBIFN),U,1) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT=" Sequence: ",IBD=$P($$EXSET^IBJU1($P(IBD0,U,21),399,.21)," ",1) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Purch Svc: ",IBD=$S($P(IBDU2,U,11)="":"NO",1:$$EXPAND^IBTRE(399,233,$P(IBDU2,U,11))),IBLN=$$SET(IBT,IBD,IBLN,4)
I $P(IBDM1,"^",8) S IBT=" ECME No: ",IBD=$P($P(IBDM1,"^",8),";",1),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
I $L($P(IBDM1,"^",9)) S IBT="ECME Ap No: ",IBD=$P(IBDM1,"^",9),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
I IBNABP'="" S IBT=$S(($L($TR(IBNABP," ",""))=7):" NCPDP No: ",1:" NPI: "),IBD=IBNABP,IBLN=$$SET(IBT,IBD,IBLN,IBLR)
; IB*2.0*521 add Claim HPID to display
S IBD=$S($P(IBD0,U,21)="P":$P(IBDM1,U,13),$P(IBD0,U,21)="S":$P(IBDM1,U,14),$P(IBD0,U,21)="T":$P(IBDM1,U,15),1:"")
S:IBD="" IBD=$$HPD^IBCNHUT1(+IBDI1) S IBVL=$$HOD^IBCNHUT1(IBD,+IBDI1,IBD) S IBT=$P(IBVL,U,2)_": ",IBLN=$$SET(IBT,IBD,IBLN,IBLR)
I IBWNR S IBT="MRA Status: ",IBD=$S($P(IBDTX,U,5):$P(IBDTX,U,5),1:"NOT RECEIVED"),IBLN=$$SET(IBT,$S(IBD:$$EXPAND^IBTRE(399,24,IBD),1:IBD),IBLN,IBLR)
I $G(IBBX19(1))'="" D
. S IBT=" Box 19: ",IBD=IBBX19(1),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
. I $G(IBBX19(2))'="" S IBT=$J("",11),IBD=IBBX19(2),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
;
S IBLR=6,IBPRVO=""
S IBT="Providers: ",IBD="NONE"
;IB*2.0*432/TAZ - Changed how providers are displayed to take line-level providers into account.
;D F^IBCEF("N-ALL PROVIDERS","IBZ",,IBIFN)
D F^IBCEF("N-ALL PROVIDERS 1","IBZ",,IBIFN)
S IBZ0=0
S IBLVL=0
F S IBLVL=$O(IBZ(IBLVL)) Q:'IBLVL D
. S IBT=IBT_$S(IBLVL=1:"Claim: ",1:"Line: ")
. S IBPRVTYP="",IBCNT=0
. F S IBCNT=$O(IBZ(IBLVL,IBCNT)) Q:'IBCNT D
.. I IBLVL=1 S IBD=$J("",5)
.. I IBLVL=2 S IBD=$E("("_IBCNT_")"_$J("",5),1,5)
.. F S IBPRVTYP=$O(IBZ(IBLVL,IBCNT,IBPRVTYP)) Q:'IBPRVTYP D
... S IBD=IBD_$E($$EXPAND^IBTRE(399.0222,.01,IBPRVTYP)_":"_$J("",15),1,15)
... S IBD=IBD_$P(IBZ(IBLVL,IBCNT,IBPRVTYP),U)
... I $L($P(IBZ(IBLVL,IBCNT,IBPRVTYP),U,4)) S IBD=IBD_" ("_$P(IBZ(IBLVL,IBCNT,IBPRVTYP),U,4)_")"
... S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT="",IBD=$J("",5)
;
S IBGRPE=IBLN,IBLN=IBGRPB+1,IBLR=2
;
S IBT="Charge Type: ",IBD=$$EXSET^IBJU1($P(IBD0,U,27),399,.27) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Service Dates: ",IBD=$$DATE^IBJU1($P(IBDU,U,1))_" - "_$$DATE^IBJU1($P(IBDU,U,2)) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
S IBT="Orig Claim: ",IBD=$$BILL^RCJIBFN2(+IBIFN) S IBLN=$$SET(IBT,$J($P(IBD,U,1),9,2),IBLN,IBLR) ;ICR #1452
S IBT="Balance Due: ",IBD=$J($P(IBD,U,3),9,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
I +$P(IBDM,U,2) S IBX=$S($P(IBD0,U,21)="P":2,1:1) D S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
. S IBT=$S(IBX=2:"Secondary",1:"Primary")_": ",IBD=$P($G(^DIC(36,+$P(IBDM,U,IBX),0)),U,1)
. S IBX=$P(IBDU2,U,(IBX+3)) I +IBX S IBX="("_$J(IBX,0,2)_")" S IBD=$E(IBD,1,(IBSW(IBLR)-$L(IBX)-2))_" "_IBX
I +$P(IBDM,U,3) S IBX=$S($P(IBD0,U,21)="T":2,1:3) D S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
. S IBT=$S(IBX=2:"Secondary",1:"Tertiary")_": ",IBD=$P($G(^DIC(36,+$P(IBDM,U,IBX),0)),U,1)
. S IBX=$P(IBDU2,U,(IBX+3)) I +IBX S IBX="("_$J(IBX,0,2)_")" S IBD=$E(IBD,1,(IBSW(IBLR)-$L(IBX)-2))_" "_IBX
S IBLN=$$SET("","",IBLN,5)
I IBWNR S IBT="MRA Rec Date: " D S IBLN=$$SET(IBT,IBD,IBLN,2)
. N Z
. ; find last MRA for receipt date
. S (IBD,Z)="" F S Z=$O(^IBM(361.1,"B",IBIFN,Z),-1) Q:'Z I $P($G(^IBM(361.1,Z,0)),U,4)=1 S IBD=$$DATE^IBJU1($P($P(^IBM(361.1,Z,0),U,6),".")) Q
F Z=IBLN:1:IBGRPE S IBLN=$$SET("","",IBLN,5)
;
S (IBLN,VALMCNT)=$S(IBLN>IBGRPE:IBLN,1:IBGRPE)
;
S IBGRPB=IBLN,IBLR=1
;
COPAY I $O(^IBA(362.4,"C",IBIFN,0)) D
. S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR) ; blank line
. S IBNC(1)=21,IBT="Related Prescription Copay Information" S IBLN=$$SETN(IBT,IBLN,1,1)
. N IBZ,IBX,IBC,IBCAP
. S IBZ=0 F S IBZ=$O(^IBA(362.4,"C",IBIFN,IBZ)) Q:'IBZ D
.. K ^TMP("IBTPJI",$J)
.. S IBC=$G(^IBA(362.4,IBZ,0))
.. D:$P(IBC,"^",5) RX^PSO52API($P(IBD0,"^",2),"IBTPJI",$P(IBC,"^",5),"","I^") ;ICR #4820 (Supported)
.. ; original fill
.. I $P(IBC,"^",10)=0 D
... S IBX=+$G(^TMP($J,"IBTPJI",$P(IBD0,"^",2),+$P(IBC,"^",5),106)),IBCAP=+$G(^(106.6))
.. ; refills
.. E D
... S IBX=+$G(^TMP($J,"IBTPJI",$P(IBD0,"^",2),+$P(IBC,"^",5),"IB",+$P(IBC,"^",10),9)),IBCAP=+$G(^(9.1))
.. I '$G(IBX),$G(IBCAP) S IBT=" <copay exceeded cap>",IBLN=$$SET(IBT,"",IBLN,4) Q
.. I '$G(IBX) S IBT=" <none found>",IBLN=$$SET(IBT,"",IBLN,4) Q
.. S IBX=$G(^IB(IBX,0))
.. S IBT="Rx: "_$P(IBC,"^")_" Chg: $"_$FN($P(IBX,"^",7),",",2)_" Status: "_$$TITLE^XLFSTR($$EXTERNAL^DILFD(350,.05,"",$P(IBX,"^",5)))_" Bill: "_$P(IBX,"^",11)
.. S IBLN=$$SET(IBT,"",IBLN,4)
;K ^TMP("IBTPJI",$J)
;
S (IBLN,VALMCNT)=IBLN-1
;
BLDQ Q
;
;FOLLOWING CODE PULLED FROM
;D CONT^IBJTCA2
;CONT ; Continuation of Claim Information Screen Build
; reason cancelled
I $P(IBD0,U,13)=7 D
. S (IBNC(1),IBTC(1))=2,(IBNC(2),IBTC(2))=0,IBNC(3)=28,IBTW(1)=29,IBTW(2)=0,IBSW(1)=49,IBSW(2)=0
. S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
. ;
. S IBGRPB=IBLN,IBLR=1
. K IBY D RCANC^IBJTU2(IBIFN,.IBY,50)
. S IBT="Reason Cancelled by ("_$P(IBY,U,3)_"): "
. S IBI=0 F S IBI=$O(IBY(IBI)) Q:'IBI S IBD=IBY(IBI) S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
;
S (IBLN,VALMCNT)=$S(IBLN>IBGRPE:IBLN,1:IBGRPE)
S (IBNC(1),IBTC(1))=2,IBTW(1)=16,IBSW(1)=50
S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
;
S IBGRPB=IBLN,IBLR=1
;
I +$P(IBDS,U,1) S IBT="Entered: ",IBD=$$EXT(IBDS,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
I +$P(IBDS,U,4) S IBT="Initial Review: ",IBD=$$EXT(IBDS,4,5) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
I +$P(IBDS,U,7) S IBT="MRA Request: ",IBD=$$EXT(IBDS,7,8) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
I +$P(IBDS,U,10) S IBT="Authorized: ",IBD=$$EXT(IBDS,10,11) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
I +$P(IBDS,U,12) S IBT="First Printed: ",IBD=$$EXT(IBDS,12,13) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
I $P(IBDS,U,14)>$P(IBDS,U,12) S IBT="Last Printed: ",IBD=$$EXT(IBDS,14,15) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
I +$P(IBDS,U,17) S IBT="Cancelled: ",IBD=$$EXT(IBDS,17,18) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
;
; Patch 320 - added bill cloning history to TPJI report.
N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT
S IBINDENT=0
;
D EN^IBCCR(IBIFN,.IBCCR) ; utility to pull cloning history
;
; attempt to go one claim forward from the current claim
S IBCURR="IBCCR("_+$P(IBDS,U,1)_","_IBIFN_")"
S IBNEXT=$Q(@IBCURR)
I IBNEXT'="" D
. N IBX S IBX=@IBNEXT
. S IBT="Copied: "
. S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_" by "_$P(IBX,U,3)
. S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
. S IBT="Copied To: ",IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
. S IBINDENT=1
. Q
;
; now go backwards for claim cloning history all the way back
S IBBCH=IBCURR
F S IBBCH=$Q(@IBBCH,-1) Q:IBBCH="" D
. N IBX S IBX=@IBBCH
. S IBT="Copied: " I IBINDENT S IBT=" "_IBT
. S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_" by "_$P(IBX,U,3)
. S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
. S IBT="Copied From: " I IBINDENT S IBT=" "_IBT
. S IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
. S IBT="Reason Copied: " I IBINDENT S IBT=" "_IBT
. S IBD=$P(IBX,U,4),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
. S IBINDENT=1
. Q
;
I $D(^DGCR(399,IBIFN,"R","AC",1)) S IBT="Returned to AR: ",X=0 F S X=$O(^DGCR(399,IBIFN,"R","AC",1,X)) Q:'X D
. S IBY=$G(^DGCR(399,IBIFN,"R",X,0)),IBD=$$EXT(IBY,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
;
N IBCOB,IBX,IBY,IBI,IBJ,IBK D BCOB^IBCU3(IBIFN,.IBCOB) I $O(IBCOB(0)) D
. S IBTC(1)=2,IBTW(1)=12,IBSW(1)=68,IBLR=1,IBNC(1)=26,IBTW(0)=0
. S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
. S IBT="Payers and Related Bills" S IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1)
. S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
. S IBTC(1)=0,IBTW(1)=0,IBSW(1)=68,IBLR=1,IBNC(1)=0
. S IBT="",IBD="Insurance Co. Bill # Status Original Collected Balance"
. S IBLN=$$SET(IBT,IBD,IBLN,IBLR) D CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF)
. S IBI=0 F S IBI=$O(IBCOB(IBI)) Q:'IBI D
.. S IBT=$S(IBI=1:"Primary",IBI=2:"Secondary",IBI=3:"Tertiary",1:"Other")_": "
.. S IBJ=0 F S IBJ=$O(IBCOB(IBI,IBJ)) Q:'IBJ S IBK="" F S IBK=$O(IBCOB(IBI,IBJ,IBK)) Q:IBK="" D
... S IBD="",IBY=$$BILL^RCJIBFN2(IBK) ;ICR# 1452
... S IBX=$P($G(^DIC(36,+IBJ,0)),U,1) S IBD=$$SLINE(IBD,IBX,0,15)
... I +IBK D
.... S IBX=$P($G(^DGCR(399,+IBK,0)),U,1) S IBD=$$SLINE(IBD,IBX,17,10)
.... S IBX=$P($$STNO^RCJIBFN2(+$P(IBY,U,2)),U,2) ;bill status ;ICR# 1452
.... ; if MRA active & bill pyr seq >1 & dsply'g prmry & prmry ins is WNR
.... I $$EDIACTV^IBCEF4(2),$$COBN^IBCEF(+IBK)>1,IBI=1,$$MCRWNR^IBEFUNC(+IBJ) D
..... S IBX=" ",IBY="0^^0^0^0" ;blank out status & reset WNR amounts
.... S IBD=$$SLINE(IBD,IBX,30,3)
.... S IBX=$J($P(IBY,U,1),10,2) S IBD=$$SLINE(IBD,IBX,35,10)
.... S IBX=$J($P(IBY,U,4),10,2) S IBD=$$SLINE(IBD,IBX,46,10)
.... S IBX=$J($P(IBY,U,3),10,2) S IBD=$$SLINE(IBD,IBX,57,10)
... S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
;
;IB*2.0*516 - Display links from 3rd party bill to 1st party bill(s)
K ^TMP("IBRBF",$J)
D RELBILL^IBRFN(IBIFN)
N IBCIFN,IBCNT
S IBCNT=0,IBCIFN="" F S IBCIFN=$O(^TMP("IBRBF",$J,IBIFN,IBCIFN)) Q:IBCIFN="" D
. I $P(^TMP("IBRBF",$J,IBIFN,IBCIFN),"^",6)["RX COPAY" K ^TMP("IBRBF",$J,IBIFN,IBCIFN) Q
. S IBCNT=IBCNT+1
D HDR2
I IBCNT=0 S (IBT,IBD)="",IBX="No Links to 1st Party Bills Found",IBD=$$SLINE(IBD,IBX,0,35),IBLN=$$SET(IBT,IBD,IBLN,IBLR) Q
S (IBD,IBX,IBT)=""
S IBCIFN="" F S IBCIFN=$O(^TMP("IBRBF",$J,IBIFN,IBCIFN)) Q:IBCIFN="" D PRINT2^IBACCWLEE4
;
K ^TMP("IBRBF",$J)
;
Q
;
SET(IBT,IBD,IBLN,IBLR) ;
N LN S LN=$$SET2(IBT,IBD,IBLN,IBLR) ;TPF
S VALMCNT=IBLN
Q LN
;
SET2(TTL,DATA,LN,LR) ;EP -
N IBY
S IBY=$J(TTL,IBTW(LR))_DATA D SET1(IBY,LN,IBTC(LR),(IBTW(LR)+IBSW(LR)))
S LN=LN+1
Q LN
;
SETN(TTL,LN,LR,RV) ;EP -
N IBY
S IBY=" "_TTL_" " D SET1(IBY,LN,IBNC(LR),$L(IBY),$G(RV))
S LN=LN+1
Q LN
;
SET1(STR,LN,COL,WD,RV) ; set up TMP array with screen data
N IBX S IBX=$G(@VALMAR@(LN,0))
S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
D SET^VALM10(LN,IBX) I $G(RV)'="" D CNTRL^VALM10(LN,COL,WD,IORVON,IORVOFF)
Q
;
EXT(STR,DT,USER) ; returns external form of user and date, given their position in the string
N X,Y S Y="",STR=$G(STR),DT=+$G(DT),USER=+$G(USER)
S X=$P(STR,U,DT),DT="" I +X S DT=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
S X=$P(STR,U,USER),USER="" I +X S USER=$P($G(^VA(200,+X,0)),U,1) ;ICR #10060 (Supported)
S Y=DT_" by "_$S(USER="":"UNKNOWN",1:USER)
Q Y
;
SLINE(IBD,DATA,COL,WD) ; format a single line with multiple data fields
S IBD=$E(IBD,1,(COL-1)),IBD=IBD_$J("",(COL-$L(IBD))),IBD=IBD_$E(DATA,1,WD)
Q IBD
;
HDR2 ;Print the header for first party bills - IB*2*516
S (IBT,IBD)="",IBLR=1,IBNC(1)=26
S IBLN=$$SET(IBT,IBD,IBLN,1)
S IBT="Related First Party Charges" S IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1)
S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
S IBTC(1)=0,IBTW(1)=1,IBSW(1)=80,IBLR=1,IBNC(1)=26
S IBT="Bill# Charge Type Status Amt Billed On Hold Balance"
S IBLN=$$SET(IBT,IBD,IBLN,IBLR) D CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACCWLEE1 15318 printed May 25, 2026@12:09:58 Page 2
IBACCWLEE1 ;EDE/TPF - ACC (Automated Community Care) Encounters - Action Item Expand Encounter Display Formats ; 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 ;
+4 ; Reference to $$NABP^BPSBUTL(IBBPSRX,IBBPSFL) in ICR #4719
+5 ; Reference to $$BILL^RCJIBFN2(IBK) in ICR# 1452
+6 ; Reference to $$STNO^RCJIBFN2(+$P(IBY,U,2)),U,2) in ICR# 1452
+7 QUIT
+8 ;
+9 ;CLONED FROM IBJTCA1 PER REQUEST OF SQA
+10 ;CALLED FROM IBACCWLEE
BLD(IBIFN,IBLN,VALMCNT) ; build array for Third Party Joint Inquiry Claims Info screen, IBIFN must be defined
+1 ;
+2 NEW I
+3 KILL IBPOLICY
FOR I="IBJTCA","IBJTBA","IBJTBB","IBJTBC","IBJTBD","IBJTEA","IBJTRA","IBJTTA","IBJTTB","IBJTTC","IBTRCD","IBTRDD","IBCNSA","IBCNSC","IBCNSVP"
KILL ^TMP(I,$JOB)
+4 ;
+5 NEW X,IBY,IBZ,IBZ0,IBI,IBT,IBD,IBLR,IBD0,IBDI1,IBDM,IBDM1,IBDU,IBDS,IBDU2,IBID0,IBID13,IBNC,IBTC,IBTW,IBSW,IBGRPB,IBGRPE,IBWNR,IBDTX,IBBX19,IBPRVO,IBNABP,IBLVL,IBCNT,IBPRVTYP,IBVL
+6 ; IB*2.0*473 bi
NEW IBXSAVE
+7 NEW BPSBINFO,IBBPS,IBBPSRX,IBBPSFL
+8 SET X=""
SET IBD0=$GET(^DGCR(399,+$GET(IBIFN),0))
IF IBD0=""
SET VALMQUIT=""
GOTO BLDQ
+9 FOR IBI="M","M1","U","S","U2","TX"
SET @("IBD"_IBI)=$GET(^DGCR(399,+IBIFN,IBI))
+10 SET IBDI1=$PIECE(IBD0,U,21)
SET IBDI1=$SELECT(IBDI1="S":2,IBDI1="T":3,1:1)
SET IBDI1=$$POLICY^IBCEF(IBIFN,,IBDI1)
+11 SET IBID0=$GET(^DIC(36,+IBDI1,0))
SET IBID13=$GET(^DIC(36,+IBDI1,.13))
+12 ;
+13 SET IBNC(1)=2
SET IBTC(1)=2
SET IBTW(1)=15
SET IBSW(1)=23
+14 SET IBNC(2)=42
SET IBTC(2)=42
SET IBTW(2)=16
SET IBSW(2)=21
+15 SET IBNC(3)=35
+16 SET IBTC(4)=2
SET IBTW(4)=12
SET IBSW(4)=60
+17 SET IBTC(5)=78
SET IBTW(5)=1
SET IBSW(5)=1
+18 SET IBTC(6)=2
SET IBTW(6)=20
SET IBSW(6)=49
+19 SET IBTC(7)=2
SET IBTW(7)=20
SET IBSW(7)=58
+20 ;
+21 SET IBLR=1
+22 ;
+23 SET IBT="Insurance Demographics"
SET IBLN=$$SETN(IBT,IBLN,IBLR,1)
+24 SET IBWNR=$$WNRBILL^IBEFUNC(IBIFN)
+25 SET IBNABP=$$NABP^IBNCPDPU(IBIFN)
+26 IF IBNABP=""
Begin DoDot:1
+27 SET IBBPS=$$BILINF^IBNCPUT3(IBIFN,.BPSBINFO)
+28 SET IBBPSRX=$GET(BPSBINFO("PRESCRIPTION"))
+29 SET IBBPSFL=$GET(BPSBINFO("FILL NUMBER"))
+30 ; IA# 4719
SET IBNABP=$$NABP^BPSBUTL(IBBPSRX,IBBPSFL)
End DoDot:1
+31 SET IBT=$SELECT(IBWNR:" *",1:" ")_"Bill Payer: "
SET IBD=$PIECE(IBID0,U,1)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+32 SET IBT="Claim Address: "
Begin DoDot:1
+33 IF $PIECE(IBID0,U,1)'=$PIECE(IBDM,U,4)
SET IBD=$PIECE(IBDM,U,4)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
SET IBT=""
End DoDot:1
SET IBD=$PIECE(IBDM,U,5)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+34 IF $PIECE(IBDM,U,6)'=""
SET IBT=""
SET IBD=$PIECE(IBDM,U,6)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+35 IF $PIECE(IBDM1,U,1)'=""
SET IBT=""
SET IBD=$PIECE(IBDM1,U,1)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+36 SET IBT=""
SET IBD=$PIECE(IBDM,U,7)
SET IBD=IBD_$SELECT(IBD'="":", ",1:"")_$PIECE($GET(^DIC(5,+$PIECE(IBDM,U,8),0)),U,2)_" "_$PIECE(IBDM,U,9)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+37 SET IBT="Claim Phone: "
SET IBD=$PIECE($$BADD^IBJTU3(+IBIFN),U,2)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+38 SET IBLN=$$SET("","",IBLN,5)
+39 ;
+40 ; MRD;IB*2.0*516 - Use an IBLR of 7 for this section, then reset below.
+41 SET IBLR=7
+42 SET IBT="Subscriber Demographics"
SET IBLN=$$SETN(IBT,IBLN,1,1)
+43 SET IBT="Group Number: "
SET IBD=$PIECE(IBDI1,U,3)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+44 SET IBT="Group Name: "
SET IBD=$PIECE(IBDI1,U,15)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+45 SET IBT="Subscriber ID: "
SET IBD=$PIECE(IBDI1,U,2)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+46 SET IBT="Employer: "
SET IBD=$$EMPL^IBACCWLEE4(+DFN)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+47 SET IBT="Insured's Name: "
SET IBD=$PIECE(IBDI1,U,17)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+48 SET IBT="Relationship: "
SET IBD=$$EXSET^IBJU1($PIECE(IBDI1,U,16),2.312,16)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+49 SET IBLR=1
+50 ;
+51 SET (IBNC(1),IBTC(1))=2
SET (IBNC(2),IBTC(2))=42
SET IBNC(3)=29
SET IBTW(1)=12
SET IBTW(2)=16
SET IBSW(1)=26
SET IBSW(2)=22
+52 SET (IBT,IBD)=""
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+53 ;JWS:IB*2.0*592:US131 - added dental claim #7
+54 IF $$FT^IBCEF(IBIFN)=2!($$FT^IBCEF(IBIFN)=7)
Begin DoDot:1
+55 NEW IBXDATA,IBXSAVE
KILL ^TMP("IBXSAVE",$JOB)
+56 DO F^IBCEF("N-HCFA 1500 BOX 19",,,IBIFN)
+57 IF IBXDATA'=""
SET IBBX19(1)=$EXTRACT(IBXDATA,1,40)
if $EXTRACT(IBXDATA,41,$LENGTH(IBXDATA))'=""
SET IBBX19(2)=$EXTRACT(IBXDATA,41,$LENGTH(IBXDATA))
End DoDot:1
+58 ;
+59 SET IBGRPB=IBLN
SET IBLR=1
+60 SET IBT="Claim Information"
SET IBLN=$$SETN(IBT,IBLN,3,1)
+61 SET IBT="Bill Type: "
SET IBD=$$EXSET^IBJU1($PIECE(IBD0,U,5),399,.05)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+62 SET IBT="Time Frame: "
SET IBD=$$EXSET^IBJU1($PIECE(IBD0,U,6),399,.06)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+63 SET IBT="Rate Type: "
SET IBD=$PIECE($GET(^DGCR(399.3,+$PIECE(IBD0,U,7),0)),U,1)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+64 SET IBT="AR Status: "
SET IBD=$PIECE($$ARSTATA^IBJTU4(IBIFN),U,1)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+65 SET IBT=" Sequence: "
SET IBD=$PIECE($$EXSET^IBJU1($PIECE(IBD0,U,21),399,.21)," ",1)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+66 SET IBT="Purch Svc: "
SET IBD=$SELECT($PIECE(IBDU2,U,11)="":"NO",1:$$EXPAND^IBTRE(399,233,$PIECE(IBDU2,U,11)))
SET IBLN=$$SET(IBT,IBD,IBLN,4)
+67 IF $PIECE(IBDM1,"^",8)
SET IBT=" ECME No: "
SET IBD=$PIECE($PIECE(IBDM1,"^",8),";",1)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+68 IF $LENGTH($PIECE(IBDM1,"^",9))
SET IBT="ECME Ap No: "
SET IBD=$PIECE(IBDM1,"^",9)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+69 IF IBNABP'=""
SET IBT=$SELECT(($LENGTH($TRANSLATE(IBNABP," ",""))=7):" NCPDP No: ",1:" NPI: ")
SET IBD=IBNABP
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+70 ; IB*2.0*521 add Claim HPID to display
+71 SET IBD=$SELECT($PIECE(IBD0,U,21)="P":$PIECE(IBDM1,U,13),$PIECE(IBD0,U,21)="S":$PIECE(IBDM1,U,14),$PIECE(IBD0,U,21)="T":$PIECE(IBDM1,U,15),1:"")
+72 if IBD=""
SET IBD=$$HPD^IBCNHUT1(+IBDI1)
SET IBVL=$$HOD^IBCNHUT1(IBD,+IBDI1,IBD)
SET IBT=$PIECE(IBVL,U,2)_": "
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+73 IF IBWNR
SET IBT="MRA Status: "
SET IBD=$SELECT($PIECE(IBDTX,U,5):$PIECE(IBDTX,U,5),1:"NOT RECEIVED")
SET IBLN=$$SET(IBT,$SELECT(IBD:$$EXPAND^IBTRE(399,24,IBD),1:IBD),IBLN,IBLR)
+74 IF $GET(IBBX19(1))'=""
Begin DoDot:1
+75 SET IBT=" Box 19: "
SET IBD=IBBX19(1)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+76 IF $GET(IBBX19(2))'=""
SET IBT=$JUSTIFY("",11)
SET IBD=IBBX19(2)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
End DoDot:1
+77 ;
+78 SET IBLR=6
SET IBPRVO=""
+79 SET IBT="Providers: "
SET IBD="NONE"
+80 ;IB*2.0*432/TAZ - Changed how providers are displayed to take line-level providers into account.
+81 ;D F^IBCEF("N-ALL PROVIDERS","IBZ",,IBIFN)
+82 DO F^IBCEF("N-ALL PROVIDERS 1","IBZ",,IBIFN)
+83 SET IBZ0=0
+84 SET IBLVL=0
+85 FOR
SET IBLVL=$ORDER(IBZ(IBLVL))
if 'IBLVL
QUIT
Begin DoDot:1
+86 SET IBT=IBT_$SELECT(IBLVL=1:"Claim: ",1:"Line: ")
+87 SET IBPRVTYP=""
SET IBCNT=0
+88 FOR
SET IBCNT=$ORDER(IBZ(IBLVL,IBCNT))
if 'IBCNT
QUIT
Begin DoDot:2
+89 IF IBLVL=1
SET IBD=$JUSTIFY("",5)
+90 IF IBLVL=2
SET IBD=$EXTRACT("("_IBCNT_")"_$JUSTIFY("",5),1,5)
+91 FOR
SET IBPRVTYP=$ORDER(IBZ(IBLVL,IBCNT,IBPRVTYP))
if 'IBPRVTYP
QUIT
Begin DoDot:3
+92 SET IBD=IBD_$EXTRACT($$EXPAND^IBTRE(399.0222,.01,IBPRVTYP)_":"_$JUSTIFY("",15),1,15)
+93 SET IBD=IBD_$PIECE(IBZ(IBLVL,IBCNT,IBPRVTYP),U)
+94 IF $LENGTH($PIECE(IBZ(IBLVL,IBCNT,IBPRVTYP),U,4))
SET IBD=IBD_" ("_$PIECE(IBZ(IBLVL,IBCNT,IBPRVTYP),U,4)_")"
+95 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
SET IBT=""
SET IBD=$JUSTIFY("",5)
End DoDot:3
End DoDot:2
End DoDot:1
+96 ;
+97 SET IBGRPE=IBLN
SET IBLN=IBGRPB+1
SET IBLR=2
+98 ;
+99 SET IBT="Charge Type: "
SET IBD=$$EXSET^IBJU1($PIECE(IBD0,U,27),399,.27)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+100 SET IBT="Service Dates: "
SET IBD=$$DATE^IBJU1($PIECE(IBDU,U,1))_" - "_$$DATE^IBJU1($PIECE(IBDU,U,2))
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+101 ;ICR #1452
SET IBT="Orig Claim: "
SET IBD=$$BILL^RCJIBFN2(+IBIFN)
SET IBLN=$$SET(IBT,$JUSTIFY($PIECE(IBD,U,1),9,2),IBLN,IBLR)
+102 SET IBT="Balance Due: "
SET IBD=$JUSTIFY($PIECE(IBD,U,3),9,2)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+103 IF +$PIECE(IBDM,U,2)
SET IBX=$SELECT($PIECE(IBD0,U,21)="P":2,1:1)
Begin DoDot:1
+104 SET IBT=$SELECT(IBX=2:"Secondary",1:"Primary")_": "
SET IBD=$PIECE($GET(^DIC(36,+$PIECE(IBDM,U,IBX),0)),U,1)
+105 SET IBX=$PIECE(IBDU2,U,(IBX+3))
IF +IBX
SET IBX="("_$JUSTIFY(IBX,0,2)_")"
SET IBD=$EXTRACT(IBD,1,(IBSW(IBLR)-$LENGTH(IBX)-2))_" "_IBX
End DoDot:1
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+106 IF +$PIECE(IBDM,U,3)
SET IBX=$SELECT($PIECE(IBD0,U,21)="T":2,1:3)
Begin DoDot:1
+107 SET IBT=$SELECT(IBX=2:"Secondary",1:"Tertiary")_": "
SET IBD=$PIECE($GET(^DIC(36,+$PIECE(IBDM,U,IBX),0)),U,1)
+108 SET IBX=$PIECE(IBDU2,U,(IBX+3))
IF +IBX
SET IBX="("_$JUSTIFY(IBX,0,2)_")"
SET IBD=$EXTRACT(IBD,1,(IBSW(IBLR)-$LENGTH(IBX)-2))_" "_IBX
End DoDot:1
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+109 SET IBLN=$$SET("","",IBLN,5)
+110 IF IBWNR
SET IBT="MRA Rec Date: "
Begin DoDot:1
+111 NEW Z
+112 ; find last MRA for receipt date
+113 SET (IBD,Z)=""
FOR
SET Z=$ORDER(^IBM(361.1,"B",IBIFN,Z),-1)
if 'Z
QUIT
IF $PIECE($GET(^IBM(361.1,Z,0)),U,4)=1
SET IBD=$$DATE^IBJU1($PIECE($PIECE(^IBM(361.1,Z,0),U,6),"."))
QUIT
End DoDot:1
SET IBLN=$$SET(IBT,IBD,IBLN,2)
+114 FOR Z=IBLN:1:IBGRPE
SET IBLN=$$SET("","",IBLN,5)
+115 ;
+116 SET (IBLN,VALMCNT)=$SELECT(IBLN>IBGRPE:IBLN,1:IBGRPE)
+117 ;
+118 SET IBGRPB=IBLN
SET IBLR=1
+119 ;
COPAY IF $ORDER(^IBA(362.4,"C",IBIFN,0))
Begin DoDot:1
+1 ; blank line
SET (IBT,IBD)=""
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+2 SET IBNC(1)=21
SET IBT="Related Prescription Copay Information"
SET IBLN=$$SETN(IBT,IBLN,1,1)
+3 NEW IBZ,IBX,IBC,IBCAP
+4 SET IBZ=0
FOR
SET IBZ=$ORDER(^IBA(362.4,"C",IBIFN,IBZ))
if 'IBZ
QUIT
Begin DoDot:2
+5 KILL ^TMP("IBTPJI",$JOB)
+6 SET IBC=$GET(^IBA(362.4,IBZ,0))
+7 ;ICR #4820 (Supported)
if $PIECE(IBC,"^",5)
DO RX^PSO52API($PIECE(IBD0,"^",2),"IBTPJI",$PIECE(IBC,"^",5),"","I^")
+8 ; original fill
+9 IF $PIECE(IBC,"^",10)=0
Begin DoDot:3
+10 SET IBX=+$GET(^TMP($JOB,"IBTPJI",$PIECE(IBD0,"^",2),+$PIECE(IBC,"^",5),106))
SET IBCAP=+$GET(^(106.6))
End DoDot:3
+11 ; refills
+12 IF '$TEST
Begin DoDot:3
+13 SET IBX=+$GET(^TMP($JOB,"IBTPJI",$PIECE(IBD0,"^",2),+$PIECE(IBC,"^",5),"IB",+$PIECE(IBC,"^",10),9))
SET IBCAP=+$GET(^(9.1))
End DoDot:3
+14 IF '$GET(IBX)
IF $GET(IBCAP)
SET IBT=" <copay exceeded cap>"
SET IBLN=$$SET(IBT,"",IBLN,4)
QUIT
+15 IF '$GET(IBX)
SET IBT=" <none found>"
SET IBLN=$$SET(IBT,"",IBLN,4)
QUIT
+16 SET IBX=$GET(^IB(IBX,0))
+17 SET IBT="Rx: "_$PIECE(IBC,"^")_" Chg: $"_$FNUMBER($PIECE(IBX,"^",7),",",2)_" Status: "_$$TITLE^XLFSTR($$EXTERNAL^DILFD(350,.05,"",$PIECE(IBX,"^",5)))_" Bill: "_$PIECE(IBX,"^",11)
+18 SET IBLN=$$SET(IBT,"",IBLN,4)
End DoDot:2
End DoDot:1
+19 ;K ^TMP("IBTPJI",$J)
+20 ;
+21 SET (IBLN,VALMCNT)=IBLN-1
+22 ;
BLDQ QUIT
+1 ;
+2 ;FOLLOWING CODE PULLED FROM
+3 ;D CONT^IBJTCA2
+4 ;CONT ; Continuation of Claim Information Screen Build
+5 ; reason cancelled
+6 IF $PIECE(IBD0,U,13)=7
Begin DoDot:1
+7 SET (IBNC(1),IBTC(1))=2
SET (IBNC(2),IBTC(2))=0
SET IBNC(3)=28
SET IBTW(1)=29
SET IBTW(2)=0
SET IBSW(1)=49
SET IBSW(2)=0
+8 SET (IBT,IBD)=""
SET IBLN=$$SET(IBT,IBD,IBLN,1)
+9 ;
+10 SET IBGRPB=IBLN
SET IBLR=1
+11 KILL IBY
DO RCANC^IBJTU2(IBIFN,.IBY,50)
+12 SET IBT="Reason Cancelled by ("_$PIECE(IBY,U,3)_"): "
+13 SET IBI=0
FOR
SET IBI=$ORDER(IBY(IBI))
if 'IBI
QUIT
SET IBD=IBY(IBI)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
SET IBT=""
End DoDot:1
+14 ;
+15 SET (IBLN,VALMCNT)=$SELECT(IBLN>IBGRPE:IBLN,1:IBGRPE)
+16 SET (IBNC(1),IBTC(1))=2
SET IBTW(1)=16
SET IBSW(1)=50
+17 SET (IBT,IBD)=""
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+18 ;
+19 SET IBGRPB=IBLN
SET IBLR=1
+20 ;
+21 IF +$PIECE(IBDS,U,1)
SET IBT="Entered: "
SET IBD=$$EXT(IBDS,1,2)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+22 IF +$PIECE(IBDS,U,4)
SET IBT="Initial Review: "
SET IBD=$$EXT(IBDS,4,5)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+23 IF +$PIECE(IBDS,U,7)
SET IBT="MRA Request: "
SET IBD=$$EXT(IBDS,7,8)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+24 IF +$PIECE(IBDS,U,10)
SET IBT="Authorized: "
SET IBD=$$EXT(IBDS,10,11)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+25 IF +$PIECE(IBDS,U,12)
SET IBT="First Printed: "
SET IBD=$$EXT(IBDS,12,13)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+26 IF $PIECE(IBDS,U,14)>$PIECE(IBDS,U,12)
SET IBT="Last Printed: "
SET IBD=$$EXT(IBDS,14,15)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+27 IF +$PIECE(IBDS,U,17)
SET IBT="Cancelled: "
SET IBD=$$EXT(IBDS,17,18)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+28 ;
+29 ; Patch 320 - added bill cloning history to TPJI report.
+30 NEW IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT
+31 SET IBINDENT=0
+32 ;
+33 ; utility to pull cloning history
DO EN^IBCCR(IBIFN,.IBCCR)
+34 ;
+35 ; attempt to go one claim forward from the current claim
+36 SET IBCURR="IBCCR("_+$PIECE(IBDS,U,1)_","_IBIFN_")"
+37 SET IBNEXT=$QUERY(@IBCURR)
+38 IF IBNEXT'=""
Begin DoDot:1
+39 NEW IBX
SET IBX=@IBNEXT
+40 SET IBT="Copied: "
+41 SET IBD=$$FMTE^XLFDT($PIECE(IBX,U,1),"2Z")_" by "_$PIECE(IBX,U,3)
+42 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+43 SET IBT="Copied To: "
SET IBD=$PIECE(IBX,U,2)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+44 SET IBINDENT=1
+45 QUIT
End DoDot:1
+46 ;
+47 ; now go backwards for claim cloning history all the way back
+48 SET IBBCH=IBCURR
+49 FOR
SET IBBCH=$QUERY(@IBBCH,-1)
if IBBCH=""
QUIT
Begin DoDot:1
+50 NEW IBX
SET IBX=@IBBCH
+51 SET IBT="Copied: "
IF IBINDENT
SET IBT=" "_IBT
+52 SET IBD=$$FMTE^XLFDT($PIECE(IBX,U,1),"2Z")_" by "_$PIECE(IBX,U,3)
+53 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+54 SET IBT="Copied From: "
IF IBINDENT
SET IBT=" "_IBT
+55 SET IBD=$PIECE(IBX,U,2)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+56 SET IBT="Reason Copied: "
IF IBINDENT
SET IBT=" "_IBT
+57 SET IBD=$PIECE(IBX,U,4)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+58 SET IBINDENT=1
+59 QUIT
End DoDot:1
+60 ;
+61 IF $DATA(^DGCR(399,IBIFN,"R","AC",1))
SET IBT="Returned to AR: "
SET X=0
FOR
SET X=$ORDER(^DGCR(399,IBIFN,"R","AC",1,X))
if 'X
QUIT
Begin DoDot:1
+62 SET IBY=$GET(^DGCR(399,IBIFN,"R",X,0))
SET IBD=$$EXT(IBY,1,2)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
End DoDot:1
+63 ;
+64 NEW IBCOB,IBX,IBY,IBI,IBJ,IBK
DO BCOB^IBCU3(IBIFN,.IBCOB)
IF $ORDER(IBCOB(0))
Begin DoDot:1
+65 SET IBTC(1)=2
SET IBTW(1)=12
SET IBSW(1)=68
SET IBLR=1
SET IBNC(1)=26
SET IBTW(0)=0
+66 SET (IBT,IBD)=""
SET IBLN=$$SET(IBT,IBD,IBLN,1)
+67 SET IBT="Payers and Related Bills"
SET IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1)
+68 SET (IBT,IBD)=""
SET IBLN=$$SET(IBT,IBD,IBLN,1)
+69 SET IBTC(1)=0
SET IBTW(1)=0
SET IBSW(1)=68
SET IBLR=1
SET IBNC(1)=0
+70 SET IBT=""
SET IBD="Insurance Co. Bill # Status Original Collected Balance"
+71 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
DO CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF)
+72 SET IBI=0
FOR
SET IBI=$ORDER(IBCOB(IBI))
if 'IBI
QUIT
Begin DoDot:2
+73 SET IBT=$SELECT(IBI=1:"Primary",IBI=2:"Secondary",IBI=3:"Tertiary",1:"Other")_": "
+74 SET IBJ=0
FOR
SET IBJ=$ORDER(IBCOB(IBI,IBJ))
if 'IBJ
QUIT
SET IBK=""
FOR
SET IBK=$ORDER(IBCOB(IBI,IBJ,IBK))
if IBK=""
QUIT
Begin DoDot:3
+75 ;ICR# 1452
SET IBD=""
SET IBY=$$BILL^RCJIBFN2(IBK)
+76 SET IBX=$PIECE($GET(^DIC(36,+IBJ,0)),U,1)
SET IBD=$$SLINE(IBD,IBX,0,15)
+77 IF +IBK
Begin DoDot:4
+78 SET IBX=$PIECE($GET(^DGCR(399,+IBK,0)),U,1)
SET IBD=$$SLINE(IBD,IBX,17,10)
+79 ;bill status ;ICR# 1452
SET IBX=$PIECE($$STNO^RCJIBFN2(+$PIECE(IBY,U,2)),U,2)
+80 ; if MRA active & bill pyr seq >1 & dsply'g prmry & prmry ins is WNR
+81 IF $$EDIACTV^IBCEF4(2)
IF $$COBN^IBCEF(+IBK)>1
IF IBI=1
IF $$MCRWNR^IBEFUNC(+IBJ)
Begin DoDot:5
+82 ;blank out status & reset WNR amounts
SET IBX=" "
SET IBY="0^^0^0^0"
End DoDot:5
+83 SET IBD=$$SLINE(IBD,IBX,30,3)
+84 SET IBX=$JUSTIFY($PIECE(IBY,U,1),10,2)
SET IBD=$$SLINE(IBD,IBX,35,10)
+85 SET IBX=$JUSTIFY($PIECE(IBY,U,4),10,2)
SET IBD=$$SLINE(IBD,IBX,46,10)
+86 SET IBX=$JUSTIFY($PIECE(IBY,U,3),10,2)
SET IBD=$$SLINE(IBD,IBX,57,10)
End DoDot:4
+87 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
SET IBT=""
End DoDot:3
End DoDot:2
End DoDot:1
+88 ;
+89 ;IB*2.0*516 - Display links from 3rd party bill to 1st party bill(s)
+90 KILL ^TMP("IBRBF",$JOB)
+91 DO RELBILL^IBRFN(IBIFN)
+92 NEW IBCIFN,IBCNT
+93 SET IBCNT=0
SET IBCIFN=""
FOR
SET IBCIFN=$ORDER(^TMP("IBRBF",$JOB,IBIFN,IBCIFN))
if IBCIFN=""
QUIT
Begin DoDot:1
+94 IF $PIECE(^TMP("IBRBF",$JOB,IBIFN,IBCIFN),"^",6)["RX COPAY"
KILL ^TMP("IBRBF",$JOB,IBIFN,IBCIFN)
QUIT
+95 SET IBCNT=IBCNT+1
End DoDot:1
+96 DO HDR2
+97 IF IBCNT=0
SET (IBT,IBD)=""
SET IBX="No Links to 1st Party Bills Found"
SET IBD=$$SLINE(IBD,IBX,0,35)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
QUIT
+98 SET (IBD,IBX,IBT)=""
+99 SET IBCIFN=""
FOR
SET IBCIFN=$ORDER(^TMP("IBRBF",$JOB,IBIFN,IBCIFN))
if IBCIFN=""
QUIT
DO PRINT2^IBACCWLEE4
+100 ;
+101 KILL ^TMP("IBRBF",$JOB)
+102 ;
+103 QUIT
+104 ;
SET(IBT,IBD,IBLN,IBLR) ;
+1 ;TPF
NEW LN
SET LN=$$SET2(IBT,IBD,IBLN,IBLR)
+2 SET VALMCNT=IBLN
+3 QUIT LN
+4 ;
SET2(TTL,DATA,LN,LR) ;EP -
+1 NEW IBY
+2 SET IBY=$JUSTIFY(TTL,IBTW(LR))_DATA
DO SET1(IBY,LN,IBTC(LR),(IBTW(LR)+IBSW(LR)))
+3 SET LN=LN+1
+4 QUIT LN
+5 ;
SETN(TTL,LN,LR,RV) ;EP -
+1 NEW IBY
+2 SET IBY=" "_TTL_" "
DO SET1(IBY,LN,IBNC(LR),$LENGTH(IBY),$GET(RV))
+3 SET LN=LN+1
+4 QUIT LN
+5 ;
SET1(STR,LN,COL,WD,RV) ; set up TMP array with screen data
+1 NEW IBX
SET IBX=$GET(@VALMAR@(LN,0))
+2 SET IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
+3 DO SET^VALM10(LN,IBX)
IF $GET(RV)'=""
DO CNTRL^VALM10(LN,COL,WD,IORVON,IORVOFF)
+4 QUIT
+5 ;
EXT(STR,DT,USER) ; returns external form of user and date, given their position in the string
+1 NEW X,Y
SET Y=""
SET STR=$GET(STR)
SET DT=+$GET(DT)
SET USER=+$GET(USER)
+2 SET X=$PIECE(STR,U,DT)
SET DT=""
IF +X
SET DT=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+3 ;ICR #10060 (Supported)
SET X=$PIECE(STR,U,USER)
SET USER=""
IF +X
SET USER=$PIECE($GET(^VA(200,+X,0)),U,1)
+4 SET Y=DT_" by "_$SELECT(USER="":"UNKNOWN",1:USER)
+5 QUIT Y
+6 ;
SLINE(IBD,DATA,COL,WD) ; format a single line with multiple data fields
+1 SET IBD=$EXTRACT(IBD,1,(COL-1))
SET IBD=IBD_$JUSTIFY("",(COL-$LENGTH(IBD)))
SET IBD=IBD_$EXTRACT(DATA,1,WD)
+2 QUIT IBD
+3 ;
HDR2 ;Print the header for first party bills - IB*2*516
+1 SET (IBT,IBD)=""
SET IBLR=1
SET IBNC(1)=26
+2 SET IBLN=$$SET(IBT,IBD,IBLN,1)
+3 SET IBT="Related First Party Charges"
SET IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1)
+4 SET (IBT,IBD)=""
SET IBLN=$$SET(IBT,IBD,IBLN,1)
+5 SET IBTC(1)=0
SET IBTW(1)=1
SET IBSW(1)=80
SET IBLR=1
SET IBNC(1)=26
+6 SET IBT="Bill# Charge Type Status Amt Billed On Hold Balance"
+7 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
DO CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF)
+8 QUIT
+9 ;
