IBJTCA1 ;ALB/ARH - TPI CLAIMS INFO BUILD ;10/31/07 14:17
;;2.0;INTEGRATED BILLING;**39,80,106,137,223,276,363,384,432,452,473,497,521,516,592,617**;21-MAR-94;Build 43
;;Per VA Directive 6402, this routine should not be modified.
;
;Reference to $$NABP^BPSBUTL supported by IA# 4719
;
BLD ; build array for Third Party Joint Inquiry Claims Info screen, IBIFN must be defined
;
N X,IBY,IBZ,IBZ0,IBI,IBT,IBD,IBLN,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 VALMCNT=0,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 (IBLN,VALMCNT)=1
;
; MRD;IB*2.0*516 - Try to make the following more readable; also
; added IBTC(7), IBTW(7) and IBSW(7).
;IB*2.0*432/TAZ - Added IBTW(6) and IBSW(6)
;S (IBNC(1),IBTC(1),IBTC(4),IBTC(6))=2,IBTC(5)=78,(IBNC(2),IBTC(2))=42,IBNC(3)=35,IBTW(1)=15,IBTW(2)=16,IBTW(4)=12,IBTW(5)=1,IBTW(6)=20,IBSW(1)=23,IBSW(2)=21,IBSW(4)=60,IBSW(5)=1,IBSW(6)=49
;
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(+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 Z=$O(IBZ(Z)) Q:'Z D
;. I $G(IBZ(Z)),$G(IBZ(Z,1))'="" S IBLN=$$SET(IBT,"(OLD PROV DATA) "_IBZ(Z,1),IBLN,IBLR),IBZ0=1 Q
;. I $P($G(IBZ(Z,1)),U)'="" S IBD=$E($$EXPAND^IBTRE(399.0222,.01,Z)_":"_$J("",15),1,15)_$P(IBZ(Z,1),U)_$S($P(IBZ(Z,1),U,4)'="":" ("_$P(IBZ(Z,1),U,4)_")",1:"") S IBLN=$$SET(IBT,IBD,IBLN,IBLR) S IBT=$J("",11),IBZ0=1
;I 'IBZ0 S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
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)
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
D CONT^IBJTCA2
;
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^")
.. ; 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
;
EMPL(DFN) ; returns employer name
Q $P($G(^DPT(+DFN,.311)),U,1)
;
SET(TTL,DATA,LN,LR) ;
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) ;
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(^TMP("IBJTCA",$J,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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJTCA1 9727 printed Oct 16, 2024@18:24:29 Page 2
IBJTCA1 ;ALB/ARH - TPI CLAIMS INFO BUILD ;10/31/07 14:17
+1 ;;2.0;INTEGRATED BILLING;**39,80,106,137,223,276,363,384,432,452,473,497,521,516,592,617**;21-MAR-94;Build 43
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Reference to $$NABP^BPSBUTL supported by IA# 4719
+5 ;
BLD ; build array for Third Party Joint Inquiry Claims Info screen, IBIFN must be defined
+1 ;
+2 NEW X,IBY,IBZ,IBZ0,IBI,IBT,IBD,IBLN,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
+3 ; IB*2.0*473 bi
NEW IBXSAVE
+4 NEW BPSBINFO,IBBPS,IBBPSRX,IBBPSFL
+5 SET VALMCNT=0
SET X=""
SET IBD0=$GET(^DGCR(399,+$GET(IBIFN),0))
IF IBD0=""
SET VALMQUIT=""
GOTO BLDQ
+6 FOR IBI="M","M1","U","S","U2","TX"
SET @("IBD"_IBI)=$GET(^DGCR(399,+IBIFN,IBI))
+7 SET IBDI1=$PIECE(IBD0,U,21)
SET IBDI1=$SELECT(IBDI1="S":2,IBDI1="T":3,1:1)
SET IBDI1=$$POLICY^IBCEF(IBIFN,,IBDI1)
+8 SET IBID0=$GET(^DIC(36,+IBDI1,0))
SET IBID13=$GET(^DIC(36,+IBDI1,.13))
+9 ;
+10 SET (IBLN,VALMCNT)=1
+11 ;
+12 ; MRD;IB*2.0*516 - Try to make the following more readable; also
+13 ; added IBTC(7), IBTW(7) and IBSW(7).
+14 ;IB*2.0*432/TAZ - Added IBTW(6) and IBSW(6)
+15 ;S (IBNC(1),IBTC(1),IBTC(4),IBTC(6))=2,IBTC(5)=78,(IBNC(2),IBTC(2))=42,IBNC(3)=35,IBTW(1)=15,IBTW(2)=16,IBTW(4)=12,IBTW(5)=1,IBTW(6)=20,IBSW(1)=23,IBSW(2)=21,IBSW(4)=60,IBSW(5)=1,IBSW(6)=49
+16 ;
+17 SET IBNC(1)=2
SET IBTC(1)=2
SET IBTW(1)=15
SET IBSW(1)=23
+18 SET IBNC(2)=42
SET IBTC(2)=42
SET IBTW(2)=16
SET IBSW(2)=21
+19 SET IBNC(3)=35
+20 SET IBTC(4)=2
SET IBTW(4)=12
SET IBSW(4)=60
+21 SET IBTC(5)=78
SET IBTW(5)=1
SET IBSW(5)=1
+22 SET IBTC(6)=2
SET IBTW(6)=20
SET IBSW(6)=49
+23 SET IBTC(7)=2
SET IBTW(7)=20
SET IBSW(7)=58
+24 ;
+25 SET IBLR=1
+26 ;
+27 SET IBT="Insurance Demographics"
SET IBLN=$$SETN(IBT,IBLN,IBLR,1)
+28 SET IBWNR=$$WNRBILL^IBEFUNC(IBIFN)
+29 SET IBNABP=$$NABP^IBNCPDPU(IBIFN)
+30 IF IBNABP=""
Begin DoDot:1
+31 SET IBBPS=$$BILINF^IBNCPUT3(IBIFN,.BPSBINFO)
+32 SET IBBPSRX=$GET(BPSBINFO("PRESCRIPTION"))
+33 SET IBBPSFL=$GET(BPSBINFO("FILL NUMBER"))
+34 ; IA# 4719
SET IBNABP=$$NABP^BPSBUTL(IBBPSRX,IBBPSFL)
End DoDot:1
+35 SET IBT=$SELECT(IBWNR:" *",1:" ")_"Bill Payer: "
SET IBD=$PIECE(IBID0,U,1)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+36 SET IBT="Claim Address: "
Begin DoDot:1
+37 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)
+38 IF $PIECE(IBDM,U,6)'=""
SET IBT=""
SET IBD=$PIECE(IBDM,U,6)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+39 IF $PIECE(IBDM1,U,1)'=""
SET IBT=""
SET IBD=$PIECE(IBDM1,U,1)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+40 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)
+41 SET IBT="Claim Phone: "
SET IBD=$PIECE($$BADD^IBJTU3(+IBIFN),U,2)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+42 SET IBLN=$$SET("","",IBLN,5)
+43 ;
+44 ; MRD;IB*2.0*516 - Use an IBLR of 7 for this section, then reset below.
+45 SET IBLR=7
+46 SET IBT="Subscriber Demographics"
SET IBLN=$$SETN(IBT,IBLN,1,1)
+47 SET IBT="Group Number: "
SET IBD=$PIECE(IBDI1,U,3)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+48 SET IBT="Group Name: "
SET IBD=$PIECE(IBDI1,U,15)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+49 SET IBT="Subscriber ID: "
SET IBD=$PIECE(IBDI1,U,2)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+50 SET IBT="Employer: "
SET IBD=$$EMPL(+DFN)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+51 SET IBT="Insured's Name: "
SET IBD=$PIECE(IBDI1,U,17)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+52 SET IBT="Relationship: "
SET IBD=$$EXSET^IBJU1($PIECE(IBDI1,U,16),2.312,16)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+53 SET IBLR=1
+54 ;
+55 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
+56 SET (IBT,IBD)=""
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+57 ;JWS:IB*2.0*592:US131 - added dental claim #7
+58 IF $$FT^IBCEF(IBIFN)=2!($$FT^IBCEF(IBIFN)=7)
Begin DoDot:1
+59 NEW IBXDATA,IBXSAVE
KILL ^TMP("IBXSAVE",$JOB)
+60 DO F^IBCEF("N-HCFA 1500 BOX 19",,,IBIFN)
+61 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
+62 ;
+63 SET IBGRPB=IBLN
SET IBLR=1
+64 SET IBT="Claim Information"
SET IBLN=$$SETN(IBT,IBLN,3,1)
+65 SET IBT="Bill Type: "
SET IBD=$$EXSET^IBJU1($PIECE(IBD0,U,5),399,.05)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+66 SET IBT="Time Frame: "
SET IBD=$$EXSET^IBJU1($PIECE(IBD0,U,6),399,.06)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+67 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)
+68 SET IBT="AR Status: "
SET IBD=$PIECE($$ARSTATA^IBJTU4(IBIFN),U,1)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+69 SET IBT=" Sequence: "
SET IBD=$PIECE($$EXSET^IBJU1($PIECE(IBD0,U,21),399,.21)," ",1)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+70 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)
+71 IF $PIECE(IBDM1,"^",8)
SET IBT=" ECME No: "
SET IBD=$PIECE($PIECE(IBDM1,"^",8),";",1)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+72 IF $LENGTH($PIECE(IBDM1,"^",9))
SET IBT="ECME Ap No: "
SET IBD=$PIECE(IBDM1,"^",9)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+73 IF IBNABP'=""
SET IBT=$SELECT(($LENGTH($TRANSLATE(IBNABP," ",""))=7):" NCPDP No: ",1:" NPI: ")
SET IBD=IBNABP
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+74 ; IB*2.0*521 add Claim HPID to display
+75 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:"")
+76 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)
+77 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)
+78 IF $GET(IBBX19(1))'=""
Begin DoDot:1
+79 SET IBT=" Box 19: "
SET IBD=IBBX19(1)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+80 IF $GET(IBBX19(2))'=""
SET IBT=$JUSTIFY("",11)
SET IBD=IBBX19(2)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
End DoDot:1
+81 ;
+82 SET IBLR=6
SET IBPRVO=""
+83 SET IBT="Providers: "
SET IBD="NONE"
+84 ;IB*2.0*432/TAZ - Changed how providers are displayed to take line-level providers into account.
+85 ;D F^IBCEF("N-ALL PROVIDERS","IBZ",,IBIFN)
+86 DO F^IBCEF("N-ALL PROVIDERS 1","IBZ",,IBIFN)
+87 SET IBZ0=0
+88 SET IBLVL=0
+89 ;F S Z=$O(IBZ(Z)) Q:'Z D
+90 ;. I $G(IBZ(Z)),$G(IBZ(Z,1))'="" S IBLN=$$SET(IBT,"(OLD PROV DATA) "_IBZ(Z,1),IBLN,IBLR),IBZ0=1 Q
+91 ;. I $P($G(IBZ(Z,1)),U)'="" S IBD=$E($$EXPAND^IBTRE(399.0222,.01,Z)_":"_$J("",15),1,15)_$P(IBZ(Z,1),U)_$S($P(IBZ(Z,1),U,4)'="":" ("_$P(IBZ(Z,1),U,4)_")",1:"") S IBLN=$$SET(IBT,IBD,IBLN,IBLR) S IBT=$J("",11),IBZ0=1
+92 ;I 'IBZ0 S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+93 SET IBLVL=0
+94 FOR
SET IBLVL=$ORDER(IBZ(IBLVL))
if 'IBLVL
QUIT
Begin DoDot:1
+95 SET IBT=IBT_$SELECT(IBLVL=1:"Claim: ",1:"Line: ")
+96 SET IBPRVTYP=""
SET IBCNT=0
+97 FOR
SET IBCNT=$ORDER(IBZ(IBLVL,IBCNT))
if 'IBCNT
QUIT
Begin DoDot:2
+98 IF IBLVL=1
SET IBD=$JUSTIFY("",5)
+99 IF IBLVL=2
SET IBD=$EXTRACT("("_IBCNT_")"_$JUSTIFY("",5),1,5)
+100 FOR
SET IBPRVTYP=$ORDER(IBZ(IBLVL,IBCNT,IBPRVTYP))
if 'IBPRVTYP
QUIT
Begin DoDot:3
+101 SET IBD=IBD_$EXTRACT($$EXPAND^IBTRE(399.0222,.01,IBPRVTYP)_":"_$JUSTIFY("",15),1,15)
+102 SET IBD=IBD_$PIECE(IBZ(IBLVL,IBCNT,IBPRVTYP),U)
+103 IF $LENGTH($PIECE(IBZ(IBLVL,IBCNT,IBPRVTYP),U,4))
SET IBD=IBD_" ("_$PIECE(IBZ(IBLVL,IBCNT,IBPRVTYP),U,4)_")"
+104 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
SET IBT=""
SET IBD=$JUSTIFY("",5)
End DoDot:3
End DoDot:2
End DoDot:1
+105 ;
+106 SET IBGRPE=IBLN
SET IBLN=IBGRPB+1
SET IBLR=2
+107 ;
+108 SET IBT="Charge Type: "
SET IBD=$$EXSET^IBJU1($PIECE(IBD0,U,27),399,.27)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+109 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)
+110 SET IBT="Orig Claim: "
SET IBD=$$BILL^RCJIBFN2(+IBIFN)
SET IBLN=$$SET(IBT,$JUSTIFY($PIECE(IBD,U,1),9,2),IBLN,IBLR)
+111 SET IBT="Balance Due: "
SET IBD=$JUSTIFY($PIECE(IBD,U,3),9,2)
SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
+112 IF +$PIECE(IBDM,U,2)
SET IBX=$SELECT($PIECE(IBD0,U,21)="P":2,1:1)
Begin DoDot:1
+113 SET IBT=$SELECT(IBX=2:"Secondary",1:"Primary")_": "
SET IBD=$PIECE($GET(^DIC(36,+$PIECE(IBDM,U,IBX),0)),U,1)
+114 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)
+115 IF +$PIECE(IBDM,U,3)
SET IBX=$SELECT($PIECE(IBD0,U,21)="T":2,1:3)
Begin DoDot:1
+116 SET IBT=$SELECT(IBX=2:"Secondary",1:"Tertiary")_": "
SET IBD=$PIECE($GET(^DIC(36,+$PIECE(IBDM,U,IBX),0)),U,1)
+117 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)
+118 SET IBLN=$$SET("","",IBLN,5)
+119 IF IBWNR
SET IBT="MRA Rec Date: "
Begin DoDot:1
+120 NEW Z
+121 ; find last MRA for receipt date
+122 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)
+123 FOR Z=IBLN:1:IBGRPE
SET IBLN=$$SET("","",IBLN,5)
+124 ;
+125 SET (IBLN,VALMCNT)=$SELECT(IBLN>IBGRPE:IBLN,1:IBGRPE)
+126 ;
+127 SET IBGRPB=IBLN
SET IBLR=1
+128 DO CONT^IBJTCA2
+129 ;
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 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 KILL ^TMP("IBTPJI",$JOB)
+20 ;
+21 SET (IBLN,VALMCNT)=IBLN-1
+22 ;
BLDQ QUIT
+1 ;
EMPL(DFN) ; returns employer name
+1 QUIT $PIECE($GET(^DPT(+DFN,.311)),U,1)
+2 ;
SET(TTL,DATA,LN,LR) ;
+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) ;
+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(^TMP("IBJTCA",$JOB,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
