source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOPED.m@ 613

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

initial load of WorldVistAEHR
File size: 9.5 KB
Line 
1RMPOPED ;EDS/MDB,DDW,RVD - HOME OXYGEN MISC FILE EDITS ;7/24/98
2 ;;3.0;PROSTHETICS;**29,44,41,52,77,110,140,148**;Feb 09, 1996;Build 1
3 ;
4 ; HNC - patch 52
5 ; modified SITECHK sub
6 ; X will be undefined from GETS^DIQ if field is null
7 ; added $G.
8 ;RVD - patch #77 use Fileman to set items that are not Primary item
9 ; to 'N' in order to set correctly the 'AC' cross-ref.
10 Q
11UNLOCK I $D(RMPODFN) L -^RMPR(665,RMPODFN)
12 Q
13EXIT K DIC,DIE,DIR,DIK,X,Y,Z,DR,DA,DD,DO,D0,DTOUT,DIROUT,DUOUT,DIRUT,QUIT,DFN,ITEM,ITEMS,IEN,IENS,ITMACT,ITM,C,S,W,PI,VDR,ZST
14 D UNLOCK
15 Q
16 ;
17KEY ;user must have the RMPRSUPERVISOR key in order to add a new patient.
18 ;option name is EDIT HOME OXYGEN PATIENT
19 N KEY
20 S KEY=$O(^DIC(19.1,"B","RMPRSUPERVISOR",0))
21 I '$D(^VA(200,DUZ,51,KEY)) D Q
22 . W !!,"You do not hold the RMPSUPERVISOR key!!"
23 G PAT
24 ;
25SITE ; Editing of Home Oxygen site parameter file.
26 K DIC,DIE,DA,DR,DD,RMPOXITE
27 S DIC="^RMPR(669.9,",DIC(0)="QEAMLZ",DIC("A")="Select SITE: "
28 D ^DIC Q:Y<0!$$QUIT
29 K DIC("A")
30 S (DA,RMPOXITE)=+Y
31 ; Lock it...
32 L +^RMPR(669.9,RMPOXITE):2
33 I '$T D G SITE
34 . W ?10,$C(7)_Y(0,0)_" -- record in use. Try again later."
35 ; Edit it
36 S DIE=DIC,DR="60;61;62;65" D ^DIE Q:$$EQUIT
37 ; Edit FCP
38 K DIC,DA,DD,DR,DIE
39 ;
40 ; Done. Unlock
41 L -^RMPR(669.9,RMPOXITE)
42 G SITE
43 ;
44FCPHLP ; Executable help for FCP multiple in 669.9
45 ;
46 Q
47FCPIX ; Input transform for FCP multiple in 669.9
48 ;
49 Q:'$D(X)
50 I $L(X)>30!($L(X)<3) K X Q
51 S ZST=$P(^RMPR(669.9,D0,4),U,1),RMPOX=X
52 D FIND^DIC(420.01,","_ZST_",",".01;","M",X,1,,,,"X")
53 S X=$S($D(X("DILIST","ID",1,.01)):X("DILIST","ID",1,.01),1:RMPOX)
54 K X("DILIST"),RMPOX
55 I $G(ZST),('$D(^PRC(420,+ZST,1,"B",X))) W !,"Control Point is not a valid IFCAP FCP.." K X
56 Q
57ACT ;activate/inactivate a home oxygen patient
58 ;Set up site variables.
59 D HOSITE^RMPOUTL0 I QUIT D EXIT Q
60 W @IOF
61 ;
62ACT1 ;Toggle ACTIVATE/INACTIVATE functions.
63 N NAME K DIC,DA
64 S DIC="^RMPR(665,",DIC(0)="QEAMZ" D ^DIC I Y<0!$$QUIT D EXIT Q
65 S DIE=DIC,DA=+Y,NAME=Y(0,0)
66 L +^RMPR(665,DA):2
67 I '$T D G ACT1
68 . W ?10,$C(7)_Y(0,0)_" -- record in use. Try later."
69 ;If the patient has never been activated, quit.
70 I $P($G(^RMPR(665,DA,"RMPOA")),U,2)="" D G ACT1
71 . W !!,$C(7)_NAME_" has not been added as a Home Oxygen patient."
72 . W !,"Please add using the ""Add/Edit Home Oxygen Patient"" option."
73 ;If the patient is active, perform inactivation actions.
74 I $P($G(^RMPR(665,DA,"RMPOA")),U,3)="" D INACTVT^RMPOPED G ACT1
75 ;If the patient is inactive, perform activation actions.
76 I $P($G(^RMPR(665,DA,"RMPOA")),U,3)'="" D ACTVT^RMPOPED G ACT1
77 Q
78INACTVT ; Inactivate the patient if user wants to.
79 ; Confirm if the user wants to proceed.
80 K DIR S DIR(0)="YO",DIR("B")="NO"
81 S DIR("A")="Are you sure you want to inactivate "_NAME_" ?" D ^DIR
82 Q:(Y<1)!$$QUIT
83 S DR="19.5//TODAY;19.6;19.7////"_DUZ,DIE("NO^")="BACK"
84 D ^DIE
85 Q
86 ;
87ACTVT ;Activate the patient if the user wants to.
88 K DIR S DIR(0)="YO",DIR("B")="NO"
89 S DIR("A")="Are you sure you want to reactivate "_NAME_" ?" D ^DIR
90 Q:(Y<1)!$$QUIT
91 S DR="19.2//TODAY;19.5///@;19.6///@;19.7///@"
92 S DIE("NO^")="BACK"
93 D ^DIE
94 Q
95PAT ;Add/Edit Home Oxygen Patient
96 S QUIT=0
97 D HOSITE^RMPOUTL0
98 I '$D(RMPOXITE)!QUIT D EXIT Q
99LOOP ;
100 S QUIT=0
101 D LOOKUP I QUIT!'$D(RMPODFN) D EXIT Q
102 D EDBLK I QUIT D EXIT Q
103 D UNLOCK G LOOP
104EDBLK ;
105 D SITECHK Q:QUIT
106 D DEMOG Q:QUIT
107 D RX Q:QUIT
108 D ITEM
109 Q
110 ;called by ^RMPOBIL1, providing RMPOPATN as the X variable
111EDIT ;From Billing...
112 I '$D(RMPODFN) S RMPODFN=$TR($G(RMPOPATN),"`")
113 Q:'$D(^RMPR(665,+RMPODFN,0))
114 W !,"EDITING "_$P(^DPT(RMPODFN,0),U)_"...",!
115 S QUIT=0,DA=RMPODFN
116 L +^RMPR(665,DA):2
117 I '$T W !!?10,*7," << Record in use. Try later. >>" Q
118 D EDBLK,EXIT
119 Q
120LOOKUP ;First look-up the patient
121 K DIC,DIE,DA,DR,RMPODFN
122 W !!! S DIC="^RMPR(665,",DIC(0)="LQEAMZ"
123 D ^DIC Q:(Y<0)!$$QUIT
124CONT S (RMPODFN,DA)=+Y
125 L +^RMPR(665,DA):2
126 I '$T W !!?10,*7," << Record in use. Try later. >>" G LOOKUP
127 Q
128 ;
129QUIT() S QUIT=$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q QUIT
130EQUIT() S QUIT=$D(DTOUT)!$D(Y) Q QUIT
131LJ(S,W,C) ; LEFT JUSTIFY S IN A FIELD W WIDE PADDING WITH CHAR F
132 ;
133 S C=$G(C," ") ;DEFAULT PAD CHAR IS SPACE
134 S $P(S,C,W-$L(S)+$L(S,C))=""
135 Q S
136 ;
137SITECHK ;If user chooses patient from site different from billing site
138 ;
139 S Y=$P($G(^RMPR(665,RMPODFN,"RMPOA")),U,7)
140 Q:Y=RMPOXITE ;Site is the same..
141 I Y="" D SET Q ;Site not defined, stuff RMPOXITE...
142 ; Site is different...
143 S IENS=RMPODFN_","
144 D GETS^DIQ(665,IENS,19.12,"E","X")
145 W !!,"Patient's Home Oxygen Contract Location (HOCL) is "
146 W $G(X(665,IENS,19.12,"E"))
147 W !,"You are working on billing for HOCL "_RMPO("NAME"),!
148 K DIR S DIR(0)="Y",DIR("B")="NO"
149 S DIR("A")="Should I change this patient's HOCL to "_RMPO("NAME")
150 D ^DIR Q:$$QUIT!(Y=0)
151 D SET
152 Q
153SET ;
154 K DIE,DR,DA
155 S DA=RMPODFN
156 ;W "HERE,RMPOXITE=",RMPOXITE
157 S DIE="^RMPR(665,",DR="19.12////"_RMPOXITE D ^DIE
158 Q
159 ;
160DEMOG ;First edit the patient's basic fields
161 ;
162 K DIE,DR,DA
163 S DA=RMPODFN
164 S DIE="^RMPR(665,",DR="19.1" D ^DIE Q:$$EQUIT
165 S RMPOELIG=$P($G(^RMPR(665,RMPODFN,"RMPOA")),U)
166 K DR S DR="19.11"_$S(RMPOELIG="D":"",1:"///@")_";19.12"
167 D ^DIE Q:$$EQUIT
168 K DR S Y=DT X ^DD("DD") S DR="19.2//"_Y D ^DIE Q:$$QUIT
169 Q
170 ;
171RX ;Edit the Rx Data
172 ;
173 N RXD,RXDI
174 K DIC,DIE,DA,DR
175 S DIC="^RMPR(665,"_RMPODFN_",""RMPOB"",",DIC(0)="AEQLZ"
176 S DA(1)=RMPODFN,DIC("P")="665.193D"
177 S RXD=$O(^RMPR(665,DA(1),"RMPOB","B",""),-1) D:RXD
178 . S DIC("B")=$$FMTE^XLFDT(RXD)
179 D ^DIC Q:Y<0!$$QUIT
180 S DIE=DIC,DA=+Y,DR=".01;2//^D EXPIRE^RMPOBIL4;3" D ^DIE Q:$$EQUIT
181 Q
182 ;
183ITEM ;Add/Edit Items
184 ;
185 ; Display items
186 D ITEMD
187 ; If no items on file, then only allow ADD PRIMARY ITEM
188 I '$D(IEN) D ITEMP Q:QUIT!(ITEM="") G ITEM
189 ; ask for ACTION, quit if <return>, timeout, etc
190 S ITMACT=$$ITEMO Q:$$QUIT!(ITMACT="")
191 ; if they entered 'A', do ADD ITEM, then edit it
192 I ITMACT="A" D ITEMA Q:QUIT!(ITEM="") D ITEME Q:QUIT G ITEM
193 ; if they entered 'D', select an item, then delete it
194 I ITMACT="D" D ITEMS Q:QUIT!(ITEM="") D ITEMK G ITEM
195 ; if they entered 'E', select an item, then edit it
196 I ITMACT="E" D ITEMS Q:QUIT!(ITEM="") D ITEME Q:QUIT G ITEM
197 G ITEM
198 Q
199ITEMP ; Add Primary Item
200 W !!,$C(7)_"No items found, please enter PRIMARY ITEM",!
201 D ITEMA Q:QUIT!(ITEM="")
202 S PI="///Y" D ITEME K PI
203 Q
204ITEMA ; Add Items
205 S ITEM=""
206 K DIC S DIC="^RMPR(661,",DIC(0)="AEQMZ" D ^DIC Q:Y<0!$$QUIT
207 K DD,DO,DA,DIC
208 S DIC="^RMPR(665,"_RMPODFN_",""RMPOC"",",DIC(0)="L"
209 S DIC("P")=$P(^DD(665,19.4,0),U,2),DA(1)=RMPODFN,X=+Y
210 D FILE^DICN I Y>0 S IEN=$G(IEN)+1,IEN(IEN)=+Y,ITEM=IEN
211 Q
212ITEMS ; Select Item
213 ; Return ITEM = index into both ITEMS and IEN arrays
214 I IEN=1 S ITEM=1 W " ",$E(ITEMS(1),1,33) Q
215 K DIR
216 S ITEM=""
217 S DIR(0)="NO^1:"_IEN,DIR("A")="Select an ITEM"
218 S DIR("?")="Select an item from the list"
219 M DIR("?")=ITEMS
220 D ^DIR Q:Y'>0!$$QUIT
221 S ITEM=+Y W " ",$E(ITEMS(ITEM),1,33)
222 Q
223ITEME ; Edit an Item
224 N FCP,DFCP,RMCPTHCP,RMCPRENT K DIE,DA,DR,RMCPT
225 S DA(1)=RMPODFN,DA=IEN(ITEM),DIE="^RMPR(665,"_DA(1)_",""RMPOC"","
226 D ITEMEP Q:QUIT
227 S DR=".01R;6R" D ^DIE Q:$$EQUIT!('$D(DA))
228 S RMCPTHCP=$P($G(^RMPR(665,RMPODFN,"RMPOC",DA,0)),U,7)
229 S RMCPT=$P($G(^RMPR(661.1,RMCPTHCP,4)),U,1) S DR=""
230 S RMCPRENT=$P($G(^RMPR(661.1,RMCPTHCP,5)),U,1)
231 I RMCPT["RR",(RMCPRENT=1) S DR="11;"
232 I RMCPT["QH" S DR=DR_"12;"
233 S DR=DR_"1R;2R;3R;4;7;8;9R" K RMCPRENT,RMCPTHCP
234 D ^DIE I $D(DA),$D(RMCPT),(RMCPT'["RR") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,12)=""
235 I $D(DA),$D(RMCPT),(RMCPT'["QH") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,13)=""
236 Q:$$EQUIT
237 ; Kludge to "point" to file 420
238 S DFCP=$P(^RMPR(665,RMPODFN,"RMPOC",IEN(ITEM),0),U,6)
239 F D Q:(FCP>0)!QUIT
240 . S FCP=$$GETFCP^RMPOBILU(DFCP) Q:QUIT
241 . I FCP<0 W $C(7)_"REQUIRED FIELD!"
242 I FCP>0 S DR="5///"_$P(FCP,U,2) D ^DIE Q:$$EQUIT
243 ; End Kludge
244 ;S DR="7:9" D ^DIE Q:$$EQUIT
245 Q
246ITEMEP ; Primary Item edit...
247 N PIEN,PFLG,RMDA,RMNO
248 S RMDA=DA,DR="10" D ^DIE Q:$$QUIT
249 I $P(^RMPR(665,RMPODFN,"RMPOC",RMDA,0),U,11)'="Y" Q
250 ; Logic to control toggling of Primary Item flag...
251 S RMNO="N"
252 F RMX=0:0 S RMX=$O(^RMPR(665,RMPODFN,"RMPOC",RMX)) Q:RMX'>0 D
253 . Q:RMDA=RMX
254 . S DA=RMX,DR="10///^S X=RMNO" D ^DIE
255 S DA=RMDA
256 Q
257PIEN(DFN) ; FIND PRIMARY ITEM
258 ; RETURN IEN OF P.I. IN MULTIPLE ^ IEN IN FILE 661
259 N X,PIEN
260 S X=0,PIEN=0
261 F S X=$O(^RMPR(665,DFN,"RMPOC",X)) Q:X'>0 D Q:PIEN
262 . S:$P(^RMPR(665,DFN,"RMPOC",X,0),U,11)="Y" PIEN=X
263 S:PIEN PIEN=PIEN_U_$P(^RMPR(665,DFN,"RMPOC",PIEN,0),U,1)
264 Q PIEN
265ITEMD ; Display Items
266 N I,Z,PIF,ITMNM,VDRNM
267 K IEN,ITEMS S I=0
268 Q:$O(^RMPR(665,RMPODFN,"RMPOC",0))'>0
269 W !!,"The following items are already in this patient's template:",!
270 F IEN=1:1 S I=$O(^RMPR(665,RMPODFN,"RMPOC",I)) Q:I'>0 D
271 . S Z=^RMPR(665,RMPODFN,"RMPOC",I,0)
272 . S PIF=$S($P(Z,U,11)="Y":"*",1:" ")
273 . S ITMNM=$$ITEMNM($P(Z,U)),VDRNM=$$VDRNM($P(Z,U,2))
274 .; K X S IENS=$P(Z,U)_","
275 .; D GETS^DIQ(661,IENS,.01,"","X") S ITMNM=$E(X(661,IENS,.01),1,33)
276 .; S IENS=$P(Z,U,2)_",",VDRNM="<< VENDOR NOT DEFINED >>"
277 .; I IENS'="," D GETS^DIQ(440,IENS,.01,"","X") S VDRNM=X(440,IENS,.01)
278 . S IEN(IEN)=I
279 . S ITEMS(IEN)=" "_PIF_$J(IEN,4)_" "_$$LJ(ITMNM,38)_$E(VDRNM,1,30)
280 . W !,ITEMS(IEN)
281 W !!," * = Primary Item",!
282 S IEN=IEN-1
283 Q
284ITEMNM(ITM) ; RETURN ITEM NAME
285 S IENS=ITM_","
286 D GETS^DIQ(661,IENS,.01,"","X")
287 Q $E(X(661,IENS,.01),1,33)
288VDRNM(VDR) ; RETURN VENDOR NAME
289 I VDR="" Q "<< VENDOR NOT DEFINED >>"
290 S IENS=VDR_"," D GETS^DIQ(440,IENS,.01,"","X")
291 Q X(440,IENS,.01)
292ITEMK ; Delete an Item
293 ;
294 K DIR S DIR(0)="Y",DIR("A")="Are you SURE you want to delete this item"
295 S DIR("B")="NO" D ^DIR Q:Y'>0
296 K DIK,DA
297 S DA(1)=RMPODFN,DA=IEN(ITEM),DIK="^RMPR(665,"_DA(1)_",""RMPOC"","
298 D ^DIK W " ...deleted!"
299 Q
300ITEMO() ; Choose Option
301 K DIR
302 S DIR(0)="SBO^A:Add;D:Delete;E:Edit",DIR("A")="Select ACTION" D ^DIR
303 Q Y
304 Q
Note: See TracBrowser for help on using the repository browser.