Ignore:
Timestamp:
Oct 1, 2012, 9:32:46 PM (12 years ago)
Author:
Sam Habiel
Message:

Merged Routines in OHUM branch back in main tree

Location:
ccr/trunk/p
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • ccr/trunk/p

  • ccr/trunk/p/C0CMAIL2.m

    r1336 r1544  
    1 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
    2 V ;;0.1;C0C;nopatch;noreleasedate
    3  ;Copyright 2011 Chris Richardson, Richardson Computer Research
    4  ; Modified 3110615@1040
    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  ;
    57 GETMSG(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  ;  ===================
    115 GATHER(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  ;
    150 GETTYP(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  ;  ===================
    206 NAME(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  ;  ===================
    226 TIME(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  ;
    244 DETAIL(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
    260 GETTYP2(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="--"
    264  S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
    265  S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
    266  S (BCN,CNT,D1,END,SGC)=0
    267  S XX=$G(^XMB(3.9,D0,0))
    268  ; S K=$P(^XMB(3.9,D0,2,0),U,3)
    269  S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
    270  S LST("CREATED")=$$TIME($P(XX,U,3))
    271  F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
    272  S LST("FROM")=$$NAME(XXNM)
    273  ; Get the folks the email is sent to.
    274  S D1=0
    275  F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
    276  . N I,T
    277  . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
    278  . S:T T=$P($G(^VA(200,T,0)),"^")
    279  . S LST("TO",+D1)=T
    280  . S T=$G(^XMB(3.9,D0,6,+D1,0))
    281  . S:T="" T=$P($G(^VA(200,+T,0)),"^")
    282  . S:T="" T="<Unknown>"
    283  . S LST("TO NAME",D1)=T
    284  .QUIT
    285  ; Get the Header for the message
    286  S D1=0
    287  F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
    288  . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
    289  .QUIT
    290  ; Start walking the different sections
    291  S D1=.99999,SEP="@@",SGC=0
    292  F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
    293  . ; Clear any control characters (cr/lf/ff) off
    294  . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
    295  . ; Enter once to set the SEP to capture the separator
    296  . I (SEP="@@")&(X?2."--"5.AN.E)  D   Q
    297  . . I $L(X,FLG)>2 D ERROR("ER10")
    298  . . S SEP=X,END=X_FLG
    299  . . S (CNT,SGC)=1,BCN=0
    300  . . S LST("SEG",SGC)=D1
    301  . .QUIT
    302  . ;
    303  . ; A new SEGMENT separator is set, process original
    304  . I X=SEP  D  QUIT
    305  . . ; Save Current Values
    306  . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF)
    307  . . ;  Close this Segment and prepare to start a New Segment
    308  . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1)
    309  . . ;  Put the result in LST("SEG",SGC,"XML")
    310  . . I $L(BF) D
    311  . . . S ZN=1
    312  . . . N I,T,TBF
    313  . . . S TBF=BF
    314  . . . F I=1:1:($L(TBF,"="))  D
    315  . . . . S BF=$P(TBF,"=",I)_"="
    316  . . . . I BF'="="  D DECODER
    317  . . . .QUIT
    318  . . . S BF=""
    319  . . .QUIT
    320  . . S SGC=SGC+1,BCN=0
    321  . . ; Incriment SGC to start a new Segment
    322  . . S LST("SEG",SGC)=D1
    323  . .QUIT
    324  . ;
    325  . ; Accumulate the 64 bit encoding
    326  . I X=$TR(X,MSK)&$L(X)  S BF=BF_X  QUIT
    327  . ;
    328  . ; Ending Condition, close out the Segment
    329  . I X=END D  QUIT
    330  . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
    331  . . I $L(BF) S ZN=1 D DECODER  S BF="" Q
    332  . .QUIT
    333  . ;
    334  . ; Accumulate the lengths of other lines of the message
    335  . S BCN=BCN+$L(X)
    336  . ; Split out the Content Info
    337  . I X[CON D  Q
    338  . . S J=$P(X,CON,2)
    339  . . I J[" boundary=" D
    340  . . . S SEP=$P($P(J," boundary=",2),"""",2),END=SEP_FLG
    341  . . . Q:SEP?2"-"5.ANP
    342  . . . ;
    343  . . . D ERROR("ER11")
    344  . . . Q:SEP'[" "
    345  . . . ;
    346  . . . D ERROR("ER12")
    347  . . .QUIT
    348  . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9)
    349  . .QUIT
    350  . ;
    351  . ; Everything else is Text, Check for CCR/CCD.
    352  . N KK,UBF
    353  . D
    354  . . S UBF=$$UPPER(X)
    355  . . I UBF["<CONTINUITYOFCARERECORD"   S $P(LST("SEG",SGC),U,3)="CCR" Q
    356  . . ;
    357  . . I UBF["<CLINICALDOCUMENT"         S $P(LST("SEG",SGC),U,3)="CCD" Q
    358  . .QUIT
    359  . ; Look for directives in the text before it gets published
    360  . ;  Look for "=3D" and replace it with a single "=".  I can do more parsing
    361  . ;  but there may be situations where the line has been wrapped.
    362  . D:X["=3D"
    363  . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D"
    364  . .QUIT
    365  . S LST("SEG",SGC,"TXT",D1)=X
    366  .QUIT
    367  QUIT
    368  ;  ===================
    369  ; Break down the Buffer Array so it can be saved.
    370  ;  BF is passed in.
    371 DECODER ;
    372  N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE
    373  S ZBF=BF
    374  ;  Full Buffer, BF, now check for Encryption and Unpack
    375  F RCNT=1:1:$L(ZBF,"=")   D
    376  . N BF
    377  . S BF=$P(ZBF,"=",RCNT)
    378  . ;  Unpacking the 64 bit encoding
    379  . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
    380  . D:$L(TBF)
    381  . . N C,OK,OKCNT,KK,XBF,UBF
    382  . . D
    383  . . . S UBF=$$UPPER(TBF)
    384  . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q
    385  . . . ;
    386  . . . I UBF["<CLINICALDOCUMENT XMLNS="       S $P(LST("SEG",SGC),U,3)="CCD" Q
    387  . . .QUIT
    388  . . ; Check for Bad Signature Decoding, after 100 bad characters
    389  . . S OK=1,OKCNT=0
    390  . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q
    391  . . ;
    392  . . D
    393  . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q
    394  . . . ;
    395  . . . S BF=BF_"="
    396  . . . D NORMAL(.XBF,.TBF)
    397  . . .QUIT
    398  . . M LST("SEG",SGC,"XML",RCNT)=XBF
    399  . .QUIT
    400  .QUIT
    401  QUIT
    402  ;  ===================
    403  ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
    404  ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
    405  ;   >D NORMAL^C0CMAIL(.OUT,BF)
    406 NORMAL(OUTXML,INXML)    ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
    407  ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
    408  ;
    409  N ZN,OUTBF,XX,ZSEP
    410  S INXML=$TR(INXML,$C(10,12,13))
    411  S ZN=1,ZSEP=">"
    412  S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1
    413  F ZN=ZN+1:1:$L(INXML,"><")  D   Q:XX=""
    414  . S XX=$P(INXML,"><",ZN)
    415  . S:$E($RE(XX))=">" ZSEP=""
    416  . Q:XX=""
    417  . ;
    418  . S XX="<"_XX_ZSEP
    419  . D
    420  . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1   Q
    421  . . ;
    422  . . D ERROR("ER05")
    423  . . F ZL=ZL+1:1 D   Q:XX=""
    424  . . .  N XL
    425  . . .  S XL=$E(XX,1,4000)
    426  . . .  S $E(XX,1,4000)=""   ; S XX=$E(XX,4001,999999) ; Remove 4K characters
    427  . . .  S OUTBF(ZL)=XL
    428  . . .QUIT
    429  . .QUIT
    430  .QUIT
    431  M OUTXML=OUTBF
    432  QUIT
    433  ;  ===================
    434 UPPER(X) ; Convert any lowercase letters to Uppercase letters
    435  QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    436  ;  ===================
    437  ; EN is a counter that remains between error events
    438 ERROR(ER) ; Error Handler
    439  N TXXQ,XXXQ
    440  S XXXQ="Unknown Error Encountered = "_ER
    441  S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99)
    442  I TXXQ'=""  D
    443  . I TXXQ["_" X "S TXXQ="_TXXQ
    444  . S XXXQ=TXXQ
    445  .QUIT
    446  S EN(ER)=$G(EN(ER))+1
    447  S LST("ERR",ER,EN(ER))=XXXQ
    448  QUIT
    449  ;  ===================
    450 ER01 ;;Message Missing
    451 ER02 ;;Message Text Missing
    452 ER03 ;;Message Not Identifiable
    453 ER04 ;;Segment is too large
    454 ER05 ;;Mailbox Missing
    455 ER06 ;;"User Missing = "_$G(DUZ)
    456 ER07 ;;"Bad DUZ = "_DUZ
    457 ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN)
    458 ER10 ;;"Bad Separator found = "_X
    459 ER11 ;;"Non-Standard Separator Found:>"_$G(J)
    460 ER12 ;;"Spaces are not allowed in Separators:>"_$G(J)
    461  ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
    462  ;  End note if needed
    463  QUIT
    464  ;  ===================
     1C0CMAIL2        ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr  ; 5/10/12 2:50pm
     2        ;;1.2;C0C;;May 11, 2012;Build 47
     3        ;Copyright 2011 Chris Richardson, Richardson Computer Research
     4        ; Modified 3110615@1040
     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="--"
     264        S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
     265        S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
     266        S (BCN,CNT,D1,END,SGC)=0
     267        S XX=$G(^XMB(3.9,D0,0))
     268        ; S K=$P(^XMB(3.9,D0,2,0),U,3)
     269        S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
     270        S LST("CREATED")=$$TIME($P(XX,U,3))
     271        F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
     272        S LST("FROM")=$$NAME(XXNM)
     273        ; Get the folks the email is sent to.
     274        S D1=0
     275        F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
     276        . N I,T
     277        . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
     278        . S:T T=$P($G(^VA(200,T,0)),"^")
     279        . S LST("TO",+D1)=T
     280        . S T=$G(^XMB(3.9,D0,6,+D1,0))
     281        . S:T="" T=$P($G(^VA(200,+T,0)),"^")
     282        . S:T="" T="<Unknown>"
     283        . S LST("TO NAME",D1)=T
     284        .QUIT
     285        ; Get the Header for the message
     286        S D1=0
     287        F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
     288        . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
     289        .QUIT
     290        ; Start walking the different sections
     291        S D1=.99999,SEP="@@",SGC=0
     292        F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
     293        . ; Clear any control characters (cr/lf/ff) off
     294        . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
     295        . ; Enter once to set the SEP to capture the separator
     296        . I (SEP="@@")&(X?2."--"5.AN.E)  D   Q
     297        . . I $L(X,FLG)>2 D ERROR("ER10")
     298        . . S SEP=X,END=X_FLG
     299        . . S (CNT,SGC)=1,BCN=0
     300        . . S LST("SEG",SGC)=D1
     301        . .QUIT
     302        . ;
     303        . ; A new SEGMENT separator is set, process original
     304        . I X=SEP  D  QUIT
     305        . . ; Save Current Values
     306        . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF)
     307        . . ;  Close this Segment and prepare to start a New Segment
     308        . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1)
     309        . . ;  Put the result in LST("SEG",SGC,"XML")
     310        . . I $L(BF) D
     311        . . . S ZN=1
     312        . . . N I,T,TBF
     313        . . . S TBF=BF
     314        . . . F I=1:1:($L(TBF,"="))  D
     315        . . . . S BF=$P(TBF,"=",I)_"="
     316        . . . . I BF'="="  D DECODER
     317        . . . .QUIT
     318        . . . S BF=""
     319        . . .QUIT
     320        . . S SGC=SGC+1,BCN=0
     321        . . ; Incriment SGC to start a new Segment
     322        . . S LST("SEG",SGC)=D1
     323        . .QUIT
     324        . ;
     325        . ; Accumulate the 64 bit encoding
     326        . I X=$TR(X,MSK)&$L(X)  S BF=BF_X  QUIT
     327        . ;
     328        . ; Ending Condition, close out the Segment
     329        . I X=END D  QUIT
     330        . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
     331        . . I $L(BF) S ZN=1 D DECODER  S BF="" Q
     332        . .QUIT
     333        . ;
     334        . ; Accumulate the lengths of other lines of the message
     335        . S BCN=BCN+$L(X)
     336        . ; Split out the Content Info
     337        . I X[CON D  Q
     338        . . S J=$P(X,CON,2)
     339        . . I J[" boundary=" D
     340        . . . S SEP=$P($P(J," boundary=",2),"""",2),END=SEP_FLG
     341        . . . Q:SEP?2"-"5.ANP
     342        . . . ;
     343        . . . D ERROR("ER11")
     344        . . . Q:SEP'[" "
     345        . . . ;
     346        . . . D ERROR("ER12")
     347        . . .QUIT
     348        . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9)
     349        . .QUIT
     350        . ;
     351        . ; Everything else is Text, Check for CCR/CCD.
     352        . N KK,UBF
     353        . D
     354        . . S UBF=$$UPPER(X)
     355        . . I UBF["<CONTINUITYOFCARERECORD"   S $P(LST("SEG",SGC),U,3)="CCR" Q
     356        . . ;
     357        . . I UBF["<CLINICALDOCUMENT"         S $P(LST("SEG",SGC),U,3)="CCD" Q
     358        . .QUIT
     359        . ; Look for directives in the text before it gets published
     360        . ;  Look for "=3D" and replace it with a single "=".  I can do more parsing
     361        . ;  but there may be situations where the line has been wrapped.
     362        . D:X["=3D"
     363        . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D"
     364        . .QUIT
     365        . S LST("SEG",SGC,"TXT",D1)=X
     366        .QUIT
     367        QUIT
     368        ;  ===================
     369        ; Break down the Buffer Array so it can be saved.
     370        ;  BF is passed in.
     371DECODER ;
     372        N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE
     373        S ZBF=BF
     374        ;  Full Buffer, BF, now check for Encryption and Unpack
     375        F RCNT=1:1:$L(ZBF,"=")   D
     376        . N BF
     377        . S BF=$P(ZBF,"=",RCNT)
     378        . ;  Unpacking the 64 bit encoding
     379        . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
     380        . D:$L(TBF)
     381        . . N C,OK,OKCNT,KK,XBF,UBF
     382        . . D
     383        . . . S UBF=$$UPPER(TBF)
     384        . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q
     385        . . . ;
     386        . . . I UBF["<CLINICALDOCUMENT XMLNS="       S $P(LST("SEG",SGC),U,3)="CCD" Q
     387        . . .QUIT
     388        . . ; Check for Bad Signature Decoding, after 100 bad characters
     389        . . S OK=1,OKCNT=0
     390        . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q
     391        . . ;
     392        . . D
     393        . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q
     394        . . . ;
     395        . . . S BF=BF_"="
     396        . . . D NORMAL(.XBF,.TBF)
     397        . . .QUIT
     398        . . M LST("SEG",SGC,"XML",RCNT)=XBF
     399        . .QUIT
     400        .QUIT
     401        QUIT
     402        ;  ===================
     403        ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
     404        ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
     405        ;   >D NORMAL^C0CMAIL(.OUT,BF)
     406NORMAL(OUTXML,INXML)       ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
     407        ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
     408        ;
     409        N ZN,OUTBF,XX,ZSEP
     410        S INXML=$TR(INXML,$C(10,12,13))
     411        S ZN=1,ZSEP=">"
     412        S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1
     413        F ZN=ZN+1:1:$L(INXML,"><")  D   Q:XX=""
     414        . S XX=$P(INXML,"><",ZN)
     415        . S:$E($RE(XX))=">" ZSEP=""
     416        . Q:XX=""
     417        . ;
     418        . S XX="<"_XX_ZSEP
     419        . D
     420        . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1   Q
     421        . . ;
     422        . . D ERROR("ER05")
     423        . . F ZL=ZL+1:1 D   Q:XX=""
     424        . . .  N XL
     425        . . .  S XL=$E(XX,1,4000)
     426        . . .  S $E(XX,1,4000)=""   ; S XX=$E(XX,4001,999999) ; Remove 4K characters
     427        . . .  S OUTBF(ZL)=XL
     428        . . .QUIT
     429        . .QUIT
     430        .QUIT
     431        M OUTXML=OUTBF
     432        QUIT
     433        ;  ===================
     434UPPER(X)        ; Convert any lowercase letters to Uppercase letters
     435        QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     436        ;  ===================
     437        ; EN is a counter that remains between error events
     438ERROR(ER)       ; Error Handler
     439        N TXXQ,XXXQ
     440        S XXXQ="Unknown Error Encountered = "_ER
     441        S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99)
     442        I TXXQ'=""  D
     443        . I TXXQ["_" X "S TXXQ="_TXXQ
     444        . S XXXQ=TXXQ
     445        .QUIT
     446        S EN(ER)=$G(EN(ER))+1
     447        S LST("ERR",ER,EN(ER))=XXXQ
     448        QUIT
     449        ;  ===================
     450ER01    ;;Message Missing
     451ER02    ;;Message Text Missing
     452ER03    ;;Message Not Identifiable
     453ER04    ;;Segment is too large
     454ER05    ;;Mailbox Missing
     455ER06    ;;"User Missing = "_$G(DUZ)
     456ER07    ;;"Bad DUZ = "_DUZ
     457ER08    ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN)
     458ER10    ;;"Bad Separator found = "_X
     459ER11    ;;"Non-Standard Separator Found:>"_$G(J)
     460ER12    ;;"Spaces are not allowed in Separators:>"_$G(J)
     461        ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
     462        ;  End note if needed
     463        QUIT
     464        ;  ===================
Note: See TracChangeset for help on using the changeset viewer.