source: WorldVistAEHR/trunk/r/CLINICAL_PROCEDURES-MD/MDRPCOR.m@ 1753

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

initial load of WorldVistAEHR
File size: 9.5 KB
RevLine 
[613]1MDRPCOR ; HOIFO/DP - Object RPCs (TMDRecordId) ; [01-10-2003 09:14]
2 ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
3 ; Description:
4 ; This routine manages both the MDVCL components and
5 ; the TMDRecordID object
6 ;
7 ; Integration Agreements:
8 ; IA# 3568 [Private] TIUCP call.
9 ; IA# 3266 [Subscription] Calls to DPTLK1
10 ; IA# 3267 [Subscription] Call to DPTLK1
11 ; IA# 10104 [Public] Call to XLFSTR
12 ;
13CHANGES ; [Procedure] Returns number of changes to save
14 S MDCHNG=0,(MDDD,MDIENS)=""
15 F S MDDD=$O(^TMP("MDFDA",$J,MDDD)) Q:MDDD="" D
16 .Q:$E(MDDD,1,$L(DD))'=DD ; Not even the right DD
17 .F S MDIENS=$O(^TMP("MDFDA",$J,MDDD,MDIENS)) Q:MDIENS="" D
18 ..Q:$E(MDIENS,$L(MDIENS)-$L(IENS)+1,$L(MDIENS))'=IENS
19 ..F FLD=0:0 S FLD=$O(^TMP("MDFDA",$J,MDDD,MDIENS,FLD)) Q:'FLD D
20 ...S MDCHNG=MDCHNG+1
21 S @RESULTS@(0)=MDCHNG_"^Changes to Save"
22 Q
23 ;
24CHKVER ; [Procedure]
25 S @RESULTS@(0)=+$G(DATA)'<1
26 Q
27 ;
28CLEARFDA ; [Procedure] Discards changes in the FDA
29 S MDFDA=$NA(^TMP("MDFDA",$J))
30 F S MDFDA=$Q(@MDFDA) Q:MDFDA="" Q:$QS(MDFDA,2)'=$J D
31 .S MDDD=$QS(MDFDA,3),MDIENS=$QS(MDFDA,4)
32 .I MDIENS'?@(".E1"""_IENS_"""") Q
33 .I MDDD'?@("1"""_DD_""".E") Q
34 .K ^TMP("MDFDA",$J,MDDD,MDIENS)
35 S @RESULTS@(0)="1^FDA CLEARED"
36 Q
37 ;
38DELREC ; [Procedure] Delete a fileman record
39 D VAL^DIE(DD,IENS,.01,"FR","@",.MDRET,"MDDEL","MDERR")
40 I MDRET="^" D ERROR^MDRPCU($NA(^TMP($J)),.MDERR) Q
41 D FILE^DIE("","MDDEL","MDERR")
42 I $D(MDERR) D ERROR^MDRPCU($NA(^TMP($J)),.MDERR) Q
43 D RPC(.X,"CLEARFDA",DD,IENS)
44 S @RESULTS@(0)="1^Record Deleted"
45 Q
46 ;
47DT ; [Procedure] Convert date/time via %DT
48 S DATA=$G(DATA,"NOW^TS")
49 S X=$P(DATA,U,1),%DT=$P(DATA,U,2)
50 D ^%DT
51 I Y<1 S @RESULTS@(0)=Y_U_"Invalid date/time input '"_X_"'"
52 E S @RESULTS@(0)=1_U_Y D DD^%DT S $P(@RESULTS@(0),U,3)=Y
53 Q
54 ;
55EXISTS ; [Procedure] Verify that a record exists
56 S X=$$ROOT^DILFD(DD,IENS)
57 S @RESULTS@(0)=$D(@(X_(+IENS)_",0)"))
58 Q
59 ;
60FILENAME ; [Procedure] Return a filename
61 I $$VFILE^DILFD(DD) S @RESULTS@(0)="1^"_$$GET1^DID(DD,"","","NAME")
62 E S @RESULTS@(0)="-1^Not a valid file #"
63 Q
64 ;
65GETCODES ; [Procedure] Returns set of codes
66 S MDTYPE=$$GET1^DID(DD,FLD,"","TYPE","","MDERR")
67 I $D(MDERR) D ERROR^MDRPCU($NA(^TMP($J)),.MDERR) Q
68 D:MDTYPE="SET"
69 .S MDSET=$$GET1^DID(DD,FLD,"","POINTER")
70 .F X=1:1:$L(MDSET,";")-1 D
71 ..S @RESULTS@(X)=$P(MDSET,";",X)
72 .S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_"^Set of Codes"
73 D:MDTYPE="POINTER"
74 .S MDPTR=$$GET1^DID(DD,FLD,"","POINTER")
75 .F X=0:0 S X=$O(@(U_MDPTR_"X)")) Q:'X D
76 ..S Y=$O(@RESULTS@(""),-1)+1
77 ..S @RESULTS@(Y)="`"_X_":"_$P(@(U_MDPTR_"X,0)"),U,1)
78 .S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_"^Pointers as set of codes"
79 Q
80 ;
81GETDATA ; [Procedure] Returns data for a field
82 I $$GET1^DID(DD,FLD,"","TYPE")["WORD" D Q
83 .I $D(^TMP("MDFDA",$J,DD,IENS,FLD)) M ^TMP($J)=^TMP("MDFDA",$J,DD,IENS,FLD)
84 .E S X=$$GET1^DIQ(DD,IENS,FLD,"",$NA(^TMP($J)))
85 .S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
86 I $D(^TMP("MDFDA",$J,DD,IENS,FLD)) S Y=^(FLD) D Q
87 .I $G(DATA) S @RESULTS@(0)=Y Q ; Internal Format
88 .S @RESULTS@(0)=$$EXTERNAL^DILFD(DD,FLD,"",Y)
89 S @RESULTS@(0)=$$GET1^DIQ(DD,IENS,FLD,$S($G(DATA):"I",1:""))
90 Q
91 ;
92GETHELP ; [Procedure] Returns fileman help
93 D HELP^DIE(DD,IENS,FLD,"D")
94 D:'$O(^TMP("DIHELP",$J,0)) HELP^DIE(DD,IENS,FLD,"A")
95 I '$O(^TMP("DIHELP",$J,0)) D Q
96 .S @RESULTS@(0)=1
97 .S @RESULTS@(1)="SORRY: No help available"
98 M ^TMP($J)=^TMP("DIHELP",$J)
99 S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
100 Q
101 ;
102GETIDS ; [Procedure] Returns list of required ID's
103 D FILE^DID(DD,"","REQUIRED IDENTIFIERS;NAME;ENTRIES","MDRET")
104 S X=$NA(MDRET("REQUIRED IDENTIFIERS",0))
105 F S X=$Q(@X) Q:X="" D
106 .S Y=$O(@RESULTS@(""),-1)+1
107 .S @RESULTS@(Y)=@X_U_$$GET1^DID(DD,@X,"","LABEL")_U_$$GET1^DID(DD,@X,"","TYPE")
108 S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_MDRET("NAME")_U_MDRET("ENTRIES")
109 Q
110 ;
111GETLABEL ; [Procedure] Get field label/title
112 S MDLBL=$$GET1^DID(DD,FLD,"",$S($G(DATA):"TITLE",1:"LABEL"))
113 S:$G(DATA)&(MDLBL="") MDLBL=$$GET1^DID(DD,FLD,"","LABEL")
114 S @RESULTS@(0)=MDLBL_":"
115 Q
116 ;
117GETLST ; [Procedure] Get list of records
118 S IENS=$G(IENS),FLD=$G(FLD,"@;.01")
119 S:$P(FLD,";",1)'="@" FLD="@;"_FLD
120 D LIST^DIC(DD,IENS,FLD,"P",,,,,$G(DATA))
121 F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X D
122 .S @RESULTS@(X)=DD_";"_^TMP("DILIST",$J,X,0)
123 S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
124 F X=2:1 Q:$P(^TMP("DILIST",$J,0,"MAP"),U,X)="" D
125 .S @RESULTS@(0)=@RESULTS@(0)_U_$$GET1^DID(DD,$P(^TMP("DILIST",$J,0,"MAP"),U,X),"","LABEL")
126 Q
127 ;
128LOCK ; [Procedure] Lock a record
129 D LOCK^MDRPCU(.RESULTS,DD,IENS) Q
130 ;
131LOOKUP ; [Procedure] Lookup on a DD
132 I DD=2 D RPC(.RESULTS,"PTLKUP",DD,,,DATA) Q
133 D FIND^DIC(DD,IENS,.01,"P",DATA)
134 F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X D
135 .S @RESULTS@(X)=DD_";"_$P(^TMP("DILIST",$J,X,0),U,1,2)
136 I '$D(^TMP($J)) S @RESULTS@(0)="-1^No entries found matching '"_DATA_"'"
137 E S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
138 Q
139 ;
140NEWIEN ; [Procedure] Return next available IEN
141 S @RESULTS@(0)=$O(@($$ROOT^DILFD(DD,$G(IENS))_"""A"")"),-1)+1
142 Q
143 ;
144NEWREC ; [Procedure] Create a new record
145 I $G(DATA)]"" D Q:MDRET="^"
146 .D VAL^DIE(DD,"+1,"_IENS,$P(DATA,U,1),"F",$P(DATA,U,2,250),.MDRET,"MDNEW","MDERR")
147 .I MDRET="^" D ERROR^MDRPCU($NA(^TMP($J)),.MDERR)
148 S MDTMP="DATA"
149 F S MDTMP=$Q(@MDTMP) Q:MDTMP="" D Q:MDRET="^"
150 .D VAL^DIE(DD,"+1,"_IENS,$P(@MDTMP,U,1),"F",$P(@MDTMP,U,2,250),.MDRET,"MDNEW","MDERR")
151 .I MDRET="^" D ERROR^MDRPCU($NA(^TMP($J)),.MDERR)
152 D:$D(MDNEW) UPDATE^DIE("","MDNEW","MDIEN")
153 S @RESULTS@(0)=$G(MDIEN(1),"-1^Unable to create record")
154 Q
155 ;
156PTLKUP ; [Procedure] Patient lookup handled separately for security
157 D FIND^DIC(2,,"@;.01;.02;.03;.09","MP",DATA,45)
158 I $P($G(^TMP("DILIST",$J,0)),U,3) D Q
159 .S @RESULTS@(0)="-1^Too many entries found matching '"_DATA_"', please be more specific."
160 F MDX=0:0 S MDX=$O(^TMP("DILIST",$J,MDX)) Q:'MDX D
161 .S @RESULTS@(MDX)="2;"_$P(^TMP("DILIST",$J,MDX,0),U,1,5)
162 .S MDIENS=+^TMP("DILIST",$J,MDX,0)_","
163 .S $P(@RESULTS@(MDX),U,3)=$$GET1^DIQ(2,MDIENS,.02,"I")
164 .S $P(@RESULTS@(MDX),U,4)=$$GET1^DIQ(2,MDIENS,.03,"I")
165 .S $P(@RESULTS@(MDX),U,10)=$$DOB^DPTLK1(+MDIENS)
166 .S $P(@RESULTS@(MDX),U,11)=$$SSN^DPTLK1(+MDIENS)
167 I '$D(^TMP($J)) S @RESULTS@(0)="-1^No entries found matching '"_DATA_"'"
168 E S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
169 Q
170 ;
171PTRLKUP ; [Procedure] Lookup a pointer field
172 S PTRDD=+$P($$GET1^DID(DD,FLD,"","SPECIFIER"),"P",2)
173 I PTRDD=8925.1 D Q ; Handle TIU Note lookup with TIU API
174 .S DATA=$$UP^XLFSTR(DATA)
175 .D LNGCP^TIUCP(.MDRET,DATA)
176 .I '$O(MDRET(0)) S @RESULTS@(0)=0 Q
177 .I $D(MDRET(44)),$P($P(MDRET(44),U,2),DATA)="" S @RESULTS@(0)=0 Q
178 .F X=0:0 S X=$O(MDRET(X)) Q:'X D:$P($P(MDRET(X),U,2),DATA)=""
179 ..S @RESULTS@(X)="8925.1;"_MDRET(X)
180 .S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
181 D FIND^DIC(PTRDD,"","","PM",DATA,151,"",$G(PTRSCRN))
182 F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X D
183 .S @RESULTS@(X)=PTRDD_";"_^TMP("DILIST",$J,X,0)
184 S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
185 Q
186 ;
187RENAME ; [Procedure] Rename a record
188 I DATA=""!(DATA="@") S @RESULTS@(0)="-1^Deletion Not Supported" Q
189 I $$DUPS^MDRPCU(DD,+IENS,DATA) D Q
190 .S @RESULTS@(0)="-1",@RESULTS@(1)="Duplicates not allowed"
191 D VAL^DIE(DD,IENS,.01,"EFHR",DATA,.MDRET,"MDRENAME","MDERR")
192 I MDRET="^" D ERROR^MDRPCU($NA(^TMP($J)),.MDERR) Q
193 D FILE^DIE("","MDRENAME")
194 S @RESULTS@(0)="1^"_MDRET(0)
195 K ^TMP("MDFDA",$J,DD,IENS,.01) ; In case of editing
196 Q
197 ;
198RPC(RESULTS,OPTION,DD,IENS,FLD,DATA) ; [Procedure] RPC call tag
199 NEW MDCHNG,MDDD,MDDEL,MDERR,MDFDA,MDGBL,MDIENS,MDIEN,MDLBL,MDNEW,MDPTR,MDRENAME,MDRET,MDSET,MDTYPE,MDUTL,PTRDD,PTRSCRN
200 S RESULTS=$NA(^TMP($J)) K @RESULTS
201 D:$T(@OPTION)]"" @OPTION
202 D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDRECORDID","MDRPCOR",OPTION)
203 D CLEAN^DILF
204 Q
205 ;
206SAVEFDA ; [Procedure] Save changes to the VistA database
207 I DD<702!(DD>703.1999) D Q
208 .S @RESULTS@(0)="-1^Non CLINICAL PROCEDURES DD number space"
209 K ^TMP("MDSAVE",$J)
210 S MDFDA=$NA(^TMP("MDFDA",$J))
211 F S MDFDA=$Q(@MDFDA) Q:MDFDA="" Q:$QS(MDFDA,2)'=$J D
212 .S MDDD=$QS(MDFDA,3),MDIENS=$QS(MDFDA,4)
213 .I MDIENS'?@(".E1"""_IENS_"""") Q
214 .I MDDD'?@("1"""_DD_""".E") Q
215 .M ^TMP("MDSAVE",$J,MDDD,MDIENS)=^TMP("MDFDA",$J,MDDD,MDIENS)
216 .K ^TMP("MDFDA",$J,MDDD,MDIENS)
217 I '$D(^TMP("MDSAVE",$J)) S @RESULTS@(0)="1^No changes to save" Q
218 D:IENS?1"+1,".NP ; New record
219 .D UPDATE^DIE("",$NA(^TMP("MDSAVE",$J)),"MDIEN","MDERR")
220 .I '$D(MDERR) S @RESULTS@(0)="1^New Record Created^"_MDIEN(1) Q
221 .D ERROR^MDRPCU($NA(^TMP($J)),.MDERR)
222 .M ^TMP("MDFDA",$J)=^TMP("MDSAVE",$J)
223 D:IENS'?1"+1,".NP ; Existing record
224 .D FILE^DIE("",$NA(^TMP("MDSAVE",$J)),"MDERR")
225 .I '$D(MDERR) S @RESULTS@(0)="1^FDA Saved" Q
226 .D ERROR^MDRPCU($NA(^TMP($J)),.MDERR)
227 .M ^TMP("MDFDA",$J)=^TMP("MDSAVE",$J)
228 K ^TMP("MDSAVE",$J)
229 Q
230 ;
231SETFDA ; [Procedure] Validate data and store in FDA
232 D VAL^DIE(DD,IENS,FLD,"F",.DATA,.MDRET,$NA(^TMP("MDFDA",$J)),"MDERR")
233 I MDRET="^" D ERROR^MDRPCU($NA(^TMP($J)),.MDERR) Q
234 S @RESULTS@(0)="1^FDA Set"
235 Q
236 ;
237UNLOCK ; [Procedure] Unlock a record
238 D UNLOCK^MDRPCU(.RESULTS,DD,IENS) Q
239 ;
240VALIDATE ; [Procedure] Validate data for a field
241 I ($G(DATA)="@"!($G(DATA)=""))&(FLD=.01) D Q
242 .S @RESULTS@(0)="-1^Record Deletion Not Allowed Here."
243 I FLD=.01 I $$DUPS^MDRPCU(DD,+IENS,DATA) D Q
244 .S @RESULTS@(0)="-1",@RESULTS@(1)="Duplicates not allowed"
245 S:$G(DATA)="@" DATA=""
246 I $$GET1^DID(DD,FLD,"","TYPE")["WORD" D Q
247 .S MDGBL=$NA(^TMP("MDFDA",$J,DD,IENS,FLD))
248 .K @MDGBL
249 .I $O(DATA(""))="" S @MDGBL="@",@RESULTS@(0)="1^OK" Q
250 .I $O(DATA(""),-1)=1&($G(DATA(1)))="" S @MDGBL="@",@RESULTS@(0)="1^OK" Q
251 .S X="" F S X=$O(DATA(X)) Q:X="" D
252 ..S Y=$O(@MDGBL@(""""),-1)+1
253 ..S @MDGBL@(Y)=DATA(X)
254 .S @MDGBL=$NA(^TMP("MDSAVE",$J,DD,IENS,FLD))
255 .S RESULTS(0)="1^WP"
256 D VAL^DIE(DD,IENS,FLD,"EF",$G(DATA),.MDRET,$NA(^TMP("MDFDA",$J)),"MDERR")
257 I MDRET="^" D ERROR^MDRPCU($NA(^TMP($J)),.MDERR) Q
258 S @RESULTS@(0)="1^"_MDRET(0)
259 Q
260 ;
Note: See TracBrowser for help on using the repository browser.