source: cprs/branches/tmg-cprs/m_files/TMGSIPH0.m@ 1742

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

replacing soft links with actual files

File size: 16.6 KB
RevLine 
[896]1TMGSIPH0 ;TMG/kst/SIPHON PROGRAM, FOR TRANSFERRING VISTA INSTANCES ;11/27/09
2 ;;1.0;TMG-LIB;**1**;11/27/09
3 ;
4 ;"TMG SIPHON PROGRAM, FOR TRANSFERRING VISTA INSTANCE
5 ;"----===== SERVER-SIDE CODE ====------
6 ;"Kevin Toppenberg MD
7 ;"GNU General Public License (GPL) applies
8 ;"11/27/09
9 ;
10 ;"=======================================================================
11 ;" API -- Public Functions.
12 ;"=======================================================================
13 ;"HANDLMSG(MESSAGE) -- A message handler for communication between VistA instances.
14 ;
15 ;"=======================================================================
16 ;" API -- Private Functions.
17 ;"=======================================================================
18 ;"HANDLGET(REF) --A handler for GET command between VistA instances. Get a ^global node
19 ;"HANDLGDD(FILENUM) -- Return Data Dictionary information about specified file.
20 ;"GETSUBDD(SUBFILENUM) -- Return DD information about subfiles (and sub-subfiles)
21 ;"HANDLORD(REF) --A handler for ORDREF command between VistA instances. Will get ^Global node that is $ORDER'd after REF
22 ;"HANDLNRS(FILENUM) -- Return the highest record number in given file.
23 ;"HANDGRXR(PARAMS) -- Return one record, and associated cross-reference entries
24 ;"SENDFLDS(FILENUM,IEN) -- send any .01 fields VALUES of any pointers OUT
25 ;"HANDLDIC(PARAMS) -- Do a ^DIC lookup in file for value.
26 ;"
27 ;"=======================================================================
28 ;"Dependancies
29 ;"=======================================================================
30 ;"DILF, XLFSTR, TMGSIPHU, TMGKERN2, TMGFMUT2
31 ;"=======================================================================
32 ;
33 ;"=============================================================
34 ;" Below will be core of server-side request handler.
35 ;"=============================================================
36HANDLMSG(MESSAGE) ;
37 ;"Purpose: A message handler for communication between VistA instances.
38 ;"Input MESSAGE -- This is the message send from the client, who will be asking for
39 ;" information and records etc from this instance.
40 ;" Format: 'Command|parameters'
41 ;" -----------------------
42 ;" GET|REF -- Get a ^global node
43 ;" GET DD|FILENUM -- return Data Dictionary information about specified file.
44 ;" ORDREF|REF -- Get ^Global node that is $ORDER'd after REF
45 ;" NUMRECS|FILENUM -- Return the highest record number in given file
46 ;" PT XREF|FILENUM -- Prepair PT XREF for all records pointing INTO specified file.
47 ;" WIPE PT XREF| -- Delete the last run of PT XREF, so it can be refreshened.
48 ;" PREP XREFS|FILENUM^[1] -- Make a xref of cross-references (a backward xref)
49 ;" GET REF & FILE XREF|REF^FILENUM^IENS -- Return one reference, and associated FILENUM cross-reference entries
50 ;" GET RECORD & XREF|FILENUM^IEN -- Return one record, and associated cross-reference entries
51 ;" GET PTRS IN|FILENUM^IEN -- Get a listing of all pointers INTO requested record
52 ;" DO DIC|FILENUM^VALUE -- Do a ^DIC lookup in file for value.
53 ;" GET XREF AGE -- Get age of server-side PT xrefs etc, in HOURS
54 ;" GET .01 FLD|FILENUM^IEN -- Return INTERNAL format of .01 field. Doesn't support subfiles.
55 ;" DUMP REC|FILENUM^IENS^SHOWEMPTY -- Display dump of server record.
56 ;" GET IEN LIST|FILENUM -- Get a listing of all records (IEN's) in specified file.
57 ;" GET IEN HDR|FILENUM -- Get Last IEN,HighestIEN from file header.
58 ;" -----------------------
59 ;"Results: None
60 ;
61 NEW CMD SET CMD=$$UP^XLFSTR($PIECE(MESSAGE,"|",1))
62 SET CMD=$$TRIM^XLFSTR(CMD)
63 NEW PARAMS SET PARAMS=$$TRIM^XLFSTR($PIECE(MESSAGE,"|",2,99))
64 DO DEBUGMSG^TMGKERN2("In HANDLMSG. CMD="_CMD_" & PARAMS="_PARAMS)
65 DO
66 . NEW $ETRAP SET $ETRAP="write ""#ERROR TRAPPED# "",$ZSTATUS,! set $etrap="""",$ecode="""""
67 . IF CMD="GET" DO HANDLGET(PARAMS) QUIT
68 . IF CMD="GET DD" DO HANDLGDD(PARAMS) QUIT
69 . IF CMD="ORDREF" DO HANDLORD(PARAMS) QUIT
70 . IF CMD="NUMRECS" DO HANDLNRS(PARAMS) QUIT
71 . IF CMD="PT XREF" DO HNDLPTIX^TMGSIPH2(PARAMS) QUIT
72 . IF CMD="WIPE PT XREF" DO KILLPTIX^TMGFMUT2 QUIT
73 . IF CMD="GET PTRS IN" DO GETPTIN^TMGSIPH2(PARAMS) QUIT
74 . IF CMD="PREP XREFS" DO BAKXREF^TMGSIPH2(PARAMS) QUIT
75 . IF CMD="GET RECORD & XREF" DO HANDGRXR(PARAMS) QUIT
76 . IF CMD="GET REF & FILE XREF" DO HANDGRFX(PARAMS) QUIT
77 . IF CMD="DO DIC" DO HANDLDIC(PARAMS) QUIT
78 . IF CMD="GET XREF AGE" DO GETXRAGE^TMGSIPH2 QUIT
79 . IF CMD="GET .01 FLD" DO GET01FLD^TMGSIPH2(PARAMS) QUIT
80 . IF CMD="DUMP REC" DO DUMPREC(PARAMS) QUIT
81 . IF CMD="GET IEN LIST" DO HANDIENL^TMGSIPH2(PARAMS) QUIT
82 . IF CMD="GET IEN HDR" DO HANDLIENHDR^TMGSIPH2(PARAMS) QUIT
83 . ELSE DO
84 . . DO SEND^TMGKERN2("Got: ["_MESSAGE_"]. Server is $JOB="_$JOB)
85 QUIT
86 ;"=============================================================
87 ;"=============================================================
88 ;
89HANDLGET(REF) ;
90 ;"Purpose: A handler for GET command between VistA instances. Get a ^global node
91 ;"Input --REF -- reference to a global. May be in Open or Closed format
92 ;"Results: none
93 ;"Output: Will write output to current device (should be socket to other instance)
94 ;
95 NEW OREF SET OREF=$$OREF^DILF(REF)
96 NEW LEN SET LEN=$LENGTH(OREF)
97 SET REF=$$CREF^DILF(REF)
98 NEW DONE SET DONE=0
99 FOR DO QUIT:(DONE>0)
100 . IF $DATA(@REF)#10 DO
101 . . DO SEND^TMGKERN2(REF_"=")
102 . . DO SEND^TMGKERN2("="_$GET(@REF))
103 . SET REF=$QUERY(@REF)
104 . IF (REF="")!($QSUBSCRIPT(REF,1)="") SET DONE=1 QUIT
105 . IF $EXTRACT(REF,1,LEN)'=OREF SET DONE=1 QUIT
106 QUIT
107 ;
108 ;
109HANDLGDD(FILENUM) ; "Handle Get DD
110 ;"Purpose: to return Data Dictionary information about specified file.
111 SET FILENUM=+$GET(FILENUM)
112 NEW REF SET REF=$NAME(^DD(FILENUM))
113 DO HANDLGET(REF)
114 SET REF=$NAME(^DIC(FILENUM))
115 DO HANDLGET(REF)
116 ;"Get nodes from INDEX file
117 NEW IDX SET IDX=""
118 FOR SET IDX=$ORDER(^DD("IX","B",FILENUM,IDX)) QUIT:(IDX="") DO
119 . SET REF=$NAME(^DD("IX",IDX))
120 . DO HANDLGET(REF)
121 NEW FLD SET FLD=0
122 FOR SET FLD=$ORDER(^DD(FILENUM,FLD)) QUIT:(+FLD'>0) DO
123 . NEW PT SET PT=+$PIECE($GET(^DD(FILENUM,FLD,0)),"^",2)
124 . QUIT:(PT'>0)
125 . IF $DATA(^DD(PT,0,"UP")) DO GETSUBDD(PT)
126 QUIT
127 ;
128 ;
129GETSUBDD(SUBFILENUM)
130 ;"Purpose: Return DD information about subfiles (and sub-subfiles)
131 NEW REF SET REF=$NAME(^DD(SUBFILENUM))
132 DO HANDLGET(REF)
133 NEW PT SET PT=+$PIECE($GET(^DD(SUBFILENUM,0)),"^",2)
134 QUIT:(PT'>0)
135 IF $DATA(^DD(PT,0,"UP")) DO GETSUBDD(PT)
136 QUIT
137 ;
138 ;
139HANDLORD(REF) ;
140 ;"Purpose: A handler for ORDREF command between VistA instances.
141 ;" Will get ^Global node that is $ORDER'd after REF
142 ;" e.g. ^TIU(8925,"") --> returns node ^TIU(8925,0,
143 ;" ^TIU(8925, --> returns node ^TIU(8925.1,
144 ;"Input --REF -- reference to a global. May be in Open or Closed format
145 ;"Results: none
146 ;"Output: Will write output to current device (should be socket to other VistA instance)
147 ;"
148 NEW CREF SET CREF=$$CREF^DILF(REF)
149 SET REF=$$ORDREF^TMGSIPHU(CREF)
150 IF REF'="" DO HANDLGET(REF)
151 QUIT
152 ;
153 ;
154HANDLNRS(FILENUM) ;
155 ;"Purpose: Return the highest record number in given file.
156 ;"Input: FILENUM -- The fileman number of the file to return info for.
157 ;"Results: None
158 DO SEND^TMGKERN2($$GETNUMREC^TMGSIPHU(FILENUM))
159 QUIT
160 ;
161 ;
162HANDGRFX(PARAMS) ;" Handler for GET REF & FILE XREF|REF^FILENUM^IENS
163 ;"Purpose: Return one reference, and associated FILENUM cross-reference entries
164 ;" Note: It is anticipated that this will be used to get subfile entries.
165 ;"Input: PARAMS : REF^FILENUM^IENS
166 ;" REF -- should be in OPEN format (ending in a ',')
167 ;" FILENUM -- the subfile number.
168 ;" IENS -- A standard IENS string
169 ;"Output: Will write output to current device (should be socket). Format
170 ;" <Ref>=
171 ;" =<Value>
172 ;" <Ref>=
173 ;" =<Value>
174 ;" ...
175 ;" %PTRSOUT%^PointedToFile^IEN^FIELD_VALUE
176 ;" %PTRSOUT%^PointedToFile^IEN^FIELD_VALUE
177 ;" ...
178 ;"Result: none
179 ;"NOTE: This function will assume that an xref of all the cross-references has
180 ;" already been set up by calling BAKXREF^TMGSIPH1(FILENUM). This can be
181 ;" triggered on the client side by calling QUERY="PREP XREFS|<filenumber>"
182 SET PARAMS=$GET(PARAMS)
183 NEW GREF SET GREF="^"_$PIECE(PARAMS,"^",2) ;"Ref itself has a ^ in it.
184 NEW FILENUM SET FILENUM=$PIECE(PARAMS,"^",3)
185 NEW IENS SET IENS=$PIECE(PARAMS,"^",4)
186 DO HANDLGET(GREF) ;
187 ;"Now send XRef entries for IEN.
188 DO BAKXREF^TMGSIPH2(FILENUM_"^1") ;"organize XRefs if needed, keeping current orangization array
189 NEW REF SET REF=""
190 FOR SET REF=$ORDER(^TMG("PTXREF","XREFS",FILENUM,IENS,REF)) QUIT:(REF="") DO
191 . DO SEND^TMGKERN2(REF_"=")
192 . DO SEND^TMGKERN2("="_$GET(^TMG("PTXREF","XREFS",FILENUM,IENS,REF)))
193 DO SENDFLDS(FILENUM,IENS) ;"Send values of .01 fields for all pointers OUT from record
194 QUIT
195 ;
196 ;
197HANDGRXR(PARAMS) ;
198 ;"Purpose: Return one record, and associated cross-reference entries
199 ;"Input: PARAMS : Filenumber^IEN
200 ;"Output: Will write output to current device (should be socket). Format
201 ;" <Ref>=
202 ;" =<Value>
203 ;" <Ref>=
204 ;" =<Value>
205 ;" ...
206 ;" %PTRSOUT%^PointedToFile^IEN^FIELD_VALUE
207 ;" %PTRSOUT%^PointedToFile^IEN^FIELD_VALUE
208 ;" ...
209 ;"Result: none
210 ;"NOTE: This function will assume that an xref of all the cross-references has
211 ;" already been set up by calling BAKXREF^TMGSIPH1(FILENUM). This can be
212 ;" triggered on the client side by calling QUERY="PREP XREFS|<filenumber>"
213 ;
214 NEW FILENUM,IEN
215 SET PARAMS=$GET(PARAMS)
216 SET FILENUM=+PARAMS
217 SET IEN=$PIECE(PARAMS,"^",2)
218 IF (FILENUM'>0)!(IEN'>0) QUIT
219 NEW GREF SET GREF=$GET(^DIC(FILENUM,0,"GL"))
220 IF GREF="" QUIT
221 DO HANDLGET(GREF_IEN_",") ;
222 ;"Now send XRef entries for IEN.
223 NEW REF SET REF=""
224 DO BAKXREF^TMGSIPH2(FILENUM_"^1") ;"organize XRefs if needed, keeping current orangization array
225 FOR SET REF=$ORDER(^TMG("PTXREF","XREFS",FILENUM,IEN,REF)) QUIT:(REF="") DO
226 . DO SEND^TMGKERN2(REF_"=")
227 . DO SEND^TMGKERN2("="_$GET(^TMG("PTXREF","XREFS",FILENUM,IEN,REF)))
228 DO SENDFLDS(FILENUM,IEN) ;"Send values of .01 fields for all pointers OUT from record
229HGXDN QUIT
230 ;
231 ;
232SENDFLDS(FILENUM,IEN) ;
233 ;"Purpose to send any .01 fields VALUES of any pointers OUT
234 ;"Input: FILENUM -- the file containing the record to be scanned
235 ;" IEN -- The record number being scanned.
236 ;"Results: none
237 ;"Output: Values will be sent to client via SEND^TMGKERN2. Format as follows:
238 ;" %PTRSOUT%^PointedToFile^IEN^FIELD_VALUE
239 ;" %PTRSOUT%^PointedToFile^IEN^FIELD_VALUE
240 NEW TALLY
241 KILL ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM)
242 IF $$REAL1PTOUT^TMGSIPH1(FILENUM,IEN,.TALLY)=1 DO
243 . NEW REF SET REF=""
244 . FOR SET REF=$ORDER(^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",REF)) QUIT:(REF="") DO
245 . . NEW INFO SET INFO=""
246 . . FOR SET INFO=$ORDER(^TMG("TMGSIPH","DD",FILENUM,"PTR OUT",REF,INFO)) QUIT:(INFO="") DO
247 . . . NEW PCE SET PCE=+INFO
248 . . . NEW P2FILE SET P2FILE=$PIECE(INFO,"^",2)
249 . . . NEW P2REF SET P2REF=$PIECE(INFO,"^",3)
250 . . . NEW IENDEPTH SET IENDEPTH=$PIECE(INFO,"^",4)
251 . . . NEW ISVIRT SET ISVIRT=($PIECE(INFO,"^",5)="V")
252 . . . NEW TEMP SET TEMP=IEN KILL IEN SET IEN=TEMP ;"kill subnodes
253 . . . NEW OKCOMBO
254 . . . FOR DO QUIT:(OKCOMBO=0)
255 . . . . SET OKCOMBO=$$IENCOMBO^TMGFMUT2(REF,IENDEPTH,.IEN) ;"Sets up IEN(n).. needed for @REF
256 . . . . QUIT:(OKCOMBO=0)
257 . . . . NEW PT SET PT=$PIECE($GET(@REF),"^",PCE)
258 . . . . IF ISVIRT,$PIECE(PT,";",2)'=P2REF QUIT ;"Loop to handle PTR with different INFO entry (V-Ptrs stored as IEN;OREF)
259 . . . . SET PT=+PT QUIT:(PT'>0)
260 . . . . NEW VALUE SET VALUE=$$FLD01^TMGSIPH2(P2FILE_"^"_PT) ;
261 . . . . DO SEND^TMGKERN2("%PTRSOUT%^"_P2FILE_"^"_PT_"^"_VALUE)
262 . . . KILL IEN("DONE"),IEN("INIT")
263 ;"KILL ^TMG("TMGSIPH","UNRESOLVED",FILENUM)
264 KILL ^TMG("TMGSIPH","NEEDED RECORDS","PTOUT",FILENUM)
265 KILL ^TMG("TMGSIPH","DD",FILENUM)
266 QUIT
267 ;
268 ;
269HANDLDIC(PARAMS) ;
270 ;"Purpose: Do a ^DIC lookup in file for value.
271 ;"Input: Params: this is FILENUM^LOOKUPVALUE
272 ;"Result: Will send back value of Y to client
273 SET PARAMS=$GET(PARAMS)
274 NEW DIC SET DIC=+$PIECE(PARAMS,"^",1)
275 NEW Y,X SET X=$PIECE(PARAMS,"^",2)
276 SET DIC(0)="M"
277 DO ^DIC
278 DO SEND^TMGKERN2(Y)
279 QUIT
280 ;
281 ;
282DUMPREC(PARAMS) ;
283 ;"Purpose: To do a record dump of a server-side record, sending output back to client
284 ;"Input: Params -- FILENUM^IENS^SHOWEMPTY
285 NEW FILENUM,IENS,SHOWEMPTY
286 SET PARAMS=$GET(PARAMS)
287 SET FILENUM=+PARAMS
288 SET IENS=$PIECE(PARAMS,"^",2)
289 IF (FILENUM'>0)!(IENS'>0) QUIT
290 SET SHOWEMPTY=+$PIECE(PARAMS,"^",3)
291 NEW OPTION
292 SET OPTION("WRITE REC FN")="WRLABEL^TMGSIPH0"
293 SET OPTION("WRITE FLD FN")="WFLABEL^TMGSIPH0"
294 SET OPTION("WRITE LINE FN")="WLINE^TMGSIPH0"
295 SET OPTION("WRITE WP LINE")="WWPLINE^TMGSIPH0"
296 NEW TMGDUMPS ;"Will be used with global scope
297 DO DumpRec2^TMGDEBUG(FILENUM,IENS,SHOWEMPTY,,.OPTION)
298 QUIT
299 ;
300 ;
301WRLABEL(IEN,ENDER)
302 ;"Purpose: To actually write out labels for record starting and ending.
303 ;"Input: IEN -- the IEN (record number) of the record
304 ;" ENDER -- OPTIONAL if 1, then ends field.
305 ;"Note: also uses globally scoped variable TMGDUMPS
306 ;"Results: none.
307 ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2
308 SET TMGDUMPS=$GET(TMGDUMPS)
309 IF +$GET(ENDER)>0 DO
310 . IF TMGDUMPS="" SET TMGDUMPS="."
311 ELSE SET TMGDUMPS=TMGDUMPS_" Multiple Entry #"_IEN
312 DO SEND^TMGKERN2(TMGDUMPS)
313 SET TMGDUMPS=""
314 QUIT
315 ;
316WFLABEL(LABEL,FIELD,TYPE,ENDER)
317 ;"Purpose: This is the code that actually does writing of labels etc for output
318 ;" This is a CUSTOM CALL BACK function called by Write1Fld^TMGXMLE2
319 ;"Input: LABEL -- OPTIONAL -- Name of label, to write after 'label='
320 ;" FIELD -- OPTIONAL -- Name of field, to write after 'id='
321 ;" TYPE -- OPTIONAL -- TYPEof field, to write after 'type='
322 ;" ENDER -- OPTIONAL if 1, then ends field.
323 ;"Note: also uses globally scoped variable TMGDUMPS
324 ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2
325 ;"To write out <FIELD label="NAME" id=".01" type="FREE TEXT"> or </FIELD>
326 SET TMGDUMPS=$GET(TMGDUMPS)
327 IF +$GET(ENDER)>0 DO
328 . IF TMGDUMPS="" SET TMGDUMPS="."
329 . DO SEND^TMGKERN2(TMGDUMPS)
330 . SET TMGDUMPS=""
331 ELSE DO
332 . IF $GET(FIELD)'="" SET TMGDUMPS=TMGDUMPS_$$RJ^XLFSTR(FIELD,6," ")_"-"
333 . IF $GET(LABEL)'="" SET TMGDUMPS=TMGDUMPS_LABEL_" "
334 . ;"IF $GET(TYPE)'="" SET TMGDUMPS=TMGDUMPS_"type="""_TYPE_""" "
335 . SET TMGDUMPS=TMGDUMPS_": "
336 QUIT
337 ;
338WLINE(LINE)
339 ;"Purpose: To actually write out labels for record starting and ending.
340 ;"Input: Line -- The line of text to be written out.
341 ;"Note: also uses globally scoped variable TMGDUMPS
342 ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2
343 SET TMGDUMPS=$GET(TMGDUMPS)_$GET(LINE)
344 QUIT
345 ;
346WWPLINE(LINE)
347 ;"Purpose: To actually write out line from WP field
348 ;"Input: Line -- The line of text to be written out.
349 ;"Note: also uses globally scoped variable TMGDUMPS
350 ;"Note: Used by DumpRec2 above, with callback from TMGXMLE2
351 SET TMGDUMPS=$GET(TMGDUMPS)_$GET(LINE)
352 IF TMGDUMPS="" SET TMGDUMPS="."
353 DO SEND^TMGKERN2(TMGDUMPS)
354 SET TMGDUMPS=""
355 QUIT
Note: See TracBrowser for help on using the repository browser.