IBCU83 ;ALB/ARH - THIRD PARTY BILLING UTILITES (BILL-CT) ; 3/10/96
;;2.0;INTEGRATED BILLING;**48,347**;21-MAR-94;Build 24
;;Per VHA Directive 2004-038, this routine should not be modified.
;
IFNTRN(IBIFN,ARRAY,ARR2) ; find CT records for events on a bill: sched adm, inpt adm, outpt vsts, rx refills, prosthetics
; sets ARRAY=COUNT, ARRAY(IBTRN)=EV TYPE, if bill passed in defined
; ARR2(DATE,TRN)=TRN (based on IBCC1 and IBJTU5)
;
N IBI,IBX,IBD0,DFN,IBTYP,IBTRN,IBDT,IBBDT,IBEDT,IBRX,IBRXN,IBPR,IBPRN,IBBILL,IBN K ARRAY,ARR2
S ARRAY=0,IBD0=$G(^DGCR(399,+$G(IBIFN),0)) I IBD0="" G IFNQ
S DFN=$P(IBD0,U,2)
;
; -- directly linked through 356.399 (not always correct)
;S IBI=0 F S IBI=$O(^IBT(356.399,"C",IBIFN,IBI)) Q:'IBI S IBX=+$G(^IBT(356.399,IBI,0)) I +IBX S ARRAY(+IBX)=""
;
SCH ; -- scheduled admissions (all on event date of inpatient bills)
S IBTYP=5,IBDT=$P(IBD0,U,3),IBBDT=$E(IBDT,1,7)-.00001,IBEDT=$E(IBDT,1,7)+.7
F S IBBDT=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT)) Q:'IBBDT!(IBBDT>IBEDT) D
. S IBTRN=0 F S IBTRN=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN)) Q:'IBTRN D
.. S ARRAY(IBTRN)=IBTYP,ARR2(IBBDT,IBTRN)=IBTRN
;
INPT ; -- inpt admission (matches event date and episode date, does not check patient admission movement or PTF)
S IBTYP=1,IBDT=$P(IBD0,U,3),IBBDT=$E(IBDT,1,7)-.00001,IBEDT=$E(IBDT,1,7)+.7
F S IBBDT=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT)) Q:'IBBDT!(IBBDT>IBEDT) D
. S IBTRN=0 F S IBTRN=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN)) Q:'IBTRN D
.. S IBBILL=$P(^IBT(356,IBTRN,0),U,11) I +IBBILL,IBBILL'=IBIFN Q
.. S ARRAY(IBTRN)=IBTYP,ARR2(IBBDT,IBTRN)=IBTRN
;
OPT ; -- outpatient visits (all CT visits on bills's opt visit dates)
S IBTYP=2,IBDT=0 F S IBDT=$O(^DGCR(399,IBIFN,"OP",IBDT)) Q:'IBDT D
. S IBBDT=$E(IBDT,1,7)-.00001,IBEDT=$E(IBDT,1,7)+.7
. F S IBBDT=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT)) Q:'IBBDT!(IBBDT>IBEDT) D
.. S IBTRN=0 F S IBTRN=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN)) Q:'IBTRN D
... S ARRAY(IBTRN)=IBTYP,ARR2(IBBDT,IBTRN)=IBTRN
;
RX ; -- rx refills (matches rx's (52: (362.4,.05)=(356,.08)) for refill dates on bill)
S IBTYP=4,IBI=0 F S IBI=$O(^IBA(362.4,"C",IBIFN,IBI)) Q:'IBI D
. S IBRX=$G(^IBA(362.4,IBI,0)),IBDT=$P(IBRX,U,3),IBRXN=$P(IBRX,U,5)
. I 'IBRXN S DIC=52,DIC(0)="BO",X=$P(IBRX,"^") D DIC^PSODI(52,.DIC,X) S IBRXN=+Y K DIC,X,Y Q:IBRXN=-1
. S IBBDT=$E(IBDT,1,7)-.00001,IBEDT=$E(IBDT,1,7)+.7
. F S IBBDT=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT)) Q:'IBBDT!(IBBDT>IBEDT) D
.. S IBTRN=0 F S IBTRN=$O(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN)) Q:'IBTRN D
... I $P($G(^IBT(356,IBTRN,0)),U,8)=IBRXN S ARRAY(IBTRN)=IBTYP,ARR2(IBBDT,IBTRN)=IBTRN
;
PRO ; -- prosthetics (does not match delivery dates)
S IBTYP=3,IBX="AIFN"_IBIFN,IBDT=0 F S IBDT=$O(^IBA(362.5,IBX,IBDT)) Q:'IBDT D
. S IBI=0 F S IBI=$O(^IBA(362.5,IBX,IBDT,IBI)) Q:'IBI D
.. S IBPR=$G(^IBA(362.5,IBI,0)),IBPRN=$P(IBPR,U,4) Q:'IBPRN
.. S IBTRN=$O(^IBT(356,"APRO",IBPRN,0))
.. I +IBTRN S ARRAY(IBTRN)=IBTYP,ARR2(IBDT,IBTRN)=IBTRN
;
S IBI=0 F S IBI=$O(ARRAY(IBI)) Q:'IBI S ARRAY=ARRAY+1
IFNQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU83 3143 printed Dec 13, 2024@02:21:01 Page 2
IBCU83 ;ALB/ARH - THIRD PARTY BILLING UTILITES (BILL-CT) ; 3/10/96
+1 ;;2.0;INTEGRATED BILLING;**48,347**;21-MAR-94;Build 24
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
IFNTRN(IBIFN,ARRAY,ARR2) ; find CT records for events on a bill: sched adm, inpt adm, outpt vsts, rx refills, prosthetics
+1 ; sets ARRAY=COUNT, ARRAY(IBTRN)=EV TYPE, if bill passed in defined
+2 ; ARR2(DATE,TRN)=TRN (based on IBCC1 and IBJTU5)
+3 ;
+4 NEW IBI,IBX,IBD0,DFN,IBTYP,IBTRN,IBDT,IBBDT,IBEDT,IBRX,IBRXN,IBPR,IBPRN,IBBILL,IBN
KILL ARRAY,ARR2
+5 SET ARRAY=0
SET IBD0=$GET(^DGCR(399,+$GET(IBIFN),0))
IF IBD0=""
GOTO IFNQ
+6 SET DFN=$PIECE(IBD0,U,2)
+7 ;
+8 ; -- directly linked through 356.399 (not always correct)
+9 ;S IBI=0 F S IBI=$O(^IBT(356.399,"C",IBIFN,IBI)) Q:'IBI S IBX=+$G(^IBT(356.399,IBI,0)) I +IBX S ARRAY(+IBX)=""
+10 ;
SCH ; -- scheduled admissions (all on event date of inpatient bills)
+1 SET IBTYP=5
SET IBDT=$PIECE(IBD0,U,3)
SET IBBDT=$EXTRACT(IBDT,1,7)-.00001
SET IBEDT=$EXTRACT(IBDT,1,7)+.7
+2 FOR
SET IBBDT=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT))
if 'IBBDT!(IBBDT>IBEDT)
QUIT
Begin DoDot:1
+3 SET IBTRN=0
FOR
SET IBTRN=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN))
if 'IBTRN
QUIT
Begin DoDot:2
+4 SET ARRAY(IBTRN)=IBTYP
SET ARR2(IBBDT,IBTRN)=IBTRN
End DoDot:2
End DoDot:1
+5 ;
INPT ; -- inpt admission (matches event date and episode date, does not check patient admission movement or PTF)
+1 SET IBTYP=1
SET IBDT=$PIECE(IBD0,U,3)
SET IBBDT=$EXTRACT(IBDT,1,7)-.00001
SET IBEDT=$EXTRACT(IBDT,1,7)+.7
+2 FOR
SET IBBDT=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT))
if 'IBBDT!(IBBDT>IBEDT)
QUIT
Begin DoDot:1
+3 SET IBTRN=0
FOR
SET IBTRN=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN))
if 'IBTRN
QUIT
Begin DoDot:2
+4 SET IBBILL=$PIECE(^IBT(356,IBTRN,0),U,11)
IF +IBBILL
IF IBBILL'=IBIFN
QUIT
+5 SET ARRAY(IBTRN)=IBTYP
SET ARR2(IBBDT,IBTRN)=IBTRN
End DoDot:2
End DoDot:1
+6 ;
OPT ; -- outpatient visits (all CT visits on bills's opt visit dates)
+1 SET IBTYP=2
SET IBDT=0
FOR
SET IBDT=$ORDER(^DGCR(399,IBIFN,"OP",IBDT))
if 'IBDT
QUIT
Begin DoDot:1
+2 SET IBBDT=$EXTRACT(IBDT,1,7)-.00001
SET IBEDT=$EXTRACT(IBDT,1,7)+.7
+3 FOR
SET IBBDT=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT))
if 'IBBDT!(IBBDT>IBEDT)
QUIT
Begin DoDot:2
+4 SET IBTRN=0
FOR
SET IBTRN=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN))
if 'IBTRN
QUIT
Begin DoDot:3
+5 SET ARRAY(IBTRN)=IBTYP
SET ARR2(IBBDT,IBTRN)=IBTRN
End DoDot:3
End DoDot:2
End DoDot:1
+6 ;
RX ; -- rx refills (matches rx's (52: (362.4,.05)=(356,.08)) for refill dates on bill)
+1 SET IBTYP=4
SET IBI=0
FOR
SET IBI=$ORDER(^IBA(362.4,"C",IBIFN,IBI))
if 'IBI
QUIT
Begin DoDot:1
+2 SET IBRX=$GET(^IBA(362.4,IBI,0))
SET IBDT=$PIECE(IBRX,U,3)
SET IBRXN=$PIECE(IBRX,U,5)
+3 IF 'IBRXN
SET DIC=52
SET DIC(0)="BO"
SET X=$PIECE(IBRX,"^")
DO DIC^PSODI(52,.DIC,X)
SET IBRXN=+Y
KILL DIC,X,Y
if IBRXN=-1
QUIT
+4 SET IBBDT=$EXTRACT(IBDT,1,7)-.00001
SET IBEDT=$EXTRACT(IBDT,1,7)+.7
+5 FOR
SET IBBDT=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT))
if 'IBBDT!(IBBDT>IBEDT)
QUIT
Begin DoDot:2
+6 SET IBTRN=0
FOR
SET IBTRN=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN))
if 'IBTRN
QUIT
Begin DoDot:3
+7 IF $PIECE($GET(^IBT(356,IBTRN,0)),U,8)=IBRXN
SET ARRAY(IBTRN)=IBTYP
SET ARR2(IBBDT,IBTRN)=IBTRN
End DoDot:3
End DoDot:2
End DoDot:1
+8 ;
PRO ; -- prosthetics (does not match delivery dates)
+1 SET IBTYP=3
SET IBX="AIFN"_IBIFN
SET IBDT=0
FOR
SET IBDT=$ORDER(^IBA(362.5,IBX,IBDT))
if 'IBDT
QUIT
Begin DoDot:1
+2 SET IBI=0
FOR
SET IBI=$ORDER(^IBA(362.5,IBX,IBDT,IBI))
if 'IBI
QUIT
Begin DoDot:2
+3 SET IBPR=$GET(^IBA(362.5,IBI,0))
SET IBPRN=$PIECE(IBPR,U,4)
if 'IBPRN
QUIT
+4 SET IBTRN=$ORDER(^IBT(356,"APRO",IBPRN,0))
+5 IF +IBTRN
SET ARRAY(IBTRN)=IBTYP
SET ARR2(IBDT,IBTRN)=IBTRN
End DoDot:2
End DoDot:1
+6 ;
+7 SET IBI=0
FOR
SET IBI=$ORDER(ARRAY(IBI))
if 'IBI
QUIT
SET ARRAY=ARRAY+1
IFNQ QUIT
