source: cprs/branches/tmg-cprs/m_files/TMGRPC3F.m@ 834

Last change on this file since 834 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload

File size: 13.4 KB
RevLine 
[796]1TMGRPC3F ;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 ;
26REGPAT(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 ;
105RP2 ;"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 ;
200RPTDONE ;
201 QUIT
202 ;
203SRCHPTEXACT(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 ;
269PSEDONE ;
270 QUIT TMGRESULT
271 ;
272 ;
Note: See TracBrowser for help on using the repository browser.