source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVF.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1TIUSRVF ; SLC/JM - Server calls for Template Fields ; 02/27/2002
2 ;;1.0;TEXT INTEGRATION UTILITIES;**105,127,132**;Jun 20, 1997
3LOAD(TIUY,FLD) ; Load Template Field by Name
4 N FLDIEN
5 D GETFLD(.TIUY,FLD,0,.FLDIEN)
6 I +FLDIEN S TIUY(.05)=FLDIEN
7 Q
8LOADIEN(TIUY,FLDIEN) ; Load Template Field by IEN
9 D GETFLD(.TIUY,"",0,.FLDIEN)
10 I +FLDIEN S TIUY(.05)=FLDIEN
11 Q
12GETCONV(DIR,L1,L2,COUNT,DOQ) ; Returns a list of XML conversions
13 S L1(1)="&",L2(1)="&" ; Keep "&" first
14 S L1(2)=">",L2(2)=">"
15 S L1(3)="<",L2(3)="&lt;"
16 S COUNT=3
17 I $G(DOQ) D
18 .S L1(4)="'",L2(4)="&apos;"
19 .S L1(5)="""",L2(5)="&quot;"
20 .S COUNT=5
21 I +DIR D ; If Going from L2 to L1, make "&" last entry
22 .N TMP
23 .S TMP=L1(1),L1(1)=L1(COUNT),L1(COUNT)=TMP
24 .S TMP=L2(1),L2(1)=L2(COUNT),L2(COUNT)=TMP
25 Q
26XMLCONV(INPUT,DIR,DOQ) ; Returns Valid XML Text
27 N IFROM,ITO,COUNT,OUTPUT,CNT,IDX,LEN,TMP
28 I DIR D GETCONV(DIR,.ITO,.IFROM,.COUNT,$G(DOQ)) I 1
29 E D GETCONV(DIR,.IFROM,.ITO,.COUNT,$G(DOQ))
30 S OUTPUT=INPUT
31 F CNT=1:1:COUNT D
32 .S LEN=$L(IFROM(CNT))+1
33 .S IDX=0
34 .F S IDX=$F(OUTPUT,IFROM(CNT),IDX) Q:IDX=0 D
35 .. S OUTPUT=$E(OUTPUT,1,IDX-LEN)_ITO(CNT)_$E(OUTPUT,IDX,250)
36 .. S IDX=IDX-(LEN-2)
37 Q OUTPUT
38 ;
39XMLTXT(INPUT,FLDNAME,DOQ) ; Returns Valid XML Text
40 N OUTPUT
41 S OUTPUT=$$XMLCONV(INPUT,0,$G(DOQ))
42 I $G(FLDNAME)'="" S OUTPUT="<"_FLDNAME_">"_OUTPUT_"</"_FLDNAME_">"
43 Q OUTPUT
44 ;
45TRUETXT(INPUT,DOQ) ; Returns True text from XML
46 Q $$XMLCONV(INPUT,1,$G(DOQ))
47 ;
48GETFLD(TIUY,FLD,ASXML,FLDIEN) ; Load Template Field into TIUY
49 N I,J,FNUM,ID,NODE,FIRST,FLDN,FP,NODE3
50 I '+$G(FLDIEN) S FLDIEN=$O(^TIU(8927.1,"B",FLD,0))
51 S FLD=FLDIEN
52 I +FLD'>0 Q
53 S NODE=$G(^TIU(8927.1,FLD,0))
54 S NODE3=$G(^TIU(8927.1,FLD,3))
55 I 'ASXML D I 1
56 . S I=1,TIUY(1)=NODE,ID="D"
57 . I NODE3'="" S I=2,TIUY(2)="U"_U_NODE3
58 E D
59 . D ADD(.TIUY,"<FIELD NAME="""_$$XMLTXT($P(NODE,U,1),"",1)_""">",2)
60 . F FNUM=.02:.01:.16 D
61 . . S FLDN=$$FLDNAME(FNUM),FP=+$E(FNUM_"0",2,3)
62 . . I $P(NODE,U,FP)'="" D ADD(.TIUY,$$XMLTXT($P(NODE,U,FP),FLDN),4)
63 . I NODE3'="" D
64 . . S FLDN=$$FLDNAME(3)
65 . . D ADD(.TIUY,$$XMLTXT(NODE3,FLDN),4)
66 F FNUM=2,10 S:FNUM=10 ID="I" D
67 . S J=0,FIRST=1
68 . F S J=$O(^TIU(8927.1,FLD,FNUM,J)) Q:J'>0 D
69 . . I 'ASXML D I 1
70 . . . S I=I+1
71 . . . S TIUY(I)=ID_U_^TIU(8927.1,FLD,FNUM,J,0)
72 . . E D
73 . . . I FIRST D
74 . . . . S FIRST=0
75 . . . . D ADD(.TIUY,"<"_$$FLDNAME(FNUM)_">",4)
76 . . . D ADD(.TIUY,$$XMLTXT(^TIU(8927.1,FLD,FNUM,J,0),"p"),6)
77 . I ASXML,'FIRST D ADD(.TIUY,"</"_$$FLDNAME(FNUM)_">",4)
78 I ASXML D ADD(.TIUY,"</FIELD>",2)
79 Q
80SAVE(SUCCESS,TIUDA,TIUX) ; Save Template Field
81 ; Input:
82 ; TIUDA=IEN of TEMPLATE record
83 ; TIUX(SEQ)=IEN of item
84 ; Output:
85 ; SUCCESS=IEN of item if successful, or
86 ; 0^ Explanatory message if not
87 N FLD,TMP
88 S SUCCESS=""
89 I (+TIUDA'>0)!($G(TIUX(.01))'="") D Q:$P(SUCCESS,U,1)="0"
90 . I $L($G(TIUX(.01)))<3 D Q
91 . . S SUCCESS="0^Template Field name must be at least 3 characters"
92 . S TIUX(.01)=$$UPPER^TIULS(TIUX(.01))
93 . N FOUNDIEN
94 . S FOUNDIEN=$O(^TIU(8927.1,"B",TIUX(.01),0))
95 . I FOUNDIEN>0,FOUNDIEN'=TIUDA D Q
96 . . S SUCCESS="0^"_TIUX(.01)_" is not a unique name"
97 . I +TIUDA'>0 D
98 . . S TIUDA=$$CREATE($G(TIUX(.01)))
99 S SUCCESS=TIUDA Q:'+SUCCESS
100 D LOCK^TIUSRVF1(.TMP,TIUDA)
101 I TMP=0 D Q
102 . S SUCCESS="0^Template Field currently being edited by another user"
103 F FLD=2,10 D
104 . I +$O(TIUX(FLD,0)) D Q:$D(TIUX)'>9
105 . . K ^TIU(8927.1,TIUDA,FLD)
106 . . I $G(TIUX(FLD,1))="@" K TIUX(FLD) Q
107 . . M ^TIU(8927.1,TIUDA,FLD)=TIUX(FLD) K TIUX(FLD)
108 . . D SETXT0(TIUDA,FLD)
109 I $D(TIUX)>9 D FILE(.SUCCESS,""""_TIUDA_",""",.TIUX)
110 D UNLOCK^TIUSRVF1(.TMP,TIUDA)
111 Q
112CREATE(NAME) ; Get or create Template Field record
113 N DIC,DLAYGO,DR,X,Y
114 S (DIC,DLAYGO)=8927.1,DIC(0)="FL"
115 S X=""""_NAME_"""" D ^DIC
116 I +Y'>0 Q "0^Error Creating New Template Field."
117 Q +Y
118SETXT0(TIUDA,FLD) ; Set the root node of the WP-field
119 N TIUC,TIUI S (TIUC,TIUI)=0
120 I '+$G(FLD) S FLD=2
121 F S TIUI=$O(^TIU(8927.1,TIUDA,FLD,TIUI)) Q:+TIUI'>0 D
122 . S:$D(^TIU(8927.1,TIUDA,FLD,TIUI,0)) TIUC=TIUC+1
123 S ^TIU(8927.1,TIUDA,FLD,0)="^^"_TIUC_U_TIUC_U_DT_"^^"
124 Q
125FILE(SUCCESS,IENS,TIUX) ; Call FM Filer to commit updates to DB
126 N FDA,FDARR,FLAGS,TIUMSG
127 S FDARR="FDA(8927.1,"_IENS_")",FLAGS=""
128 M @FDARR=TIUX
129 D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
130 I $D(TIUMSG)>9 S SUCCESS=0_U_$G(TIUMSG("DIERR",1,"TEXT",1))
131 Q
132EXPORT(TIUXML,FLDS) ; Exports Template Fields as XML
133 ; FLDS should be an array of Template Field names, not IENs
134 N I,IEN
135 K TIUXML
136 D ADD(.TIUXML,"<TEMPLATE_FIELDS>",0)
137 S I=0
138 F S I=$O(FLDS(I)) Q:I'>0 D
139 . S IEN=$O(^TIU(8927.1,"B",FLDS(I),0))
140 . I +IEN D ADDXML(.TIUXML,IEN)
141 D ADD(.TIUXML,"</TEMPLATE_FIELDS>",0)
142 Q
143ADDXML(TIUXML,IEN) ; Add a single Template Field to the XML list
144 D GETFLD(.TIUXML,"",1,IEN)
145 Q
146FLDNAME(FLDNUM) ; Returns Field Name from it's number (DBIA 1412)
147 Q $TR($P(^DD(8927.1,FLDNUM,0),U,1)," ","_")
148FLDNUM(FLDNAME) ; Returns Field Number from it's name (DBIA 1412)
149 Q $O(^DD(8927.1,"B",$TR(FLDNAME,"_"," "),0))
150ADD(XML,TXT,INDENT) ; Add text to XML
151 N IND
152 S $P(IND," ",INDENT+1)=""
153 S XML($O(XML(999999),-1)+1)=IND_TXT
154 Q
155STRIP(INPUT) ;Strips leading and trailing spaces
156 N TIULEN,TIUI,TIUIDX
157 S TIULEN=$L(INPUT)
158 I TIULEN>0 D
159 . S TIUIDX=0
160 . F TIUI=1:1:TIULEN S:($E(INPUT,TIUI)=" ") TIUIDX=TIUI Q:(TIUIDX'=TIUI)
161 . S INPUT=$E(INPUT,TIUIDX+1,TIULEN)
162 . S TIULEN=$L(INPUT)
163 . I TIULEN>0 D
164 . . S TIUIDX=TIULEN+1
165 . . F TIUI=TIULEN:-1:1 S:($E(INPUT,TIUI)=" ") TIUIDX=TIUI Q:(TIUIDX'=TIUI)
166 . . S INPUT=$E(INPUT,1,TIUIDX-1)
167 Q
168STRIPLST(LIST) ; Strip spaces from all list entries
169 N TIUIDX,TIUTEMP
170 S TIUIDX=0
171 F S TIUIDX=$O(@LIST@(TIUIDX)) Q:(TIUIDX'>0) D
172 . S TIUTEMP=@LIST@(TIUIDX)
173 . D STRIP(.TIUTEMP)
174 . S @LIST@(TIUIDX)=TIUTEMP
175 Q
176UPDATE(REPORT,SIDX,STATUS,REQNAME,TRUENAME) ; Update Status
177 I STATUS'="0" D
178 .N END
179 .S SIDX=SIDX+1
180 .I +STATUS D I 1
181 ..I REQNAME=TRUENAME S END=1
182 ..E S END=0_U_TRUENAME
183 .E S END=$P(STATUS,U,2)
184 .S REPORT(SIDX)=REQNAME_U_END
185 .S STATUS=0
186 Q
187IMPORT(REPORT,XMLTMP) ;Call layer for IMPORT2; created to maintain backward
188 ;compatibility and extend the IMPORT function to optionally
189 ;specify saving the template field.
190 D IMPORT2(.REPORT,"XMLTMP",1)
191 Q
192IMPORT2(REPORT,XML,SAVEIT) ; Imports Template Fields from XML
193 ; REPORT returns a status for each Template Field
194 ; Template Field Created Successfully REQUESTED NAME^1
195 ; Template Field Renamed to New Field REQUESTED NAME^0^NEW NAME
196 N PL,PG,PS,PE,I,SIDX,LINE,ITEM,ENDTAG,LEVEL,LEVELS,TAG,ERROR,SKIP
197 N OK2ADD,IEN,INITNAME,REQNAME,TRUENAME,SAVE,DATA,DIDX,DFLDNUM,STATUS
198 D STRIPLST(XML)
199 S (I,SIDX,LEVEL,ERROR,OK2ADD,DIDX,STATUS)=0
200 S (REQNAME,TRUENAME)=""
201 F S I=$O(@XML@(I)) Q:(I'>0)!ERROR D
202 .D UPDATE(.REPORT,.SIDX,.STATUS,REQNAME,TRUENAME)
203 .S LINE=@XML@(I)
204 .F D Q:(LINE="")!ERROR
205 ..S PL=$F(LINE,"<")
206 ..S PG=$F(LINE,">",PL)
207 ..I (PL=0)!(PG'>PL) S ERROR=1 Q
208 ..S ITEM=$E(LINE,PL,PG-2)
209 ..I ITEM="" S ERROR=1 Q
210 ..S LINE=$E(LINE,1,PL-2)_$E(LINE,PG,$L(LINE))
211 ..S PL=$F(LINE,"<")
212 ..I PL>2 D
213 ...S DATA=$$TRUETXT($E(LINE,1,PL-2))
214 ...S LINE=$E(LINE,PL-1,$L(LINE))
215 ..E S DATA=""
216 ..S ENDTAG=($E(ITEM)="/")
217 ..I ENDTAG S ITEM=$E(ITEM,2,$L(ITEM))
218 ..S PS=$F(ITEM," ")
219 ..I ENDTAG,(PS>0)!(LEVEL<1)!($G(LEVELS(LEVEL))'=ITEM) S ERROR=1 Q
220 ..I PS S TAG=$E(ITEM,1,PS-2)
221 ..E S TAG=ITEM
222 ..I TAG="" S ERROR=1 Q
223 ..I ENDTAG D Q
224 ...K LEVELS(LEVEL)
225 ...S LEVEL=LEVEL-1
226 ...I TAG'="p" S DIDX=0
227 ...I TAG="FIELD" S OK2ADD=0 D
228 ....I $D(SAVE) D
229 .....N SUCCESS
230 .....I SAVEIT D SAVE(.SUCCESS,0,.SAVE) I 1
231 .....E S SUCCESS=0_U_"0~"_TRUENAME
232 .....K SAVE
233 .....S STATUS=SUCCESS
234 ..S LEVEL=LEVEL+1
235 ..S LEVELS(LEVEL)=TAG
236 ..I PS,TAG'="FIELD" S ERROR=1 Q
237 ..I TAG="TEMPLATE_FIELDS" Q
238 ..S SKIP=0
239 ..I 'PS,OK2ADD,((DATA'="")!(TAG="p")) D
240 ...I TAG'="p" S SAVE($$FLDNUM(TAG))=DATA
241 ...E D
242 ....I DIDX=0 S DFLDNUM=$$FLDNUM(LEVELS(LEVEL-1))
243 ....S DIDX=DIDX+1
244 ....S SAVE(DFLDNUM,DIDX,0)=DATA
245 ..I PS D Q:(ERROR!SKIP)
246 ...N NAMEIDX
247 ...I ($E(ITEM,PS,PS+5)'="NAME=""")!($E(ITEM,$L(ITEM))'="""") S ERROR=1 Q
248 ...S REQNAME=$E(ITEM,PS+6,$L(ITEM)-1)
249 ...I REQNAME="" S ERROR=1 Q
250 ...S REQNAME=$$TRUETXT(REQNAME,1),INITNAME=REQNAME
251 ...S TRUENAME=REQNAME,NAMEIDX=0
252 ...I $E(INITNAME,1,8)="WORDFLD_" D
253 ....S INITNAME=$E(INITNAME,1,13),TRUENAME=INITNAME_"1",NAMEIDX=1
254 ...F S IEN=+$O(^TIU(8927.1,"B",TRUENAME,0)) D:+IEN Q:(SKIP!('IEN))
255 ....N TMPXML,IDX,J,NO,LASTJ
256 ....D ADDXML(.TMPXML,IEN)
257 ....D STRIPLST("TMPXML")
258 ....S (NO,IDX,LASTJ)=0,J=I,IDX=1
259 ....F S IDX=$O(TMPXML(IDX)) Q:(IDX'>0) S J=$O(@XML@(J)) Q:(J'>0) D Q:NO
260 .....S LASTJ=J
261 .....I TMPXML(IDX)'=@XML@(J) S NO=1
262 ....I 'NO S I=LASTJ-1,LINE="",SKIP=1,STATUS=1 Q
263 ....S NAMEIDX=NAMEIDX+1
264 ....S TRUENAME=$E(INITNAME,1,30-$L(NAMEIDX))_NAMEIDX
265 ...I 'IEN S OK2ADD=1
266 ...Q:SKIP
267 ...S SAVE(.01)=TRUENAME
268 D UPDATE(.REPORT,.SIDX,.STATUS,REQNAME,TRUENAME)
269 I ERROR!(LEVEL>0) D
270 .S SIDX=SIDX+1
271 .S REPORT(SIDX)=U_0_U_"XML FORMAT ERROR"
272 Q
Note: See TracBrowser for help on using the repository browser.