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

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

initial load of WorldVistAEHR
File size: 6.4 KB
Line 
1IBYPSA1 ;ALB/ARH - IB*2.0*245 POST INIT: REASONABLE CHARGES V2.0 CONT; 10-OCT-2003
2 ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6 Q
7 ;
8ADDRB ; Add Billable Service (399.1, .2=1)
9 N IBA,IBCNT,IBI,IBLN,IBFN,IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
10 ;
11 F IBI=1:1 S IBLN=$P($T(RBF+IBI),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D
12 . ;
13 . I +$$MCCRUTL($P(IBLN,U,1),13) Q
14 . ;
15 . K DD,DO S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
16 . S IBFN=+Y,IBCNT=IBCNT+1
17 . ;
18 . S DR=".03////"_$P(IBLN,U,2)_";.2////"_1
19 . S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
20 . ;
21 . S IBA(IBCNT+1)=" "_$P(IBLN,U,1)
22 ;
23RBQ S IBA(1)=" >> "_IBCNT_" Billable Services added (399.1)..."
24 D MES^XPDUTL(.IBA)
25 Q
26 ;
27ADDBS ; Add Bedsection (399.1, .12=1)
28 N IBA,IBCNT,IBI,IBLN,IBRB,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
29 ;
30 F IBI=1:1 S IBLN=$P($T(BSF+IBI),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D
31 . ;
32 . I +$$MCCRUTL($P(IBLN,U,1),5) Q
33 . ;
34 . S IBRB=$P(IBLN,U,3) I IBRB'="" S IBRB=$$MCCRUTL(IBRB,13) D Q:'IBRB
35 .. I 'IBRB D MSG(" *** Billable Service "_$P(IBLN,U,3)_" not defined, BS "_$P(IBLN,U,1)_" not created")
36 . ;
37 . K DD,DO S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
38 . S IBFN=+Y,IBCNT=IBCNT+1
39 . ;
40 . S DR=".03////"_$P(IBLN,U,2)_";.12////"_1 I +IBRB S DR=DR_";.25////"_IBRB
41 . S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
42 . ;
43 . S IBA(IBCNT+1)=" "_$P(IBLN,U,1)
44 ;
45BSQ S IBA(1)=" >> "_IBCNT_" Bedsection added (399.1)..."
46 D MES^XPDUTL(.IBA)
47 Q
48 ;
49ADDBI ; Add Billing Items (363.21)
50 N IBA,IBCNT,IBI,IBLN,IBFN,IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
51 ;
52 F IBI=1:1 S IBLN=$P($T(BIF+IBI),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D
53 . ;
54 . S IBX=$O(^IBA(363.21,"B",$P(IBLN,U,1),0)) I +IBX,$P($G(^IBA(363.21,IBX,0)),U,2)=$P(IBLN,U,2) Q
55 . ;
56 . S DIC("DR")=".02////"_$P(IBLN,U,2)
57 . K DD,DO S DLAYGO=363.21,DIC="^IBA(363.21,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC,DLAYGO I Y<1 K X,Y Q
58 . S IBFN=+Y,IBCNT=IBCNT+1
59 . ;
60 . S IBA(IBCNT+1)=" "_$P(IBLN,U,1)
61 ;
62BIQ S IBA(1)=" >> "_IBCNT_" Billing Items added (363.21)..."
63 D MES^XPDUTL(.IBA)
64 Q
65ADDBR ; Add Billing Rates (363.3)
66 N IBA,IBCNT,IBI,IBJ,IBBR,IBLN,IBFN,DD,DO,DINUM,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
67 ;
68 F IBI=1:1 S IBLN=$P($T(BRF+IBI),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D
69 . ;
70 . I $O(^IBE(363.3,"B",$P(IBLN,U,1),0)) Q
71 . ;
72 . F IBJ=1:1 S IBBR=$G(^IBE(363.3,IBJ,0)) I IBBR="" S DINUM=IBJ Q
73 . ;
74 . K DD,DO S DLAYGO=363.3,DIC="^IBE(363.3,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
75 . S IBFN=+Y,IBCNT=IBCNT+1
76 . ;
77 . S DR=".02////"_$P(IBLN,U,2)_";.03////"_$P(IBLN,U,3)_";.04////"_$P(IBLN,U,4)_";.05////"_$P(IBLN,U,5)_";.06////"_$P(IBLN,U,6)
78 . S DIE="^IBE(363.3,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
79 . ;
80 . S IBA(IBCNT+1)=" "_$P(IBLN,U,1)
81 ;
82BRQ S IBA(1)=" >> "_IBCNT_" Billing Rates added (363.3)..."
83 D MES^XPDUTL(.IBA)
84 Q
85 ;
86ADDRS ; add Rate Schedules (363) for Reasonable Charges, if this is the first time the patch is installed
87 ; (charge sets will be added when rates are uploaded)
88 N IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBJ,IBLNCS,IBCS,IBCSFN,IBSTDT,IBRS,DINUM,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBSTDT="",IBCNT=0
89 ;
90 I $O(^IBE(363.3,"B","RC PHYSICIAN MN",0)) G RSQ
91 ;
92 S IBSTDT=$$VERSDT^IBCRHBRV(2) ;I '$$PROD^IBCORC S IBSTDT=2981001
93 ;
94 F IBI=1:1 S IBLN=$P($T(RSF+IBI),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D
95 . ;
96 . S IBBS=$P(IBLN,U,4) I IBBS'="" S IBBS=$$MCCRUTL(IBBS,13) D Q:'IBBS
97 .. I 'IBBS D MSG(" *** Billable Service "_$P(IBLN,U,4)_" not defined, RS "_$P(IBLN,U,1)_" not created")
98 . ;
99 . S IBRT=$P(IBLN,U,2),IBRT=$O(^DGCR(399.3,"B",IBRT,0)) D Q:'IBRT
100 .. I 'IBRT D MSG(" *** Rate Type "_$P(IBLN,U,2)_" not defined, RS "_$P(IBLN,U,1)_" not created")
101 .. I +$P($G(^DGCR(399.3,+IBRT,0)),U,3) S IBRT=0 D MSG(" *** Rate Type "_$P(IBLN,U,2)_" not Active, RS "_$P(IBLN,U,1)_" not created")
102 . ;
103 . F IBJ=1:1 S IBRS=$G(^IBE(363,IBJ,0)) I IBRS="" S DINUM=IBJ Q
104 . ;
105 . K DD,DO S DLAYGO=363,DIC="^IBE(363,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
106 . S IBFN=+Y,IBCNT=IBCNT+1
107 . ;
108 . S DR=".02////"_IBRT_";.03////"_$P(IBLN,U,3) S:+IBBS DR=DR_";.04////"_IBBS S DR=DR_";.05////"_IBSTDT
109 . S DIE="^IBE(363,",DA=+Y D ^DIE K DIE,DA,DR,X,Y
110 . ;
111 . ; charge sets (multiple)
112 . S IBLNCS=$P(IBLN,":",2,999) I IBLNCS'="" F IBJ=1:1 S IBCS=$P(IBLNCS,":",IBJ) Q:IBCS="" D
113 .. S IBCSFN=$O(^IBE(363.1,"B",IBCS,0)) Q:'IBCSFN
114 .. ;
115 .. S DLAYGO=363,DA(1)=+IBFN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L",X=IBCS,DIC("DR")=".02////"_1,DIC("P")="363.0011P" D ^DIC K DIC,DIE
116 ;
117RSQ S IBA(1)=" >> "_IBCNT_" Rate Schedules added, active on "_$E(IBSTDT,4,5)_"/"_$E(IBSTDT,6,7)_"/"_$E(IBSTDT,2,3)_" (363)..."
118 D MES^XPDUTL(.IBA)
119 Q
120 ;
121MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
122 N IBX,IBY S IBY=""
123 I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
124 Q IBY
125 ;
126MSG(X) ;
127 N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
128 S IBA(IBX)=$G(X)
129 Q
130 ;
131 ;
132RBF ; billable services (399.1,.2)
133 ;; name ^ abbreviation
134 ;;
135 ;;SKILLED NURSING^SNF
136 ;;
137 ;
138BSF ; Bedsections (399.1,.12)
139 ;; name ^ abbreviation ^ other care
140 ;;
141 ;;ICU^ICU
142 ;;PARTIAL HOSPITALIZATION^PARTIAL HOSP
143 ;;SKILLED NURSING CARE^SNF^SKILLED NURSING
144 ;;SUB-ACUTE CARE^SUBACUTE^SKILLED NURSING
145 ;;
146 ;
147BIF ; Billing Items (363.21)
148 ;; name ^ type
149 ;;
150 ;;PARTIAL HOSPITALIZATION^9
151 ;;
152BRF ; Billing Rates File (363.3)
153 ;; name ^ abbreviation ^ distribution ^ billable item ^ charge method ^ base allowed
154 ;;
155 ;;RC FACILITY PER DIEM^RC F/PD^1^1^1
156 ;;
157 ;;RC FACILITY HR^RC F/HR^1^2^6^1
158 ;;RC FACILITY ML^RC F/ML^1^2^4
159 ;;
160 ;;RC MISCELLANEOUS^RC MISC^1^9^1
161 ;;
162 ;;RC PHYSICIAN MN^RC P/MN^1^2^5^1
163 ;;RC PHYSICIAN ML^RC P/ML^1^2^4
164 ;;
165RSF ; Rate Schedules (363)
166 ;; rs name ^ rate type ^ bill type ^ billable service ^ effective date ^^ charge sets
167 ;;
168 ;;RI-INPT^REIMBURSABLE INS.^1^^
169 ;;RI-SNF^REIMBURSABLE INS.^1^SKILLED NURSING^
170 ;;RI-OPT^REIMBURSABLE INS.^3^^
171 ;;RI-RX^REIMBURSABLE INS.^3^^^^:TL-RX FILL
172 ;;
173 ;;NF-INPT^NO FAULT INS.^1^^
174 ;;NF-SNF^NO FAULT INS.^1^SKILLED NURSING^
175 ;;NF-OPT^NO FAULT INS.^3^^
176 ;;NF-RX^NO FAULT INS.^3^^^^:TL-RX FILL
177 ;;
178 ;;WC-INPT^WORKERS' COMP.^1^^
179 ;;WC-SNF^WORKERS' COMP.^1^SKILLED NURSING^
180 ;;WC-OPT^WORKERS' COMP.^3^^
181 ;;WC-RX^WORKERS' COMP.^3^^^^:TL-RX FILL
182 ;;
Note: See TracBrowser for help on using the repository browser.