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

IBEFUNC1.m

Go to the documentation of this file.
  1. IBEFUNC1 ;ALB/ARH - CPT BILLING EXTRINSIC FUNCTIONS ; 11/27/91
  1. ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ;created front-ends for extrinsic functions for use until all versions of file man can use them
  1. FCC ;
  1. S IBCHGX=$$CPTCHG($S('$D(IBCDX):"",1:IBCDX),$S('$D(IBDIVX):"",1:IBDIVX),$S('$D(IBDTX):"",1:IBDTX))
  1. Q
  1. ;
  1. CPTCHG(CODE,DIV,DATE) ;ambulatory procedure billing charge on a date
  1. ;assumes current date if none passed in (to disallow guessing on division pass in +DIV)
  1. ;assumes first active division if (DIV=""!'$D(DIV)) passed in
  1. ;returns - the charge if code is valid and active in Billing on DATE
  1. ; - "" if unable to calc charge or there was none
  1. ; division or rate group inactive on date or not defined in file
  1. N X,%,%H,%I,Y
  1. S Y=-1 G:'$D(CODE) ENDCHG
  1. S:'$D(DATE) DATE=DT S DATE=$E(DATE,1,7) I DATE'?7N S DATE=DT
  1. S:'$D(DIV) DIV="" I DIV="" S DIV=$$MCDIV(DIV,DATE)
  1. I +$$CPTBSTAT(CODE,DATE) S X=DATE_"^"_DIV_"^"_+CODE D RATE^IBAUTL1
  1. ENDCHG Q $S(Y<0:"",1:Y)
  1. ;
  1. FCBS ;
  1. S IBSTX=$$CPTBSTAT($S('$D(IBCDX):"",1:IBCDX),$S('$D(IBDTX):"",1:IBDTX))
  1. Q
  1. ;
  1. CPTBSTAT(CODE,DATE) ;ambulatory procedure billing status on a date
  1. ;assumes current date if none passed in
  1. ;returns - "" if CODE had never been a billing code on/before DATE given or DATE before BASC start date
  1. ; - 0^INACTIVE if CODE billing inactive on DATE given or rate group inactive on DATE
  1. ; - 1^ACTIVE if CODE billing active on DATE given
  1. N LN,ST,%,%H,%I,X
  1. S ST="" I '$D(CODE) G ENDST
  1. S:'$D(DATE) DATE=DT S DATE=$E(DATE,1,7) I DATE'?7N S DATE=DT
  1. I $$STDATE^IBCU63>DATE G ENDST
  1. I $D(^IBE(350.4,+$O(^(+$O(^IBE(350.4,"AIVDT",+CODE,-(DATE+1))),0)),0)) S LN=^(0),ST=+$P(LN,"^",4)
  1. I ST,$P($G(^IBE(350.2,+$P(LN,"^",3),0)),"^",2)>DATE S ST=""
  1. S ST=ST_$S(ST'="":"^"_$P($P($P(^DD(350.4,.04,0),"^",3),ST_":",2),";",1),1:"")
  1. ENDST Q ST
  1. ;
  1. FCR ;
  1. S IBRGX=$$CPTRG($S('$D(IBCDX):"",1:IBCDX),$S('$D(IBDTX):"",1:IBDTX))
  1. Q
  1. ;
  1. CPTRG(CPT,DATE) ;find the rate group for the CPT on the given date
  1. ;assumes current date if none passed in
  1. ;returns - a rate group name
  1. ; - "" if no rate group listed for date, or CPT or DATE is ""
  1. N RATE,%,%H,%I,X
  1. G:'$D(CPT) ENDRG
  1. S:'$D(DATE) DATE=DT S DATE=$E(DATE,1,7) I DATE'?7N S DATE=DT
  1. I $D(^IBE(350.4,+$O(^(+$O(^IBE(350.4,"AIVDT",+CPT,-(DATE+1))),0)),0)) S RATE=$P($P($G(^IBE(350.1,+$P(^(0),"^",3),0)),"^",1)," ",2,999)
  1. ENDRG Q $S($D(RATE):RATE,1:"")
  1. ;
  1. FMCD ;
  1. S IBDIVX=$$MCDIV($S('$D(IBDIVX):"",1:IBDIVX),$S('$D(IBDTX):"",1:IBDTX))
  1. Q
  1. ;
  1. MCDIV(DIV,DATE) ;find the medical center division
  1. ; if DATE is not defined then assumes current date
  1. ;returns - DIV passed in, if its status is active for date given
  1. ; - first active division found, if DIV was inactive or ""
  1. ; - if all divisions are inactive for the given date, returns ""
  1. N I,NDIV,INACT,%,%H,%I,X S DIV=$G(DIV)
  1. ;I '$D(DIV) S DIV="" G ENDIV
  1. S:'$D(DATE) DATE=DT S DATE=$E(DATE,1,7) I DATE'?7N S DATE=DT
  1. S NDIV=+$O(^(+$O(^IBE(350.5,"AIVDT",+DIV,-(DATE+1))),0))
  1. I '$P($G(^IBE(350.5,NDIV,0)),"^",4) S DIV="" F I=1:1 S DIV=$O(^IBE(350.5,"AIVDT",DIV)) Q:DIV=""!('$D(INACT(+DIV))&($P($G(^IBE(350.5,+$O(^(+$O(^IBE(350.5,"AIVDT",+DIV,-(DATE+1))),0)),0)),"^",4))) S INACT(DIV)=""
  1. ENDIV Q DIV
  1. ;
  1. RC(D0,D1,DATE) ;find BASC charge for particular revenue code entry (399,42)
  1. ;input: D0 = bill ifn, D1 = revenue code sub-file IFN
  1. ; if DATE not passed then assums STATEMENT FROM date of bill
  1. ;returns: dollar amount if rev code has an active BASC CPT, otherwise ""
  1. N X,Y,DA S X="",DATE=$P($G(DATE),".") I DATE'?7N S DATE=+$G(^DGCR(399,D0,"U"))
  1. S Y=$G(^DGCR(399,D0,"RC",D1,0)) I +$P(Y,U,6),+$P(Y,U,7) S X=+$$CPTCHG^IBEFUNC1(+$P(Y,U,6),+$P(Y,U,7),DATE)
  1. Q X
  1. ;
  1. CP(D0,D1) ;find BASC charge for particular procedure entry (399,304)
  1. ;input: D0 = bill IFN, D1 = procedure code sub-file IFN
  1. ;returns: dollar amount if CPT is BASC active, otherwise ""
  1. N X,Y,DA S X="",Y=$G(^DGCR(399,D0,"CP",D1,0)) I $P(Y,U,1)[";ICPT(",+$P(Y,U,2),+$P(Y,U,6) S X=$$CPTCHG^IBEFUNC1(+Y,+$P(Y,U,6),+$P(Y,U,2))
  1. Q X