source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBEECPT.m@ 1006

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

initial load of WorldVistAEHR

File size: 9.5 KB
Line 
1LRBEECPT ;DALOI/JAH - Edit CPT associated with CIDC; 3/29/05
2 ;;5.2;LAB SERVICES;**291**;Sep 27, 1994
3 ;
4 ; To be able to provide a clean claim to the billing application, there
5 ; needs be an association between the test, the specimen, and the
6 ; CPT/HCPCS codes. This routine is designed to allow the user to define
7 ; this associaton.
8 ;
9 ; Reference to EN^DDIOL supported by IA #10142
10 ; Reference to ^DIC supported by IA #10006
11 ; Reference to $$GET1^DIQ supported by IA #2056
12 ; Reference to ^DIR supported by IA #10026
13 ; Reference to $$CPT^ICPTCOD Supported by DBIA #1995-A
14 ;
15STRT ; Start the routine
16 N DIC,DIR,X,Y,LRBEY,LRBEQUIT,LRBEPNL
17 N LRBEAR,LRBEAR2,LRBEARP,LRBETST,LRBETSTN,LRBEMSG
18 S LRBEQUIT=0
19 F D Q:LRBEQUIT
20 .D TST S:Y<1 LRBEQUIT=1 Q:LRBEQUIT
21 .D EN^DDIOL("","","!")
22 .S DIR(0)="E" D ^DIR S:Y<1 LRBEQUIT=1
23 .D EN^DDIOL("","","!")
24 .D KLL
25 Q
26TST ; Ask the user for the test to work on.
27 S DIC="^LAB(60,",DIC(0)="AEMQZ" D ^DIC
28 I Y=-1 K DIC Q ;quit if look-up fails
29 S LRBEPNL=0
30 I $P(Y(0),"^",5)="" S LRBEPNL=1 ;Selected test is a panel
31 S LRBEY=Y D WORK(LRBEY) Q:LRBEQUIT
32 Q
33WORK(LRBEY) ; Start getting the CPT/HCPCS Codes
34 S LRBETST=$P(LRBEY,U,1),LRBETSTN=$P(LRBEY,U,2)
35 S LRBEAR2("TEST",LRBETST)=LRBEY
36 W ! D SPEC(LRBETST) Q:LRBEQUIT
37 W ! D DEFH(LRBETST,LRBETSTN) Q:LRBEQUIT
38 W ! D DEFC(LRBETST,LRBETSTN) Q:LRBEQUIT
39 I LRBEPNL D Q:LRBEQUIT
40 .W ! D AAMA^LRBEECP1(LRBETST,LRBETSTN)
41 D DISCPT(.LRBEAR2) Q:LRBEQUIT
42 Q
43SPEC(LRBETST) ; Get the Specimen and CPT of the Test
44 N A,LRBEAX,LRBESP,LRBESPI,LRBESPE,LRBECPT,LRBEFIL,LRBEFLD,LRBEDT,LRBEMSG
45 N LRBEQT,LRBEXMSG,LRBEDCPT,LRX,LRBEDESC
46 D SAR(LRBETST,.LRX)
47 S A="" F S A=$O(LRX(60.196,A)) Q:A=""!(LRBEQUIT) D
48 .S LRBESP=$O(LRX(60.196,A,""),-1)
49 .S LRBESPI=$P(A,",",1)
50 .S LRBESPE=$P($G(LRX(60.196,A,LRBESP)),"^",1)
51 .S LRBEDCPT=$P($G(LRX(60.196,A,LRBESP)),"^",2)
52 .S LRBEQT=0 F D Q:LRBEQT!(LRBEQUIT)
53 ..S LRBEMSG="Enter a CPT for a "_LRBESPE_" specimen: "
54 ..S LRBECPT=$$ACPT(LRBEMSG,LRBEDCPT) Q:LRBEQUIT
55 ..I LRBEDCPT="",LRBECPT="@" D WMSG("","ND") Q
56 ..I LRBECPT=LRBEDCPT S LRBEQT=1 Q:LRBEQT
57 ..S:LRBECPT="" LRBEQT=1 Q:LRBEQT
58 ..I $P(LRBECPT,U,1)="@" D Q
59 ...S LRBEDESC=$$GET1^DIQ(81,LRBEDCPT_",",2)
60 ...S LRBECPT=LRBECPT_"^"_LRBEDCPT_"^"_LRBEDESC_"^"
61 ...S LRBECPT=LRBECPT_LRBESP_","_LRBESPI_","_LRBETST_","
62 ...S LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI)=LRBECPT,LRBEQT=1
63 ...S $P(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI,"S"),U,1)=LRBESPE
64 ..S LRBEDT=$$ADAT("TODAY") Q:LRBEQUIT
65 ..S LRBEAX=$$GCPT(LRBECPT,LRBEDT) Q:LRBEQUIT
66 ..I +LRBEAX=-1 D WMSG($P(LRBEAX,U,2),"IV") Q
67 ..I $P(LRBEAX,U,7)'=1 D WMSG("INACTIVE","IA") Q
68 ..D WMSG($P(LRBEAX,U,3),"V")
69 ..S $P(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI),U,1)=LRBEAX,LRBEQT=1
70 ..S LRBEAX=LRBESPE_"^"_LRBEDT
71 ..S $P(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI,"S"),U,1)=LRBESPE
72 ..S $P(LRBEAR2("TEST",LRBETST,"00-SPECIMEN",LRBESPI,"D"),U,1)=LRBEDT
73 Q
74DEFH(LRBETST,LRBETSTN) ; Get the Default HCPCS
75 N LRBEAX,LRBEQT
76 S LRBEQT=0 F D Q:LRBEQT!(LRBEQUIT)
77 .S LRBEAX=$$DHCPCS(LRBETST,LRBETSTN)
78 .S:LRBEAX="" LRBEQT=1 Q:LRBEQT!(LRBEQUIT)
79 .I +LRBEAX=-3 D WMSG("","ND") Q
80 .I $P(LRBEAX,U,1)="@" D Q
81 ..S LRBEAR2("TEST",LRBETST,"01-DEFAULT HCPCS")=LRBEAX,LRBEQT=1
82 .I +LRBEAX=-2 S LRBEQT=1 Q:LRBEQT
83 .I +LRBEAX=-1 D WMSG($P(LRBEAX,U,2),"IV") Q
84 .I $P(LRBEAX,U,7)'=1 D WMSG("INACTIVE","IA") Q
85 .D WMSG($P(LRBEAX,U,3),"V")
86 .S LRBEAR2("TEST",LRBETST,"01-DEFAULT HCPCS")=LRBEAX,LRBEQT=1
87 Q
88DHCPCS(LRBETST,LRBETSTN) ; Get the Default HCPCS code of the Test
89 N LRBECPT,LRBEDCPT,LRBEDT,LRBEMSG,LRBEFIL,LRBEFLD,LRBEQT,LRBEDESC
90 S LRBEMSG="Enter a HCPCS code for "_LRBETSTN_": "
91 S LRBEFIL=60,LRBEFLD=507
92 S LRBEDCPT=$$GET1^DIQ(LRBEFIL,LRBETST_",",LRBEFLD)
93 S LRBECPT=$$ACPT(LRBEMSG,LRBEDCPT) Q:LRBEQUIT LRBEQUIT
94 I LRBECPT="" Q LRBECPT
95 I LRBEDCPT="",LRBECPT="@" Q -3
96 I LRBECPT="@" D Q LRBECPT
97 .S LRBEDESC=$$GET1^DIQ(81,LRBEDCPT_",",2)
98 .S LRBECPT=LRBECPT_"^"_LRBEDCPT_"^"_LRBEDESC
99 I LRBECPT=LRBEDCPT Q -2
100 S LRBEDT=$$ADAT("TODAY") Q:LRBEQUIT LRBEQUIT
101 S $P(LRBEAR2("TEST",LRBETST,"01-DEFAULT HCPCS","D"),U,1)=LRBEDT
102 Q $$GCPT(LRBECPT,LRBEDT)
103DEFC(LRBETST,LRBETSTN) ; Get the Default CPT
104 N LRBEAX,LRBEQT
105 S LRBEQT=0 F D Q:LRBEQT!(LRBEQUIT)
106 .S LRBEAX=$$DCPT(LRBETST,LRBETSTN)
107 .S:LRBEAX="" LRBEQT=1 Q:LRBEQT!(LRBEQUIT)
108 .I +LRBEAX=-3 D WMSG("","ND") Q
109 .I $P(LRBEAX,U,1)="@" D Q
110 ..S LRBEAR2("TEST",LRBETST,"02-DEFAULT CPT")=LRBEAX,LRBEQT=1
111 .I +LRBEAX=-2 S LRBEQT=1 Q:LRBEQT
112 .I +LRBEAX=-1 D WMSG($P(LRBEAX,U,2),"IV") Q
113 .I $P(LRBEAX,U,7)'=1 D WMSG("INACTIVE","IA") Q
114 .D WMSG($P(LRBEAX,U,3),"V")
115 .S LRBEAR2("TEST",LRBETST,"02-DEFAULT CPT")=LRBEAX,LRBEQT=1
116 Q
117DCPT(LRBETST,LRBETSTN) ; Get the Default CPT code of the Test
118 N LRBECPT,LRBEDCPT,LRBEDT,LRBEMSG,LRBEFIL,LRBEFLD,LRBEQT,LRBEDESC
119 S LRBEMSG="Enter a Default CPT code for "_LRBETSTN_": "
120 S LRBEFIL=60,LRBEFLD=506
121 S LRBEDCPT=$$GET1^DIQ(LRBEFIL,LRBETST_",",LRBEFLD)
122 S LRBECPT=$$RCPT(LRBEMSG,LRBEDCPT) Q:LRBEQUIT LRBEQUIT
123 I LRBECPT="" Q LRBECPT
124 I LRBEDCPT="",LRBECPT="@" Q -3
125 I LRBECPT="@" D Q LRBECPT
126 .S LRBEDESC=$$GET1^DIQ(81,LRBEDCPT_",",2)
127 .S LRBECPT=LRBECPT_"^"_LRBEDCPT_"^"_LRBEDESC
128 I LRBECPT=LRBEDCPT Q -2
129 S LRBEDT=$$ADAT("TODAY") Q:LRBEQUIT LRBEQUIT
130 S $P(LRBEAR2("TEST",LRBETST,"02-DEFAULT CPT","D"),U,1)=LRBEDT
131 Q $$GCPT(LRBECPT,LRBEDT)
132ACPT(LRBEMSG,DCPT) ; Ask for CPT/HCPCS Code
133 N X,Y,DIR,DUOUT,DTOUT,DIRUT
134 S DIR("B")=DCPT
135 S DIR("A")=LRBEMSG,DIR(0)="FAUO^3:10" D ^DIR
136 I $D(DTOUT)!($D(DUOUT))!(X[U) S LRBEQUIT=1 Q LRBEQUIT
137 I Y?1A.4N Q Y
138 I X="@" Q X
139 S:Y<1 Y=""
140 Q Y
141ADAT(LRBEMSG) ; Ask for date
142 N X,Y,DIR,DUOUT,DTOUT,DIRUT
143 D NOW^%DTC
144 S DIR(0)="DAO^"_X_"::E",DIR("B")=LRBEMSG
145 S DIR("A")="Enter Date to be Checked: "
146 D ^DIR I $D(DTOUT)!($D(DUOUT)) S Y=-1,LRBEQUIT=1
147 Q Y_"."_$P(%,".",2)
148RCPT(LRBEMSG,DCPT) ; Ask for Required default CPT/HCPCS Code
149 N X,Y,DIR,DUOUT,DTOUT,DIRUT
150 S DIR("B")=DCPT
151 S DIR("A")=LRBEMSG,DIR(0)="FAUO^3:10" D ^DIR
152 I $D(DTOUT)!($D(DUOUT))!(X[U) S LRBEQUIT=1 Q LRBEQUIT
153 I X="@" Q X
154 S:Y<1 Y=""
155 Q Y
156GCPT(CPT,TDAT) ; Get the CPT/HCPCS Code
157 Q $$CPT^ICPTCOD(CPT,TDAT)
158DISCPT(LRBEAR2) ; Display the CPT code in File #60
159 N LRBEAX,LRBEALO,LRBEBX,DIR,LRBEQT,X,Y
160 S LRBEQT=0 D EN^DDIOL("","","!!")
161 S LRBEAX="" F S LRBEAX=$O(LRBEAR2("TEST",LRBEAX)) Q:LRBEAX=""!(LRBEQT) D
162 .I $D(LRBEAR2("TEST",LRBEAX))'=11 S LRBEQT=1 Q:LRBEQT
163 .S LRBEALO=1
164 .D EN^DDIOL("TEST:","","")
165 .D EN^DDIOL($E($P(LRBEAR2("TEST",LRBEAX),U,2),1,30),"","?10")
166 .S LRBEBX="" F S LRBEBX=$O(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX)) Q:LRBEBX="" D
167 ..S X=$G(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX)) Q:X=""
168 ..S Y=$G(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX,"S"))
169 ..D:LRBEALO
170 ...D EN^DDIOL("SPECIMEN:","","!"),EN^DDIOL("","","!")
171 ..D EN^DDIOL($E(Y,1,15),"","?3")
172 ..D EN^DDIOL($E($P(X,U,3),1,35),"","?20")
173 ..D EN^DDIOL($S($P(X,U,1)="@":$P(X,U,2)_" (DELETE)",1:$P(X,U,1)),"","?60")
174 ..D EN^DDIOL("","","!") S LRBEALO=0
175 .S X=$G(LRBEAR2("TEST",LRBEAX,"01-DEFAULT HCPCS"))
176 .D:X'=""
177 ..D EN^DDIOL("HCPCS:","","")
178 ..D EN^DDIOL($E($P(X,U,3),1,35),"","?20")
179 ..D EN^DDIOL($S($P(X,U,1)="@":$P(X,U,2)_" (DELETE)",1:$P(X,U,1)),"","?60")
180 ..D EN^DDIOL("","","!")
181 .S X=$G(LRBEAR2("TEST",LRBEAX,"02-DEFAULT CPT"))
182 .D:X'=""
183 ..D EN^DDIOL("Default CPT:","","")
184 ..D EN^DDIOL($E($P(X,U,3),1,35),"","?20")
185 ..D EN^DDIOL($S($P(X,U,1)="@":$P(X,U,2)_" (DELETE)",1:$P(X,U,1)),"","?60")
186 ..D EN^DDIOL("","","!")
187 .S X=$G(LRBEAR2("TEST",LRBEAX,"03-AMA FLAG"))
188 .D:X'=""
189 ..D EN^DDIOL("Panel CPT(S) AMA compliant or otherwise billable?:","","")
190 ..D EN^DDIOL($S(X=1:"YES",1:"NO"),"","?60")
191 ..D EN^DDIOL("","","!")
192 Q:LRBEQT
193 S DIR("A")="Is this correct",DIR(0)="Y",DIR("B")="YES" D ^DIR
194 I Y D SCPT(.LRBEAR2)
195 Q
196SCPT(LRBEAR2) ; Set the CPT code in File #60
197 N LRBEAX,LRBEBX,LRBEFIL1,LRBEFIL2,LRERR,LRFDA,LRBESEQ,LRBEX,LRBEXX
198 N LRBEXIEN,LRBEDEL
199 S LRBEFIL1=60,LRBEFIL2=60.196
200 S LRBEAX="" F S LRBEAX=$O(LRBEAR2("TEST",LRBEAX)) Q:LRBEAX="" D
201 .S LRBEX=$G(LRBEAR2("TEST",LRBEAX,"01-DEFAULT HCPCS"))
202 .S:LRBEX'="" LRFDA(99,LRBEFIL1,LRBEAX_",",507)=$P(LRBEX,U,1)
203 .S LRBEX=$G(LRBEAR2("TEST",LRBEAX,"02-DEFAULT CPT"))
204 .S:LRBEX'="" LRFDA(99,LRBEFIL1,LRBEAX_",",506)=$P(LRBEX,U,1)
205 .S LRBEX=$G(LRBEAR2("TEST",LRBEAX,"03-AMA FLAG"))
206 .S:LRBEX'="" LRFDA(99,LRBEFIL1,LRBEAX_",",508)=$P(LRBEX,U)
207 .S LRBEBX=""
208 .F S LRBEBX=$O(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX)) Q:LRBEBX="" D
209 ..S LRBEX=$G(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX))
210 ..S LRBEDEL=$S($P(LRBEX,U)="@":1,1:0)
211 ..I LRBEDEL D
212 ...S LRBEXIEN=$P(LRBEX,U,4),LRFDAIEN=""
213 ..I 'LRBEDEL D
214 ...S LRBESEQ=$O(^LAB(60,LRBEAX,1,LRBEBX,3,"A"),-1)+1
215 ...S LRBETNUM=$G(LRBETNUM)+1
216 ...S LRBEXIEN="+"_LRBETNUM_","_LRBEBX_","_LRBEAX_","
217 ...S LRFDAIEN(LRBETNUM)=LRBESEQ
218 ...S LRBEXX=$G(LRBEAR2("TEST",LRBEAX,"00-SPECIMEN",LRBEBX,"D"))
219 ..S LRFDA(99,LRBEFIL2,LRBEXIEN,.01)=$P(LRBEX,U,1)
220 ..S:'LRBEDEL LRFDA(99,LRBEFIL2,LRBEXIEN,1)=$P(LRBEXX,U,1)
221 D UPDATE^DIE("","LRFDA(99)","LRFDAIEN","LRERR")
222 Q
223SAR(LRBETST,LRBEAR2) ; Setup Array for Specimen
224 N A,B,LRBEAR,LRBETNAM,LRBETNUM,LRBETCPT
225 D GETS^DIQ(60,LRBETST_",","100*","","LRBEAR")
226 S A="" F S A=$O(LRBEAR(60.01,A)) Q:A="" D
227 .S LRBETNUM=1,LRBETCPT="",LRBETNAM=$P(LRBEAR(60.01,A,.01),U,1)
228 .S B="" F S B=$O(LRBEAR(60.196,B)) Q:B="" D
229 ..Q:A'=$P(B,",",2,4)
230 ..S LRBETNUM=$P(B,",",1),LRBETCPT=$G(LRBEAR(60.196,B,.01))
231 .S LRBEAR2(60.196,$P(A,",",1),LRBETNUM)=LRBETNAM_"^"_LRBETCPT
232 Q
233WMSG(LRBEDESC,LRBEFLG) ; Write Message
234 N LRBEXMSG
235 S:LRBEFLG="ND" LRBEXMSG="NOTHING TO DELETE"
236 S:LRBEFLG="IV" LRBEXMSG="INVALID CPT: "_LRBEDESC
237 S:LRBEFLG="IA" LRBEXMSG="INACTIVE CPT: NOT ACTIVE FOR THIS DATE"
238 S:LRBEFLG="V" LRBEXMSG="VALID CPT: "_LRBEDESC
239 D EN^DDIOL(LRBEXMSG,"","!?$X+5")
240 Q
241KLL ; Kill all variable
242 K LRBEAX,DIC,DIR,LRBEQT,X,Y
243 K LRBEAR,LRBEAR2,LRBEARP,LRBETST,LRBETSTN,LRBEMSG
244 Q
Note: See TracBrowser for help on using the repository browser.