source: FOIAVistA/trunk/r/SURGERY-SR/SROADX.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 8.3 KB
Line 
1SROADX ;BIR/RJS - ASSOCIATED DIAGNOSIS FOR CODER AND VERIFY SCREENS ;11/22/05
2 ;;3.0;Surgery;**119,150**;24 Jun 93
3CASDX ;Associate/Delete "Primary" CPT to Diagnosis from the CPT Coding menu.
4 N SRDX0,SRDX1,SRDX2,SROANS,SRODIR,SRDIRX,OTHCNT,SRASSDS
5 S S("OP")=^SRF(SRTN,"OP"),CPT=$P(S("OP"),U,2),SROPER=$P(S("OP"),U)
6 Q:'CPT
7 K DIR
8 D HDR^SROVER2
9 D CPTDISP^SROADX1,ASDX^SROADX1,ADXPRMT
10 Q:($G(Y(0))="")!($G(Y(0))="QUIT")
11 K DIR
12 S Y=$P(SROLST,",",Y)
13 S SROANS=Y
14 S SRODIR("A",1)=" Select the number(s) of the Diagnosis Code appropriate for this procedure"
15 S SRODIR("A")=" ("_SRTXT_")"
16 S:$G(SROANS)="D" SRODIR("A",1)=" Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
17 D HDR^SROVER2
18 D CPTDISP^SROADX1,ASDX^SROADX1
19 S Y=SROANS
20 I Y="D" D
21 .W !,?8,SRDXCNT,". ALL"
22 .S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
23 .F I=1:1 D ^DIR Q:$$VALASC()
24 .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
25 .I +Y(0)'=SRDXCNT D PDEL1^SROADX1
26 .I +Y(0)=SRDXCNT D PDELALL^SROADX1
27 I Y="A" D
28 .K DIR
29 .D SRODIR^SROADX1
30 .W ! F I=1:1:80 W "-"
31 .S DIR(0)=SRDX2
32 .S SRASSDS=$$PASSDS^SROADX1
33 .S DIR("B")=SRASSDS
34 .F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
35 .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
36 .I SRDIRX(+Y(0))'="ALL" D PADD1^SROADX1 Q
37 .I SRDIRX(+Y(0))="ALL" D PADDALL^SROADX1 Q
38 Q:Y="Q"!(Y["")
39 G CASDX
40 Q
41COTHADX D COTHBLD^SROADX1 ;Associate/Delete "Other" CPTs to Diagnosis from CPT/CODE menu.
42 N SRDX0,SRDX1,SRDX2,SRDIR,OTHCNT,SRASSDS
43 D HDR^SROVER2
44 S OTHCNT=SRDA
45 K DIR
46 D OTHCPTD^SROADX1
47 D OTHADX^SROADX1,ADXPRMT
48 Q:($G(Y(0))="")!($G(Y(0))="QUIT")
49 S SRODIR("A",1)=" Select the number(s) of the Diagnosis Code appropriate for this procedure"
50 S SRODIR("A")=" ("_$G(SRSHT)_")"
51 S:$G(Y(0))="DELETE" SRODIR("A",1)=" Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
52 K DIR
53 S Y=$P(SROLST,",",Y)
54 S SROANS=Y
55 W @IOF
56 D OTHCPTD^SROADX1
57 D OTHADX^SROADX1
58 S Y=SROANS
59 I Y="D" D
60 .W !,?8,SRDXCNT,". ALL"
61 .S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
62 .F I=1:1 D ^DIR Q:$$VALASC()
63 .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
64 .I +Y(0)=SRDXCNT D
65 ..W !,"ARE YOU SRE YOU WANT TO DELETE ALL ? (Y/N) "
66 ..S %=2 D YN^DICN
67 ..I %=1 Q:$E($G(IOST))'="C"!($G(DIK)'="") D KOADX^SROADX2(SRTN,OTH)
68 ..W @IOF
69 ..S OTHCNT=SRDA
70 .I +Y(0)'=SRDXCNT D
71 ..S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
72 ..D ODEL1^SROADX1
73 ..W @IOF
74 .D OTHCPTD^SROADX1
75 I Y="A" D G COTHADX
76 .K DIR
77 .D SRODIR^SROADX1
78 .W ! F I=1:1:80 W "-"
79 .S DIR(0)=SRDX2
80 .S SRASSDS=$$OASSDS^SROADX1
81 .S DIR("B")=SRASSDS
82 .F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
83 .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
84 .I SRDIRX(+Y(0))="ALL",SRDX0'="SO^1:ASSOCIATE;2:DELETE;3:QUIT" D Q
85 ..D OADDALL^SROADX1
86 .I SRDIRX(+Y(0))="ALL",SRDX0="SO^1:ASSOCIATE;2:DELETE;3:QUIT" D Q
87 ..D OADD1^SROADX1
88 .I SRDIRX(+Y(0))'="ALL" D
89 ..D OADD1^SROADX1
90 .W @IOF
91 .D OTHCPTD^SROADX1
92 .D OTHADX^SROADX1
93 Q:Y="Q"!(Y["")
94 G COTHADX
95 Q
96VASDX ;Associate/Delete PRINCIPAL CPTs to Diagnosis from Physician's Verify menu.
97 N SRDX0,SRDX1,SRDX2,SROANS,SRODIR,SRDIRX,SRASSDS
98 K DIR
99 W @IOF
100 S DIR("?")="^D VHELP^SROADX"
101 S DIR("??")="^D VHELP1^SROADX"
102 D CPTDISP^SROADX1,ASDX^SROADX1,ADXPRMT
103 Q:($G(Y(0))="")!($G(Y(0))="QUIT")
104 S SRODIR("A",1)=" Select the number(s) of the Diagnosis Code appropriate for this procedure"
105 S SRODIR("A")=" ("_SROCPT2_")"
106 S:$G(Y(0))="DELETE" SRODIR("A",1)=" Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
107 K DIR
108 S Y=$P(SROLST,",",Y)
109 S SROANS=Y
110 W @IOF
111 D CPTDISP^SROADX1,ASDX^SROADX1
112 S Y=SROANS
113 I Y="D" D
114 .W !,?8,SRDXCNT,". ALL"
115 .S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
116 .S DIR("?")="^D DHELP^SROADX"
117 .S DIR("??")="^D PHELP^SROADX"
118 .F I=1:1 D ^DIR Q:$$VALASC()
119 .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
120 .I +Y(0)=SRDXCNT D PDELALL^SROADX1 Q
121 .I +Y(0)'=SRDXCNT D PDEL1^SROADX1 Q
122 I Y="A" D
123 .K DIR
124 .D SRODIR^SROADX1
125 .W ! F I=1:1:80 W "-"
126 .S DIR("?")="^D AHELP^SROADX"
127 .S DIR("??")="^D PHELP^SROADX"
128 .S SRASSDS=$$PASSDS^SROADX1
129 .S DIR("B")=SRASSDS
130 .S DIR(0)=SRDX2
131 .F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
132 .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
133 .I SRDIRX(+Y(0))'="ALL" D PADD1^SROADX1 Q
134 .I SRDIRX(+Y(0))="ALL" D PADDALL^SROADX1 Q
135 G VASDX
136 Q
137NOTHADX S OTH=DA,OTHCNT=CNT
138 S SRSEL(CNT)=OTH_U_$G(OTHER)_"^CPT Code: "_CPT_U_$G(CPT1)
139VOTHADX N SRDX0,SRDX1,SRDX2,SRDIR,SRASSDS ;Associate/Delete OTHER Diagnosis to CPTs from Physician's Verify menu.
140 Q:'$D(^SRF(SRTN,13,OTH))
141 W @IOF
142 K DIR
143 D OTHCPTD^SROADX1,OTHADX^SROADX1,ADXPRMT
144 Q:($G(Y(0))="")!($G(Y(0))="QUIT")
145 S SRODIR("A",1)=" Select the number(s) of the Diagnosis Code appropriate for this procedure"
146 S SRODIR("A")=" ("_$G(SRSHT)_")"
147 S:$G(Y(0))="DELETE" SRODIR("A",1)=" Select the number(s) of the Diagnosis Code(s) to delete from this procedure"
148 K DIR
149 S Y=$P(SROLST,",",Y)
150 S SROANS=Y
151 W @IOF
152 D OTHCPTD^SROADX1
153 D OTHADX^SROADX1
154 S Y=SROANS
155 I Y="D" D
156 .W !,?8,SRDXCNT,". ALL"
157 .S DIR("?")="^D DHELP^SROADX"
158 .S DIR("??")="^D OHELP^SROADX"
159 .S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)="",DIR("A",2)=SRODIR("A",1)
160 .F I=1:1 D ^DIR Q:$$VALASC()
161 .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
162 .I +Y(0)=SRDXCNT D
163 ..W !,"ARE YOU SRE YOU WANT TO DELETE ALL ? (Y/N) "
164 ..S %=2 D YN^DICN
165 ..I %=1 Q:$E($G(IOST))'="C"!($G(DIK)'="") D KOADX^SROADX2(SRTN,OTH)
166 .I +Y(0)'=SRDXCNT D Q
167 ..S DIR(0)=SRDX1,DIR("A")=SRODIR("A"),DIR("A",1)=""
168 ..W ! F I=1:1:80 W "-"
169 ..S DIR("A",2)=SRODIR("A",1)
170 ..D ODEL1^SROADX1
171 .W @IOF
172 .D OTHCPTD^SROADX1
173 I Y="A" D
174 .K DIR
175 .D SRODIR^SROADX1
176 .W ! F I=1:1:80 W "-"
177 .S DIR("?")="^D AHELP^SROADX"
178 .S DIR("??")="^D OHELP^SROADX"
179 .S SRASSDS=$$OASSDS^SROADX1
180 .S DIR("B")=SRASSDS
181 .S DIR(0)=SRDX2
182 .F I=1:1 D ^DIR Q:(($$VALASC())&('$$DXDUP(Y)))
183 .Q:(Y["^")!(Y="")!($P(Y,",",1)=0)
184 .I SRDIRX(+Y(0))="ALL" D OADDALL^SROADX1 Q
185 .I SRDIRX(+Y(0))'="ALL" D OADD1^SROADX1 Q
186 G VOTHADX
187 Q
188OHELP ;
189 W !!,?5,"The Other Associated Diagnosis is used to associate a diagnosis"
190 W !,?5,"or a group of diagnoses to the Other Procedures"
191 Q
192PHELP ;
193 W !!,?5,"The Principal Associated Diagnosis is used to associate a diagnosis"
194 W !,?5,"or a group of diagnoses to the Principal CPT Code"
195 Q
196DHELP ;
197 W !!,?5,"Please enter a list or range, e.g.,2, or 2,3 or 1-3"
198 W !,?5,"from the above list to be Deleted."
199 Q
200AHELP ;
201 W !!,?5,"Please enter a list or range, e.g.,2, or 2,3 or 1-3"
202 W !,?5,"from the above list to be Associated."
203 Q
204VHELP ;
205 W !!,?5
206 W:DIR("0")="SO^D:DELETE;Q:QUIT" "Select either D to Delete or Q to Quit"
207 W:DIR("0")="SO^A:ASSOCIATE;D:DELETE;Q:QUIT" "Select A to Associate, D to Delete or Q to Quit"
208 W:DIR("0")="SO^A:ASSOCIATE;Q:QUIT" "Select A to Associate or Q to Quit"
209 Q
210VHELP1 ;
211 W !!,?5
212 W:DIR("0")="SO^D:DELETE;Q:QUIT" "This will setup your choices for Deleting any Associated Diagnosis"
213 W:DIR("0")="SO^A:ASSOCIATE;D:DELETE;Q:QUIT" "This will setup your choices for Associating or Deleting any Associated Diagnosis"
214 W:DIR("0")="SO^A:ASSOCIATE;Q:QUIT" "This will setup your choices for Associating any Associated Diagnosis"
215 Q
216PINPUT ;
217 Q:$D(EMILY)
218 N SRC,SRDX
219 S SRC(1)="The Associated Diagnosis can only be added via the",SRC(1,"F")="!!?5"
220 S SRC(2)="Surgery Menu options. Your entry has NOT been filed",SRC(2,"F")="!?5"
221 D EN^DDIOL(.SRC),CONT^SROADX1
222 K X
223 Q
224ADXPRMT ;
225 I SRDX1'="LO^:0",SRDX2'="LO^:0" S SRDX0="SO^1:ASSOCIATE;2:DELETE;3:QUIT",SROLST="A,D,Q",DIR("L")=" 1 ASSOCIATE 2 DELETE 3 QUIT"
226 I SRDX1'="LO^:0",SRDX2="LO^:0" S SRDX0="SO^1:DELETE;2:QUIT",SROLST="D,Q",DIR("L")=" 1 DELETE 2 QUIT"
227 I SRDX1="LO^:1",SRDX2'="LO^:0" S SRDX0="SO^1:ASSOCIATE;2:QUIT",SROLST="A,Q",DIR("L")=" 1 ASSOCIATE 2 QUIT"
228 I SRDX1="LO^:0",SRDX2="LO^:0" S SRDX0="SO^1:QUIT",SROLST="A,Q",DIR("L")=" No Diagnosis to associate 1 QUIT"
229 S DIR(0)=SRDX0,DIR("L",1)=" Select one of the following:",DIR("L",2)=""
230 D ^DIR K DIR
231 Q
232DXDUP(SRDX) I (Y["^")!($G(DTOUT)) Q 0
233 N SRAI,SRDXX,SRDUP,DIR S SRDUP=0
234 I SRDX="" Q 0
235 F SRAI=1:1:$L(SRDX,",") D
236 .Q:$P(SRDX,",",SRAI)<1
237 .I $D(SRDXX($P(SRDX,",",SRAI)))!((SRDIRX($P(SRDX,",",SRAI))="ALL")&($L(SRDX,",")>2)) S SRDUP=1,DIR(0)="FO^",DIR("A",1)=" **Duplicates entered",DIR("A")=" Press Return to continue" D ^DIR
238 .S SRDXX($P(SRDX,",",SRAI))=""
239 Q SRDUP
240VALASC() I (Y["^")!('$G(Y(0)))!($G(DTOUT)) Q 1
241 N VALA,DIR S VALA=1
242 S:Y=""!(Y=U)!('+Y(0))!(Y[",0")!($P(Y,",",1)=0) VALA=0
243 I 'VALA S DIR("A",1)=" **Invalid input",DIR(0)="FO^",DIR("A")=" Press Return to continue" D ^DIR
244 Q VALA
Note: See TracBrowser for help on using the repository browser.