- IBAUTL5 ;ALB/CPM - MEANS TEST BILLING UTILITIES (CON'T.) ; 02-JAN-92
- ;;Version 2.0 ; INTEGRATED BILLING ;**15**; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- PASS ; Find unbilled charges for an event and pass to Accounts Receivable.
- ; Input: IBEVDA, IBY Output: IBCHCDA, IBCHPDA are reset to 0.
- N IBNOS,IBACTN
- S IBACTN=0 F S IBACTN=$O(^IB("AF",IBEVDA,IBACTN)) Q:'IBACTN!(IBY<1) I IBACTN'=IBEVDA,$P($G(^IB(IBACTN,0)),"^",5)=1 S IBNOS=IBACTN D FILER
- S (IBCHCDA,IBCHPDA)=0 Q
- ;
- FILER ; Pass charge to Accounts Receivable. Input: IBNOS
- ; - first, get a bill number and build a complete charge..
- N IBATYP,IBNOW D NOW^%DTC S IBNOW=%
- ;S IBTOTL=0,IBATYP=$P($G(^IB(IBNOS,0)),"^",3)
- ;D BILLNO^IBAUTL K IBARTYP I Y<1 S IBY=Y G FILERQ
- ;S DIE="^IB(",DA=IBNOS,DR=".05////2;.11////"_IBIL_";.12////"_IBTRAN
- ;D ^DIE K DIE,DR,DA I $D(Y) S IBY="-1^IB020" G FILERQ
- ;
- ; - doing IVM-related back-billing?
- I $G(IBJOB)=9 S DIE="^IB(",DA=IBNOS,DR=".05////21" D ^DIE K DIE,DA,DR G FILERQ
- ;
- ; - and then pass the charge to A/R.
- S IBSEQNO=1,IBDUZ=DUZ D ^IBR K IBSEQNO,IBDUZ,IBARTYP,IBN
- I Y<1 S IBY=Y,IBWHER=IBWHER+25 G FILERQ
- ;I $G(IBJOB)=1,IBNOS S ^TMP($J,"IBAMTC","I",+$G(DFN),IBNOS)=""
- FILERQ Q
- ;
- LAST ; Find Last Billed date, if one exists, for pts. w/o billable events
- ; Input: DFN, IBADMDT Output: IBBDT (if past event exists)
- N IBD,IBDATE,IBTEMP,J,DA S IBD=IBADMDT\1,J=-9999999,(IBDATE,DA)=0
- F S J=$O(^IB("AFDT",DFN,J)) Q:'J!(-J<IBD) D
- . F S DA=$O(^IB("AFDT",DFN,J,DA)) Q:'DA D
- .. I $P($G(^IB(DA,0)),"^",8)["ADMISSION" S IBTEMP=$P(^(0),"^",18) D
- ... I 'IBDATE S IBDATE=IBTEMP Q
- ... I IBTEMP>IBDATE S IBDATE=IBTEMP
- I IBDATE S X=IBDATE D H^%DTC S IBBDT=%H+1
- Q
- ;
- DIEM() ; Find the earliest date for which the per diem charge may be billed.
- Q $S($P($G(^IBE(350.9,1,0)),"^",12):$P(^(0),"^",12),1:9999999)
- ;
- SECT(FTS) ; Find the billable bedsection.
- ; Input: Facility Treating Specialty (IEN from file #45.7)
- ; Returned: Billable bedsection from file 399.1 (MCCR UTILITY), or
- ; 0 if the specialty does not have a corresp. bedsection
- S FTS=$P($G(^DIC(42.4,+$P($G(^DIC(45.7,+FTS,0)),"^",2),0)),"^",5)
- Q $S(FTS]"":+$O(^DGCR(399.1,"B",FTS,0)),1:0)
- ;
- CONT(DFN) ; Find continuous patient discharge date.
- ; Input: DFN Returned: 0 - not continuous
- ; 9999999 - still continuous, or
- ; actual discharge date from continuous stay
- N X S X=0
- I $O(^IBE(351.1,"B",DFN,0)) S X=$P($G(^IBE(351.1,+$O(^(0)),0)),"^",2) S:'X X=9999999
- Q X
- ;
- STD(DFN) ; Is the patient's A/R Statement date 4 days from now?
- ; Input: DFN Returned: Statement date in 4 days? (1 - yes, 0 - no)
- S X1=DT,X2=4 D C^%DTC
- Q $$PST^PRCAFN(DFN_";DPT(")=+$E(X,6,7)
- ;
- OE(DGPMDA) ; Was the patient admitted for Observation & Examination?
- ; Input: DGPMDA - pointer to 0th node of pt mvt (adm) in file #405
- ; Returned: O&E Admission? (1 - yes, 0 - no)
- N AR,SOA,DGPM0
- S DGPM0=$G(^DGPM(+DGPMDA,0))
- S AR=+$P(DGPM0,"^",12),SOA=+$G(^DGPT(+$P(DGPM0,"^",16),101))
- Q $D(^DIC(43.4,"D",17.45,AR))!($D(^DIC(45.1,"B","1T",SOA)))
- ;
- ASIH(PM) ; Is patient movement an ASIH movement?
- ; Input: PM - 0th node of patient movement in file #405
- ; Returned: ASIH Movement? (1 - yes, 0 - no)
- Q "^13^14^40^41^42^43^44^45^46^47^"[("^"_$P($G(PM),"^",18)_"^")
- ;
- CVA(DFN) ; Is CHAMPVA the patient's Primary Eligibility?
- ; Input: DFN Returned: Prim Elig = CHAMPVA? (1 - yes, 0 - no)
- Q $P($G(^DIC(8,+$G(^DPT(+$G(DFN),.36)),0)),"^",9)=12
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAUTL5 3629 printed Jan 18, 2025@03:09:21 Page 2
- IBAUTL5 ;ALB/CPM - MEANS TEST BILLING UTILITIES (CON'T.) ; 02-JAN-92
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;**15**; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- PASS ; Find unbilled charges for an event and pass to Accounts Receivable.
- +1 ; Input: IBEVDA, IBY Output: IBCHCDA, IBCHPDA are reset to 0.
- +2 NEW IBNOS,IBACTN
- +3 SET IBACTN=0
- FOR
- SET IBACTN=$ORDER(^IB("AF",IBEVDA,IBACTN))
- if 'IBACTN!(IBY<1)
- QUIT
- IF IBACTN'=IBEVDA
- IF $PIECE($GET(^IB(IBACTN,0)),"^",5)=1
- SET IBNOS=IBACTN
- DO FILER
- +4 SET (IBCHCDA,IBCHPDA)=0
- QUIT
- +5 ;
- FILER ; Pass charge to Accounts Receivable. Input: IBNOS
- +1 ; - first, get a bill number and build a complete charge..
- +2 NEW IBATYP,IBNOW
- DO NOW^%DTC
- SET IBNOW=%
- +3 ;S IBTOTL=0,IBATYP=$P($G(^IB(IBNOS,0)),"^",3)
- +4 ;D BILLNO^IBAUTL K IBARTYP I Y<1 S IBY=Y G FILERQ
- +5 ;S DIE="^IB(",DA=IBNOS,DR=".05////2;.11////"_IBIL_";.12////"_IBTRAN
- +6 ;D ^DIE K DIE,DR,DA I $D(Y) S IBY="-1^IB020" G FILERQ
- +7 ;
- +8 ; - doing IVM-related back-billing?
- +9 IF $GET(IBJOB)=9
- SET DIE="^IB("
- SET DA=IBNOS
- SET DR=".05////21"
- DO ^DIE
- KILL DIE,DA,DR
- GOTO FILERQ
- +10 ;
- +11 ; - and then pass the charge to A/R.
- +12 SET IBSEQNO=1
- SET IBDUZ=DUZ
- DO ^IBR
- KILL IBSEQNO,IBDUZ,IBARTYP,IBN
- +13 IF Y<1
- SET IBY=Y
- SET IBWHER=IBWHER+25
- GOTO FILERQ
- +14 ;I $G(IBJOB)=1,IBNOS S ^TMP($J,"IBAMTC","I",+$G(DFN),IBNOS)=""
- FILERQ QUIT
- +1 ;
- LAST ; Find Last Billed date, if one exists, for pts. w/o billable events
- +1 ; Input: DFN, IBADMDT Output: IBBDT (if past event exists)
- +2 NEW IBD,IBDATE,IBTEMP,J,DA
- SET IBD=IBADMDT\1
- SET J=-9999999
- SET (IBDATE,DA)=0
- +3 FOR
- SET J=$ORDER(^IB("AFDT",DFN,J))
- if 'J!(-J<IBD)
- QUIT
- Begin DoDot:1
- +4 FOR
- SET DA=$ORDER(^IB("AFDT",DFN,J,DA))
- if 'DA
- QUIT
- Begin DoDot:2
- +5 IF $PIECE($GET(^IB(DA,0)),"^",8)["ADMISSION"
- SET IBTEMP=$PIECE(^(0),"^",18)
- Begin DoDot:3
- +6 IF 'IBDATE
- SET IBDATE=IBTEMP
- QUIT
- +7 IF IBTEMP>IBDATE
- SET IBDATE=IBTEMP
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +8 IF IBDATE
- SET X=IBDATE
- DO H^%DTC
- SET IBBDT=%H+1
- +9 QUIT
- +10 ;
- DIEM() ; Find the earliest date for which the per diem charge may be billed.
- +1 QUIT $SELECT($PIECE($GET(^IBE(350.9,1,0)),"^",12):$PIECE(^(0),"^",12),1:9999999)
- +2 ;
- SECT(FTS) ; Find the billable bedsection.
- +1 ; Input: Facility Treating Specialty (IEN from file #45.7)
- +2 ; Returned: Billable bedsection from file 399.1 (MCCR UTILITY), or
- +3 ; 0 if the specialty does not have a corresp. bedsection
- +4 SET FTS=$PIECE($GET(^DIC(42.4,+$PIECE($GET(^DIC(45.7,+FTS,0)),"^",2),0)),"^",5)
- +5 QUIT $SELECT(FTS]"":+$ORDER(^DGCR(399.1,"B",FTS,0)),1:0)
- +6 ;
- CONT(DFN) ; Find continuous patient discharge date.
- +1 ; Input: DFN Returned: 0 - not continuous
- +2 ; 9999999 - still continuous, or
- +3 ; actual discharge date from continuous stay
- +4 NEW X
- SET X=0
- +5 IF $ORDER(^IBE(351.1,"B",DFN,0))
- SET X=$PIECE($GET(^IBE(351.1,+$ORDER(^(0)),0)),"^",2)
- if 'X
- SET X=9999999
- +6 QUIT X
- +7 ;
- STD(DFN) ; Is the patient's A/R Statement date 4 days from now?
- +1 ; Input: DFN Returned: Statement date in 4 days? (1 - yes, 0 - no)
- +2 SET X1=DT
- SET X2=4
- DO C^%DTC
- +3 QUIT $$PST^PRCAFN(DFN_";DPT(")=+$EXTRACT(X,6,7)
- +4 ;
- OE(DGPMDA) ; Was the patient admitted for Observation & Examination?
- +1 ; Input: DGPMDA - pointer to 0th node of pt mvt (adm) in file #405
- +2 ; Returned: O&E Admission? (1 - yes, 0 - no)
- +3 NEW AR,SOA,DGPM0
- +4 SET DGPM0=$GET(^DGPM(+DGPMDA,0))
- +5 SET AR=+$PIECE(DGPM0,"^",12)
- SET SOA=+$GET(^DGPT(+$PIECE(DGPM0,"^",16),101))
- +6 QUIT $DATA(^DIC(43.4,"D",17.45,AR))!($DATA(^DIC(45.1,"B","1T",SOA)))
- +7 ;
- ASIH(PM) ; Is patient movement an ASIH movement?
- +1 ; Input: PM - 0th node of patient movement in file #405
- +2 ; Returned: ASIH Movement? (1 - yes, 0 - no)
- +3 QUIT "^13^14^40^41^42^43^44^45^46^47^"[("^"_$PIECE($GET(PM),"^",18)_"^")
- +4 ;
- CVA(DFN) ; Is CHAMPVA the patient's Primary Eligibility?
- +1 ; Input: DFN Returned: Prim Elig = CHAMPVA? (1 - yes, 0 - no)
- +2 QUIT $PIECE($GET(^DIC(8,+$GET(^DPT(+$GET(DFN),.36)),0)),"^",9)=12