IBJTLB1 ;ALB/ARH - TPI INACTIVE LIST BUILD ;2/14/95
;;2.0;INTEGRATED BILLING;**39,80,61,137,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, DFN must be defined
; first search starts at dt and works backwards for 6 months of bills or IBMAXCNT bills, whichever is greater
; all bills for a single day are included in the same search so even IBMAXCNT may be exceeded
; if IBEND is defined on entry it is used as the end dt of the search, otherwise DT is used
; IBBEG is left defined on exit, if it has a value then it is used by the Change Dates action to define the next
; end date of the search, this results in each CD action default working backwards through the date range until
; no bills are found and IBBEG is null then search restarts at DT, IBEND is defined so can tell if range changed
N IBIFN,IBCNT,IBBDT,IBEDT,IBFIRST,IBLAST,IBDT1,IBDT2,IBMAXCNT K IBHMSG
S IBEDT=$S(+$G(IBEND):IBEND,1:DT),IBBDT=$$FMADD^XLFDT(IBEDT,-180),IBMAXCNT=52
;
S (VALMCNT,IBCNT)=0,IBDT1=$S(IBEDT'="":-(IBEDT+.01),1:""),IBDT2=-IBBDT
S IBFIRST=IBBDT,IBLAST=-$O(^DGCR(399,"APDS",DFN,""))
;
F S IBDT1=$O(^DGCR(399,"APDS",DFN,IBDT1)) Q:'IBDT1!(IBDT1>IBDT2&(IBCNT'<IBMAXCNT)) S IBFIRST=-IBDT1 D
. S IBIFN=0 F S IBIFN=$O(^DGCR(399,"APDS",DFN,IBDT1,IBIFN)) Q:'IBIFN I '$$ACTIVE^IBJTU4(IBIFN) D SCRN W "."
;
S IBBEG=$S('IBDT1:"",IBBDT>IBFIRST:IBFIRST,1:IBBDT),IBBDT=$S(+IBBEG:$$DATE(IBBEG),1:"BEGIN")
S IBEND=$S(IBEDT=""!(IBLAST'>IBEDT):"",1:IBEDT),IBEDT=$S(+IBEND:$$DATE(IBEND),1:"END")
;
I 'IBBEG,'IBEND S IBHMSG="** All Inactive Bills **"
I $G(IBHMSG)="" S IBHMSG=IBBDT_" - "_IBEDT
S IBHMSG=IBHMSG_" ("_VALMCNT_")"
;
I VALMCNT=0 D SET(" ",0),SET("No Inactive 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 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^IBJTLA1(+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=$P(IBD0,U,1)_$$ECME^IBTRE(IBIFN),X=$$SETFLD^VALM1(IBY,X,"BILL")
S IBY=INDFLG_IBY,X=$$SETFLD^VALM1(IBY,X,"BILL")
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=$$TYPE($P(IBD0,U,5))_$$TF($P(IBD0,U,6)),X=$$SETFLD^VALM1(IBY,X,"TYPE")
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)
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),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
Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
;
TYPE(X) ; return abbreviated form of Bill Classification (399,.05)
; modified for 516 - baa
Q $S(X=1:"IP",X=2:"IH",X=3:"OP",X=4:"OH",1:"") ;(vd-US14)-IB*2*592 - after detecting as a bug, made this
;Q $S(X=1:"I",X=2:"IH",X=3:"O",X=4:"OH",1:"") ;change so the code would be consistent with TYPE^IBTJLA1.
;
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("IBJTLB",$J,VALMCNT,0)=X Q:'CNT
S ^TMP("IBJTLB",$J,"IDX",VALMCNT,+CNT)=""
S ^TMP("IBJTLBX",$J,CNT)=VALMCNT_U_IBIFN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJTLB1 4739 printed Nov 22, 2024@17:34:03 Page 2
IBJTLB1 ;ALB/ARH - TPI INACTIVE LIST BUILD ;2/14/95
+1 ;;2.0;INTEGRATED BILLING;**39,80,61,137,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, DFN must be defined
+1 ; first search starts at dt and works backwards for 6 months of bills or IBMAXCNT bills, whichever is greater
+2 ; all bills for a single day are included in the same search so even IBMAXCNT may be exceeded
+3 ; if IBEND is defined on entry it is used as the end dt of the search, otherwise DT is used
+4 ; IBBEG is left defined on exit, if it has a value then it is used by the Change Dates action to define the next
+5 ; end date of the search, this results in each CD action default working backwards through the date range until
+6 ; no bills are found and IBBEG is null then search restarts at DT, IBEND is defined so can tell if range changed
+7 NEW IBIFN,IBCNT,IBBDT,IBEDT,IBFIRST,IBLAST,IBDT1,IBDT2,IBMAXCNT
KILL IBHMSG
+8 SET IBEDT=$SELECT(+$GET(IBEND):IBEND,1:DT)
SET IBBDT=$$FMADD^XLFDT(IBEDT,-180)
SET IBMAXCNT=52
+9 ;
+10 SET (VALMCNT,IBCNT)=0
SET IBDT1=$SELECT(IBEDT'="":-(IBEDT+.01),1:"")
SET IBDT2=-IBBDT
+11 SET IBFIRST=IBBDT
SET IBLAST=-$ORDER(^DGCR(399,"APDS",DFN,""))
+12 ;
+13 FOR
SET IBDT1=$ORDER(^DGCR(399,"APDS",DFN,IBDT1))
if 'IBDT1!(IBDT1>IBDT2&(IBCNT'<IBMAXCNT))
QUIT
SET IBFIRST=-IBDT1
Begin DoDot:1
+14 SET IBIFN=0
FOR
SET IBIFN=$ORDER(^DGCR(399,"APDS",DFN,IBDT1,IBIFN))
if 'IBIFN
QUIT
IF '$$ACTIVE^IBJTU4(IBIFN)
DO SCRN
WRITE "."
End DoDot:1
+15 ;
+16 SET IBBEG=$SELECT('IBDT1:"",IBBDT>IBFIRST:IBFIRST,1:IBBDT)
SET IBBDT=$SELECT(+IBBEG:$$DATE(IBBEG),1:"BEGIN")
+17 SET IBEND=$SELECT(IBEDT=""!(IBLAST'>IBEDT):"",1:IBEDT)
SET IBEDT=$SELECT(+IBEND:$$DATE(IBEND),1:"END")
+18 ;
+19 IF 'IBBEG
IF 'IBEND
SET IBHMSG="** All Inactive Bills **"
+20 IF $GET(IBHMSG)=""
SET IBHMSG=IBBDT_" - "_IBEDT
+21 SET IBHMSG=IBHMSG_" ("_VALMCNT_")"
+22 ;
+23 IF VALMCNT=0
DO SET(" ",0)
DO SET("No Inactive Bills for this Patient",0)
+24 ;
+25 QUIT
+26 ;
SCRN ; add bill to screen list (IBIFN,DFN must be defined)
+1 NEW X,IBY,IBD0,IBDU,IBDM,TYPE,REJFLAG,INDFLG
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^IBJTLA1(+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 SET IBY=$PIECE(IBD0,U,1)_$$ECME^IBTRE(IBIFN)
SET X=$$SETFLD^VALM1(IBY,X,"BILL")
+9 SET IBY=INDFLG_IBY
SET X=$$SETFLD^VALM1(IBY,X,"BILL")
+10 SET IBY=$SELECT($$REF^IBJTU31(+IBIFN):"r",1:"")
SET X=$$SETFLD^VALM1(IBY,X,"REFER")
+11 SET IBY=$SELECT($$IB^IBRUTL(+IBIFN,0):"*",1:"")
SET X=$$SETFLD^VALM1(IBY,X,"HD")
+12 SET IBY=$$DATE($PIECE(IBDU,U,1))
SET X=$$SETFLD^VALM1(IBY,X,"STFROM")
+13 SET IBY=$$DATE($PIECE(IBDU,U,2))
SET X=$$SETFLD^VALM1(IBY,X,"STTO")
+14 ;
+15 ;S IBY=$$TYPE($P(IBD0,U,5))_$$TF($P(IBD0,U,6)),X=$$SETFLD^VALM1(IBY,X,"TYPE")
+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)
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 SET IBTYP=$$TYP^IBRFN(IBIFN)
+22 SET IBTYP=$SELECT(IBTYP="":-1,IBTYP="PR":"P",IBTYP="PH":"R",1:IBTYP)
+23 SET IBY=IBY_"/"_IBTYP
SET X=$$SETFLD^VALM1(IBY,X,"TYPE")
+24 SET IBY=" "_$PIECE($$ARSTATA^IBJTU4(IBIFN),U,2)
SET X=$$SETFLD^VALM1(IBY,X,"ARST")
+25 ;
+26 SET IBY=$PIECE($GET(^DGCR(399.3,+$PIECE(IBD0,U,7),0)),U,4)
SET X=$$SETFLD^VALM1(IBY,X,"RATE")
+27 SET IBY=$SELECT($$MINS^IBJTU31(IBIFN):"+",1:"")
SET X=$$SETFLD^VALM1(IBY,X,"CB")
+28 SET IBY=+$GET(^DGCR(399,+IBIFN,"MP"))
+29 IF 'IBY
IF $$MCRWNR^IBEFUNC(+$$CURR^IBCEF2(IBIFN))
SET IBY=+$$CURR^IBCEF2(IBIFN)
+30 SET IBY=$PIECE($GET(^DIC(36,+IBY,0)),U,1)
SET X=$$SETFLD^VALM1(IBY,X,"INSUR")
+31 SET IBY=$$BILL^RCJIBFN2(IBIFN)
+32 SET X=$$SETFLD^VALM1($JUSTIFY(+$PIECE(IBY,U,1),8,2),X,"OAMT")
+33 SET X=$$SETFLD^VALM1($JUSTIFY(+$PIECE(IBY,U,3),8,2),X,"CAMT")
+34 DO SET(X,IBCNT)
+35 QUIT
+36 ;
DATE(X) ; date in external format
+1 QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+2 ;
TYPE(X) ; return abbreviated form of Bill Classification (399,.05)
+1 ; modified for 516 - baa
+2 ;(vd-US14)-IB*2*592 - after detecting as a bug, made this
QUIT $SELECT(X=1:"IP",X=2:"IH",X=3:"OP",X=4:"OH",1:"")
+3 ;Q $S(X=1:"I",X=2:"IH",X=3:"O",X=4:"OH",1:"") ;change so the code would be consistent with TYPE^IBTJLA1.
+4 ;
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("IBJTLB",$JOB,VALMCNT,0)=X
if 'CNT
QUIT
+3 SET ^TMP("IBJTLB",$JOB,"IDX",VALMCNT,+CNT)=""
+4 SET ^TMP("IBJTLBX",$JOB,CNT)=VALMCNT_U_IBIFN
+5 QUIT
