source: FOIAVistA/trunk/r/CLINICAL_PROCEDURES-MD/MDKRPC2.m@ 1150

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

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1MDKRPC2 ; HOIFO/DP - RPC Calls (Cont.) ;11/27/07 09:42
2 ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
3 ;
4 ; Reference IA #1625 [Supported] Use routine XUA4A72
5 ; #10060 [Supported] FILE 200 references
6 ; #10112 [Supported] VASITE calls
7 ; #10090 [Supported] Institution File (#4) Read w/FM
8 ; #2263 [Supported] XPAR calls
9 ; #4440 [Supported] XUPROD calls
10 ; #3065 [Supported] XLFNAME calls
11 ; #4815 [Controlled] GMVDCSAV call
12 ; #4866 [Private] File 120.51
13 ; #4867 [Private] File 120.5
14 ; #4868 [Private] - VA(200,"AUSER"
15RPC(RESULTS,OPTION,P1,P2,P3,P4,P5,P6,P7,P8,P9) ; Generic RPC tag
16 S RESULTS=$NA(^TMP($J,"MDKRPC2")) K @RESULTS
17 D @OPTION
18 S:'$D(@RESULTS) @RESULTS@(0)="-1^No Results"
19 Q
20 ;
21ACTIVE ; Return all active dialysis treatments
22 N MDAS,MDFLD,MDLP,MDLIST,MDMORE K ^TMP("MDAS",$J)
23 F MDLP=1,2 S MDLIST=0 F S MDLIST=$O(^MDK(704.202,"AS",MDLP,MDLIST)) Q:MDLIST<1 S ^TMP("MDAS",$J,MDLIST)=""
24 S MDMORE=".03;;STUDY_CHECKIN^.05;;USER_ID^.06;;DATETIME_ACCESSED^.07;;WORKSTATION_ID"
25 D BLDFLD^MDXMLFM(.MDFLD,704.202,".01;I;STUDY_ID^.02;I;PATIENT_ID^.02:.01;;PATIENT_NAME^.02:.09;;PATIENT_SSN^.09;E;STATUS^.02:.02;I;PATIENT_SEX^.02:.03;I;PATIENT_DOB;DATE^.02:.033;;PATIENT_AGE^.04;;STUDY_LOCATION^"_MDMORE)
26 D LOADALL^MDXMLFM($NA(^TMP("MDAS",$J)),704.202,.MDFLD)
27 K ^TMP("MDAS",$J)
28 Q
29 ;
30ALLBYPT ; Return all treatments for a patient
31 N MDFLD
32 D BLDFLD^MDXMLFM(.MDFLD,704.202,".01;I;STUDY_ID^.02;I;PATIENT_ID^.03;I;STUDY_DATETIME^.09;I;STATUS")
33 D LOADALL^MDXMLFM($NA(^MDK(704.202,"C",+P1)),704.202,.MDFLD)
34 Q
35 ;
36ALLRSLT ; Get all available results for a study
37 ;
38 ; If P2=1 then whole list is forced, otherwise, only Unmatched
39 ;
40 N MDFLD,MDFDA,MDLIST
41 D BLDFLD^MDXMLFM(.MDFLD,703.1,".001;;ID^.05;;STUDY_ID")
42 ;D:'$G(P3) LOADALL^MDXMLFM($NA(^MDD(703.1,"ASTUDYID",+P1)),703.1,.MDFLD)
43 ;
44 ; Remove the P3 reference once it's working!
45 ;
46 ; Prepare the lists
47 S MDLIST=$NA(^TMP("MDTEMP",$J)) K @MDLIST
48 S MDFDA=$NA(^TMP("MDFDA",$J)) K @MDFDA
49 ; Scan results by study id
50 F X=0:0 S X=$O(^MDD(703.1,"ASTUDYID",+P1,X)) Q:'X D
51 .Q:$P(^MDD(703.1,X,0),U,9)="P" ; Skip pendings being filed now
52 .Q:'$G(P2)&($P(^MDD(703.1,X,0),U,9)="M") ; Only new results requested
53 .S ^TMP("MDTEMP",$J,X)="" ; Add this study to the list
54 D LOADALL^MDXMLFM(.MDLIST,703.1,.MDFLD)
55 Q
56 ;
57CCOW ; Return CCOW site and production indicator
58 S @RESULTS@(0)=$P($$SITE^VASITE(),"^",3)_"^"_$$PROD^XUPROD()
59 Q
60 ;
61GETRSLT ; Get instrument XML Result
62 I '$D(^MDD(703.1,P1,.4)) S @RESULTS@(0)="0" Q
63 M @RESULTS=^MDD(703.1,P1,.4)
64 S @RESULTS@(0)=+$O(^MDD(703.1,P1,.4,""),-1)
65 ; Set to matched
66 N MDFDA S MDFDA(703.1,P1_",",.09)="M" D FILE^DIE("","MDFDA")
67 Q
68 ;
69GETXML ; Get a single XML field
70 S X=$$GET1^DIQ(P1,P2,P3,,RESULTS)
71 Q
72 ;
73SETXML ; Set a single XML field
74 S @RESULTS@(0)=$$XMLFILER(P1,P2,P3,"P4")
75 Q
76 ;
77UPDUSER ; Update User Access Information
78 Q:$G(P1)=""
79 Q:$G(P2)=""
80 Q:$G(P3)=""
81 N MDFDA S P1=P1_","
82 S:+P2 MDFDA(704.202,P1,.05)=P2
83 S:P3'="" MDFDA(704.202,P1,.06)=P3
84 S:P4'="" MDFDA(704.202,P1,.07)=P4
85 S:+P5 MDFDA(704.202,P1,.09)=P5
86 D FILE^DIE("","MDFDA")
87 K MDFDA
88 S @RESULTS@(0)="1^Information Filed"
89 ;
90GETOPT ; Get option from the Parameters File
91 ;
92 ; P1=Setting Name
93 ; P2=Owner
94 ;
95 N MDOPT
96 S MDOPT=$$FIND1^DIC(704.209,,"X",P1,"B","I $P(^(0),U,2)=P2")
97 I MDOPT<0 S @RESULTS@(0)="-1^No such setting" Q
98 S X=$$GET1^DIQ(704.209,MDOPT_",",.1,,RESULTS)
99 Q
100 ;
101LOCKOPT ; Lock/Unlock an option for update
102 ;
103 ; P1=Setting Name
104 ; P2=0:Unlock;1:Lock
105 ;
106 N MDOPT
107 S MDOPT=$$FIND1^DIC(704.209,,"X",P1,"B","I $P(^(0),U,2)=.5")
108 I 'MDOPT S @RESULTS@(0)="-1^No such setting." Q
109 I 'P2 D Q
110 .L -(^MDK(704.209,+MDOPT,0)) S @RESULTS@(0)="1^Option Unlocked"
111 .N MDFDA
112 .S MDFDA(704.209,+MDOPT_",",.03)=""
113 .S MDFDA(704.209,+MDOPT_",",.04)=""
114 .S MDFDA(704.209,+MDOPT_",",.05)=""
115 .D FILE^DIE("","MDFDA")
116 .Q
117 I +P2 L +(^MDK(704.209,+MDOPT,0)):0 I '$T S @RESULTS@(0)="-1^Unable to lock"_"^"_$P($G(^MDK(704.209,+MDOPT,0)),"^",3,5) Q
118 N MDFDA D NOW^%DTC
119 S MDFDA(704.209,+MDOPT_",",.03)=DUZ
120 S MDFDA(704.209,+MDOPT_",",.04)=%
121 S MDFDA(704.209,+MDOPT_",",.05)=$J
122 D FILE^DIE("","MDFDA")
123 S @RESULTS@(0)="1^Option locked"
124 Q
125 ;
126DELOPT ; Delete option from the RENAL SETTING file(#704.209)
127 ;
128 ; P1=Setting Name
129 ; P2=Owner
130 ;
131 N DA,DIK,MDOPT
132 S MDOPT=$$FIND1^DIC(704.209,,"X",P1,"B","I $P(^(0),U,2)=P2")
133 I 'MDOPT S @RESULTS@(0)="1^No such setting." Q
134 S DA=MDOPT,DIK="^MDK(704.209," D ^DIK
135 S @RESULTS@(0)="1^Setting deleted."
136 Q
137 ;
138SETOPT ; Set option into RENAL SETTING file (#704.209)
139 ;
140 ; P1=Setting Name
141 ; P2=Owner
142 ; P3=Array of text
143 ;
144 N MDOPT
145 S MDOPT=$$FIND1^DIC(704.209,,"X",P1,"B","I $P(^(0),U,2)=P2")
146 D:'MDOPT ; Try to create a new entry
147 .N MDFDA,MDIEN
148 .S MDFDA(704.209,"+1,",.01)=P1
149 .S MDFDA(704.209,"+1,",.02)=P2
150 .D UPDATE^DIE("","MDFDA","MDIEN")
151 .S MDOPT=+$G(MDIEN(1),-1)
152 I 'MDOPT S @RESULTS@(0)="-1^Unable to create entry" Q
153 S @RESULTS@(0)=$$XMLFILER(704.209,MDOPT_",",.1,"P3")
154 Q
155 ;
156ALLOPT ; Get all options by user
157 N MDFLD
158 D BLDFLD^MDXMLFM(.MDFLD,704.209,".001;;NUMBER^.01;;SETTING NAME")
159 K ^TMP("DILIST",$J)
160 D LIST^DIC(704.209,,"@;.01","P","*",,,"B","I $P(^(0),U,2)=P2")
161 F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X S ^TMP("DILIST",$J,"B",+^(X,0),X)=""
162 D LOADALL^MDXMLFM($NA(^TMP("DILIST",$J,"B")),704.209,.MDFLD)
163 Q
164 ;
165XMLFILER(DD,IENS,FLD,ROOT) ; This files UUEncoded XML into Fileman WP
166 N MDFLAG,MDERR,MDL,MDXL ; Set to control appending
167 K ^TMP("MDKXML",$J)
168 S MDXL="",MDL=0
169 F S MDXL=$O(@ROOT@(MDXL)) Q:MDXL="" S MDL=MDL+1,^TMP("MDKXML",$J,MDL)=@ROOT@(MDXL)
170 S MDFLAG=$S(@ROOT@(0)["-- Begin UUEncoded Data --":"",1:"A")
171 D WP^DIE(DD,IENS,FLD,MDFLAG,$NA(^TMP("MDKXML",$J)),"MDERR")
172 I $D(MDERR) Q "-1^"_$G(MDERR("DIERR",1,"TEXT",1),"Unknown Error")
173 Q "1^Filed"_"^"_MDL
174 ;
175GETPROV ; Get list of available providers with name starting with P1
176 N MDFLD,MDDATE,MDDUP,MDRI,MDI1,MDI2,MDLAST,MDMAX,MDPREV,MDTTL,X,X1,X2
177 D BLDFLD^MDXMLFM(.MDFLD,200,".001;;ID^.01;;PROV_NAME^8;;TITLE")
178 S MDRI=0,MDMAX=44,(MDLAST,MDPREV)="",X1=DT,MDFROM=P1,X2=-30 D C^%DTC S MDDATE=DT K X
179 S RESULTS=$NA(^TMP("MDPLIST",$J)) K @RESULTS K ^TMP("DILIST",$J)
180 F Q:MDRI'<MDMAX S MDFROM=$O(^VA(200,"AUSER",MDFROM),1) Q:MDFROM="" D
181 .S MDI1=""
182 .F S MDI1=$O(^VA(200,"AUSER",MDFROM,MDI1),1) Q:'MDI1 D
183 ..I MDDATE>0,$$GET^XUA4A72(MDI1,MDDATE)<1 Q ; Check date?
184 ..S MDDUP=0 ; Init flag, check dupe.
185 ..I ($P(MDPREV_" "," ")=$P(MDFROM_" "," ")) S MDDUP=1
186 ..;
187 ..; Append Title if not duplicated:
188 ..I 'MDDUP D
189 ...S MDI2=MDI1
190 ...D TITLE ; Get Title.
191 ...S MDRI=MDRI+1,^TMP("DILIST",$J,MDRI)=MDI1_U_$$NAMEFMT^XLFNAME(MDFROM,"F","DcMPC")_$S(MDTTL'="":U_"- "_MDTTL,1:"")
192 ;F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X S ^TMP("DILIST",$J,"B",+^(X),X)=""
193 D LOADALL^MDXMLFM1($NA(^TMP("DILIST",$J)),200,.MDFLD)
194 Q
195 ;
196TITLE ; Retrieve Title or Title and Service/Section.
197 ; (Assumes certain vars already set/new'd in calling code.)
198 ;
199 S MDTTL="" ; Init each time.
200 ; DBIA# 4329:
201 S MDTTL=$P($G(^VA(200,MDI2,0)),U,9) ; Get Title pointer.
202 I MDTTL<1 S MDTTL="" ; Reset var if none.
203 ; DBIA# 1234:
204 I MDTTL>0 S MDTTL=$G(^DIC(3.1,MDTTL,0)) ; Actual Title value.
205 Q
206 ;
207VITALS ; File a vitals sign
208 S P3=$$FIND1^DIC(120.51,,"MX",P3)
209 I P3<1 S @RESULTS@(0)="-1^Unknown Vital Type" Q
210 S X=P1_U_P2_U_P3_";"_P4_U_P5_U_P6
211 L +^GMR(120.5,0)
212 D EN1^GMVDCSAV(.ZZZ,X)
213 S @RESULTS@(0)=+$O(^GMR(120.5,"A"),-1)
214 S @RESULTS@(1)=X
215 L -^GMR(120.5,0)
216 Q
217 ;
218GETINST ; Get list of Institutions with name starting with P1
219 N MDFLD
220 D BLDFLD^MDXMLFM(.MDFLD,4,".001;;STATION NUMBER^.01;;STATION NAME")
221 K ^TMP("DILIST",$J)
222 D FIND^DIC(4,,"@;.01","P",P1,"*")
223 F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X S ^TMP("DILIST",$J,"B",+^(X,0),X)=""
224 D LOADALL^MDXMLFM($NA(^TMP("DILIST",$J,"B")),4,.MDFLD)
225 Q
226GETADM ; Get Administrators
227 N MDFLD
228 D BLDFLD^MDXMLFM(.MDFLD,200,".001;;NUMBER^.01;;NAME")
229 K ^TMP("DILIST",$J)
230 D FIND^DIC(200,,"@;.01","P",P1,"*")
231 F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X S ^TMP("DILIST",$J,"B",+^(X,0),X)=""
232 D LOADALL^MDXMLFM($NA(^TMP("DILIST",$J,"B")),200,.MDFLD)
233 Q
234GUI ; Returns Hemodialysis version check
235 ; Returns yes or no
236 S @RESULTS@(0)=$$GET^XPAR("SYS","MDK GUI VERSION",P1,"E")
237 S:@RESULTS@(0)="" @RESULTS@(0)="NO"
238 Q
239CURRENT ; Current Version
240 N MDKLST,MDK,MDKY,MDKY1 S @RESULTS@(0)=""
241 D GETLST^XPAR(.MDKLST,"SYS","MDK GUI VERSION")
242 F MDK=0:0 S MDK=$O(MDKLST(MDK)) Q:MDK<1 S MDKY=$G(MDKLST(MDK)) D
243 . S MDKY1=$P(MDKY,"^")
244 . I $$GET^XPAR("SYS","MDK GUI VERSION",MDKY1,"I") S:@RESULTS@(0)="" @RESULTS@(0)=MDKY1
245 . Q
246 S:@RESULTS@(0)="" @RESULTS@(0)="No Current Version Recorded."
247 Q
248USERINF ; Current User Information
249 N MDUSER
250 S MDUSER(0)=DUZ
251 S MDUSER(1)=$$GET1^DIQ(200,+MDUSER(0)_",",.01)
252 S MDUSER(2)=MDUSER(1)
253 S MDUSER(3)=""
254 S MDUSER(4)=$$GET1^DIQ(200,+MDUSER(0)_",",8)
255 S MDUSER(5)=$$GET1^DIQ(200,+MDUSER(0)_",",29)
256 S MDUSER(6)=$$GET1^DIQ(200,+MDUSER(0)_",",200.07)
257 S MDUSER(7)=$$GET1^DIQ(200,+MDUSER(0)_",",200.1)
258 M @RESULTS=MDUSER K MDUSER
259 Q
Note: See TracBrowser for help on using the repository browser.