IBCRHBR6.m

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 ---IBCRHBR6   9986     printed  Mar 13, 2025@21:24:18                                                                                                                                                                                                    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)