Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBAUTL5

IBAUTL5.m

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