source: ccr/trunk/p/C0CMAIL3.m@ 1582

Last change on this file since 1582 was 1544, checked in by Sam Habiel, 12 years ago

Merged Routines in OHUM branch back in main tree
  • Property svn:mergeinfo set to (toggle deleted branches)
    /ccr/branches/ohum/o-old/p/C0CMAIL3.m1290
    /ccr/branches/ohum/p/C0CMAIL3.m1291-1543
    /ccr/branches/ohum/p/p/C0CMAIL3.m1287-1289
File size: 16.7 KB
RevLine 
[1544]1C0CMAIL3 ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr ; 5/10/12 2:51pm
2 ;;1.2;C0C;;May 11, 2012;Build 47
3 ;Copyright 2011 Chris Richardson, Richardson Computer Research
4 ; Modified 3110619@2038
5 ; rcr@rcresearch.us
6 ; Licensed under the terms of the GNU
7 ;General Public License See attached copy of the License.
8 ;
9 ;This program is free software; you can redistribute it and/or modify
10 ;it under the terms of the GNU General Public License as published by
11 ;the Free Software Foundation; either version 2 of the License, or
12 ;(at your option) any later version.
13 ;
14 ;This program is distributed in the hope that it will be useful,
15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;GNU General Public License for more details.
18 ;
19 ;You should have received a copy of the GNU General Public License along
20 ;with this program; if not, write to the Free Software Foundation, Inc.,
21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
22 ;
23 ; ------------------
24 ;Entry Points
25 ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments
26 ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
27 ; Input:
28 ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
29 ; or "*" for all boxes, default is "IN" if missing]"
30 ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
31 ; "*" for All or 9,999 maximum
32 ; MALL?1.n = that number of the n most recent
33 ; Internally:
34 ; BNAM = Box Name
35 ; Output:
36 ; C0CDATA
37 ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket
38 ; (BNAM,"MSG",C0CIEN,"FROM")=Name
39 ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
40 ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
41 ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
42 ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
43 ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
44 ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
45 ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
46 ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
47 ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
48 ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
49 ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
50 ;
51 ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
52 ; Input;
53 ; D0 - The IEN for the message in file 3.9, MESSAGE global
54 ; Output
55 ; OUTBF - The array of your choice to save the expanded and decoded message.
56 ;
57GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data
58 K:'$G(C0CDATA("KEEP")) C0CDATA
59 N U
60 S U="^"
61 D:$G(C0CINPUT)
62 . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
63 . S INPUT=C0CINPUT
64 . S DUZ=+INPUT
65 . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q
66 . ;
67 . D:$D(^XMB(3.7,DUZ,0))#2
68 . . S MBLST=$P(INPUT,";",2)
69 . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
70 . . S:MALL["*" MALL=99999
71 . . ; Only one of these can be correct
72 . . D
73 . . . ; If nul, make it "IN" only
74 . . . I MBLST="" D QUIT
75 . . . . S MBLST("IN")=0,I=0
76 . . . . D GATHER(DUZ,"IN",.LST)
77 . . . .QUIT
78 . . . ;
79 . . . ; If "*", Get all Mailboxes and look for New Messages
80 . . . I MBLST["*" D QUIT
81 . . . . N NAM,NUM
82 . . . . S NUM=0
83 . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D
84 . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
85 . . . . . D GATHER(DUZ,NAM,.LST)
86 . . . . .QUIT
87 . . . .QUIT
88 . . . ;
89 . . . ; If comma separated, look for mailboxes with new messages
90 . . . I $L(MBLST,",")>1 D QUIT
91 . . . . S NAM=""
92 . . . . N TN,V
93 . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D
94 . . . . . I $L(V) D QUIT
95 . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
96 . . . . . . S:NAM="" NAM=V
97 . . . . . . D GATHER(DUZ,NAM,.LST)
98 . . . . . .QUIT
99 . . . . . ;
100 . . . . . D ERROR("ER08")
101 . . . . .QUIT
102 . . . .QUIT
103 . . . ;
104 . . . ; If only 1 mailbox named, go get it
105 . . . I $L(MBLST) D QUIT
106 . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT
107 . . . . ;
108 . . . . D ERROR("ER07")
109 . . .QUIT
110 . . MERGE C0CDATA=LST
111 . .QUIT
112 .QUIT
113 QUIT
114 ; ===================
115GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail
116 N I,J,K,L
117 S (I,K)=0
118 S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
119 F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D
120 . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
121 . D ; :L
122 . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails
123 . . S LST(NAM,"MSG",I)=L
124 . . D GETTYP(I)
125 . .QUIT
126 .QUIT
127 S LST(NAM,"NUMBER")=K
128 QUIT
129 ; ===================
130 ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
131 ; The products of these emails are scanned to identify
132 ; the number of documents stored in the MIME package.
133 ; The protocol runs like this;
134 ; Line 1 is the --separator
135 ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
136 ; Line n+2 thru t-1 where t does NOT have "Content-"
137 ; Line t is Next Section Terminator, or Message Terminator, --separator
138 ; Line t+1 should not exist in the data set if Message Terminator
139 ; CON = "Content-"
140 ; FLG = "--"
141 ; SEP = FLG+7 or more characters ; Separator
142 ; END = SEP+FLG
143 ; SGC = Segment Count
144 ; Note: separator is a string of specific characters of
145 ; indeterminate length
146 ; LST() the transfer array
147 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
148 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
149 ;
150GETTYP(D0) ; Look for the goodies in the Mail
151 N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
152 S CON="Content-"
153 S FLG="--"
154 S SEP="" ; Start SEP as null, so we can use this to help identify the type
155 S (BCN,CNT,D1,END,SGC)=0
156 S XX=$G(^XMB(3.9,D0,0))
157 S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
158 S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
159 F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM)
160 S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
161 S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
162 ; Get the folks the email is sent to.
163 S D1=0
164 F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D
165 . N T
166 . S T=+$G(^XMB(3.9,D0,1,D1,0))
167 . S:T T=$P($G(^VA(200,+T,0)),"^")
168 . S LST("TO",D1)=T
169 . S T=$G(^XMB(3.9,D0,6,D1,0))
170 . S:T T=$P($G(^VA(200,+T,0)),"^")
171 . S:T="" T="<Unknown>"
172 . S LST("TO NAME",D1)=T
173 .QUIT
174 ; Preload first Segment (0) with beginning on Line 1
175 ; if not a 64bit
176 S LST(NAM,"MSG",D0,"SEG",0)=1
177 S D1=.9999,SEP="@@"
178 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D
179 . ; Clear any control characters (cr/lf/ff) off
180 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
181 . ; Enter once to set the SEP to capture the separator
182 . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q
183 . . S SEP=X,END=X_FLG
184 . . S (CNT,SGC)=1,BCN=0
185 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
186 . .QUIT
187 . ;
188 . ; A new separator is set, process original
189 . I X=SEP D QUIT
190 . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF)
191 . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
192 . . S SGC=SGC+1,BCN=0
193 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
194 . .QUIT
195 . ;
196 . S BCN=BCN+$L(X)
197 . I X[CON D Q
198 . . S J=$P($P(X,";"),CON,2)
199 . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
200 . .QUIT
201 . ;
202 . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
203 .QUIT
204 QUIT
205 ; ===================
206NAME(NM) ; Return the name of the Sender
207 N NAME
208 S NAME="<Unknown Sender>"
209 D
210 . ; Look first for a value to use with the NEW PERSON file
211 . ;
212 . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
213 . ;
214 . I $L(NM) S NAME=NM Q
215 . ;
216 . ; Else, pull the data from the message and display the foreign source
217 . ; of the message.
218 . N T
219 . S VAL=$G(^XMB(3.9,D0,.7))
220 . S:VAL T=$P(^VA(200,VAL,0),U)
221 . I $L($G(T)) S NAME=T Q
222 . ;
223 .QUIT
224 QUIT NAME
225 ; ===================
226TIME(Y) ; The time and date of the sending
227 X ^DD("DD")
228 QUIT Y
229 ; ===================
230 ; Segments in Message need to be identified and decoded properly
231 ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message
232 ; ARRAY will have the details of this one call
233 ;
234 ; Inputs;
235 ; C0CINPUT - The IEN of the message to expand
236 ; Outputs;
237 ; C0CDATA - Carrier for the returned structure of the Message
238 ; C0CDATA(D0,"SEG")=number of SEGMENTS
239 ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type
240 ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
241 ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
242 ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
243 ;
244DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery
245 N LST,D0,D1,U
246 S U="^"
247 S D0=+$G(C0CINPUT)
248 I D0 D QUIT
249 . I $D(^XMB(3.9,D0))<10 D ERROR("ER01") QUIT
250 . ;
251 . D GETTYP2(D0)
252 . I $D(LST) M C0CDATA(D0)=LST Q
253 . ;
254 . D ERROR("ER02")
255 .QUIT
256 QUIT
257 ; ===================
258 ; End note if needed
259 ; MSK - Set of characters that do not exist in 64 bit encoding
260GETTYP2(D0) ; Try to get the types and MSK for the
261 N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
262 S CON="Content-",U="^"
263 S FLG="--",MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
264 S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type
265 S (BCN,CNT,D1,END,SGC)=0
266 S XX=$G(^XMB(3.9,D0,0))
267 ; S K=$P(^XMB(3.9,D0,2,0),U,3)
268 S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
269 S LST("CREATED")=$$TIME($P(XX,U,3))
270 F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM)
271 S LST("FROM")=$$NAME(XXNM)
272 ; Get the folks the email is sent to.
273 S D1=0
274 F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1=""
275 . N I,T
276 . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
277 . S:T T=$P($G(^VA(200,T,0)),"^")
278 . S LST("TO",+D1)=T
279 . S T=$G(^XMB(3.9,D0,6,+D1,0))
280 . S:T="" T=$P($G(^VA(200,+T,0)),"^")
281 . S:T="" T="<Unknown>"
282 . S LST("TO NAME",D1)=T
283 .QUIT
284 ; Get the Header for the message and store as "HDR"
285 S D1=0,SGC=0
286 F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D
287 . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
288 .QUIT
289 N BNDRY,STKL,SEG
290 S STKL=0,SEG=0
291 ; Find boundaries and map them
292 S D1=0
293 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D
294 . ; Clear any control characters (cr/lf/ff) off
295 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
296 . ; Look for " boundary=" in the various parts. Map the establishment and the
297 . ; terminator markers and the actual boundary markers.
298 . I X[" boundary=" D Q
299 . . S SEP=$P(X," boundary=",2)
300 . . S:$E(SEP)="""" SEP=$TR(SEP,"""")
301 . . S STKL=STKL+1
302 . . S END=SEP_FLG
303 . . S BNDRY(STKL,SEP)=0
304 . . S BNDRX(SEP)=STKL,BNDRZ(END)=0
305 . .QUIT
306 . ;
307 . ; Look for information as to how amy boudaries are present and where
308 . ; they terminate
309 . D:X'=""&($E(X,1,2)="--")&($E(X,$L(X)-1,9999)'="--")
310 . . ; Boundary Found
311 . . I $D(BNDRX(X)) D Q
312 . . . S SEG=SEG+1
313 . . . S BNDRE(X)=$G(BNDRE(X))_D1_";"
314 . . . S BND1(D1)=STKL_";B;"_SEG_";"_X
315 . . . S BNDR(X,D1,"B")=STKL
316 . . . I BNDRX(X)=X D ERROR("ER13")
317 . . .QUIT
318 . . ;
319 . . ; Boundary Terminator
320 . . I $D(BNDRZ(X)) D Q
321 . . . S BNDR(X,D1,"E")=STKL
322 . . . S BNDRZ(X)=BNDRZ(X)+1
323 . . . S BND1(D1)=STKL_";E;"_SEG_";"_X
324 . . . S SEG=SEG+1
325 . . . I BNDRX(X)=X D ERROR("ER14")
326 . . . S STKL=STKL-1
327 . . .QUIT
328 . .QUIT
329 .QUIT
330 ; Start walking the TEXT/XML/64-BIT ENCODING sections of the message
331 N A,B,C,STACK,STYP,SEG,AX
332 S D1=.99999,SGC=0
333 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D
334 . ; Clear any control characters (cr/lf/ff) off
335 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
336 . ;
337 . D
338 . . I $D(BND1(D1)) D BOUNDARY(X) QUIT
339 . . ;
340 . . S DX=$O(BND1(D1))
341 . . I DX="" D ERROR("ER15") Q
342 . . ;
343 . . ; Good situation, extract the parts for the section
344 . . S A=$G(BND1(DX))
345 . . S STACK=+A,STYP=$P(A,";",2),SGC=$P(A,";",3),AX=$P(A,";",4,999)
346 . .QUIT
347 . ; Enter once to set the SEP to capture the separator
348 . ;
349 . ; A new SEGMENT separator is set, process original
350 . I $D(BND1(X)) D QUIT
351 . . ; Save Current Values
352 . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF)
353 . . ; Close this Segment and prepare to start a New Segment
354 . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1)
355 . . ; Put the result in LST("SEG",SGC,"XML")
356 . . I $L(BF) D
357 . . . S ZN=1
358 . . . N I,T,TBF
359 . . . S TBF=BF
360 . . . F I=1:1:($L(TBF,"=")) D
361 . . . . S BF=$P(TBF,"=",I)_"="
362 . . . . I "="'[BF D DECODER(.BF,.TYP)
363 . . . .QUIT
364 . . . S BF=""
365 . . .QUIT
366 . . S SGC=SGC+1,BCN=0
367 . . ; Incriment SGC to start a new Segment
368 . . S LST("SEG",SGC)=D1
369 . .QUIT
370 . ;
371 . ; Accumulate the 64 bit encoding, no spaces, or other non-64bit characters
372 . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT
373 . ;
374 . ; Ending Condition, close out the Segment
375 . I $D(BNDRZ(X)) D QUIT
376 . . S $P(LST("SEG",SGC),"^",2)=D1-1
377 . . I $L(BF) S ZN=1 D DECODER(.BF,.TYP) S BF="" Q
378 . .QUIT
379 . ;
380 . ; Accumulate the content lines of the message
381 . S BCN=BCN+$L(X)
382 . ; Split out the Content Info
383 . I X[CON D Q
384 . . S J=$P(X,CON,2)
385 . . S TYP="CONTENT"
386 . . S LST("SEG",SGC,TYP,$P(J,":"))=$P(J,":",2,9)
387 . . D CONTENT(D1)
388 . .QUIT
389 . ;
390 . ; Everything else is Text, Check for CCR/CCD.
391 . N KK,UBF
392 . D
393 . . S UBF=$$UPPER(X)
394 . . I UBF["<CONTINUITYOFCARERECORD" S $P(LST("SEG",SGC),U,3)="CCR" Q
395 . . ;
396 . . I UBF["<CLINICALDOCUMENT" S $P(LST("SEG",SGC),U,3)="CCD" Q
397 . .QUIT
398 . ; Look for directives in the text before it gets published
399 . ; Look for "=3D" and replace it with a single "=". I can do more parsing
400 . ; but there may be situations where the line has been wrapped.
401 . D:X["=3D"
402 . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D"
403 . .QUIT
404 . S LST("SEG",SGC,TYP,D1)=X
405 .QUIT
406 QUIT
407 ; ===================
408CONTENT(D1) ; Try pulling Content Statements
409 N J,UP,X
410 S X=$G(^XMB(3.9,D0,2,D1,0))
411 S J=$P(X,CON,2)
412 S UP=$TR($$UPPER(X),"""")
413 S:$G(TYP)="" TYP="TXT"
414 D
415 . I UP["NAME=",($L(UP,".")>1) S TYP=$P(UP,".",2) Q
416 . I UP["XML" S TYP="XML" Q
417 . I UP["P7S" S TYP="P7S" Q
418 . I J[" boundary=" D BOUNDARY(J)
419 .QUIT
420 S LIS("CON",SGC,D1)=X
421 S LIS("CON",SGC,D1,"TYP")=TYP
422 ; If there is a follow-on, look for another line after this.
423 I $E($RE(X),1)=";" D CONTENT(D1+1)
424 QUIT
425 ; ===================
426BOUNDARY(X) ; Set an additional BOUNDARY, and activate another stack level
427 S SEP=$P($P(X," boundary=",2),"""",2),END=SEP_FLG
428 Q:SEP?2"-".ANP
429 ;
430 D ERROR("ER11")
431 Q:SEP'[" "
432 ;
433 D ERROR("ER12")
434 QUIT
435 ; ===================
436 ; Break down the Buffer Array so it can be saved.
437 ; BF is passed in.
438 ; TYP is the type of
439DECODER(BF,TYP) ;
440 N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE
441 S:$G(TYP)="" TYP="XML"
442 S ZBF=BF
443 ; Full Buffer, BF, now check for Encryption and Unpack
444 F RCNT=1:1:$L(ZBF,"=") D
445 . N BF
446 . S BF=$P(ZBF,"=",RCNT)
447 . ; Unpacking the 64 bit encoding
448 . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
449 . D:$L(TBF)
450 . . N C,OK,OKCNT,KK,XBF,UBF
451 . . D
452 . . . S UBF=$$UPPER(TBF)
453 . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q
454 . . . ;
455 . . . I UBF["<CLINICALDOCUMENT XMLNS=" S $P(LST("SEG",SGC),U,3)="CCD" Q
456 . . .QUIT
457 . . ; Check for Bad Signature Decoding, after 100 bad characters
458 . . S OK=1,OKCNT=0
459 . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q
460 . . ;
461 . . D
462 . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q
463 . . . ;
464 . . . S BF=BF_"="
465 . . . D NORMAL(.XBF,.TBF)
466 . . .QUIT
467 . . M LST("SEG",SGC,TYP,RCNT)=XBF
468 . .QUIT
469 .QUIT
470 QUIT
471 ; ===================
472 ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT
473 ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT
474 ; >D NORMAL^C0CMAIL(.OUT,BF)
475NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
476 ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
477 ;
478 N ZN,OUTBF,XX,ZSEP
479 S INXML=$TR(INXML,$C(10,12,13))
480 S ZN=1,ZSEP=">"
481 S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1
482 F ZN=ZN+1:1:$L(INXML,"><") D Q:XX=""
483 . S XX=$P(INXML,"><",ZN)
484 . S:$E($RE(XX))=">" ZSEP=""
485 . Q:XX=""
486 . ;
487 . S XX="<"_XX_ZSEP
488 . D
489 . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q
490 . . ;
491 . . D ERROR("ER05")
492 . . F ZL=ZL+1:1 D Q:XX=""
493 . . . N XL
494 . . . S XL=$E(XX,1,4000)
495 . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters
496 . . . S OUTBF(ZL)=XL
497 . . .QUIT
498 . .QUIT
499 .QUIT
500 M OUTXML=OUTBF
501 QUIT
502 ; ===================
503UPPER(X) ; Convert any lowercase letters to Uppercase letters
504 QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
505 ; ===================
506 ; EN is a counter that remains between error events
507ERROR(ER) ; Error Handler
508 N TXXQ,XXXQ
509 S XXXQ="Unknown Error Encountered = "_ER
510 S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99)
511 I TXXQ'="" D
512 . I TXXQ["_" X "S TXXQ="_TXXQ
513 . S XXXQ=TXXQ
514 .QUIT
515 S EN(ER)=$G(EN(ER))+1
516 S LST("ERR",ER,EN(ER))=XXXQ
517 QUIT
518 ; ===================
519ER01 ;;Message Missing
520ER02 ;;Message Text Missing
521ER03 ;;Message Not Identifiable
522ER04 ;;Segment is too large
523ER05 ;;Mailbox Missing
524ER06 ;;"User Missing = "_$G(DUZ)
525ER07 ;;"Bad DUZ = "_DUZ
526ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN)
527ER10 ;;"Bad Separator found = "_X
528ER11 ;;"Non-Standard Separator Found:>"_$G(J)
529ER12 ;;"Spaces are not allowed in Separators:>"_$G(J)
530ER13 ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X
531 ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv
532 ; End note if needed
533 QUIT
534 ; ===================
Note: See TracBrowser for help on using the repository browser.