IBCRHBS7 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS SITE ; 10-OCT-03
;;2.0;INTEGRATED BILLING;**245,427**;21-MAR-94;Build 7
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
A(SITE,IBXRF1) ; use Inpatient Facility National Rates to calculate Site Specific Rates
N IBXTMPC,IBI,IBLINE,IBDRG,IBEFF,IBINA,IBCT,IBCHRG
;
I $P(SITE,U,5)'=1 Q
;
S IBXTMPC="IBCR RC A"
;
S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D I '(IBI#100) W "."
. S IBLINE=$G(^XTMP(IBXTMPC,IBI)) Q:IBLINE=""
. ;
. S IBDRG="DRG"_+$P(IBLINE,U,1),IBEFF=$P(IBLINE,U,9),IBINA=$P(IBLINE,U,10),IBCT=$P(IBLINE,U,2)
. ;
. ;
. I IBCT="SNF" D Q
.. S IBCHRG=$$ISNF^IBCRHBS8(SITE,IBLINE)
.. D SET(IBXRF1,"SNF PD INC","SKILLED NURSING CARE",IBEFF,IBINA,IBCHRG,"")
.. D SET(IBXRF1,"SNF PD INC","SUB-ACUTE CARE",IBEFF,IBINA,IBCHRG,"")
. ;
. I IBCT="DRG" D Q
.. S IBCHRG=$$ISR^IBCRHBS8(SITE,IBLINE) D SET(IBXRF1,"Inpt PD R&B",IBDRG,IBEFF,IBINA,IBCHRG,"")
.. S IBCHRG=$$ISA^IBCRHBS8(SITE,IBLINE) D SET(IBXRF1,"Inpt PD Anc",IBDRG,IBEFF,IBINA,IBCHRG,"")
.. S IBCHRG=$$IIR^IBCRHBS8(SITE,IBLINE) D SET(IBXRF1,"Inpt PD R&B ICU",IBDRG,IBEFF,IBINA,IBCHRG,"")
.. S IBCHRG=$$IIA^IBCRHBS8(SITE,IBLINE) D SET(IBXRF1,"Inpt PD Anc ICU",IBDRG,IBEFF,IBINA,IBCHRG,"")
Q
;
;
B(SITE,IBXRF1) ; use Outpatient Facility National Rates to calculate Site Specific Rates
N IBXTMPC,TYPE,IBI,IBLINE,IBCPT,IBEFF,IBINA,IBCHRG,IBUT,IBFAC
;
S TYPE=$P(SITE,U,5) Q:'TYPE
;
S IBXTMPC="IBCR RC B"
;
S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D I '(IBI#100) W "."
. S IBLINE=$G(^XTMP(IBXTMPC,IBI)) Q:IBLINE=""
. ;
. S IBCPT=$P(IBLINE,U,1),IBEFF=$P(IBLINE,U,13),IBINA=$P(IBLINE,U,14),IBUT=$P(IBLINE,U,10)
. ;
. S IBCHRG=$$FAC^IBCRHBS8(SITE,IBLINE)
. ;
. ;
. I $P(IBLINE,U,2)="PHOSP" D Q ; Partial Hospitalization
.. I TYPE<3 D SET(IBXRF1,"Opt PD PHosp","PARTIAL HOSPITALIZATION",IBEFF,IBINA,IBCHRG,"")
. ;
. I TYPE=1 D ; Inpatient/SNF Facility
.. I $P(IBLINE,U,11) D SET(IBXRF1,"Inpt Fac "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"")
.. I $P(IBLINE,U,12) D SET(IBXRF1,"SNF Fac "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"")
. ;
. I TYPE<3 D ; Outpatient Facility Charges
.. D SET(IBXRF1,"Opt Fac "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"")
. ;
. I TYPE=3 D ; move facility charge to physician for Freestanding if there is no global or TC
.. S IBFAC=$$INPHYS(IBCPT,IBUT) I IBFAC<0 Q
.. I IBFAC=26 D SET(IBXRF1,"FS Phys/Opt TC "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"TC")
.. I IBFAC="" D SET(IBXRF1,"FS Phys/Opt "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"")
;
Q
;
C(SITE,IBXRF1) ; use Physician National Rates to calculate Site Specific Rates
N IBXTMPC,TYPE,IBI,IBLINE,IBCPT,IBEFF,IBINA,IBUT,IBMOD,IBXRF2A,IBCHRG
;
S TYPE=$P(SITE,U,5) Q:'TYPE
;
S IBXTMPC="IBCR RC C"
;
S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D W:'(IBI#100) "."
. S IBLINE=$G(^XTMP(IBXTMPC,IBI)) Q:IBLINE=""
. ;
. S IBCPT=$P(IBLINE,U,1),IBEFF=$P(IBLINE,U,22),IBINA=$P(IBLINE,U,23),IBUT=$P(IBLINE,U,16),IBMOD=$P(IBLINE,U,4)
. ;
. S IBCHRG=$$PROF^IBCRHBS8(SITE,IBLINE)
. ;
. ;
. I TYPE=3 D Q ; Freestanding Professional Charge
.. I +$P(IBLINE,U,21) D SET(IBXRF1,"FS Phys "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,IBMOD)
. ;
. S IBXRF2A="Phys "
. I +$P(IBLINE,U,17) S IBXRF2A="Fac/Phys ",IBMOD=$S(IBMOD="TC":"",1:IBMOD) I +$$INFAC(IBCPT) Q ; facility
. ;
. I TYPE=1 D
.. I +$P(IBLINE,U,19) D SET(IBXRF1,"Inpt "_IBXRF2A_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,IBMOD)
.. I +$P(IBLINE,U,20) D SET(IBXRF1,"SNF "_IBXRF2A_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,IBMOD)
. ;
. I TYPE<3 D
.. I +$P(IBLINE,U,18) D SET(IBXRF1,"Opt "_IBXRF2A_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,IBMOD)
;
Q
;
FA(SITE,IBXRF1) ; Add TC and 26 Freestanding Professional charges to create global charge
N IBTMPX,IBCPT,IBK,IBXRF2,IB26,IB26UT,IBTC,IBTCUT,IBUT,IBITEM,IBEFF,IBINA,IBMOD,IBCHRG,IBCHRGB
;
S IBTMPX="IBCR UPLOAD FS PROF"
;
I $P(SITE,U,5)'=3 Q
;
S IBCPT="" F S IBCPT=$O(^TMP($J,IBTMPX,IBCPT)) Q:IBCPT="" D
. I $O(^TMP($J,IBTMPX,IBCPT,"00",0)) Q
. S IBK=$O(^TMP($J,IBTMPX,IBCPT,"26",0)) Q:'IBK
. S IBXRF2=^TMP($J,IBTMPX,IBCPT,"26",IBK),IB26=^XTMP(IBXRF1,IBXRF2,+IBK) Q:IB26="" S IB26UT=$$UNITYPE(IBXRF2)
. S IBK=$O(^TMP($J,IBTMPX,IBCPT,"TC",0)) Q:'IBK
. S IBXRF2=^TMP($J,IBTMPX,IBCPT,"TC",IBK),IBTC=^XTMP(IBXRF1,IBXRF2,+IBK) Q:IBTC="" S IBTCUT=$$UNITYPE(IBXRF2)
. ;
. S IBUT=IB26UT I IB26UT'=IBTCUT W !,"ERROR, UNIT TYPES DON'T MATCH ",IBCPT Q
. ;
. S IBITEM=$P(IB26,U,1),IBEFF="20"_$E($P(IB26,U,2),2,7),IBINA="20"_$E($P(IB26,U,3),2,7),IBMOD=""
. ;
. S IBCHRG=$P(IB26,U,4)+$P(IBTC,U,4) Q:'IBCHRG S IBCHRG=$J(IBCHRG,0,2)
. S IBCHRGB=$P(IB26,U,6)+$P(IBTC,U,6) I +IBCHRGB S IBCHRG=IBCHRG_U_$J(IBCHGB,0,2)
. ;
. D SET(IBXRF1,"FS Phys/Add 00 "_IBUT,IBITEM,IBEFF,IBINA,IBCHRG,IBMOD)
;
K ^TMP($J,IBTMPX)
Q
;
;
;
SET(IBXRF1,IBXRF2,ITEM,EFFDT,INACTDT,CHRG,MOD) ; set calculated charges into XTMP
;
N IBX,IBK,IBY,IBINACT,IBMODI S IBMODI=""
S IBX=$G(^XTMP(IBXRF1,0))
;
I IBX="" W !!,"ERROR: IBXRF1 NOT SET ",IBXRF1,!! Q
I '$D(^XTMP(IBXRF1,IBXRF2)) W !!,"ERROR: IBXRF2 NOT SET ",IBXRF2,!! Q
;
S IBK=+$P(IBX,U,4)+1,$P(^XTMP(IBXRF1,0),U,4)=IBK
S $P(^XTMP(IBXRF1,IBXRF2),U,1)=(+$G(^XTMP(IBXRF1,IBXRF2))+1)
;
I $G(MOD)'="" S IBY=$$MODIFN(MOD,EFFDT) I +IBY>0 S IBMODI=+IBY
;
S ^XTMP(IBXRF1,IBXRF2,IBK)=ITEM_U_$$DATE(EFFDT)_U_$$ENDDT(INACTDT)_U_+CHRG_U_IBMODI_U_$P(CHRG,U,2)
;
I $E(IBXRF2,1,7)="FS Phys" S MOD=$S(MOD="":"00",1:MOD),^TMP($J,"IBCR UPLOAD FS PROF",ITEM,MOD,IBK)=IBXRF2
Q
;
;
DATE(X) ; return yyyymmdd in FM format
N Y S Y="" I $G(X)?8N S Y=$S($E(X,1,4)>1999:3,1:2)_$E(X,3,4)_$E(X,5,8)
Q Y
;
ENDDT(X) ; return yyyymmdd date in FM format, check version inactive date
N Y,V S Y=$$DATE($G(X)) I 'Y S V=$G(^XTMP("IBCR RC SITE","VERSION INACTIVE")) I +V S Y=V
Q Y
;
MODIFN(MOD,EFFDT) ; return internal form of modifier
; extra check is required because there are two RR modifiers so MOD will not return any
; base the get on a CPT code for which RR is known to be a valid modifier
N IBY,IBX S (IBX,IBY)="" S EFFDT=$$DATE($G(EFFDT)) I 'EFFDT S EFFDT=DT
I $G(MOD)'="" S IBY=$$MOD^ICPTMOD(MOD,"E",EFFDT)
I IBY<0,$G(MOD)="RR" S IBY=$$MODP^ICPTMOD("K0455","RR","E",EFFDT)
I IBY<0,$G(MOD)="KF" S IBY=$$MODP^ICPTMOD("E0785","KF","E",EFFDT)
I IBY>0 S IBX=+IBY
Q IBX
;
;
INPHYS(IBCPT,UNITYPE) ; returns string of all modifiers associated with Physician charges for CPT and Unit Type
; if charge exists but it has no modifier then uses 00, so if CPT has no charge then returns null
; if a charge is found for the CPT but it has a different Unit Type then -1 is returned
; note: if no freestanding physician charge then can add opt facility charge as physician charge
; note: if only a freestanding 26 physician charge then can add the opt facility charge as TC physician charge (same unit type)
;
N MOD,MODS,IBX,IBY S MODS=""
;
S IBX="" F S IBX=$O(^XTMP("IBCR RC C","A",IBCPT,IBX)) Q:IBX="" D
. S IBY=^XTMP("IBCR RC C",IBX) I $P(IBY,U,16)'=UNITYPE S MODS=-1 Q
. S MOD=$P(IBY,U,4) I MOD="" S MOD="00"
. S MODS=MODS_MOD
Q MODS
;
INFAC(IBCPT) ; check if the CPT code has a charge in the Opt Facility file (table B)
; return true if CPT code has a Opt Facility Charge
N IBX S IBX=0 I $O(^XTMP("IBCR RC B","A",IBCPT,"")) S IBX=1
Q IBX
;
UNITYPE(IBXRF2) ; return unit type of group of charges last piece of IBXRF2
N IBX,IBY,IBZ S IBX=""
S IBY=$L(IBXRF2),IBZ=$E(IBXRF2,IBY) I IBZ>0,IBZ<5 S IBX=IBZ
Q IBX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBS7 7554 printed Oct 16, 2024@18:20:09 Page 2
IBCRHBS7 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS SITE ; 10-OCT-03
+1 ;;2.0;INTEGRATED BILLING;**245,427**;21-MAR-94;Build 7
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
A(SITE,IBXRF1) ; use Inpatient Facility National Rates to calculate Site Specific Rates
+1 NEW IBXTMPC,IBI,IBLINE,IBDRG,IBEFF,IBINA,IBCT,IBCHRG
+2 ;
+3 IF $PIECE(SITE,U,5)'=1
QUIT
+4 ;
+5 SET IBXTMPC="IBCR RC A"
+6 ;
+7 SET IBI=0
FOR
SET IBI=$ORDER(^XTMP(IBXTMPC,IBI))
if 'IBI
QUIT
Begin DoDot:1
+8 SET IBLINE=$GET(^XTMP(IBXTMPC,IBI))
if IBLINE=""
QUIT
+9 ;
+10 SET IBDRG="DRG"_+$PIECE(IBLINE,U,1)
SET IBEFF=$PIECE(IBLINE,U,9)
SET IBINA=$PIECE(IBLINE,U,10)
SET IBCT=$PIECE(IBLINE,U,2)
+11 ;
+12 ;
+13 IF IBCT="SNF"
Begin DoDot:2
+14 SET IBCHRG=$$ISNF^IBCRHBS8(SITE,IBLINE)
+15 DO SET(IBXRF1,"SNF PD INC","SKILLED NURSING CARE",IBEFF,IBINA,IBCHRG,"")
+16 DO SET(IBXRF1,"SNF PD INC","SUB-ACUTE CARE",IBEFF,IBINA,IBCHRG,"")
End DoDot:2
QUIT
+17 ;
+18 IF IBCT="DRG"
Begin DoDot:2
+19 SET IBCHRG=$$ISR^IBCRHBS8(SITE,IBLINE)
DO SET(IBXRF1,"Inpt PD R&B",IBDRG,IBEFF,IBINA,IBCHRG,"")
+20 SET IBCHRG=$$ISA^IBCRHBS8(SITE,IBLINE)
DO SET(IBXRF1,"Inpt PD Anc",IBDRG,IBEFF,IBINA,IBCHRG,"")
+21 SET IBCHRG=$$IIR^IBCRHBS8(SITE,IBLINE)
DO SET(IBXRF1,"Inpt PD R&B ICU",IBDRG,IBEFF,IBINA,IBCHRG,"")
+22 SET IBCHRG=$$IIA^IBCRHBS8(SITE,IBLINE)
DO SET(IBXRF1,"Inpt PD Anc ICU",IBDRG,IBEFF,IBINA,IBCHRG,"")
End DoDot:2
QUIT
End DoDot:1
IF '(IBI#100)
WRITE "."
+23 QUIT
+24 ;
+25 ;
B(SITE,IBXRF1) ; use Outpatient Facility National Rates to calculate Site Specific Rates
+1 NEW IBXTMPC,TYPE,IBI,IBLINE,IBCPT,IBEFF,IBINA,IBCHRG,IBUT,IBFAC
+2 ;
+3 SET TYPE=$PIECE(SITE,U,5)
if 'TYPE
QUIT
+4 ;
+5 SET IBXTMPC="IBCR RC B"
+6 ;
+7 SET IBI=0
FOR
SET IBI=$ORDER(^XTMP(IBXTMPC,IBI))
if 'IBI
QUIT
Begin DoDot:1
+8 SET IBLINE=$GET(^XTMP(IBXTMPC,IBI))
if IBLINE=""
QUIT
+9 ;
+10 SET IBCPT=$PIECE(IBLINE,U,1)
SET IBEFF=$PIECE(IBLINE,U,13)
SET IBINA=$PIECE(IBLINE,U,14)
SET IBUT=$PIECE(IBLINE,U,10)
+11 ;
+12 SET IBCHRG=$$FAC^IBCRHBS8(SITE,IBLINE)
+13 ;
+14 ;
+15 ; Partial Hospitalization
IF $PIECE(IBLINE,U,2)="PHOSP"
Begin DoDot:2
+16 IF TYPE<3
DO SET(IBXRF1,"Opt PD PHosp","PARTIAL HOSPITALIZATION",IBEFF,IBINA,IBCHRG,"")
End DoDot:2
QUIT
+17 ;
+18 ; Inpatient/SNF Facility
IF TYPE=1
Begin DoDot:2
+19 IF $PIECE(IBLINE,U,11)
DO SET(IBXRF1,"Inpt Fac "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"")
+20 IF $PIECE(IBLINE,U,12)
DO SET(IBXRF1,"SNF Fac "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"")
End DoDot:2
+21 ;
+22 ; Outpatient Facility Charges
IF TYPE<3
Begin DoDot:2
+23 DO SET(IBXRF1,"Opt Fac "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"")
End DoDot:2
+24 ;
+25 ; move facility charge to physician for Freestanding if there is no global or TC
IF TYPE=3
Begin DoDot:2
+26 SET IBFAC=$$INPHYS(IBCPT,IBUT)
IF IBFAC<0
QUIT
+27 IF IBFAC=26
DO SET(IBXRF1,"FS Phys/Opt TC "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"TC")
+28 IF IBFAC=""
DO SET(IBXRF1,"FS Phys/Opt "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"")
End DoDot:2
End DoDot:1
IF '(IBI#100)
WRITE "."
+29 ;
+30 QUIT
+31 ;
C(SITE,IBXRF1) ; use Physician National Rates to calculate Site Specific Rates
+1 NEW IBXTMPC,TYPE,IBI,IBLINE,IBCPT,IBEFF,IBINA,IBUT,IBMOD,IBXRF2A,IBCHRG
+2 ;
+3 SET TYPE=$PIECE(SITE,U,5)
if 'TYPE
QUIT
+4 ;
+5 SET IBXTMPC="IBCR RC C"
+6 ;
+7 SET IBI=0
FOR
SET IBI=$ORDER(^XTMP(IBXTMPC,IBI))
if 'IBI
QUIT
Begin DoDot:1
+8 SET IBLINE=$GET(^XTMP(IBXTMPC,IBI))
if IBLINE=""
QUIT
+9 ;
+10 SET IBCPT=$PIECE(IBLINE,U,1)
SET IBEFF=$PIECE(IBLINE,U,22)
SET IBINA=$PIECE(IBLINE,U,23)
SET IBUT=$PIECE(IBLINE,U,16)
SET IBMOD=$PIECE(IBLINE,U,4)
+11 ;
+12 SET IBCHRG=$$PROF^IBCRHBS8(SITE,IBLINE)
+13 ;
+14 ;
+15 ; Freestanding Professional Charge
IF TYPE=3
Begin DoDot:2
+16 IF +$PIECE(IBLINE,U,21)
DO SET(IBXRF1,"FS Phys "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,IBMOD)
End DoDot:2
QUIT
+17 ;
+18 SET IBXRF2A="Phys "
+19 ; facility
IF +$PIECE(IBLINE,U,17)
SET IBXRF2A="Fac/Phys "
SET IBMOD=$SELECT(IBMOD="TC":"",1:IBMOD)
IF +$$INFAC(IBCPT)
QUIT
+20 ;
+21 IF TYPE=1
Begin DoDot:2
+22 IF +$PIECE(IBLINE,U,19)
DO SET(IBXRF1,"Inpt "_IBXRF2A_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,IBMOD)
+23 IF +$PIECE(IBLINE,U,20)
DO SET(IBXRF1,"SNF "_IBXRF2A_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,IBMOD)
End DoDot:2
+24 ;
+25 IF TYPE<3
Begin DoDot:2
+26 IF +$PIECE(IBLINE,U,18)
DO SET(IBXRF1,"Opt "_IBXRF2A_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,IBMOD)
End DoDot:2
End DoDot:1
if '(IBI#100)
WRITE "."
+27 ;
+28 QUIT
+29 ;
FA(SITE,IBXRF1) ; Add TC and 26 Freestanding Professional charges to create global charge
+1 NEW IBTMPX,IBCPT,IBK,IBXRF2,IB26,IB26UT,IBTC,IBTCUT,IBUT,IBITEM,IBEFF,IBINA,IBMOD,IBCHRG,IBCHRGB
+2 ;
+3 SET IBTMPX="IBCR UPLOAD FS PROF"
+4 ;
+5 IF $PIECE(SITE,U,5)'=3
QUIT
+6 ;
+7 SET IBCPT=""
FOR
SET IBCPT=$ORDER(^TMP($JOB,IBTMPX,IBCPT))
if IBCPT=""
QUIT
Begin DoDot:1
+8 IF $ORDER(^TMP($JOB,IBTMPX,IBCPT,"00",0))
QUIT
+9 SET IBK=$ORDER(^TMP($JOB,IBTMPX,IBCPT,"26",0))
if 'IBK
QUIT
+10 SET IBXRF2=^TMP($JOB,IBTMPX,IBCPT,"26",IBK)
SET IB26=^XTMP(IBXRF1,IBXRF2,+IBK)
if IB26=""
QUIT
SET IB26UT=$$UNITYPE(IBXRF2)
+11 SET IBK=$ORDER(^TMP($JOB,IBTMPX,IBCPT,"TC",0))
if 'IBK
QUIT
+12 SET IBXRF2=^TMP($JOB,IBTMPX,IBCPT,"TC",IBK)
SET IBTC=^XTMP(IBXRF1,IBXRF2,+IBK)
if IBTC=""
QUIT
SET IBTCUT=$$UNITYPE(IBXRF2)
+13 ;
+14 SET IBUT=IB26UT
IF IB26UT'=IBTCUT
WRITE !,"ERROR, UNIT TYPES DON'T MATCH ",IBCPT
QUIT
+15 ;
+16 SET IBITEM=$PIECE(IB26,U,1)
SET IBEFF="20"_$EXTRACT($PIECE(IB26,U,2),2,7)
SET IBINA="20"_$EXTRACT($PIECE(IB26,U,3),2,7)
SET IBMOD=""
+17 ;
+18 SET IBCHRG=$PIECE(IB26,U,4)+$PIECE(IBTC,U,4)
if 'IBCHRG
QUIT
SET IBCHRG=$JUSTIFY(IBCHRG,0,2)
+19 SET IBCHRGB=$PIECE(IB26,U,6)+$PIECE(IBTC,U,6)
IF +IBCHRGB
SET IBCHRG=IBCHRG_U_$JUSTIFY(IBCHGB,0,2)
+20 ;
+21 DO SET(IBXRF1,"FS Phys/Add 00 "_IBUT,IBITEM,IBEFF,IBINA,IBCHRG,IBMOD)
End DoDot:1
+22 ;
+23 KILL ^TMP($JOB,IBTMPX)
+24 QUIT
+25 ;
+26 ;
+27 ;
SET(IBXRF1,IBXRF2,ITEM,EFFDT,INACTDT,CHRG,MOD) ; set calculated charges into XTMP
+1 ;
+2 NEW IBX,IBK,IBY,IBINACT,IBMODI
SET IBMODI=""
+3 SET IBX=$GET(^XTMP(IBXRF1,0))
+4 ;
+5 IF IBX=""
WRITE !!,"ERROR: IBXRF1 NOT SET ",IBXRF1,!!
QUIT
+6 IF '$DATA(^XTMP(IBXRF1,IBXRF2))
WRITE !!,"ERROR: IBXRF2 NOT SET ",IBXRF2,!!
QUIT
+7 ;
+8 SET IBK=+$PIECE(IBX,U,4)+1
SET $PIECE(^XTMP(IBXRF1,0),U,4)=IBK
+9 SET $PIECE(^XTMP(IBXRF1,IBXRF2),U,1)=(+$GET(^XTMP(IBXRF1,IBXRF2))+1)
+10 ;
+11 IF $GET(MOD)'=""
SET IBY=$$MODIFN(MOD,EFFDT)
IF +IBY>0
SET IBMODI=+IBY
+12 ;
+13 SET ^XTMP(IBXRF1,IBXRF2,IBK)=ITEM_U_$$DATE(EFFDT)_U_$$ENDDT(INACTDT)_U_+CHRG_U_IBMODI_U_$PIECE(CHRG,U,2)
+14 ;
+15 IF $EXTRACT(IBXRF2,1,7)="FS Phys"
SET MOD=$SELECT(MOD="":"00",1:MOD)
SET ^TMP($JOB,"IBCR UPLOAD FS PROF",ITEM,MOD,IBK)=IBXRF2
+16 QUIT
+17 ;
+18 ;
DATE(X) ; return yyyymmdd in FM format
+1 NEW Y
SET Y=""
IF $GET(X)?8N
SET Y=$SELECT($EXTRACT(X,1,4)>1999:3,1:2)_$EXTRACT(X,3,4)_$EXTRACT(X,5,8)
+2 QUIT Y
+3 ;
ENDDT(X) ; return yyyymmdd date in FM format, check version inactive date
+1 NEW Y,V
SET Y=$$DATE($GET(X))
IF 'Y
SET V=$GET(^XTMP("IBCR RC SITE","VERSION INACTIVE"))
IF +V
SET Y=V
+2 QUIT Y
+3 ;
MODIFN(MOD,EFFDT) ; return internal form of modifier
+1 ; extra check is required because there are two RR modifiers so MOD will not return any
+2 ; base the get on a CPT code for which RR is known to be a valid modifier
+3 NEW IBY,IBX
SET (IBX,IBY)=""
SET EFFDT=$$DATE($GET(EFFDT))
IF 'EFFDT
SET EFFDT=DT
+4 IF $GET(MOD)'=""
SET IBY=$$MOD^ICPTMOD(MOD,"E",EFFDT)
+5 IF IBY<0
IF $GET(MOD)="RR"
SET IBY=$$MODP^ICPTMOD("K0455","RR","E",EFFDT)
+6 IF IBY<0
IF $GET(MOD)="KF"
SET IBY=$$MODP^ICPTMOD("E0785","KF","E",EFFDT)
+7 IF IBY>0
SET IBX=+IBY
+8 QUIT IBX
+9 ;
+10 ;
INPHYS(IBCPT,UNITYPE) ; returns string of all modifiers associated with Physician charges for CPT and Unit Type
+1 ; if charge exists but it has no modifier then uses 00, so if CPT has no charge then returns null
+2 ; if a charge is found for the CPT but it has a different Unit Type then -1 is returned
+3 ; note: if no freestanding physician charge then can add opt facility charge as physician charge
+4 ; note: if only a freestanding 26 physician charge then can add the opt facility charge as TC physician charge (same unit type)
+5 ;
+6 NEW MOD,MODS,IBX,IBY
SET MODS=""
+7 ;
+8 SET IBX=""
FOR
SET IBX=$ORDER(^XTMP("IBCR RC C","A",IBCPT,IBX))
if IBX=""
QUIT
Begin DoDot:1
+9 SET IBY=^XTMP("IBCR RC C",IBX)
IF $PIECE(IBY,U,16)'=UNITYPE
SET MODS=-1
QUIT
+10 SET MOD=$PIECE(IBY,U,4)
IF MOD=""
SET MOD="00"
+11 SET MODS=MODS_MOD
End DoDot:1
+12 QUIT MODS
+13 ;
INFAC(IBCPT) ; check if the CPT code has a charge in the Opt Facility file (table B)
+1 ; return true if CPT code has a Opt Facility Charge
+2 NEW IBX
SET IBX=0
IF $ORDER(^XTMP("IBCR RC B","A",IBCPT,""))
SET IBX=1
+3 QUIT IBX
+4 ;
UNITYPE(IBXRF2) ; return unit type of group of charges last piece of IBXRF2
+1 NEW IBX,IBY,IBZ
SET IBX=""
+2 SET IBY=$LENGTH(IBXRF2)
SET IBZ=$EXTRACT(IBXRF2,IBY)
IF IBZ>0
IF IBZ<5
SET IBX=IBZ
+3 QUIT IBX
