- 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 Mar 13, 2025@21:25:59 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
