IBCRHBR6 ;ALB/ARH - RATES: UPLOAD (RC) SITE CALCULATIONS ; 10-OCT-1998
;;2.0;INTEGRATED BILLING;**106,138,148,169,245**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
INPT(SITE) ; use Inpatient Facility National Rates to calculate Site Specific Rates
N IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBDRG,IBEFF,IBINA,IBCHRG,IBSNS,IBDRMB,IBSRMB,IBDANC,IBSANC,IBRG,IBRATE,IBEVNT,IBBS,IBCSRB,IBCSAN
;
S IBXTMPC="IBCR RC A",IBXTMPA="IBCR RC B",IBSITE=$$SITE(SITE,IBXTMPA,"Inpatient Facility") Q:'IBSITE
S IBXRF1="IBCR UPLOAD RC "_$P(IBSITE,U,2)_" "_$P(IBSITE,U,3),IBXRF2="Inpt Fac"
W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Inpatient Facility Charges"
;
S IBAA=$G(^XTMP(IBXTMPA,+IBSITE)) Q:IBAA=""
;
S IBRG=$$RG^IBCRHU2("RC "_$P(IBSITE,U,2)_" - "_$P(IBSITE,U,3),$P(IBSITE,U,2),$P(IBSITE,U,4)),IBRG=$P(IBRG,U,2)
S IBRATE="RC INPATIENT FACILITY"
S IBEVNT="INPATIENT DRG"
S IBBS="GENERAL MEDICAL CARE"
S IBCSRB=$$CS^IBCRHU2("RC-INPT R&B "_$P(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"INST",101,IBBS)
S IBCSAN=$$CS^IBCRHU2("RC-INPT ANC "_$P(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"INST",240,IBBS)
;
S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D I '(IBI#100) W "."
. S IBDRG=$G(^XTMP(IBXTMPC,IBI)) Q:IBDRG=""
. ;
. S IBEFF=$P(IBDRG,U,5) I $P(IBAA,U,7)>IBEFF S IBEFF=$P(IBAA,U,7)
. S IBINA=$P(IBDRG,U,6) I $P(IBAA,U,8)>IBINA S IBINA=$P(IBAA,U,8)
. ;
. S IBSNS=$P(IBDRG,U,2)
. S IBDRMB=$P(IBDRG,U,3),IBSRMB=$S(IBSNS="S":$P(IBAA,U,2),IBSNS="N":$P(IBAA,U,4),1:0)
. S IBCHRG=IBDRMB*IBSRMB,IBCHRG=$J(IBCHRG,0,$$RND)
. D SET(IBXRF1,IBXRF2_" R&B","DRG"_+$P(IBDRG,U,1),IBEFF,IBINA,+IBCHRG,"",IBCSRB,4)
. ;
. S IBDANC=$P(IBDRG,U,4),IBSANC=$S(IBSNS="S":$P(IBAA,U,3),IBSNS="N":$P(IBAA,U,5),1:0)
. S IBCHRG=IBDANC*IBSANC,IBCHRG=$J(IBCHRG,0,$$RND)
. D SET(IBXRF1,IBXRF2_" Anc","DRG"_+$P(IBDRG,U,1),IBEFF,IBINA,+IBCHRG,"",IBCSAN,4)
Q
;
SNF(SITE) ; Skilled Nursing
N IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBDRG,IBEFF,IBINA,IBCHRG,IBRG,IBRATE,IBEVNT,IBBS,IBCS
;
;
S IBXTMPC="IBCR RC A",IBXTMPA="IBCR RC B",IBSITE=$$SITE(SITE,IBXTMPA,"Skilled Nursing") Q:'IBSITE
S IBXRF1="IBCR UPLOAD RC "_$P(IBSITE,U,2)_" "_$P(IBSITE,U,3),IBXRF2="Inpt SNF"
W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Inpatient Skilled Nursing Charges"
;
S IBRG=$$RG^IBCRHU2("RC "_$P(IBSITE,U,2)_" - "_$P(IBSITE,U,3),$P(IBSITE,U,2),$P(IBSITE,U,4)),IBRG=$P(IBRG,U,2)
S IBRATE="RC SKILLED NURSING/SUB-ACUTE"
S IBEVNT="UNASSOCIATED"
S IBBS="SKILLED NURSING/SUB-ACUTE CARE"
S IBCS=$$CS^IBCRHU2("RC-SNF "_$P(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"INST","100",IBBS)
;
S IBAA=$G(^XTMP(IBXTMPA,+IBSITE)) Q:IBAA=""
;
S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D
. S IBDRG=$G(^XTMP(IBXTMPC,IBI)) I $P(IBDRG,U,1)'=999 Q
. ;
. S IBEFF=$P(IBDRG,U,5) I $P(IBAA,U,7)>IBEFF S IBEFF=$P(IBAA,U,7)
. S IBINA=$P(IBDRG,U,6) I $P(IBAA,U,8)>IBINA S IBINA=$P(IBAA,U,8)
. ;
. S IBCHRG=$P(IBAA,U,6)*$P(IBDRG,U,3),IBCHRG=$J(IBCHRG,0,$$RND)
. D SET(IBXRF1,IBXRF2,"SKILLED NURSING CARE",IBEFF,IBINA,+IBCHRG,"",IBCS,9)
. S IBCHRG=$P(IBAA,U,6)*$P(IBDRG,U,3),IBCHRG=$J(IBCHRG,0,$$RND)
. D SET(IBXRF1,IBXRF2,"SUB-ACUTE CARE",IBEFF,IBINA,+IBCHRG,"",IBCS,9)
Q
;
OPT(SITE) ; use Outpatient Facility National Rates to calculate Site Specific Rates
N IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBCPT,IBEFF,IBINA,IBCHRG,IBRG,IBRATE,IBEVNT,IBBS,IBCS
;
S IBXTMPC="IBCR RC C",IBXTMPA="IBCR RC D",IBSITE=$$SITE(SITE,IBXTMPA,"Outpatient Facility") Q:'IBSITE
S IBXRF1="IBCR UPLOAD RC "_$P(IBSITE,U,2)_" "_$P(IBSITE,U,3),IBXRF2="Opt Fac"
W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Outpatient Facility Charges"
;
S IBRG=$$RG^IBCRHU2("RC "_$P(IBSITE,U,2)_" - "_$P(IBSITE,U,3),$P(IBSITE,U,2),$P(IBSITE,U,4)),IBRG=$P(IBRG,U,2)
S IBRATE="RC FACILITY PR"
S IBEVNT="PROCEDURE"
S IBBS="OUTPATIENT VISIT"
S IBCS=$$CS^IBCRHU2("RC-OPT FAC "_$P(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"INST",510,IBBS)
;
S IBAA=$G(^XTMP(IBXTMPA,+IBSITE)) Q:IBAA=""
;
S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D I '(IBI#100) W "."
. S IBCPT=$G(^XTMP(IBXTMPC,IBI)) Q:IBCPT=""
. ;
. I +$P(IBCPT,U,5),$P(IBCPT,U,5)'=$P(IBAA,U,5) Q ; site limited charge
. ;
. S IBEFF=$P(IBCPT,U,3) I $P(IBAA,U,3)>IBEFF S IBEFF=$P(IBAA,U,3)
. S IBINA=$P(IBCPT,U,4) I $P(IBAA,U,4)>IBINA S IBINA=$P(IBAA,U,4)
. ;
. S IBCHRG=+$P(IBAA,U,2)*$P(IBCPT,U,2),IBCHRG=$J(IBCHRG,0,2)
. D SET(IBXRF1,IBXRF2,$P(IBCPT,U,1),IBEFF,IBINA,+IBCHRG,"",IBCS,2)
Q
;
PCE(SITE) ; use Physician (General) National Rates to calculate Site Specific Rates
N IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBCPT,IBEFF,IBINA,IBCHRG,IBAAM,IBCGP,IBC1,IBC2,IBC3,IBOK,IBRG,IBRATE,IBEVNT,IBBS,IBCS S IBOK=1
;
S IBXTMPC="IBCR RC E",IBXTMPA="IBCR RC H",IBSITE=$$SITE(SITE,IBXTMPA,"Physician E") Q:'IBSITE
S IBXRF1="IBCR UPLOAD RC "_$P(IBSITE,U,2)_" "_$P(IBSITE,U,3),IBXRF2="Phys Fee E"
W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Physician Charges E"
;
S IBRG=$$RG^IBCRHU2("RC "_$P(IBSITE,U,2)_" - "_$P(IBSITE,U,3),$P(IBSITE,U,2),$P(IBSITE,U,4)),IBRG=$P(IBRG,U,2)
S IBRATE="RC PHYSICIAN PR"
S IBEVNT="PROCEDURE"
S IBBS="OUTPATIENT VISIT"
S IBCS=$$CS^IBCRHU2("RC-PHYSICIAN "_$P(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"PROF",510,IBBS)
;
S IBAA=$G(^XTMP(IBXTMPA,+IBSITE)) Q:IBAA=""
S IBAAM=$G(^XTMP(IBXTMPA,+IBSITE,"BC")) Q:IBAAM=""
;
S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D W:'(IBI#100) "." I 'IBOK Q
. S IBCPT=$G(^XTMP(IBXTMPC,IBI)) Q:IBCPT=""
. S IBCGP=$$CGP($P(IBCPT,U,5),IBXTMPC_"="_$P(IBCPT,U,1)) I 'IBCGP S IBOK=0 Q
. ;
. S IBEFF=$P(IBCPT,U,7) I $P(IBAA,U,5)>IBEFF S IBEFF=$P(IBAA,U,5)
. S IBINA=$P(IBCPT,U,8) I $P(IBAA,U,6)>IBINA S IBINA=$P(IBAA,U,6)
. ;
. S IBC1=$P(IBCPT,U,3)*$P(IBAA,U,3)*$P(IBAA,U,2)
. S IBC2=$P(IBCPT,U,4)*$P(IBAA,U,4)
. S IBC3=$P(IBCPT,U,6)*$P(IBAAM,U,IBCGP)
. S IBCHRG=(IBC1+IBC2)*IBC3,IBCHRG=$J(IBCHRG,0,2)
. D SET(IBXRF1,IBXRF2,$P(IBCPT,U,1),IBEFF,IBINA,+IBCHRG,$P(IBCPT,U,2),IBCS,2)
Q
;
PCF(SITE) ; use Physician (Path & Anesthesia) National Rates to calculate Site Specific Rates
N IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBCPT,IBEFF,IBINA,IBCHRG,IBAAM,IBCGP,IBOK,IBCS S IBOK=1
;
S IBXTMPC="IBCR RC F",IBXTMPA="IBCR RC H",IBSITE=$$SITE(SITE,IBXTMPA,"Physician F") Q:'IBSITE
S IBXRF1="IBCR UPLOAD RC "_$P(IBSITE,U,2)_" "_$P(IBSITE,U,3),IBXRF2="Phys Fee F"
W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Physician Charges F"
;
S IBCS=$$USECS^IBCRHU2("RC-PHYSICIAN "_$P(IBSITE,U,2))
;
S IBAA=$G(^XTMP(IBXTMPA,+IBSITE)) Q:IBAA=""
S IBAAM=$G(^XTMP(IBXTMPA,+IBSITE,"BC")) Q:IBAAM=""
;
S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D W:'(IBI#100) "." I 'IBOK Q
. S IBCPT=$G(^XTMP(IBXTMPC,IBI)) Q:IBCPT=""
. S IBCGP=$$CGP($P(IBCPT,U,4),IBXTMPC_"="_$P(IBCPT,U,1)) I 'IBCGP S IBOK=0 Q
. ;
. S IBEFF=$P(IBCPT,U,5) I $P(IBAA,U,5)>IBEFF S IBEFF=$P(IBAA,U,5)
. S IBINA=$P(IBCPT,U,6) I $P(IBAA,U,6)>IBINA S IBINA=$P(IBAA,U,6)
. ;
. S IBCHRG=+$P(IBAAM,U,IBCGP)*$P(IBCPT,U,3),IBCHRG=$J(IBCHRG,0,2)
. D SET(IBXRF1,IBXRF2,$P(IBCPT,U,1),IBEFF,IBINA,+IBCHRG,$P(IBCPT,U,2),IBCS,2)
Q
;
PCG(SITE) ; use Physician (Total RVU) National Rates to calculate Site Specific Rates
N IBXTMPC,IBXTMPA,IBXRF1,IBXRF2,IBSITE,IBAA,IBAAM,IBI,IBCPT,IBCGP,IBEFF,IBINA,IBCHRG,IBCS
;
S IBXTMPC="IBCR RC G",IBXTMPA="IBCR RC I",IBSITE=$$SITE(SITE,IBXTMPA,"Physician G") Q:'IBSITE
S IBXRF1="IBCR UPLOAD RC "_$P(IBSITE,U,2)_" "_$P(IBSITE,U,3),IBXRF2="Phys Fee G"
W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Physician Charges G"
;
S IBCS=$$USECS^IBCRHU2("RC-PHYSICIAN "_$P(IBSITE,U,2))
;
S IBAA=$G(^XTMP(IBXTMPA,+IBSITE)) Q:IBAA=""
S IBAAM=$G(^XTMP("IBCR RC H",+IBSITE,"BC")) Q:IBAAM=""
;
S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D I '(IBI#100) W "."
. S IBCPT=$G(^XTMP(IBXTMPC,IBI)) Q:IBCPT=""
. S IBCGP=$$CGP($P(IBCPT,U,4),IBXTMPC_"="_$P(IBCPT,U,1)) I 'IBCGP S IBOK=0 Q
. ;
. S IBEFF=$P(IBCPT,U,6) I $P(IBAA,U,3)>IBEFF S IBEFF=$P(IBAA,U,3)
. S IBINA=$P(IBCPT,U,7) I $P(IBAA,U,4)>IBINA S IBINA=$P(IBAA,U,4)
. ;
. S IBCHRG=+$P(IBAAM,U,IBCGP)*$P(IBAA,U,2)*$P(IBCPT,U,3)*$P(IBCPT,U,5),IBCHRG=$J(IBCHRG,0,2)
. D SET(IBXRF1,IBXRF2,$P(IBCPT,U,1),IBEFF,IBINA,+IBCHRG,$P(IBCPT,U,2),IBCS,2)
Q
;
SITE(IBSXIFN,IBXTMP,IBCHGTYP) ; return site data: XTMP file IFN ^ div num ^ name ^ 3-digit zip
N IBSITE,IBSXTMP,IBSITEN S IBSITE="",IBSXTMP="IBCR RC SITE"
S IBSITE=$G(^XTMP(IBSXTMP,IBSXIFN,IBXTMP)),IBSITEN=$G(^XTMP(IBSXTMP,IBSXIFN))
I +IBSITE S IBSITE=IBSITE_U_$P(IBSITEN,U,1,3)
I 'IBSITE W !,"There are no ",$G(IBCHGTYP)," charges for ",$P(IBSITEN,U,1)," ",$P(IBSITEN,U,2),"!",!
Q IBSITE
;
SETHDR(IBXRF1) ; set up header for XTMP file
N IBX K ^XTMP(IBXRF1)
S IBX="IB Upload RC v"_$$VERSION^IBCRHBRV_" "_$P(IBXRF1,"UPLOAD RC ",2)_", "_$P($$HTE^XLFDT($H,2),":",1,2)_" by "_$P($G(^VA(200,+$G(DUZ),0)),U,1)
S ^XTMP(IBXRF1,0)=$$FMADD^XLFDT(DT,2)_U_DT_U_IBX
Q
;
SET(IBXRF1,IBXRF2,ITEM,EFFDT,INACTDT,CHRG,MOD,CS,ITYPE) ; set calculated charges into XTMP
;
N IBX,IBK,IBINACT S IBX=$G(^XTMP(IBXRF1,0)) I IBX="" D SETHDR(IBXRF1)
S IBK=+$P(IBX,U,4)+1,$P(^XTMP(IBXRF1,0),U,4)=IBK
S ^XTMP(IBXRF1,IBXRF2)=(+$G(^XTMP(IBXRF1,IBXRF2))+1)_U_$G(ITYPE)_U_$G(CS)
;
S ^XTMP(IBXRF1,IBXRF2,IBK)=ITEM_U_$$DATE(EFFDT)_U_$$ENDDT(INACTDT)_U_+CHRG_U_$G(MOD)
Q
;
CGP(CG,TXT) ; if Code Group is defined return benefit category number in list
N IBCGP I '$D(^TMP($J,"IBCR RC CGROUP")) D CGROUP^IBCRHBR
S IBCGP=0 I $G(CG)'="" S IBCGP=+$G(^TMP($J,"IBCR RC CGROUP",CG))
I '$G(IBCGP) W !," *** Fatal Error: ",$G(TXT),!,?21,"could not find Code Group: ",CG
Q IBCGP
;
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
;
RND() ;
N Y S Y=$$VERSION^IBCRHBRV S Y=$S(Y=1:0,1:2)
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRHBR6 9986 printed Apr 09, 2024@21:34:13 Page 2
IBCRHBR6 ;ALB/ARH - RATES: UPLOAD (RC) SITE CALCULATIONS ; 10-OCT-1998
+1 ;;2.0;INTEGRATED BILLING;**106,138,148,169,245**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
INPT(SITE) ; use Inpatient Facility National Rates to calculate Site Specific Rates
+1 NEW IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBDRG,IBEFF,IBINA,IBCHRG,IBSNS,IBDRMB,IBSRMB,IBDANC,IBSANC,IBRG,IBRATE,IBEVNT,IBBS,IBCSRB,IBCSAN
+2 ;
+3 SET IBXTMPC="IBCR RC A"
SET IBXTMPA="IBCR RC B"
SET IBSITE=$$SITE(SITE,IBXTMPA,"Inpatient Facility")
if 'IBSITE
QUIT
+4 SET IBXRF1="IBCR UPLOAD RC "_$PIECE(IBSITE,U,2)_" "_$PIECE(IBSITE,U,3)
SET IBXRF2="Inpt Fac"
+5 WRITE !,$PIECE(IBSITE,U,2)," ",$PIECE(IBSITE,U,3)," - Inpatient Facility Charges"
+6 ;
+7 SET IBAA=$GET(^XTMP(IBXTMPA,+IBSITE))
if IBAA=""
QUIT
+8 ;
+9 SET IBRG=$$RG^IBCRHU2("RC "_$PIECE(IBSITE,U,2)_" - "_$PIECE(IBSITE,U,3),$PIECE(IBSITE,U,2),$PIECE(IBSITE,U,4))
SET IBRG=$PIECE(IBRG,U,2)
+10 SET IBRATE="RC INPATIENT FACILITY"
+11 SET IBEVNT="INPATIENT DRG"
+12 SET IBBS="GENERAL MEDICAL CARE"
+13 SET IBCSRB=$$CS^IBCRHU2("RC-INPT R&B "_$PIECE(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"INST",101,IBBS)
+14 SET IBCSAN=$$CS^IBCRHU2("RC-INPT ANC "_$PIECE(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"INST",240,IBBS)
+15 ;
+16 SET IBI=0
FOR
SET IBI=$ORDER(^XTMP(IBXTMPC,IBI))
if 'IBI
QUIT
Begin DoDot:1
+17 SET IBDRG=$GET(^XTMP(IBXTMPC,IBI))
if IBDRG=""
QUIT
+18 ;
+19 SET IBEFF=$PIECE(IBDRG,U,5)
IF $PIECE(IBAA,U,7)>IBEFF
SET IBEFF=$PIECE(IBAA,U,7)
+20 SET IBINA=$PIECE(IBDRG,U,6)
IF $PIECE(IBAA,U,8)>IBINA
SET IBINA=$PIECE(IBAA,U,8)
+21 ;
+22 SET IBSNS=$PIECE(IBDRG,U,2)
+23 SET IBDRMB=$PIECE(IBDRG,U,3)
SET IBSRMB=$SELECT(IBSNS="S":$PIECE(IBAA,U,2),IBSNS="N":$PIECE(IBAA,U,4),1:0)
+24 SET IBCHRG=IBDRMB*IBSRMB
SET IBCHRG=$JUSTIFY(IBCHRG,0,$$RND)
+25 DO SET(IBXRF1,IBXRF2_" R&B","DRG"_+$PIECE(IBDRG,U,1),IBEFF,IBINA,+IBCHRG,"",IBCSRB,4)
+26 ;
+27 SET IBDANC=$PIECE(IBDRG,U,4)
SET IBSANC=$SELECT(IBSNS="S":$PIECE(IBAA,U,3),IBSNS="N":$PIECE(IBAA,U,5),1:0)
+28 SET IBCHRG=IBDANC*IBSANC
SET IBCHRG=$JUSTIFY(IBCHRG,0,$$RND)
+29 DO SET(IBXRF1,IBXRF2_" Anc","DRG"_+$PIECE(IBDRG,U,1),IBEFF,IBINA,+IBCHRG,"",IBCSAN,4)
End DoDot:1
IF '(IBI#100)
WRITE "."
+30 QUIT
+31 ;
SNF(SITE) ; Skilled Nursing
+1 NEW IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBDRG,IBEFF,IBINA,IBCHRG,IBRG,IBRATE,IBEVNT,IBBS,IBCS
+2 ;
+3 ;
+4 SET IBXTMPC="IBCR RC A"
SET IBXTMPA="IBCR RC B"
SET IBSITE=$$SITE(SITE,IBXTMPA,"Skilled Nursing")
if 'IBSITE
QUIT
+5 SET IBXRF1="IBCR UPLOAD RC "_$PIECE(IBSITE,U,2)_" "_$PIECE(IBSITE,U,3)
SET IBXRF2="Inpt SNF"
+6 WRITE !,$PIECE(IBSITE,U,2)," ",$PIECE(IBSITE,U,3)," - Inpatient Skilled Nursing Charges"
+7 ;
+8 SET IBRG=$$RG^IBCRHU2("RC "_$PIECE(IBSITE,U,2)_" - "_$PIECE(IBSITE,U,3),$PIECE(IBSITE,U,2),$PIECE(IBSITE,U,4))
SET IBRG=$PIECE(IBRG,U,2)
+9 SET IBRATE="RC SKILLED NURSING/SUB-ACUTE"
+10 SET IBEVNT="UNASSOCIATED"
+11 SET IBBS="SKILLED NURSING/SUB-ACUTE CARE"
+12 SET IBCS=$$CS^IBCRHU2("RC-SNF "_$PIECE(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"INST","100",IBBS)
+13 ;
+14 SET IBAA=$GET(^XTMP(IBXTMPA,+IBSITE))
if IBAA=""
QUIT
+15 ;
+16 SET IBI=0
FOR
SET IBI=$ORDER(^XTMP(IBXTMPC,IBI))
if 'IBI
QUIT
Begin DoDot:1
+17 SET IBDRG=$GET(^XTMP(IBXTMPC,IBI))
IF $PIECE(IBDRG,U,1)'=999
QUIT
+18 ;
+19 SET IBEFF=$PIECE(IBDRG,U,5)
IF $PIECE(IBAA,U,7)>IBEFF
SET IBEFF=$PIECE(IBAA,U,7)
+20 SET IBINA=$PIECE(IBDRG,U,6)
IF $PIECE(IBAA,U,8)>IBINA
SET IBINA=$PIECE(IBAA,U,8)
+21 ;
+22 SET IBCHRG=$PIECE(IBAA,U,6)*$PIECE(IBDRG,U,3)
SET IBCHRG=$JUSTIFY(IBCHRG,0,$$RND)
+23 DO SET(IBXRF1,IBXRF2,"SKILLED NURSING CARE",IBEFF,IBINA,+IBCHRG,"",IBCS,9)
+24 SET IBCHRG=$PIECE(IBAA,U,6)*$PIECE(IBDRG,U,3)
SET IBCHRG=$JUSTIFY(IBCHRG,0,$$RND)
+25 DO SET(IBXRF1,IBXRF2,"SUB-ACUTE CARE",IBEFF,IBINA,+IBCHRG,"",IBCS,9)
End DoDot:1
+26 QUIT
+27 ;
OPT(SITE) ; use Outpatient Facility National Rates to calculate Site Specific Rates
+1 NEW IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBCPT,IBEFF,IBINA,IBCHRG,IBRG,IBRATE,IBEVNT,IBBS,IBCS
+2 ;
+3 SET IBXTMPC="IBCR RC C"
SET IBXTMPA="IBCR RC D"
SET IBSITE=$$SITE(SITE,IBXTMPA,"Outpatient Facility")
if 'IBSITE
QUIT
+4 SET IBXRF1="IBCR UPLOAD RC "_$PIECE(IBSITE,U,2)_" "_$PIECE(IBSITE,U,3)
SET IBXRF2="Opt Fac"
+5 WRITE !,$PIECE(IBSITE,U,2)," ",$PIECE(IBSITE,U,3)," - Outpatient Facility Charges"
+6 ;
+7 SET IBRG=$$RG^IBCRHU2("RC "_$PIECE(IBSITE,U,2)_" - "_$PIECE(IBSITE,U,3),$PIECE(IBSITE,U,2),$PIECE(IBSITE,U,4))
SET IBRG=$PIECE(IBRG,U,2)
+8 SET IBRATE="RC FACILITY PR"
+9 SET IBEVNT="PROCEDURE"
+10 SET IBBS="OUTPATIENT VISIT"
+11 SET IBCS=$$CS^IBCRHU2("RC-OPT FAC "_$PIECE(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"INST",510,IBBS)
+12 ;
+13 SET IBAA=$GET(^XTMP(IBXTMPA,+IBSITE))
if IBAA=""
QUIT
+14 ;
+15 SET IBI=0
FOR
SET IBI=$ORDER(^XTMP(IBXTMPC,IBI))
if 'IBI
QUIT
Begin DoDot:1
+16 SET IBCPT=$GET(^XTMP(IBXTMPC,IBI))
if IBCPT=""
QUIT
+17 ;
+18 ; site limited charge
IF +$PIECE(IBCPT,U,5)
IF $PIECE(IBCPT,U,5)'=$PIECE(IBAA,U,5)
QUIT
+19 ;
+20 SET IBEFF=$PIECE(IBCPT,U,3)
IF $PIECE(IBAA,U,3)>IBEFF
SET IBEFF=$PIECE(IBAA,U,3)
+21 SET IBINA=$PIECE(IBCPT,U,4)
IF $PIECE(IBAA,U,4)>IBINA
SET IBINA=$PIECE(IBAA,U,4)
+22 ;
+23 SET IBCHRG=+$PIECE(IBAA,U,2)*$PIECE(IBCPT,U,2)
SET IBCHRG=$JUSTIFY(IBCHRG,0,2)
+24 DO SET(IBXRF1,IBXRF2,$PIECE(IBCPT,U,1),IBEFF,IBINA,+IBCHRG,"",IBCS,2)
End DoDot:1
IF '(IBI#100)
WRITE "."
+25 QUIT
+26 ;
PCE(SITE) ; use Physician (General) National Rates to calculate Site Specific Rates
+1 NEW IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBCPT,IBEFF,IBINA,IBCHRG,IBAAM,IBCGP,IBC1,IBC2,IBC3,IBOK,IBRG,IBRATE,IBEVNT,IBBS,IBCS
SET IBOK=1
+2 ;
+3 SET IBXTMPC="IBCR RC E"
SET IBXTMPA="IBCR RC H"
SET IBSITE=$$SITE(SITE,IBXTMPA,"Physician E")
if 'IBSITE
QUIT
+4 SET IBXRF1="IBCR UPLOAD RC "_$PIECE(IBSITE,U,2)_" "_$PIECE(IBSITE,U,3)
SET IBXRF2="Phys Fee E"
+5 WRITE !,$PIECE(IBSITE,U,2)," ",$PIECE(IBSITE,U,3)," - Physician Charges E"
+6 ;
+7 SET IBRG=$$RG^IBCRHU2("RC "_$PIECE(IBSITE,U,2)_" - "_$PIECE(IBSITE,U,3),$PIECE(IBSITE,U,2),$PIECE(IBSITE,U,4))
SET IBRG=$PIECE(IBRG,U,2)
+8 SET IBRATE="RC PHYSICIAN PR"
+9 SET IBEVNT="PROCEDURE"
+10 SET IBBS="OUTPATIENT VISIT"
+11 SET IBCS=$$CS^IBCRHU2("RC-PHYSICIAN "_$PIECE(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"PROF",510,IBBS)
+12 ;
+13 SET IBAA=$GET(^XTMP(IBXTMPA,+IBSITE))
if IBAA=""
QUIT
+14 SET IBAAM=$GET(^XTMP(IBXTMPA,+IBSITE,"BC"))
if IBAAM=""
QUIT
+15 ;
+16 SET IBI=0
FOR
SET IBI=$ORDER(^XTMP(IBXTMPC,IBI))
if 'IBI
QUIT
Begin DoDot:1
+17 SET IBCPT=$GET(^XTMP(IBXTMPC,IBI))
if IBCPT=""
QUIT
+18 SET IBCGP=$$CGP($PIECE(IBCPT,U,5),IBXTMPC_"="_$PIECE(IBCPT,U,1))
IF 'IBCGP
SET IBOK=0
QUIT
+19 ;
+20 SET IBEFF=$PIECE(IBCPT,U,7)
IF $PIECE(IBAA,U,5)>IBEFF
SET IBEFF=$PIECE(IBAA,U,5)
+21 SET IBINA=$PIECE(IBCPT,U,8)
IF $PIECE(IBAA,U,6)>IBINA
SET IBINA=$PIECE(IBAA,U,6)
+22 ;
+23 SET IBC1=$PIECE(IBCPT,U,3)*$PIECE(IBAA,U,3)*$PIECE(IBAA,U,2)
+24 SET IBC2=$PIECE(IBCPT,U,4)*$PIECE(IBAA,U,4)
+25 SET IBC3=$PIECE(IBCPT,U,6)*$PIECE(IBAAM,U,IBCGP)
+26 SET IBCHRG=(IBC1+IBC2)*IBC3
SET IBCHRG=$JUSTIFY(IBCHRG,0,2)
+27 DO SET(IBXRF1,IBXRF2,$PIECE(IBCPT,U,1),IBEFF,IBINA,+IBCHRG,$PIECE(IBCPT,U,2),IBCS,2)
End DoDot:1
if '(IBI#100)
WRITE "."
IF 'IBOK
QUIT
+28 QUIT
+29 ;
PCF(SITE) ; use Physician (Path & Anesthesia) National Rates to calculate Site Specific Rates
+1 NEW IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBCPT,IBEFF,IBINA,IBCHRG,IBAAM,IBCGP,IBOK,IBCS
SET IBOK=1
+2 ;
+3 SET IBXTMPC="IBCR RC F"
SET IBXTMPA="IBCR RC H"
SET IBSITE=$$SITE(SITE,IBXTMPA,"Physician F")
if 'IBSITE
QUIT
+4 SET IBXRF1="IBCR UPLOAD RC "_$PIECE(IBSITE,U,2)_" "_$PIECE(IBSITE,U,3)
SET IBXRF2="Phys Fee F"
+5 WRITE !,$PIECE(IBSITE,U,2)," ",$PIECE(IBSITE,U,3)," - Physician Charges F"
+6 ;
+7 SET IBCS=$$USECS^IBCRHU2("RC-PHYSICIAN "_$PIECE(IBSITE,U,2))
+8 ;
+9 SET IBAA=$GET(^XTMP(IBXTMPA,+IBSITE))
if IBAA=""
QUIT
+10 SET IBAAM=$GET(^XTMP(IBXTMPA,+IBSITE,"BC"))
if IBAAM=""
QUIT
+11 ;
+12 SET IBI=0
FOR
SET IBI=$ORDER(^XTMP(IBXTMPC,IBI))
if 'IBI
QUIT
Begin DoDot:1
+13 SET IBCPT=$GET(^XTMP(IBXTMPC,IBI))
if IBCPT=""
QUIT
+14 SET IBCGP=$$CGP($PIECE(IBCPT,U,4),IBXTMPC_"="_$PIECE(IBCPT,U,1))
IF 'IBCGP
SET IBOK=0
QUIT
+15 ;
+16 SET IBEFF=$PIECE(IBCPT,U,5)
IF $PIECE(IBAA,U,5)>IBEFF
SET IBEFF=$PIECE(IBAA,U,5)
+17 SET IBINA=$PIECE(IBCPT,U,6)
IF $PIECE(IBAA,U,6)>IBINA
SET IBINA=$PIECE(IBAA,U,6)
+18 ;
+19 SET IBCHRG=+$PIECE(IBAAM,U,IBCGP)*$PIECE(IBCPT,U,3)
SET IBCHRG=$JUSTIFY(IBCHRG,0,2)
+20 DO SET(IBXRF1,IBXRF2,$PIECE(IBCPT,U,1),IBEFF,IBINA,+IBCHRG,$PIECE(IBCPT,U,2),IBCS,2)
End DoDot:1
if '(IBI#100)
WRITE "."
IF 'IBOK
QUIT
+21 QUIT
+22 ;
PCG(SITE) ; use Physician (Total RVU) National Rates to calculate Site Specific Rates
+1 NEW IBXTMPC,IBXTMPA,IBXRF1,IBXRF2,IBSITE,IBAA,IBAAM,IBI,IBCPT,IBCGP,IBEFF,IBINA,IBCHRG,IBCS
+2 ;
+3 SET IBXTMPC="IBCR RC G"
SET IBXTMPA="IBCR RC I"
SET IBSITE=$$SITE(SITE,IBXTMPA,"Physician G")
if 'IBSITE
QUIT
+4 SET IBXRF1="IBCR UPLOAD RC "_$PIECE(IBSITE,U,2)_" "_$PIECE(IBSITE,U,3)
SET IBXRF2="Phys Fee G"
+5 WRITE !,$PIECE(IBSITE,U,2)," ",$PIECE(IBSITE,U,3)," - Physician Charges G"
+6 ;
+7 SET IBCS=$$USECS^IBCRHU2("RC-PHYSICIAN "_$PIECE(IBSITE,U,2))
+8 ;
+9 SET IBAA=$GET(^XTMP(IBXTMPA,+IBSITE))
if IBAA=""
QUIT
+10 SET IBAAM=$GET(^XTMP("IBCR RC H",+IBSITE,"BC"))
if IBAAM=""
QUIT
+11 ;
+12 SET IBI=0
FOR
SET IBI=$ORDER(^XTMP(IBXTMPC,IBI))
if 'IBI
QUIT
Begin DoDot:1
+13 SET IBCPT=$GET(^XTMP(IBXTMPC,IBI))
if IBCPT=""
QUIT
+14 SET IBCGP=$$CGP($PIECE(IBCPT,U,4),IBXTMPC_"="_$PIECE(IBCPT,U,1))
IF 'IBCGP
SET IBOK=0
QUIT
+15 ;
+16 SET IBEFF=$PIECE(IBCPT,U,6)
IF $PIECE(IBAA,U,3)>IBEFF
SET IBEFF=$PIECE(IBAA,U,3)
+17 SET IBINA=$PIECE(IBCPT,U,7)
IF $PIECE(IBAA,U,4)>IBINA
SET IBINA=$PIECE(IBAA,U,4)
+18 ;
+19 SET IBCHRG=+$PIECE(IBAAM,U,IBCGP)*$PIECE(IBAA,U,2)*$PIECE(IBCPT,U,3)*$PIECE(IBCPT,U,5)
SET IBCHRG=$JUSTIFY(IBCHRG,0,2)
+20 DO SET(IBXRF1,IBXRF2,$PIECE(IBCPT,U,1),IBEFF,IBINA,+IBCHRG,$PIECE(IBCPT,U,2),IBCS,2)
End DoDot:1
IF '(IBI#100)
WRITE "."
+21 QUIT
+22 ;
SITE(IBSXIFN,IBXTMP,IBCHGTYP) ; return site data: XTMP file IFN ^ div num ^ name ^ 3-digit zip
+1 NEW IBSITE,IBSXTMP,IBSITEN
SET IBSITE=""
SET IBSXTMP="IBCR RC SITE"
+2 SET IBSITE=$GET(^XTMP(IBSXTMP,IBSXIFN,IBXTMP))
SET IBSITEN=$GET(^XTMP(IBSXTMP,IBSXIFN))
+3 IF +IBSITE
SET IBSITE=IBSITE_U_$PIECE(IBSITEN,U,1,3)
+4 IF 'IBSITE
WRITE !,"There are no ",$GET(IBCHGTYP)," charges for ",$PIECE(IBSITEN,U,1)," ",$PIECE(IBSITEN,U,2),"!",!
+5 QUIT IBSITE
+6 ;
SETHDR(IBXRF1) ; set up header for XTMP file
+1 NEW IBX
KILL ^XTMP(IBXRF1)
+2 SET IBX="IB Upload RC v"_$$VERSION^IBCRHBRV_" "_$P(IBXRF1,"UPLOAD RC ",2)_", "_$PIECE($$HTE^XLFDT($HOROLOG,2),":",1,2)_" by "_$PIECE($GET(^VA(200,+$GET(DUZ),0)),U,1)
+3 SET ^XTMP(IBXRF1,0)=$$FMADD^XLFDT(DT,2)_U_DT_U_IBX
+4 QUIT
+5 ;
SET(IBXRF1,IBXRF2,ITEM,EFFDT,INACTDT,CHRG,MOD,CS,ITYPE) ; set calculated charges into XTMP
+1 ;
+2 NEW IBX,IBK,IBINACT
SET IBX=$GET(^XTMP(IBXRF1,0))
IF IBX=""
DO SETHDR(IBXRF1)
+3 SET IBK=+$PIECE(IBX,U,4)+1
SET $PIECE(^XTMP(IBXRF1,0),U,4)=IBK
+4 SET ^XTMP(IBXRF1,IBXRF2)=(+$GET(^XTMP(IBXRF1,IBXRF2))+1)_U_$GET(ITYPE)_U_$GET(CS)
+5 ;
+6 SET ^XTMP(IBXRF1,IBXRF2,IBK)=ITEM_U_$$DATE(EFFDT)_U_$$ENDDT(INACTDT)_U_+CHRG_U_$GET(MOD)
+7 QUIT
+8 ;
CGP(CG,TXT) ; if Code Group is defined return benefit category number in list
+1 NEW IBCGP
IF '$DATA(^TMP($JOB,"IBCR RC CGROUP"))
DO CGROUP^IBCRHBR
+2 SET IBCGP=0
IF $GET(CG)'=""
SET IBCGP=+$GET(^TMP($JOB,"IBCR RC CGROUP",CG))
+3 IF '$GET(IBCGP)
WRITE !," *** Fatal Error: ",$GET(TXT),!,?21,"could not find Code Group: ",CG
+4 QUIT IBCGP
+5 ;
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 ;
RND() ;
+1 NEW Y
SET Y=$$VERSION^IBCRHBRV
SET Y=$SELECT(Y=1:0,1:2)
+2 QUIT Y
