1 | TMGRPC3F ;TMG/kst/Support Functions for GUI_Config ;08/31/08
|
---|
2 | ;;1.02;TMG-LIB;**1**;11/18/08
|
---|
3 | ;
|
---|
4 | ;"TMG RPC FUNCTIONS for a GUI config program
|
---|
5 | ;
|
---|
6 | ;"Kevin Toppenberg MD
|
---|
7 | ;"GNU Lessor General Public License (LGPL) applies
|
---|
8 | ;"7/20/08
|
---|
9 | ;
|
---|
10 | ;"=======================================================================
|
---|
11 | ;" RPC -- Public Functions.
|
---|
12 | ;"=======================================================================
|
---|
13 | ;" <none>
|
---|
14 | ;"=======================================================================
|
---|
15 | ;"PRIVATE API FUNCTIONS
|
---|
16 | ;"=======================================================================
|
---|
17 | ;"REGPAT(TMGOUT,TMGPARAMS) -- register a new patient into VistA, providing not already been registered.
|
---|
18 | ;"SRCHPTEXACT(TMGARRAY) -- search for a preexisting patient, using an exact search
|
---|
19 | ;
|
---|
20 | ;"=======================================================================
|
---|
21 | ;"Dependencies:
|
---|
22 | ;" TMGRPC3* only
|
---|
23 | ;
|
---|
24 | ;"=======================================================================
|
---|
25 | ;
|
---|
26 | REGPAT(TMGOUT,TMGPARAMS) ;"REGISTER PATIENT
|
---|
27 | ;"Purpose: to register a new patient into VistA, providing that they have not
|
---|
28 | ;" already been registered.
|
---|
29 | ;"Note: The search for preexisting records is exact, meaning that DOE,JOHN
|
---|
30 | ;" would be considered different from DOE,JOHN H
|
---|
31 | ;"Input: TMGOUT -- an OUT PARAMETER, PASS BY REFERENCE.
|
---|
32 | ;" TMGPARAMS -- FieldNum1^FieldValue1^FieldNum2^FieldValue2^FieldNum3^FieldValue3^...
|
---|
33 | ;" NOTE: Because I want to be able to specify here the HealthRecordNumber (HRN),
|
---|
34 | ;" even though it is not truly a field in the PATIENT file, I am going
|
---|
35 | ;" to manually allow a field of '0' (HRN) to be specified as a FieldNumber
|
---|
36 | ;"Output: TMGOUT is filled as follows:
|
---|
37 | ;" TMGOUT(0)="1^Success^NewIEN" or
|
---|
38 | ;" "0^BoolAndMessage^NewIEN". Format:
|
---|
39 | ;" [Bool1;Bool2;Bool3;Bool4;Bool5*MessageText] (e.g. '1;0;1;0;0*ErrorMsg')
|
---|
40 | ;" (for Bool fields, 0=no or 1=yes)
|
---|
41 | ;" Bool1 -- patient had previously been registered
|
---|
42 | ;" Bool2 -- patient registered during this Fn
|
---|
43 | ;" Bool3 -- problem filing data into non-identifier fields
|
---|
44 | ;" Bool4 -- problem filing data into sub-file fields
|
---|
45 | ;" Bool5 -- problem with filing HRN
|
---|
46 | ;" "-1^Message" Frank failure...
|
---|
47 | ;" TMGOUT(1)=Long Fileman message (if -1 error, or perhaps 0 code)
|
---|
48 | ;
|
---|
49 | NEW TMGRSLT,TMGRCOD1,TMGRCOD2,TMGRCOD3,TMGRCOD4,TMGRCOD5,TMGRMSG
|
---|
50 | SET TMGRSLT=1,(TMGCOD1,TMGCOD2,TMGCOD3,TMGCOD4,TMGCOD5)=0,TMGMSG=""
|
---|
51 | NEW TMGARRAY
|
---|
52 | NEW TMGFDA,TMGMSG
|
---|
53 | FOR DO QUIT:($LENGTH(TMGPARAMS,"^"))<2
|
---|
54 | . NEW TMGPAIR,TMGFIELD,TMGVALUE
|
---|
55 | . SET TMGPAIR=$PIECE(TMGPARAMS,"^",1,2)
|
---|
56 | . SET TMGFIELD=$PIECE(TMGPAIR,"^",1)
|
---|
57 | . SET TMGVALUE=$PIECE(TMGPAIR,"^",2)
|
---|
58 | . SET TMGPARAMS=$EXTRACT(TMGPARAMS,$LENGTH(TMGPAIR)+2,999)
|
---|
59 | . IF (TMGFIELD="")!(TMGVALUE="") QUIT
|
---|
60 | . SET TMGARRAY(TMGFIELD)=TMGVALUE
|
---|
61 | ;
|
---|
62 | ;"Prepair list of required identifiers (needed to create record)
|
---|
63 | NEW TMGRECID,TMGFLD
|
---|
64 | SET TMGFLD=0
|
---|
65 | FOR SET TMGFLD=$O(^DD(2,TMGFLD)) Q:'TMGFLD DO
|
---|
66 | . NEW NODE,REQUIRED,ID
|
---|
67 | . SET NODE=$GET(^(TMGFLD,0))
|
---|
68 | . IF NODE'="" DO
|
---|
69 | . . SET NAME=$P(NODE,"^")
|
---|
70 | . . SET REQUIRED=$P(NODE,"^",2)["R"
|
---|
71 | . . SET ID=$DATA(^DD(2,0,"ID",TMGFLD))
|
---|
72 | . . IF REQUIRED&ID SET TMGRECID(TMGFLD)=1
|
---|
73 | ;
|
---|
74 | NEW TMGIEN SET TMGIEN=$$SRCHPTEXACT(.TMGARRAY)
|
---|
75 | IF +TMGIEN>0 DO GOTO RP2 ;"Continue to possibly update data in other fields
|
---|
76 | . SET TMGRSL=0,TMGCOD1=1
|
---|
77 | . ;"SET TMGOUT(0)="-1^Patient already registered^"_TMGIEN
|
---|
78 | ;
|
---|
79 | ;"Load TMGFDA with elements of basic record first, then add other
|
---|
80 | ;"fields on subsequent post (I think I have had problems trying to
|
---|
81 | ;"load some fields when the record has not already been created.)
|
---|
82 | KILL TMGIEN
|
---|
83 | SET TMGFDA(2,"+1,",.01)=TMGARRAY(.01)
|
---|
84 | KILL TMGARRAY(.01)
|
---|
85 | SET TMGFLD=""
|
---|
86 | FOR SET TMGFLD=$ORDER(TMGRECID(TMGFLD)) Q:TMGFLD="" DO
|
---|
87 | . IF $DATA(TMGARRAY(TMGFLD))=0 QUIT ;"Required identifier is missing, expect Filman error below
|
---|
88 | . NEW TMGVALUE SET TMGVALUE=$GET(TMGARRAY(TMGFLD))
|
---|
89 | . KILL TMGARRAY(TMGFLD)
|
---|
90 | . IF TMGVALUE="" QUIT
|
---|
91 | . SET TMGFDA(2,"+1,",TMGFLD)=TMGVALUE
|
---|
92 | ;"Create new record
|
---|
93 | DO UPDATE^DIE("SE","TMGFDA","TMGIEN","TMGMSG")
|
---|
94 | IF $DATA(TMGMSG("DIERR")) DO GOTO RPTDONE
|
---|
95 | . SET TMGOUT(0)="-1^See Fileman message"
|
---|
96 | . SET TMGOUT(1)=$$GETERSTR^TMGRPC3G(.TMGMSG)
|
---|
97 | . DO ADDFDA^TMGRPC3G(.TMGFDA,.TMGOUT,2)
|
---|
98 | SET TMGCOD2=1 ;"patient registered OK
|
---|
99 | ;"Get IEN of new record
|
---|
100 | SET TMGIEN=$GET(TMGIEN(1))
|
---|
101 | IF TMGIEN'>0 DO GOTO RPTDONE
|
---|
102 | . SET TMGRSLT=0
|
---|
103 | . SET TMGOUT(0)=TMGRSLT_"^"_TMGCOD1_";"_TMGCOD2_";"_TMGCOD3_";"_TMGCOD4_";"_TMGCOD5_"*Unable to find IEN of added record"
|
---|
104 | ;
|
---|
105 | RP2 ;"Now add the other fields not put in on first pass.
|
---|
106 | NEW TMGFIELD SET TMGFIELD=""
|
---|
107 | KILL TMGFDA,TMGMSG,TMGMVA
|
---|
108 | FOR SET TMGFIELD=$ORDER(TMGARRAY(TMGFIELD)) QUIT:(TMGFIELD="") DO
|
---|
109 | . IF TMGFIELD="0" QUIT ;" pseudoField '0' from client will hold HRN
|
---|
110 | . NEW TMGA
|
---|
111 | . DO FIELD^DID(2,TMGFIELD,,"MULTIPLE-VALUED","TMGA","TMGMSG")
|
---|
112 | . IF TMGA("MULTIPLE-VALUED")=1 SET TMGMVA(TMGFIELD)=1 QUIT ;"Process separately later
|
---|
113 | . NEW TMGVALUE SET TMGVALUE=$GET(TMGARRAY(TMGFIELD))
|
---|
114 | . IF TMGVALUE="" QUIT
|
---|
115 | . SET TMGFDA(2,TMGIEN_",",TMGFIELD)=TMGVALUE
|
---|
116 | ;
|
---|
117 | ;"File additional info in additional fields (Not multi-valued fields)
|
---|
118 | IF $DATA(TMGFDA) DO
|
---|
119 | . DO FILE^DIE("SE","TMGFDA","TMGMSG")
|
---|
120 | IF $DATA(TMGMSG("DIERR")) DO ;"GOTO RPTDONE --Keep going, try to file more...
|
---|
121 | . SET TMGRSLT=0,TMGCOD3=1 ;"Error adding fields
|
---|
122 | . SET TMGOUT(0)=TMGRSLT_"^"_TMGCOD1_";"_TMGCOD2_";"_TMGCOD3_";"_TMGCOD4_";"_TMGCOD5_"*See Fileman message^"_TMGIEN
|
---|
123 | . IF $GET(TMGOUT(1))'="" SET TMGOUT(1)=TMGOUT(1)_"// "
|
---|
124 | . SET TMGOUT(1)=$GET(TMGOUT(1))_$$GETERSTR^TMGRPC3G(.TMGMSG)
|
---|
125 | . DO ADDFDA^TMGRPC3G(.TMGFDA,.TMGOUT,2)
|
---|
126 | ;
|
---|
127 | ;"Now add multi-valued fields into subfiles.
|
---|
128 | ;"It is assumed that the value supplied will go into the .01 field in the subfile.
|
---|
129 | SET TMGFIELD=""
|
---|
130 | KILL TMGFDA,TMGMSG
|
---|
131 | NEW TMGABORT SET TMGABORT=0
|
---|
132 | FOR SET TMGFIELD=$ORDER(TMGMVA(TMGFIELD)) QUIT:(TMGFIELD="")!TMGABORT DO
|
---|
133 | . NEW TMGTEMP,TMGFN SET TMGFN=+$PIECE($GET(^DD(2,TMGFIELD,0)),"^",2)
|
---|
134 | . IF TMGFN'>0 QUIT
|
---|
135 | . NEW TMGVALUE SET TMGVALUE=$GET(TMGARRAY(TMGFIELD))
|
---|
136 | . IF TMGVALUE="" QUIT
|
---|
137 | . SET TMGFDA(TMGFN,"?+1,"_TMGIEN_",",.01)=TMGVALUE
|
---|
138 | . DO UPDATE^DIE("E","TMGFDA","TMGTEMP","TMGMSG")
|
---|
139 | . IF $DATA(TMGMSG("DIERR")) DO
|
---|
140 | . . SET TMGRSLT=0,TMGCOD4=1 ;"Problem adding to subfiles
|
---|
141 | . . SET TMGOUT(0)=TMGRSLT_"^"_TMGCOD1_";"_TMGCOD2_";"_TMGCOD3_";"_TMGCOD4_";"_TMGCOD5_"*See Fileman message^"_TMGIEN
|
---|
142 | . . IF $GET(TMGOUT(1))'="" SET TMGOUT(1)=TMGOUT(1)_"// "
|
---|
143 | . . SET TMGOUT(1)=$GET(TMGOUT(1))_$$GETERSTR^TMGRPC3G(.TMGMSG)
|
---|
144 | . . DO ADDFDA^TMGRPC3G(.TMGFDA,.TMGOUT,2)
|
---|
145 | . . ;"SET TMGABORT=1 --keep going...
|
---|
146 | IF TMGABORT GOTO RPTDONE
|
---|
147 | ;
|
---|
148 | IF $GET(TMGOUT(0))="" SET TMGOUT(0)="1^Success^"_TMGIEN
|
---|
149 | ;
|
---|
150 | NEW TMGHRN SET TMGHRN=$GET(TMGARRAY("0"))="" ;" pseudoField '0' from client will hold HRN
|
---|
151 | IF TMGHRN="" GOTO RPTDONE
|
---|
152 | ;"Set TMGHRN field in file 9000001 (^AUPNPAT), linked to Patient entry
|
---|
153 | ;
|
---|
154 | NEW TMGLOCIEN,TMGINSTIEN
|
---|
155 | ;"Get DEFAULT INSTITUTION from KERNEL SYSTEM PARAMETERS.
|
---|
156 | SET TMGINSTIEN=$PIECE($GET(^XTV(8989.3,1,"XUS")),"^",17) ;" XUS;17 = DEFAULT INSTITUTION
|
---|
157 | IF +TMGINSTIEN'>0 DO GOTO RPTDONE
|
---|
158 | . ;"SET TMGOUT(0)="1^Success (but see message)^"_TMGIEN
|
---|
159 | . SET TMGOUT(0)="0^"_TMGCOD1_";"_TMGCOD2_";"_TMGCOD3_";"_TMGCOD4_";"_TMGCOD5_"*See message^"_TMGIEN
|
---|
160 | . SET TMGOUT(1)="Unable to add HRN because couldn't find value for DEFAULT INSTITUTION in KERNEL SYSTEM PARAMETERS file."
|
---|
161 | ;
|
---|
162 | ;"Get LOCATION file entry pointing to this INSTITUTION
|
---|
163 | SET TMGLOCIEN=$ORDER(^AUTTLOC("B",TMGINSTIEN,""))
|
---|
164 | IF +TMGLOCIEN'>0 DO GOTO RPTDONE
|
---|
165 | . SET TMGOUT(0)="0^"_TMGCOD1_";"_TMGCOD2_";"_TMGCOD3_";"_TMGCOD4_";"_TMGCOD5_"*See message^"_TMGIEN
|
---|
166 | . ;"SET TMGOUT(0)="1^Success (but see message)^"_TMGIEN
|
---|
167 | . SET TMGOUT(1)="Unable to add HRN because couldn't find `"_TMGINSTIEN_" in LOCATION file"
|
---|
168 | ;
|
---|
169 | NEW TMGHRNIEN SET TMGHRNIEN=+$ORDER(^AUNPNPAT("B",TMGIEN,""))
|
---|
170 | IF TMGHRNIEN'>0 DO GOTO RPTDONE
|
---|
171 | . SET TMGOUT(0)="0^"_TMGCOD1_";"_TMGCOD2_";"_TMGCOD3_";"_TMGCOD4_";"_TMGCOD5_"*See message^"_TMGIEN
|
---|
172 | . ;"SET TMGOUT(0)="1^Success (but see message)^"_TMGIEN
|
---|
173 | . SET TMGOUT(1)="Unable to add HRN because couldn't find record in PATIENT/IHS file"
|
---|
174 | ;
|
---|
175 | KILL TMGFDA,TMGMSG
|
---|
176 | ;"Now see if there already is an entry for TMGLOCIEN (DINUM in play, so subFile record#=TMGLOCIEN)
|
---|
177 | IF $GET(^AUPNPAT(TMGHRNIEN,41,TMGLOCIEN,0))="" DO
|
---|
178 | . ;"Put HRN into value for current subfile entry
|
---|
179 | . SET TMGFDA(9000001.41,TMGLOCIEN_","_TMGHRNIEN_",",.02)=TMGHRN
|
---|
180 | . DO FILE^DIE("S","TMGFDA","TMGMSG")
|
---|
181 | . IF $DATA(TMGMSG("DIERR")) DO
|
---|
182 | . . SET TMGOUT(0)="0^"_TMGCOD1_";"_TMGCOD2_";"_TMGCOD3_";"_TMGCOD4_";"_TMGCOD5_"*See message^"_TMGIEN
|
---|
183 | . . ;"SET TMGOUT(0)="1^Success (but see message)^"_TMGIEN
|
---|
184 | . . IF $GET(TMGOUT(1))'="" SET TMGOUT(1)=TMGOUT(1)_"// "
|
---|
185 | . . SET TMGOUT(1)=$GET(TMGOUT(1))_$$GETERSTR^TMGRPC3G(.TMGMSG)
|
---|
186 | . . DO ADDFDA^TMGRPC3G(.TMGFDA,.TMGOUT,2)
|
---|
187 | ELSE DO
|
---|
188 | . ;"Add new subfile entry for HRN
|
---|
189 | . NEW TMGSIEN
|
---|
190 | . SET TMGFDA(9000001.41,TMGLOCIEN_","_TMGHRNIEN_",",.01)=TMGLOCIEN
|
---|
191 | . SET TMGFDA(9000001.41,TMGLOCIEN_","_TMGHRNIEN_",",.02)=TMGHRN
|
---|
192 | . DO UPDATE^DIE("S","TMGFDA","TMGSIEN","TMGMSG")
|
---|
193 | . IF $DATA(TMGMSG("DIERR")) DO
|
---|
194 | . . SET TMGOUT(0)="0^"_TMGCOD1_";"_TMGCOD2_";"_TMGCOD3_";"_TMGCOD4_";"_TMGCOD5_"*See message^"_TMGIEN
|
---|
195 | . . ;"SET TMGOUT(0)="1^Success (but see message)^"_TMGIEN
|
---|
196 | . . IF $GET(TMGOUT(1))'="" SET TMGOUT(1)=TMGOUT(1)_"// "
|
---|
197 | . . SET TMGOUT(1)=$GET(TMGOUT(1))_$$GETERSTR^TMGRPC3G(.TMGMSG)
|
---|
198 | . . DO ADDFDA^TMGRPC3G(.TMGFDA,.TMGOUT,2)
|
---|
199 | ;
|
---|
200 | RPTDONE ;
|
---|
201 | QUIT
|
---|
202 | ;
|
---|
203 | SRCHPTEXACT(TMGARRAY) ;
|
---|
204 | ;"Purpose: to search for a preexisting patient, using an exact search
|
---|
205 | ;" By exact search, I mean that DOE,JOHN would be considered different
|
---|
206 | ;" from DOE,JOHN H because it is a different ascii string. Etc.
|
---|
207 | ;" However, see search description below.
|
---|
208 | ;"Input: TMGARRAY -- PASS BY REFERENCE. Search info. Format:
|
---|
209 | ;" TMGARRAY(.01)=PatientName, e.g. DOE,JOHN
|
---|
210 | ;" TMGARRAY(.02)=Sex e.g. M
|
---|
211 | ;" TMGARRAY(.03)=DOB e.g. 01-04-69 (an external date format)
|
---|
212 | ;" TMGARRAY(.09)=SSNum e.g. 123-45-6789
|
---|
213 | ;"Result: returns DFN (patient IEN), or 0^Message if not found.
|
---|
214 | ;"Notes:
|
---|
215 | ;" The following are sufficient for search:
|
---|
216 | ;" -- SSNum only
|
---|
217 | ;" -- or Name-Sex-DOB
|
---|
218 | ;"
|
---|
219 | ;" Search technique:
|
---|
220 | ;" 1. Search for SSN, if found then no further comparison made.
|
---|
221 | ;" 2. Search for exact name match, no none found, then exit with 0
|
---|
222 | ;" 3. ...
|
---|
223 | ;
|
---|
224 | NEW TMGRESULT SET TMGRESULT=0
|
---|
225 | ;
|
---|
226 | ;"Search by SSN. Quit if match found
|
---|
227 | NEW TMGSSN SET TMGSSN=$TRANSLATE($GET(TMGARRAY(.09)),"-","")
|
---|
228 | IF TMGSSN'="" SET TMGRESULT=+$ORDER(^DPT("SSN",TMGSSN,""))
|
---|
229 | IF TMGRESULT>0 GOTO PSEDONE
|
---|
230 | ;
|
---|
231 | NEW TMGNAME,TMGSEX,TMGDOB
|
---|
232 | SET TMGNAME=$GET(TMGARRAY(.01))
|
---|
233 | IF TMGNAME="" DO GOTO PSEDONE
|
---|
234 | . SET TMGRESULT="0^No Name (.01 field) provided"
|
---|
235 | ;
|
---|
236 | SET TMGSEX=$GET(TMGARRAY(.02))
|
---|
237 | IF TMGSEX="" DO GOTO PSEDONE
|
---|
238 | . SET TMGRESULT="0^Sex (.02 field) not specified"
|
---|
239 | IF (TMGSEX'="M")&(TMGSEX'="F") DO GOTO PSEDONE
|
---|
240 | . SET TMGRESULT="0^Sex should be 'Y' or 'N'. Value provided="_TMGSEX
|
---|
241 | ;
|
---|
242 | SET TMGDOB=$GET(TMGARRAY(.03))
|
---|
243 | IF TMGDOB="" DO GOTO PSEDONE
|
---|
244 | . SET TMGRESULT="0^No DOB (.03 field) provided"
|
---|
245 | NEW %DT,X,Y SET %DT="P" ;"P-Post dates assumed
|
---|
246 | SET X=TMGDOB DO ^%DT SET TMGDOB=Y ;"convert external date into internal format
|
---|
247 | IF +TMGDOB'>0 DO GOTO PSEDONE
|
---|
248 | . SET TMGRESULT="0^Invalid date: "_$GET(TMGARRAY(.03))
|
---|
249 | ;
|
---|
250 | NEW TMGMATCHES MERGE TMGMATCHES=^DPT("B",TMGNAME)
|
---|
251 | IF $DATA(TMGMATCHES)=0 DO GOTO PSEDONE
|
---|
252 | . SET TMGRESULT="0^No match for name"
|
---|
253 | ;
|
---|
254 | ;"Now compare each name match for also matching sex and DOB
|
---|
255 | NEW TMGIEN SET TMGIEN=""
|
---|
256 | FOR SET TMGIEN=$ORDER(TMGMATCHES(TMGIEN)) QUIT:(+TMGIEN'>0) DO
|
---|
257 | . NEW TMGNODE0 SET TMGNODE0=$GET(^DPT(TMGIEN,0))
|
---|
258 | . IF $PIECE(TMGNODE0,"^",2)'=TMGSEX DO QUIT
|
---|
259 | . . KILL TMGMATCHES(TMGIEN)
|
---|
260 | . IF $PIECE(TMGNODE0,"^",3)'=TMGDOB DO QUIT
|
---|
261 | . . KILL TMGMATCHES(TMGIEN)
|
---|
262 | ;
|
---|
263 | ;"TMGMATCHES should contain all entries matching name+sex+DOB
|
---|
264 | SET TMGRESULT=+$ORDER(TMGMATCHES(""))
|
---|
265 | ;"Now check for more than one match
|
---|
266 | IF $ORDER(TMGMATCHES(TMGRESULT))'="" DO GOTO PSEDONE
|
---|
267 | . SET TMGRESULT="0^More than one match found for Name+Sex+DOB"
|
---|
268 | ;
|
---|
269 | PSEDONE ;
|
---|
270 | QUIT TMGRESULT
|
---|
271 | ;
|
---|
272 | ;
|
---|