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