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

Last change on this file since 829 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 7.1 KB
Line 
1IBCRHBS7 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS SITE ; 10-OCT-03
2 ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5A(SITE,IBXRF1) ; use Inpatient Facility National Rates to calculate Site Specific Rates
6 N IBXTMPC,IBI,IBLINE,IBDRG,IBEFF,IBINA,IBCT,IBCHRG
7 ;
8 I $P(SITE,U,5)'=1 Q
9 ;
10 S IBXTMPC="IBCR RC A"
11 ;
12 S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D I '(IBI#100) W "."
13 . S IBLINE=$G(^XTMP(IBXTMPC,IBI)) Q:IBLINE=""
14 . ;
15 . S IBDRG="DRG"_+$P(IBLINE,U,1),IBEFF=$P(IBLINE,U,9),IBINA=$P(IBLINE,U,10),IBCT=$P(IBLINE,U,2)
16 . ;
17 . ;
18 . I IBCT="SNF" D Q
19 .. S IBCHRG=$$ISNF^IBCRHBS8(SITE,IBLINE)
20 .. D SET(IBXRF1,"SNF PD INC","SKILLED NURSING CARE",IBEFF,IBINA,IBCHRG,"")
21 .. D SET(IBXRF1,"SNF PD INC","SUB-ACUTE CARE",IBEFF,IBINA,IBCHRG,"")
22 . ;
23 . I IBCT="DRG" D Q
24 .. S IBCHRG=$$ISR^IBCRHBS8(SITE,IBLINE) D SET(IBXRF1,"Inpt PD R&B",IBDRG,IBEFF,IBINA,IBCHRG,"")
25 .. S IBCHRG=$$ISA^IBCRHBS8(SITE,IBLINE) D SET(IBXRF1,"Inpt PD Anc",IBDRG,IBEFF,IBINA,IBCHRG,"")
26 .. S IBCHRG=$$IIR^IBCRHBS8(SITE,IBLINE) D SET(IBXRF1,"Inpt PD R&B ICU",IBDRG,IBEFF,IBINA,IBCHRG,"")
27 .. S IBCHRG=$$IIA^IBCRHBS8(SITE,IBLINE) D SET(IBXRF1,"Inpt PD Anc ICU",IBDRG,IBEFF,IBINA,IBCHRG,"")
28 Q
29 ;
30 ;
31B(SITE,IBXRF1) ; use Outpatient Facility National Rates to calculate Site Specific Rates
32 N IBXTMPC,TYPE,IBI,IBLINE,IBCPT,IBEFF,IBINA,IBCHRG,IBUT,IBFAC
33 ;
34 S TYPE=$P(SITE,U,5) Q:'TYPE
35 ;
36 S IBXTMPC="IBCR RC B"
37 ;
38 S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D I '(IBI#100) W "."
39 . S IBLINE=$G(^XTMP(IBXTMPC,IBI)) Q:IBLINE=""
40 . ;
41 . S IBCPT=$P(IBLINE,U,1),IBEFF=$P(IBLINE,U,13),IBINA=$P(IBLINE,U,14),IBUT=$P(IBLINE,U,10)
42 . ;
43 . S IBCHRG=$$FAC^IBCRHBS8(SITE,IBLINE)
44 . ;
45 . ;
46 . I $P(IBLINE,U,2)="PHOSP" D Q ; Partial Hospitalization
47 .. I TYPE<3 D SET(IBXRF1,"Opt PD PHosp","PARTIAL HOSPITALIZATION",IBEFF,IBINA,IBCHRG,"")
48 . ;
49 . I TYPE=1 D ; Inpatient/SNF Facility
50 .. I $P(IBLINE,U,11) D SET(IBXRF1,"Inpt Fac "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"")
51 .. I $P(IBLINE,U,12) D SET(IBXRF1,"SNF Fac "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"")
52 . ;
53 . I TYPE<3 D ; Outpatient Facility Charges
54 .. D SET(IBXRF1,"Opt Fac "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"")
55 . ;
56 . I TYPE=3 D ; move facility charge to physician for Freestanding if there is no global or TC
57 .. S IBFAC=$$INPHYS(IBCPT,IBUT) I IBFAC<0 Q
58 .. I IBFAC=26 D SET(IBXRF1,"FS Phys/Opt TC "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"TC")
59 .. I IBFAC="" D SET(IBXRF1,"FS Phys/Opt "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,"")
60 ;
61 Q
62 ;
63C(SITE,IBXRF1) ; use Physician National Rates to calculate Site Specific Rates
64 N IBXTMPC,TYPE,IBI,IBLINE,IBCPT,IBEFF,IBINA,IBUT,IBMOD,IBXRF2A,IBCHRG
65 ;
66 S TYPE=$P(SITE,U,5) Q:'TYPE
67 ;
68 S IBXTMPC="IBCR RC C"
69 ;
70 S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D W:'(IBI#100) "."
71 . S IBLINE=$G(^XTMP(IBXTMPC,IBI)) Q:IBLINE=""
72 . ;
73 . 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)
74 . ;
75 . S IBCHRG=$$PROF^IBCRHBS8(SITE,IBLINE)
76 . ;
77 . ;
78 . I TYPE=3 D Q ; Freestanding Professional Charge
79 .. I +$P(IBLINE,U,21) D SET(IBXRF1,"FS Phys "_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,IBMOD)
80 . ;
81 . S IBXRF2A="Phys "
82 . I +$P(IBLINE,U,17) S IBXRF2A="Fac/Phys ",IBMOD=$S(IBMOD="TC":"",1:IBMOD) I +$$INFAC(IBCPT) Q ; facility
83 . ;
84 . I TYPE=1 D
85 .. I +$P(IBLINE,U,19) D SET(IBXRF1,"Inpt "_IBXRF2A_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,IBMOD)
86 .. I +$P(IBLINE,U,20) D SET(IBXRF1,"SNF "_IBXRF2A_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,IBMOD)
87 . ;
88 . I TYPE<3 D
89 .. I +$P(IBLINE,U,18) D SET(IBXRF1,"Opt "_IBXRF2A_IBUT,IBCPT,IBEFF,IBINA,IBCHRG,IBMOD)
90 ;
91 Q
92 ;
93FA(SITE,IBXRF1) ; Add TC and 26 Freestanding Professional charges to create global charge
94 N IBTMPX,IBCPT,IBK,IBXRF2,IB26,IB26UT,IBTC,IBTCUT,IBUT,IBITEM,IBEFF,IBINA,IBMOD,IBCHRG,IBCHRGB
95 ;
96 S IBTMPX="IBCR UPLOAD FS PROF"
97 ;
98 I $P(SITE,U,5)'=3 Q
99 ;
100 S IBCPT="" F S IBCPT=$O(^TMP($J,IBTMPX,IBCPT)) Q:IBCPT="" D
101 . I $O(^TMP($J,IBTMPX,IBCPT,"00",0)) Q
102 . S IBK=$O(^TMP($J,IBTMPX,IBCPT,"26",0)) Q:'IBK
103 . S IBXRF2=^TMP($J,IBTMPX,IBCPT,"26",IBK),IB26=^XTMP(IBXRF1,IBXRF2,+IBK) Q:IB26="" S IB26UT=$$UNITYPE(IBXRF2)
104 . S IBK=$O(^TMP($J,IBTMPX,IBCPT,"TC",0)) Q:'IBK
105 . S IBXRF2=^TMP($J,IBTMPX,IBCPT,"TC",IBK),IBTC=^XTMP(IBXRF1,IBXRF2,+IBK) Q:IBTC="" S IBTCUT=$$UNITYPE(IBXRF2)
106 . ;
107 . S IBUT=IB26UT I IB26UT'=IBTCUT W !,"ERROR, UNIT TYPES DON'T MATCH ",IBCPT Q
108 . ;
109 . 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=""
110 . ;
111 . S IBCHRG=$P(IB26,U,4)+$P(IBTC,U,4) Q:'IBCHRG S IBCHRG=$J(IBCHRG,0,2)
112 . S IBCHRGB=$P(IB26,U,6)+$P(IBTC,U,6) I +IBCHRGB S IBCHRG=IBCHRG_U_$J(IBCHGB,0,2)
113 . ;
114 . D SET(IBXRF1,"FS Phys/Add 00 "_IBUT,IBITEM,IBEFF,IBINA,IBCHRG,IBMOD)
115 ;
116 K ^TMP($J,IBTMPX)
117 Q
118 ;
119 ;
120 ;
121SET(IBXRF1,IBXRF2,ITEM,EFFDT,INACTDT,CHRG,MOD) ; set calculated charges into XTMP
122 ;
123 N IBX,IBK,IBY,IBINACT,IBMODI S IBMODI=""
124 S IBX=$G(^XTMP(IBXRF1,0))
125 ;
126 I IBX="" W !!,"ERROR: IBXRF1 NOT SET ",IBXRF1,!! Q
127 I '$D(^XTMP(IBXRF1,IBXRF2)) W !!,"ERROR: IBXRF2 NOT SET ",IBXRF2,!! Q
128 ;
129 S IBK=+$P(IBX,U,4)+1,$P(^XTMP(IBXRF1,0),U,4)=IBK
130 S $P(^XTMP(IBXRF1,IBXRF2),U,1)=(+$G(^XTMP(IBXRF1,IBXRF2))+1)
131 ;
132 I $G(MOD)'="" S IBY=$$MODIFN(MOD,EFFDT) I +IBY>0 S IBMODI=+IBY
133 ;
134 S ^XTMP(IBXRF1,IBXRF2,IBK)=ITEM_U_$$DATE(EFFDT)_U_$$ENDDT(INACTDT)_U_+CHRG_U_IBMODI_U_$P(CHRG,U,2)
135 ;
136 I $E(IBXRF2,1,7)="FS Phys" S MOD=$S(MOD="":"00",1:MOD),^TMP($J,"IBCR UPLOAD FS PROF",ITEM,MOD,IBK)=IBXRF2
137 Q
138 ;
139 ;
140DATE(X) ; return yyyymmdd in FM format
141 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)
142 Q Y
143 ;
144ENDDT(X) ; return yyyymmdd date in FM format, check version inactive date
145 N Y,V S Y=$$DATE($G(X)) I 'Y S V=$G(^XTMP("IBCR RC SITE","VERSION INACTIVE")) I +V S Y=V
146 Q Y
147 ;
148MODIFN(MOD,EFFDT) ; return internal form of modifier
149 ; extra check is required because there are two RR modifiers so MOD will not return any
150 ; base the get on a CPT code for which RR is known to be a valid modifier
151 N IBY,IBX S (IBX,IBY)="" S EFFDT=$$DATE($G(EFFDT)) I 'EFFDT S EFFDT=DT
152 I $G(MOD)'="" S IBY=$$MOD^ICPTMOD(MOD,"E",EFFDT)
153 I IBY<0,$G(MOD)="RR" S IBY=$$MODP^ICPTMOD("K0455","RR","E",EFFDT)
154 I IBY>0 S IBX=+IBY
155 Q IBX
156 ;
157 ;
158INPHYS(IBCPT,UNITYPE) ; returns string of all modifiers associated with Physician charges for CPT and Unit Type
159 ; if charge exists but it has no modifier then uses 00, so if CPT has no charge then returns null
160 ; if a charge is found for the CPT but it has a different Unit Type then -1 is returned
161 ; note: if no freestanding physician charge then can add opt facility charge as physician charge
162 ; note: if only a freestanding 26 physician charge then can add the opt facility charge as TC physician charge (same unit type)
163 ;
164 N MOD,MODS,IBX,IBY S MODS=""
165 ;
166 S IBX="" F S IBX=$O(^XTMP("IBCR RC C","A",IBCPT,IBX)) Q:IBX="" D
167 . S IBY=^XTMP("IBCR RC C",IBX) I $P(IBY,U,16)'=UNITYPE S MODS=-1 Q
168 . S MOD=$P(IBY,U,4) I MOD="" S MOD="00"
169 . S MODS=MODS_MOD
170 Q MODS
171 ;
172INFAC(IBCPT) ; check if the CPT code has a charge in the Opt Facility file (table B)
173 ; return true if CPT code has a Opt Facility Charge
174 N IBX S IBX=0 I $O(^XTMP("IBCR RC B","A",IBCPT,"")) S IBX=1
175 Q IBX
176 ;
177UNITYPE(IBXRF2) ; return unit type of group of charges last piece of IBXRF2
178 N IBX,IBY,IBZ S IBX=""
179 S IBY=$L(IBXRF2),IBZ=$E(IBXRF2,IBY) I IBZ>0,IBZ<5 S IBX=IBZ
180 Q IBX
Note: See TracBrowser for help on using the repository browser.