source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBR6.m@ 1073

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