IBJTLA1 ;ALB/ARH - TPI ACTIVE BILLS LIST BUILD ;2/14/95
;;2.0;INTEGRATED BILLING;**39,80,61,51,153,137,183,276,451,516,530,568,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
BLDA ; build active list for third party joint inquiry active list
N IBIFN,IBCNT S VALMCNT=0,IBCNT=0
S IBIFN=0 F S IBIFN=$O(^DGCR(399,"C",DFN,IBIFN)) Q:'IBIFN I $$ACTIVE^IBJTU4(IBIFN) W "." D SCRN
;
I VALMCNT=0 D SET(" ",0),SET("No Active Bills for this Patient",0)
;
Q
;
SCRN ; add bill to screen list (IBIFN,DFN must be defined)
N X,IBY,IBD0,IBDU,IBDM,TYPE,REJFLAG,INDFLG,IBJTLA1 S X=""
S IBCNT=IBCNT+1,IBD0=$G(^DGCR(399,+IBIFN,0)),IBDU=$G(^DGCR(399,+IBIFN,"U")),IBDM=$G(^DGCR(399,+IBIFN,"M"))
S IBY=IBCNT,X=$$SETFLD^VALM1(IBY,X,"NUMBER")
; IB*2.0*451 - get EEOB indicator for bill # when applicable
S IBPFLAG=$$EEOB(+IBIFN)
S REJFLAG=+$$BILLREJ^IBJTU6($P(IBD0,U)) ;IB*2.0*530 Add indicator for rejects
S INDFLG=$S($G(IBPFLAG)'="":"%",1:"")_$S(REJFLAG:"c",1:"") S:INDFLG="" INDFLG=" "
S IBY=INDFLG_$P(IBD0,U,1)_$$ECME^IBTRE(IBIFN),X=$$SETFLD^VALM1(IBY,X,"BILL") ;add EEOB indicator '%' to bill number when applicable
S IBY=$S($$REF^IBJTU31(+IBIFN):"r",1:""),X=$$SETFLD^VALM1(IBY,X,"REFER")
S IBY=$S($$IB^IBRUTL(+IBIFN,0):"*",1:""),X=$$SETFLD^VALM1(IBY,X,"HD")
S IBY=$$DATE($P(IBDU,U,1)),X=$$SETFLD^VALM1(IBY,X,"STFROM")
S IBY=$$DATE($P(IBDU,U,2)),X=$$SETFLD^VALM1(IBY,X,"STTO")
;
S IBY=$P($$LST^DGMTU(DFN,$P(IBDU,U)),U,4),IBY=$S(IBY="C":"YES",IBY="P":"PEN",IBY="R":"REQ",IBY="G":"GMT",1:"NO"),X=$$SETFLD^VALM1(IBY,X,"MT?")
;S IBY=$$TYPE($P(IBD0,U,5))_$$TF($P(IBD0,U,6))_$S($P(IBD0,U,27)=1:"I",$P(IBD0,U,27)=2:"P",1:""),X=$$SETFLD^VALM1(IBY,X,"TYPE") ; 516 - baa
S TYPE=$$TYPE($P(IBD0,U,5)) I $E(TYPE,2)="P" S TYPE=$E(TYPE) ; 516 - baa
;S IBY=TYPE_"/"_$S($P(IBD0,U,27)=1:"I",$P(IBD0,U,27)=2:"P",1:""),X=$$SETFLD^VALM1(IBY,X,"TYPE") ; 516 - baa
;IB*2.0*592; If the claim is a Dental Claim, set the 2nd piece of the TYPE to "D" for Dental
;IA# 10116
S IBY=TYPE_"/"_$S($$FT^IBCEF(IBIFN)=7:"D",$P(IBD0,U,27)=1:"I",$P(IBD0,U,27)=2:"P",1:" "),X=$$SETFLD^VALM1(IBY,X,"TYPE") ; 592 (vd-US14) ;568 - lmh ret space if null
;
; Return care type for (I)npat,(O)utpat, (R)x or (P)rosthetics - add under TJPI screen TYPE column - 568
S IBTYP=$$TYP^IBRFN(IBIFN)
S IBTYP=$S(IBTYP="":-1,IBTYP="PR":"P",IBTYP="PH":"R",1:IBTYP)
S IBY=IBY_"/"_IBTYP,X=$$SETFLD^VALM1(IBY,X,"TYPE")
;
S IBY=" "_$P($$ARSTATA^IBJTU4(IBIFN),U,2),X=$$SETFLD^VALM1(IBY,X,"ARST")
;
S IBY=$P($G(^DGCR(399.3,+$P(IBD0,U,7),0)),U,4),X=$$SETFLD^VALM1(IBY,X,"RATE")
S IBY=$S($$MINS^IBJTU31(+IBIFN):"+",1:""),X=$$SETFLD^VALM1(IBY,X,"CB")
S IBY=+$G(^DGCR(399,+IBIFN,"MP"))
I 'IBY,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBY=+$$CURR^IBCEF2(IBIFN)
S IBY=$P($G(^DIC(36,+IBY,0)),U,1)
S X=$$SETFLD^VALM1(IBY,X,"INSUR")
S IBY=$$BILL^RCJIBFN2(IBIFN)
S X=$$SETFLD^VALM1($J(+$P(IBY,U,1),8,2),X,"OAMT")
S X=$$SETFLD^VALM1($J(+$P(IBY,U,3),8,2),X,"CAMT")
D SET(X,IBCNT)
Q
;
DATE(X) ; date in external format
N Y S Y="" I X?7N.E S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
Q Y
;
TYPE(X) ; return abbreviated form of Bill Classification (399,.05)
Q $S(X=1:"IP",X=2:"IH",X=3:"OP",X=4:"OH",1:"")
;
TF(X) ; return abbreviated form of Timeframe of Bill (399,.06)
Q $S(X=2:"-F",X=3:"-C",X=4:"-L",X'=1:"-O",1:"")
;
SET(X,CNT) ; set up list manager screen array
S VALMCNT=VALMCNT+1
S ^TMP("IBJTLA",$J,VALMCNT,0)=X Q:'CNT
S ^TMP("IBJTLA",$J,"IDX",VALMCNT,+CNT)=""
S ^TMP("IBJTLAX",$J,CNT)=VALMCNT_U_IBIFN
Q
;
EEOB(IBIFN) ; get payment information
; IB*2.0*451 - find an EOB payment for a bill
; input is the IEN for the bill # in file #399 and must be valid,
; output is the EEOB indicator '%' if a payment is found in file #361.1,
; exclude EOB type MRA (Medicare).
N IBPFLAG,IBVAL,Z
I $G(IBIFN)=0 Q ""
I '$O(^IBM(361.1,"B",IBIFN,0)) Q "" ; no entry here
I $P($G(^DGCR(399,IBIFN,0)),"^",13)=1 Q "" ;avoid 'ENTERED/NOT REVIEWED' status
; handle both single and multiple bill entries in file #361.1
S Z=0 F S Z=$O(^IBM(361.1,"B",IBIFN,Z)) Q:'Z D Q:$G(IBPFLAG)="%"
. S IBVAL=$G(^IBM(361.1,Z,0))
. S IBPFLAG=$S($P(IBVAL,"^",4)=1:"",$P(IBVAL,"^",4)=0:"%",1:"")
Q IBPFLAG ; EOB indicator for either 1st or 3rd payment on bill
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJTLA1 4334 printed Sep 23, 2025@20:00:14 Page 2
IBJTLA1 ;ALB/ARH - TPI ACTIVE BILLS LIST BUILD ;2/14/95
+1 ;;2.0;INTEGRATED BILLING;**39,80,61,51,153,137,183,276,451,516,530,568,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
BLDA ; build active list for third party joint inquiry active list
+1 NEW IBIFN,IBCNT
SET VALMCNT=0
SET IBCNT=0
+2 SET IBIFN=0
FOR
SET IBIFN=$ORDER(^DGCR(399,"C",DFN,IBIFN))
if 'IBIFN
QUIT
IF $$ACTIVE^IBJTU4(IBIFN)
WRITE "."
DO SCRN
+3 ;
+4 IF VALMCNT=0
DO SET(" ",0)
DO SET("No Active Bills for this Patient",0)
+5 ;
+6 QUIT
+7 ;
SCRN ; add bill to screen list (IBIFN,DFN must be defined)
+1 NEW X,IBY,IBD0,IBDU,IBDM,TYPE,REJFLAG,INDFLG,IBJTLA1
SET X=""
+2 SET IBCNT=IBCNT+1
SET IBD0=$GET(^DGCR(399,+IBIFN,0))
SET IBDU=$GET(^DGCR(399,+IBIFN,"U"))
SET IBDM=$GET(^DGCR(399,+IBIFN,"M"))
+3 SET IBY=IBCNT
SET X=$$SETFLD^VALM1(IBY,X,"NUMBER")
+4 ; IB*2.0*451 - get EEOB indicator for bill # when applicable
+5 SET IBPFLAG=$$EEOB(+IBIFN)
+6 ;IB*2.0*530 Add indicator for rejects
SET REJFLAG=+$$BILLREJ^IBJTU6($PIECE(IBD0,U))
+7 SET INDFLG=$SELECT($GET(IBPFLAG)'="":"%",1:"")_$SELECT(REJFLAG:"c",1:"")
if INDFLG=""
SET INDFLG=" "
+8 ;add EEOB indicator '%' to bill number when applicable
SET IBY=INDFLG_$PIECE(IBD0,U,1)_$$ECME^IBTRE(IBIFN)
SET X=$$SETFLD^VALM1(IBY,X,"BILL")
+9 SET IBY=$SELECT($$REF^IBJTU31(+IBIFN):"r",1:"")
SET X=$$SETFLD^VALM1(IBY,X,"REFER")
+10 SET IBY=$SELECT($$IB^IBRUTL(+IBIFN,0):"*",1:"")
SET X=$$SETFLD^VALM1(IBY,X,"HD")
+11 SET IBY=$$DATE($PIECE(IBDU,U,1))
SET X=$$SETFLD^VALM1(IBY,X,"STFROM")
+12 SET IBY=$$DATE($PIECE(IBDU,U,2))
SET X=$$SETFLD^VALM1(IBY,X,"STTO")
+13 ;
+14 SET IBY=$PIECE($$LST^DGMTU(DFN,$PIECE(IBDU,U)),U,4)
SET IBY=$SELECT(IBY="C":"YES",IBY="P":"PEN",IBY="R":"REQ",IBY="G":"GMT",1:"NO")
SET X=$$SETFLD^VALM1(IBY,X,"MT?")
+15 ;S IBY=$$TYPE($P(IBD0,U,5))_$$TF($P(IBD0,U,6))_$S($P(IBD0,U,27)=1:"I",$P(IBD0,U,27)=2:"P",1:""),X=$$SETFLD^VALM1(IBY,X,"TYPE") ; 516 - baa
+16 ; 516 - baa
SET TYPE=$$TYPE($PIECE(IBD0,U,5))
IF $EXTRACT(TYPE,2)="P"
SET TYPE=$EXTRACT(TYPE)
+17 ;S IBY=TYPE_"/"_$S($P(IBD0,U,27)=1:"I",$P(IBD0,U,27)=2:"P",1:""),X=$$SETFLD^VALM1(IBY,X,"TYPE") ; 516 - baa
+18 ;IB*2.0*592; If the claim is a Dental Claim, set the 2nd piece of the TYPE to "D" for Dental
+19 ;IA# 10116
+20 ; 592 (vd-US14) ;568 - lmh ret space if null
SET IBY=TYPE_"/"_$SELECT($$FT^IBCEF(IBIFN)=7:"D",$PIECE(IBD0,U,27)=1:"I",$PIECE(IBD0,U,27)=2:"P",1:" ")
SET X=$$SETFLD^VALM1(IBY,X,"TYPE")
+21 ;
+22 ; Return care type for (I)npat,(O)utpat, (R)x or (P)rosthetics - add under TJPI screen TYPE column - 568
+23 SET IBTYP=$$TYP^IBRFN(IBIFN)
+24 SET IBTYP=$SELECT(IBTYP="":-1,IBTYP="PR":"P",IBTYP="PH":"R",1:IBTYP)
+25 SET IBY=IBY_"/"_IBTYP
SET X=$$SETFLD^VALM1(IBY,X,"TYPE")
+26 ;
+27 SET IBY=" "_$PIECE($$ARSTATA^IBJTU4(IBIFN),U,2)
SET X=$$SETFLD^VALM1(IBY,X,"ARST")
+28 ;
+29 SET IBY=$PIECE($GET(^DGCR(399.3,+$PIECE(IBD0,U,7),0)),U,4)
SET X=$$SETFLD^VALM1(IBY,X,"RATE")
+30 SET IBY=$SELECT($$MINS^IBJTU31(+IBIFN):"+",1:"")
SET X=$$SETFLD^VALM1(IBY,X,"CB")
+31 SET IBY=+$GET(^DGCR(399,+IBIFN,"MP"))
+32 IF 'IBY
IF $$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN))
SET IBY=+$$CURR^IBCEF2(IBIFN)
+33 SET IBY=$PIECE($GET(^DIC(36,+IBY,0)),U,1)
+34 SET X=$$SETFLD^VALM1(IBY,X,"INSUR")
+35 SET IBY=$$BILL^RCJIBFN2(IBIFN)
+36 SET X=$$SETFLD^VALM1($JUSTIFY(+$PIECE(IBY,U,1),8,2),X,"OAMT")
+37 SET X=$$SETFLD^VALM1($JUSTIFY(+$PIECE(IBY,U,3),8,2),X,"CAMT")
+38 DO SET(X,IBCNT)
+39 QUIT
+40 ;
DATE(X) ; date in external format
+1 NEW Y
SET Y=""
IF X?7N.E
SET Y=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+2 QUIT Y
+3 ;
TYPE(X) ; return abbreviated form of Bill Classification (399,.05)
+1 QUIT $SELECT(X=1:"IP",X=2:"IH",X=3:"OP",X=4:"OH",1:"")
+2 ;
TF(X) ; return abbreviated form of Timeframe of Bill (399,.06)
+1 QUIT $SELECT(X=2:"-F",X=3:"-C",X=4:"-L",X'=1:"-O",1:"")
+2 ;
SET(X,CNT) ; set up list manager screen array
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBJTLA",$JOB,VALMCNT,0)=X
if 'CNT
QUIT
+3 SET ^TMP("IBJTLA",$JOB,"IDX",VALMCNT,+CNT)=""
+4 SET ^TMP("IBJTLAX",$JOB,CNT)=VALMCNT_U_IBIFN
+5 QUIT
+6 ;
EEOB(IBIFN) ; get payment information
+1 ; IB*2.0*451 - find an EOB payment for a bill
+2 ; input is the IEN for the bill # in file #399 and must be valid,
+3 ; output is the EEOB indicator '%' if a payment is found in file #361.1,
+4 ; exclude EOB type MRA (Medicare).
+5 NEW IBPFLAG,IBVAL,Z
+6 IF $GET(IBIFN)=0
QUIT ""
+7 ; no entry here
IF '$ORDER(^IBM(361.1,"B",IBIFN,0))
QUIT ""
+8 ;avoid 'ENTERED/NOT REVIEWED' status
IF $PIECE($GET(^DGCR(399,IBIFN,0)),"^",13)=1
QUIT ""
+9 ; handle both single and multiple bill entries in file #361.1
+10 SET Z=0
FOR
SET Z=$ORDER(^IBM(361.1,"B",IBIFN,Z))
if 'Z
QUIT
Begin DoDot:1
+11 SET IBVAL=$GET(^IBM(361.1,Z,0))
+12 SET IBPFLAG=$SELECT($PIECE(IBVAL,"^",4)=1:"",$PIECE(IBVAL,"^",4)=0:"%",1:"")
End DoDot:1
if $GET(IBPFLAG)="%"
QUIT
+13 ; EOB indicator for either 1st or 3rd payment on bill
QUIT IBPFLAG
