- 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 Jan 18, 2025@03:23:09 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