IBJTU5 ;ALB/ARH - TPI UTILITIES - BILLS/CLAIMS TRACKING ; 2/14/95
;;Version 2.0 ; INTEGRATED BILLING ;**39**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
IFNTRN(IBIFN,ARRAY,ARR2) ; find CT records for events on a bill: inpt adm, outpt vsts, rx refills, prosthetics
; sets ARRAY=COUNT, ARRAY(IBTRN)="", if bill passed in defined
; ARR2(DATE_TRN)=TRN
;
N IBI,IBX,IBY,IBD0,DFN,IBTYP,IBTRN,IBDT,IBBDT,IBEDT,IBRX,IBRXN,IBPR,IBPRN,IBPM,IBPTF 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)=""
;
; -- scheduled admissions (all on event date of inpatient bills)
S IBTYP=5 I $P(IBD0,U,5)<3 D
. S 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)="",IBY=IBBDT_"_"_IBTRN,ARR2(IBY)=IBTRN
;
; -- inpt admission (CT records on bill event date whose PM matches the bills PTF)
S IBTYP=1 S IBPTF=+$P(IBD0,U,8) I +IBPTF D
. S 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 IBPM=+$P($G(^IBT(356,IBTRN,0)),U,5) I +IBPM,$D(^DGPM("APTF",IBPTF,IBPM)) D
.... S ARRAY(IBTRN)="",IBY=IBBDT_"_"_IBTRN,ARR2(IBY)=IBTRN
;
; -- 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)="",IBY=IBBDT_"_"_IBTRN,ARR2(IBY)=IBTRN
;
; -- 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) Q:'IBRXN
. 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)="",IBY=IBBDT_"_"_IBTRN,ARR2(IBY)=IBTRN
;
; -- prosthetics (matches pd's (660: (362.5,.04)=(356,.09)) for delivery dates on bill)
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 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,9)=IBPRN S ARRAY(IBTRN)="",IBY=IBBDT_"_"_IBTRN,ARR2(IBY)=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[HIBJTU5 3331 printed Oct 16, 2024@18:24:55 Page 2
IBJTU5 ;ALB/ARH - TPI UTILITIES - BILLS/CLAIMS TRACKING ; 2/14/95
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**39**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
IFNTRN(IBIFN,ARRAY,ARR2) ; find CT records for events on a bill: inpt adm, outpt vsts, rx refills, prosthetics
+1 ; sets ARRAY=COUNT, ARRAY(IBTRN)="", if bill passed in defined
+2 ; ARR2(DATE_TRN)=TRN
+3 ;
+4 NEW IBI,IBX,IBY,IBD0,DFN,IBTYP,IBTRN,IBDT,IBBDT,IBEDT,IBRX,IBRXN,IBPR,IBPRN,IBPM,IBPTF
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 ;
+11 ; -- scheduled admissions (all on event date of inpatient bills)
+12 SET IBTYP=5
IF $PIECE(IBD0,U,5)<3
Begin DoDot:1
+13 SET IBDT=$PIECE(IBD0,U,3)
SET IBBDT=$EXTRACT(IBDT,1,7)-.00001
SET IBEDT=$EXTRACT(IBDT,1,7)+.7
+14 FOR
SET IBBDT=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT))
if 'IBBDT!(IBBDT>IBEDT)
QUIT
Begin DoDot:2
+15 SET IBTRN=0
FOR
SET IBTRN=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN))
if 'IBTRN
QUIT
Begin DoDot:3
+16 SET ARRAY(IBTRN)=""
SET IBY=IBBDT_"_"_IBTRN
SET ARR2(IBY)=IBTRN
End DoDot:3
End DoDot:2
End DoDot:1
+17 ;
+18 ; -- inpt admission (CT records on bill event date whose PM matches the bills PTF)
+19 SET IBTYP=1
SET IBPTF=+$PIECE(IBD0,U,8)
IF +IBPTF
Begin DoDot:1
+20 SET IBDT=$PIECE(IBD0,U,3)
SET IBBDT=$EXTRACT(IBDT,1,7)-.00001
SET IBEDT=$EXTRACT(IBDT,1,7)+.7
+21 FOR
SET IBBDT=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT))
if 'IBBDT!(IBBDT>IBEDT)
QUIT
Begin DoDot:2
+22 SET IBTRN=0
FOR
SET IBTRN=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN))
if 'IBTRN
QUIT
Begin DoDot:3
+23 SET IBPM=+$PIECE($GET(^IBT(356,IBTRN,0)),U,5)
IF +IBPM
IF $DATA(^DGPM("APTF",IBPTF,IBPM))
Begin DoDot:4
+24 SET ARRAY(IBTRN)=""
SET IBY=IBBDT_"_"_IBTRN
SET ARR2(IBY)=IBTRN
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 ;
+26 ; -- outpatient visits (all CT visits on bills's opt visit dates)
+27 SET IBTYP=2
SET IBDT=0
FOR
SET IBDT=$ORDER(^DGCR(399,IBIFN,"OP",IBDT))
if 'IBDT
QUIT
Begin DoDot:1
+28 SET IBBDT=$EXTRACT(IBDT,1,7)-.00001
SET IBEDT=$EXTRACT(IBDT,1,7)+.7
+29 FOR
SET IBBDT=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT))
if 'IBBDT!(IBBDT>IBEDT)
QUIT
Begin DoDot:2
+30 SET IBTRN=0
FOR
SET IBTRN=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN))
if 'IBTRN
QUIT
Begin DoDot:3
+31 SET ARRAY(IBTRN)=""
SET IBY=IBBDT_"_"_IBTRN
SET ARR2(IBY)=IBTRN
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;
+33 ; -- rx refills (matches rx's (52: (362.4,.05)=(356,.08)) for refill dates on bill)
+34 SET IBTYP=4
SET IBI=0
FOR
SET IBI=$ORDER(^IBA(362.4,"C",IBIFN,IBI))
if 'IBI
QUIT
Begin DoDot:1
+35 SET IBRX=$GET(^IBA(362.4,IBI,0))
SET IBDT=$PIECE(IBRX,U,3)
SET IBRXN=$PIECE(IBRX,U,5)
if 'IBRXN
QUIT
+36 SET IBBDT=$EXTRACT(IBDT,1,7)-.00001
SET IBEDT=$EXTRACT(IBDT,1,7)+.7
+37 FOR
SET IBBDT=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT))
if 'IBBDT!(IBBDT>IBEDT)
QUIT
Begin DoDot:2
+38 SET IBTRN=0
FOR
SET IBTRN=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN))
if 'IBTRN
QUIT
Begin DoDot:3
+39 IF $PIECE($GET(^IBT(356,IBTRN,0)),U,8)=IBRXN
SET ARRAY(IBTRN)=""
SET IBY=IBBDT_"_"_IBTRN
SET ARR2(IBY)=IBTRN
End DoDot:3
End DoDot:2
End DoDot:1
+40 ;
+41 ; -- prosthetics (matches pd's (660: (362.5,.04)=(356,.09)) for delivery dates on bill)
+42 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
+43 SET IBI=0
FOR
SET IBI=$ORDER(^IBA(362.5,IBX,IBDT,IBI))
if 'IBI
QUIT
Begin DoDot:2
+44 SET IBPR=$GET(^IBA(362.5,IBI,0))
SET IBPRN=$PIECE(IBPR,U,4)
if 'IBPRN
QUIT
+45 SET IBBDT=$EXTRACT(IBDT,1,7)-.00001
SET IBEDT=$EXTRACT(IBDT,1,7)+.7
+46 FOR
SET IBBDT=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT))
if 'IBBDT!(IBBDT>IBEDT)
QUIT
Begin DoDot:3
+47 SET IBTRN=0
FOR
SET IBTRN=$ORDER(^IBT(356,"APTY",DFN,IBTYP,IBBDT,IBTRN))
if 'IBTRN
QUIT
Begin DoDot:4
+48 IF $PIECE($GET(^IBT(356,IBTRN,0)),U,9)=IBPRN
SET ARRAY(IBTRN)=""
SET IBY=IBBDT_"_"_IBTRN
SET ARR2(IBY)=IBTRN
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+49 ;
+50 SET IBI=0
FOR
SET IBI=$ORDER(ARRAY(IBI))
if 'IBI
QUIT
SET ARRAY=ARRAY+1
IFNQ QUIT
