source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR5HQ4.m

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

initial load of FOIAVistA 6/30/08 version

File size: 8.8 KB
Line 
1RMPR5HQ4 ;HCIOFO/ODJ - INVENTORY REPORT - PARAMETER DATA ENTRY ; 20 SEP 00
2 ;;3.0;PROSTHETICS;**51,84,103**;Feb 09, 1996
3 ;
4 ; AAC Patch 84, 02-25-04, additions, deletions and change descriptions for Groups and lines.
5 ;
6 ; Prompts for Station, Start date, End date, level of detail,
7 ; NPPD group, NPPD line, HCPC selections and Report Device
8START N RMPRSDT,RMPREDT,RMPREXC,RMPRSEL,RMPRHTY,RMPRGLST,RMPRLINX
9 N RMPRI,RMPRJ,RMPRLCN,RMPRHCN,RMPR,RMPRGRPA,RMPRVISN
10 ; RMPR("STA") Station Number (ien ^DIC(4)
11 S RMPRSDT="" ; start date VM internal
12 S RMPREDT=DT ; end date VM internal
13 I '$D(RMPRDET) N RMPRDET S RMPRDET="" ; Level of detail
14 S RMPRHTY="" ; type of HCPCS selection
15 S RMPRLCN=1 ; Count for number of individual NPPD lines selected
16 S RMPRHCN=1 ; Count for number of individual HCPCs selected
17 K RMPREXC ; Exit condition from prompts (^ defined as quit)
18 K RMPRSEL ; Array of parameter selections
19 ; If this array gets too big then need to save in ^TMP
20 ; in which case queuing option will have to be removed
21 ;
22 D GRPLST(.RMPRGLST) ;set list of NPPD group codes for DIR prompt
23 D GRPARY(.RMPRGRPA)
24 D SETLIN(.RMPRLINX) ;set an indexing array for NPPD line help
25 S RMPREXC=$$STN(.RMPR,.RMPRVISN)
26 I RMPREXC="^" G EDX
27 S RMPREXC=$$STDT(.RMPRSDT) ;get Start Date (fileman format)
28 I RMPREXC="^" G EDX
29 S RMPREXC=$$ENDT(.RMPREDT,RMPRSDT) ;get End Date (fileman format)
30 I RMPREXC="^" G EDX
31 I RMPRDET="" S RMPREXC=$$LEV(.RMPRDET) ;get Level of Detail
32 I RMPREXC="^" G EDX
33 I RMPRDET="G" K RMPRSEL S RMPRSEL("*")="" G EDDEV ;NPPD group level of detail
34 I RMPRDET="L" G EDLIN ;NPPD line level of detail
35 I RMPRDET="H"!(RMPRDET="I") G EDHCPC ;HCPC or Item level of detail
36 ;
37 ; NPPD Group level of detail
38EDGRP S RMPREXC=$$NPGRP(.RMPRSEL)
39 I RMPREXC="^" G EDX
40 G EDDEV
41 ;
42 ; NPPD Line level of detail
43EDLIN S RMPREXC=$$NPLIN(.RMPRSEL)
44 I RMPREXC="^" G EDX
45EDLINX G EDDEV
46 ;
47 ; HCPC level of detail
48EDHCPC S RMPREXC=$$HCPCTY(.RMPRHTY)
49 I RMPREXC="^" G EDX
50 I RMPRHTY="" G EDDEV
51 I RMPRHTY="A" K RMPRSEL S RMPRSEL("*")="" G EDDEV
52 I RMPRHTY="G" S RMPREXC=$$NPGRP(.RMPRSEL) G EDDEV
53 I RMPRHTY="L" S RMPREXC=$$NPLIN(.RMPRSEL) G EDDEV
54 S RMPREXC=$$HCPC(.RMPRSEL,.RMPRHCN)
55 G EDDEV
56 ;
57 ; Get device and run report or queue it
58EDDEV S RMPREXC=$$REPDEV("")
59 I RMPREXC="^" G EDX
60 I '$D(IO("Q")) D REPORT^RMPR5HQ5 G EDX
61 K IO("Q")
62 S ZTDESC="INVENTORY REPORT",ZTRTN="REPORT^RMPR5HQ5",ZTIO=ION
63 S ZTSAVE("RMPRSDT")=""
64 S ZTSAVE("RMPREDT")=""
65 S ZTSAVE("RMPRDET")=""
66 S ZTSAVE("RMPRSEL(")=""
67 ;S ZTSAVE("IOM")=""
68 S ZTSAVE("RMPR(""STA"")")=""
69 D ^%ZTLOAD
70 W:$D(ZTSK) !,"REQUEST QUEUED!" H 1
71EDX Q
72 ;
73 ; Prompt for Site/Station
74STN(RMPR,RMPRVISN) ;
75 N X,Y,DIC,DA
76 S RMPRVISN=""
77 D DIV4^RMPRSIT ; call standard Prosthetic site look-up
78 I $D(X) S X="^"
79 E S X="" S:RMPRSITE'="" RMPRVISN=$P($G(^RMPR(669.9,RMPRSITE,"INV")),"^",2)
80 Q X
81 ;
82 ; Prompt for level of detail
83EN1 N RMPRDET S RMPRDET="G" ;entry point NPPD Group level
84 G START
85EN2 N RMPRDET S RMPRDET="L" ;entry point NPPD Line level
86 G START
87EN3 N RMPRDET S RMPRDET="H" ;entry point HCPCS level
88 G START
89EN4 N RMPRDET S RMPRDET="I" ;entry point Item level
90 G START
91LEV(RMPRDET) ;
92 N DIR,X,Y
93 S RMPRDET=$G(RMPRDET)
94 S DIR(0)="S^G:NPPD Group;L:NPPD Line;H:HCPCS Code;I:HCPCS Item"
95 S DIR("A")="Select inventory report level of detail"
96 D ^DIR
97 I Y="",$D(DTOUT) S X="^" G LEVX
98 I Y="^"!(Y="^^") S X="^" G LEVX
99 S RMPRDET=Y
100LEVX Q X
101 ;
102 ; Prompt for Start Date
103STDT(RMPRSDT) ; RMPRSDT is start date in FM internal form
104 N %DT,X,Y
105 S %DT("A")="Beginning Date: "
106 S %DT(0)=-DT
107 S %DT="AEP"
108 D ^%DT
109 I Y<0 S X="^"
110 S RMPRSDT=$P(Y,".",1)
111 Q X
112 ;
113 ; Prompt for End Date
114ENDT(RMPREDT,RMPRSDT) ; RMPREDT is end date in FM internal form
115 N %DT,X,Y
116ENDT1 S %DT("A")="Ending Date: "
117 S %DT(0)=-DT
118 S %DT="AEP"
119 D ^%DT
120 I Y<0 S X="^" G ENDT1X
121 S RMPREDT=$P(Y,".",1)
122 I RMPREDT<RMPRSDT W !,"Ending date should not precede start date",! G ENDT1
123ENDT1X Q X
124 ;
125 ; Prompt for NPPD group
126NPGRP(RMPRSEL) ;
127 N DIR,DA,X,Y,RMPRCNT,RMPRI,RMPRJ,RMPRGRP
128 W !
129 F RMPRCNT=1:1:$L(RMPRGLST,";") D
130 . W !,$J(RMPRCNT,2)_". "_$P($P(RMPRGLST,";",RMPRCNT),":",2)
131 . Q
132 S DIR(0)="L" S:$D(RMPRSEL) DIR(0)=DIR(0)_"O"
133 S DIR("A")="Select NPPD Group "
134 S $P(DIR(0),U,2)="1:"_RMPRCNT
135 D ^DIR
136 I Y="",$D(DTOUT) S X="^" G NPGRPX
137 I Y="^"!(Y="^^") S X="^" G NPGRPX
138 I Y="" S X="" G NPGRPX ; no selection so just exit
139 ;
140 ; add in the new selections
141 S RMPRI=""
142 F S RMPRI=$O(Y(RMPRI)) Q:RMPRI="" D Q:RMPRI=""
143 . I $L(Y(RMPRI),",")-1=RMPRCNT D Q
144 .. K RMPRSEL
145 .. S RMPRSEL("*")="" ; all groups selected
146 .. S RMPRI=""
147 .. Q
148 . F RMPRJ=1:1:$L(Y(RMPRI),",")-1 D
149 .. S RMPRGRP=$P($P(RMPRGLST,";",$P(Y(RMPRI),",",RMPRJ)),":",1)
150 .. K RMPRSEL(RMPRGRP)
151 .. S RMPRSEL(RMPRGRP,"*")=""
152 .. Q
153 . Q
154NPGRPX Q X
155 ;
156 ; Prompt for NPPD line
157 ; User can select lines within a group
158 ; If more than 1 group selected must use all lines within those groups
159NPLIN(RMPRSEL) ;
160 N DIR,DA,X,Y,RMPRHPG,RMPRGRP,RMPRLIN,RMPREXC,RMPRI,RMPRJ
161 S DIR(0)="L" S:$D(RMPRSEL) DIR(0)=DIR(0)_"O"
162NPLIN1C S RMPREXC=$$NPGRP(.RMPRSEL)
163 I RMPREXC="^" S X="^" G NPLIN1X
164 I $O(RMPRSEL(""))="*" S X="" G NPLIN1X
165 S RMPRI=0,RMPRJ="" F S RMPRJ=$O(RMPRSEL(RMPRJ)) Q:RMPRJ="" S RMPRI=RMPRI+1 Q:RMPRI=2
166 I RMPRI=2 S X="" G NPLIN1X
167 S RMPRGRP=$O(RMPRSEL("")) K RMPRSEL
168NPLIN1A D NPLINH(RMPRGRP,.RMPRHPG)
169 S $P(DIR(0),U,2)="1:"_RMPRHPG
170 S DIR("A")="Select NPPD line(s) within the above group"
171 D ^DIR
172 I Y="",$D(DTOUT) S X="^" G NPLIN1X
173 I Y="^"!(Y="^^") S X="^" G NPLIN1X
174 I Y="" S X="" G NPLIN1X
175 S RMPRI=""
176 F S RMPRI=$O(Y(RMPRI)) Q:RMPRI="" D Q:RMPRI=""
177 . I $L(Y(RMPRI),",")-1=RMPRHPG D Q
178 .. K RMPRSEL(RMPRGRP)
179 .. S RMPRSEL(RMPRGRP,"*")="" ; all lines selected
180 .. S RMPRI=""
181 .. Q
182 . F RMPRJ=1:1:$L(Y(RMPRI),",")-1 D
183 .. D NPLINC(RMPRGRP,$P(Y(RMPRI),",",RMPRJ),.RMPRLIN)
184 .. K RMPRSEL(RMPRGRP,RMPRLIN)
185 .. S RMPRSEL(RMPRGRP,RMPRLIN,"*")=""
186 .. Q
187 . Q
188 S X=""
189NPLIN1X Q X
190 ;
191 ; Check entered NPPD line
192 ; OFFS = line offset in RMPRN62 if valid NPPD line (else null)
193 ;
194NPLINC(RMPRGRP,INP,RMPRLIN) ;
195 N S,OFFS
196 S OFFS=RMPRLINX(RMPRGRP)+INP-1
197 S S=$P($T(DES+OFFS^RMPRN62),";;",2)
198 S RMPRLIN=$P(S,";",1)
199 Q
200 ;
201 ; Display NPPD lines for a given group
202NPLINH(RMPRGRP,TO) ;
203 N FR,I,S,LINCD
204 W !,"NPPD Lines for Group: ",RMPRGRP," - ",RMPRGRPA(RMPRGRP),!
205 S FR=RMPRLINX(RMPRGRP)
206 S TO=0
207 F S S=$P($T(DES+FR^RMPRN62),";;",2),LINCD=$P(S,";",1) Q:$P(LINCD," ",1)'=RMPRGRP D
208 . S TO=TO+1
209 . W !,$J(TO,2),". ",$P(S,";",1)_" "_$P(S,";",2)
210 . W:$D(RMPRSEL(RMPRGRP,LINCD)) ?65,"<< Selected"
211 . S FR=FR+1
212 . Q
213 Q
214 ;
215 ; Select type of HCPCS selection
216HCPCTY(RMPRHTY) ;
217 N DIR,DA,X,Y
218 S DIR("B")="A"
219 S DIR(0)="S^A:ALL HCPCS;G:ALL HCPCS for NPPD group;L:ALL HCPCS for NPPD line;S:Select individual HCPCS"
220 S DIR("A")="Choose HCPCS selection option"
221 D ^DIR
222 I Y="",$D(DTOUT) S X="^" G HCPCTYX
223 I Y="^"!(Y="^^") S X="^" G HCPCTYX
224 I X="" S RMPRHTY="" G HCPCTYX
225 S RMPRHTY=Y
226HCPCTYX Q X
227 ;
228 ; Select HCPCS
229HCPC(RMPRSEL,RMPRSCN) ;
230 N DIC,X,Y,DA,RMPRLIN
231 S DIC="^RMPR(661.1,",DIC(0)="AEQMZ"
232HCPC1 S DIC("A")="Select HCPCS "_RMPRSCN_": "
233 D ^DIC
234 I $D(DTOUT) S X="^" G HCPCX
235 I $D(DUOUT) S X="^" G HCPCX
236 I X="" G HCPCX
237 S RMPRLIN=$P(Y(0),U,7)
238 S:RMPRLIN="" RMPRLIN="999 X"
239 S RMPRSEL($P(RMPRLIN," ",1),RMPRLIN,$P(Y,U,1))=""
240 S RMPRSCN=RMPRSCN+1
241 G HCPC1
242HCPCX Q X
243 ;
244 ; Select Report device
245REPDEV(RMPRDEV) ;
246 N X,POP,Y,%ZIS,IOP
247REPDEV1 S X=""
248 S %ZIS="MQ" K IOP D ^%ZIS I POP S X="^" G REPDEVX
249 I IOM<132 W !,"You need at least 132 columns for this report.",!,"Please use a device capable of this requirement.",! G REPDEV1
250REPDEVX Q X
251 ;
252 ; LINX is an array used in the help system within NPPD line selection
253 ; Basically each page of help will show lines for a group.
254 ; Each page has a start line corresponding to an offset in RMPRN62
255SETLIN(LINX) ;
256 N I,HLPPG,S,LINCD,LINCD0
257 S HLPPG=0,LINCD0=""
258 F I=1:1 S S=$T(DES+I^RMPRN62) D Q:LINCD0=""
259 . S LINCD=$P($P(S,";;",2),";",1)
260 . S HLPPG=$P(LINCD," ",1)
261 . I $E(HLPPG)'?1N S LINX(HLPPG)=I,LINCD0="" Q
262 . I HLPPG'=LINCD0 D Q
263 .. S LINX(HLPPG)=I,LINCD0=HLPPG
264 .. Q
265 . Q
266 Q
267 ;
268 ; Set NPPD (new) group codes and desc. for use in DIR
269 ; set of codes prompt.
270 ; Hard coded, but better if in Fileman file sometime
271 ; Codes and desc. copied from RMPRN6UT
272GRPLST(LIST) ;
273 S LIST="100:WHEELCHAIRS AND ACCESSORIES"
274 S $P(LIST,";",2)="200:ARTIFICIAL LEGS"
275 S $P(LIST,";",3)="300:ARTIFICIAL ARMS AND TERMINAL DEVICES"
276 S $P(LIST,";",4)="400:ORTHOSIS/ORTHOTICS"
277 S $P(LIST,";",5)="500:SHOES/ORTHOTICS"
278 S $P(LIST,";",6)="600:SENSORI-NEURO AIDS"
279 S $P(LIST,";",7)="700:RESTORATIONS"
280 S $P(LIST,";",8)="800:OXYGEN AND RESPIRATORY"
281 S $P(LIST,";",9)="900:MEDICAL EQUIPMENT"
282 S $P(LIST,";",10)="910:ALL OTHER SUPPLIES AND EQUIPMENT"
283 S $P(LIST,";",11)="920:HOME DIALYSIS PROGRAM"
284 S $P(LIST,";",12)="930:ADAPTIVE EQUIPMENT"
285 S $P(LIST,";",13)="940:HISA"
286 S $P(LIST,";",14)="960:SURGICAL IMPLANTS"
287 S $P(LIST,";",15)="999:MISC"
288 Q
289 ;
290 ; Same as above but set into array
291GRPARY(ARRAY) ;
292 N LIST,I
293 K ARRAY
294 D GRPLST(.LIST)
295 F I=1:1:$L(LIST,";") S ARRAY($P($P(LIST,";",I),":",1))=$P($P(LIST,";",I),":",2)
296 Q
Note: See TracBrowser for help on using the repository browser.