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

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

initial load of WorldVistAEHR
File size: 7.0 KB
Line 
1IBCRHBS6 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS SETUP ; 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 ;
5INPT(IBSITE,IBXRF1) ; Create Charge Sets for Inpatient and SNF Charges
6 N IBRG,IBDIVN,IBEVNT,IBBS,TYPE
7 W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Inpatient and SNF Charges"
8 ;
9 ; set billing region
10 S IBRG=$$RG^IBCRHU2("RC "_$P(IBSITE,U,2)_" - "_$P(IBSITE,U,3),$P(IBSITE,U,2),$P(IBSITE,U,4),$P(IBSITE,U,5))
11 S IBRG=$P(IBRG,U,2),IBDIVN=$P(IBSITE,U,2)
12 ;
13 S TYPE=$P(IBSITE,U,5) Q:TYPE'=1
14 ;
15 ;
16 ; Inpatient Facility Per Diem Charges from Table A (DRG Based)
17 S IBEVNT="INPATIENT DRG",IBBS="GENERAL MEDICAL CARE" ; Inpatient Standard DRG Charges
18 D SETUP(IBXRF1,"Inpt PD R&B","RC-INPT R&B","RC INPATIENT FACILITY",IBDIVN,4,IBEVNT,IBRG,"INST",101,IBBS)
19 D SETUP(IBXRF1,"Inpt PD Anc","RC-INPT ANC","RC INPATIENT FACILITY",IBDIVN,4,IBEVNT,IBRG,"INST",240,IBBS)
20 ;
21 S IBEVNT="INPATIENT DRG",IBBS="ICU" ; Inpatient ICU DRG Charges
22 D SETUP(IBXRF1,"Inpt PD R&B ICU","RC-INPT R&B ICU","RC INPATIENT FACILITY",IBDIVN,4,IBEVNT,IBRG,"INST",200,IBBS)
23 D SETUP(IBXRF1,"Inpt PD Anc ICU","RC-INPT ANC ICU","RC INPATIENT FACILITY",IBDIVN,4,IBEVNT,IBRG,"INST",240,IBBS)
24 ;
25 S IBEVNT="INPATIENT BEDSECTION STAY",IBBS="SKILLED NURSING/SUB-ACUTE CARE" ; Inpatient SNF Charges
26 D SETUP(IBXRF1,"SNF PD INC","RC-SNF INC","RC FACILITY PER DIEM",IBDIVN,1,IBEVNT,IBRG,"INST",101,IBBS)
27 ;
28 ;
29 ; Inpatient Facility Charges from Table B (CPT Based)
30 S IBEVNT="PROCEDURE",IBBS="GENERAL MEDICAL CARE" ; Inpatient Facility Charges
31 D SETUP(IBXRF1,"Inpt Fac 1","RC-INPT FAC PR","RC FACILITY PR",IBDIVN,2,IBEVNT,IBRG,"INST",240,IBBS)
32 D SETUP(IBXRF1,"Inpt Fac 2","RC-INPT FAC HR","RC FACILITY HR",IBDIVN,2,IBEVNT,IBRG,"INST",240,IBBS)
33 D SETUP(IBXRF1,"Inpt Fac 4","RC-INPT FAC ML","RC FACILITY ML",IBDIVN,2,IBEVNT,IBRG,"INST",240,IBBS)
34 ;
35 S IBEVNT="PROCEDURE",IBBS="SKILLED NURSING/SUB-ACUTE CARE" ; SNF Facility Charges
36 D SETUP(IBXRF1,"SNF Fac 1","RC-SNF FAC PR","RC FACILITY PR",IBDIVN,2,IBEVNT,IBRG,"INST",240,IBBS)
37 D SETUP(IBXRF1,"SNF Fac 2","RC-SNF FAC HR","RC FACILITY HR",IBDIVN,2,IBEVNT,IBRG,"INST",240,IBBS)
38 D SETUP(IBXRF1,"SNF Fac 4","RC-SNF FAC ML","RC FACILITY ML",IBDIVN,2,IBEVNT,IBRG,"INST",240,IBBS)
39 ;
40 ;
41 ; Inpatient Facility Charges from Table C (CPT Based)
42 S IBEVNT="PROCEDURE",IBBS="GENERAL MEDICAL CARE" ; Inpatient Facility CPT Charges
43 D SETUP(IBXRF1,"Inpt Fac/Phys 1","RC-INPT FAC PR","RC FACILITY PR",IBDIVN,2,IBEVNT,IBRG,"INST",240,IBBS)
44 ;
45 S IBEVNT="PROCEDURE",IBBS="SKILLED NURSING/SUB-ACUTE CARE" ; SNF Facility CPT Charges
46 D SETUP(IBXRF1,"SNF Fac/Phys 1","RC-SNF FAC PR","RC FACILITY PR",IBDIVN,2,IBEVNT,IBRG,"INST",240,IBBS)
47 ;
48 ;
49 ; Inpatient Physician Charges from Table C (CPT Based)
50 S IBEVNT="PROCEDURE",IBBS="GENERAL MEDICAL CARE" ; Inpatient Professional CPT Charges
51 D SETUP(IBXRF1,"Inpt Phys 1","RC-PHYSICIAN INPT PR","RC PHYSICIAN PR",IBDIVN,2,IBEVNT,IBRG,"PROF",960,IBBS)
52 D SETUP(IBXRF1,"Inpt Phys 3","RC-PHYSICIAN INPT MN","RC PHYSICIAN MN",IBDIVN,2,IBEVNT,IBRG,"PROF",960,IBBS)
53 ;
54 S IBEVNT="PROCEDURE",IBBS="SKILLED NURSING/SUB-ACUTE CARE" ; SNF Professional CPT Charges
55 D SETUP(IBXRF1,"SNF Phys 1","RC-PHYSICIAN SNF PR","RC PHYSICIAN PR",IBDIVN,2,IBEVNT,IBRG,"PROF",960,IBBS)
56 D SETUP(IBXRF1,"SNF Phys 3","RC-PHYSICIAN SNF MN","RC PHYSICIAN MN",IBDIVN,2,IBEVNT,IBRG,"PROF",960,IBBS)
57 ;
58 Q
59 ;
60 ;
61OPT(IBSITE,IBXRF1) ; Create Charge Sets for Outpatient Facilities (CPT based and Partial Hospitalization)
62 N IBRG,IBDIVN,IBEVNT,IBBS,TYPE
63 W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Outpatient Charges"
64 ;
65 ; set billing region
66 S IBRG=$$RG^IBCRHU2("RC "_$P(IBSITE,U,2)_" - "_$P(IBSITE,U,3),$P(IBSITE,U,2),$P(IBSITE,U,4),$P(IBSITE,U,5))
67 S IBRG=$P(IBRG,U,2),IBDIVN=$P(IBSITE,U,2)
68 ;
69 S TYPE=$P(IBSITE,U,5) Q:TYPE'<3
70 ;
71 ;
72 ; Outpatient Facility Charges from Table B (CPT Based)
73 S IBEVNT="PROCEDURE",IBBS="OUTPATIENT VISIT" ; Outpatient Facility CPT Charges
74 D SETUP(IBXRF1,"Opt Fac 1","RC-OPT FAC PR","RC FACILITY PR",IBDIVN,2,IBEVNT,IBRG,"INST",510,IBBS)
75 D SETUP(IBXRF1,"Opt Fac 2","RC-OPT FAC HR","RC FACILITY HR",IBDIVN,2,IBEVNT,IBRG,"INST",510,IBBS)
76 D SETUP(IBXRF1,"Opt Fac 4","RC-OPT FAC ML","RC FACILITY ML",IBDIVN,2,IBEVNT,IBRG,"INST",510,IBBS)
77 ;
78 S IBEVNT="UNASSOCIATED",IBBS="PARTIAL HOSPITALIZATION" ; Partial Hospitalization Facility Per Diem Charge
79 D SETUP(IBXRF1,"Opt PD PHosp","RC-OPT MISC","RC MISCELLANEOUS",IBDIVN,9,IBEVNT,IBRG,"INST",912,IBBS)
80 ;
81 ;
82 ; Outpatient Facility Charges from Table C (CPT Based)
83 S IBEVNT="PROCEDURE",IBBS="OUTPATIENT VISIT" ; Outpatient Facility CPT Charges
84 D SETUP(IBXRF1,"Opt Fac/Phys 1","RC-OPT FAC PR","RC FACILITY PR",IBDIVN,2,IBEVNT,IBRG,"INST",510,IBBS)
85 ;
86 ;
87 ; Outpatient Physician Charges from Table C (CPT Based)
88 S IBEVNT="PROCEDURE",IBBS="OUTPATIENT VISIT" ; Outpatient Professional CPT Charges
89 D SETUP(IBXRF1,"Opt Phys 1","RC-PHYSICIAN OPT PR","RC PHYSICIAN PR",IBDIVN,2,IBEVNT,IBRG,"PROF",510,IBBS)
90 D SETUP(IBXRF1,"Opt Phys 3","RC-PHYSICIAN OPT MN","RC PHYSICIAN MN",IBDIVN,2,IBEVNT,IBRG,"PROF",510,IBBS)
91 ;
92 Q
93 ;
94 ;
95FREE(IBSITE,IBXRF1) ; Create Charge Sets for Freestanding Facilities
96 N IBRG,IBDIVN,IBEVNT,IBBS,TYPE
97 W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Freestanding Charges"
98 ;
99 ; set billing region
100 S IBRG=$$RG^IBCRHU2("RC "_$P(IBSITE,U,2)_" - "_$P(IBSITE,U,3),$P(IBSITE,U,2),$P(IBSITE,U,4),$P(IBSITE,U,5))
101 S IBRG=$P(IBRG,U,2),IBDIVN=$P(IBSITE,U,2)
102 ;
103 S TYPE=$P(IBSITE,U,5) Q:TYPE'=3
104 ;
105 ;
106 ; Freestanding Physician Charges from Table C (CPT Based)
107 S IBEVNT="PROCEDURE",IBBS="OUTPATIENT VISIT" ; Freestanding Professional CPT Charges
108 D SETUP(IBXRF1,"FS Phys 1","RC-PHYSICIAN FS PR","RC PHYSICIAN PR",IBDIVN,2,IBEVNT,IBRG,"PROF",510,IBBS)
109 D SETUP(IBXRF1,"FS Phys 3","RC-PHYSICIAN FS MN","RC PHYSICIAN MN",IBDIVN,2,IBEVNT,IBRG,"PROF",510,IBBS)
110 ;
111 ;
112 ; Freestanding Physician Charges from Table B (CPT Based)
113 S IBEVNT="PROCEDURE",IBBS="OUTPATIENT VISIT" ; Freestanding Professional CPT Charges
114 D SETUP(IBXRF1,"FS Phys/Opt 1","RC-PHYSICIAN FS PR","RC PHYSICIAN PR",IBDIVN,2,IBEVNT,IBRG,"PROF",510,IBBS)
115 D SETUP(IBXRF1,"FS Phys/Opt 4","RC-PHYSICIAN FS ML","RC PHYSICIAN ML",IBDIVN,2,IBEVNT,IBRG,"PROF",510,IBBS)
116 D SETUP(IBXRF1,"FS Phys/Opt TC 1","RC-PHYSICIAN FS PR","RC PHYSICIAN PR",IBDIVN,2,IBEVNT,IBRG,"PROF",510,IBBS)
117 ;
118 ;
119 ; Freestanding Physician Global Charges from Table C (CPT Based, sum of TC and 26)
120 S IBEVNT="PROCEDURE",IBBS="OUTPATIENT VISIT" ; Freestanding Professional CPT Charges
121 D SETUP(IBXRF1,"FS Phys/Add 00 1","RC-PHYSICIAN FS PR","RC PHYSICIAN PR",IBDIVN,2,IBEVNT,IBRG,"PROF",510,IBBS)
122 ;
123 Q
124 ;
125 ;
126SETUP(IBXRF1,IBXRF2,CSNM,BRATE,DIVN,BITEM,EVNT,RG,CHGTYP,RVCD,BS) ; Set up XTMP array and Charge Set for Charges
127 N IBCS
128 ;
129 S IBCS=$$CS^IBCRHU2(CSNM_" "_DIVN,BRATE,EVNT,RG,CHGTYP,RVCD,BS)
130 ;
131 D SETHDR(IBXRF1,IBXRF2,IBCS,BITEM)
132 ;
133 Q
134 ;
135SETHDR(IBXRF1,IBXRF2,CS,BITYPE) ; set up header for XTMP file
136 N IBX
137 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)
138 S ^XTMP(IBXRF1,0)=$$FMADD^XLFDT(DT,2)_U_DT_U_IBX
139 ;
140 S ^XTMP(IBXRF1,IBXRF2)=0_U_$G(BITYPE)_U_$G(CS)
141 Q
Note: See TracBrowser for help on using the repository browser.