Changeset 1332


Ignore:
Timestamp:
Jan 4, 2012, 12:05:03 AM (12 years ago)
Author:
George Lilly
Message:

reset to certification routines with tabs

Location:
ccr/branches/ohum/p
Files:
70 edited

Legend:

Unmodified
Added
Removed
  • ccr/branches/ohum/p/C0CACTOR.m

    r1330 r1332  
    11C0CACTOR         ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.
  • ccr/branches/ohum/p/C0CALERT.m

    r1330 r1332  
    11C0CALERT         ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
    44        ;Licensed under the terms of the GNU General Public License.
  • ccr/branches/ohum/p/C0CBAT.m

    r1330 r1332  
    11C0CBAT    ; CCDCCR/GPL - CCR Batch utilities; 4/21/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.
  • ccr/branches/ohum/p/C0CCCD.m

    r1330 r1332  
    11C0CCCD    ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.
  • ccr/branches/ohum/p/C0CCCD1.m

    r1330 r1332  
    11C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.
  • ccr/branches/ohum/p/C0CCCR.m

    r1330 r1332  
    11C0CCCR    ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.
     
    2626        I Y<1 Q  ; EXIT
    2727        S DFN=$P(Y,U,1) ; SET THE PATIENT
    28         ;OHUM/RUT 3120102 To take inputs from user for date limits and notes
    29         D ^C0CVALID
    30         ;OHUM/RUT
    3128        D XPAT(DFN) ; EXPORT TO A FILE
    3229        Q
     
    171168        ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
    172169        ; gpl - turned off Encounters for Certification
    173         ;OHUM/RUT 3111228 Condition for Notes ; It should be included or not
    174         I ^TMP("C0CCCR","TIULIMIT")'="" D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
    175         ;OHUM/RUT
    176170        Q
    177171        ;
  • ccr/branches/ohum/p/C0CCCR0.m

    r1330 r1332  
    11C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.
  • ccr/branches/ohum/p/C0CCMT.m

    r1330 r1332  
    11C0CCMT   ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10
    2         ;;1.0;C0C;;May 21, 2010;Build 1
     2        ;;1.0;C0C;;May 21, 2010;Build 38
    33        ;Copyright 2010 George Lilly, University of Minnesota and others.
    44        ;Licensed under the terms of the GNU General Public License.
  • ccr/branches/ohum/p/C0CCPT.m

    r1330 r1332  
    11C0CCPT  ;;BSL;RETURN CPT DATA;
    2         ;Sequence Managers Software GPL;;;;;Build 1
     2        ;Sequence Managers Software GPL;;;;;Build 38
    33        ;Copied into C0C namespace from SQMCPT with permission from
    44        ;Brian Lord - and with our thanks. gpl 01/20/2010
     
    1919               ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE
    2020               ;GET DATE OF NOTE
    21         ;OHUM/RUT 3111228 Date Range for Notes
    22                S STDT=^TMP("C0CCCR","TIULIMIT") D NOW^%DTC S ENDDT=X
    23                ;OHUM/RUT
    2421               S Z=""
    2522               F  S Z=$O(NOTE(Z)) Q:Z=""  D
  • ccr/branches/ohum/p/C0CDIC.m

    r1330 r1332  
    1 C0CDIC    ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08
    2         ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
    3         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "This is the CCR Dictionary Utility Library ",!
    21         W !
    22         Q
    23         ;
    24 DIC2CSV ;OUTPUT THE CCR DICTIONARY TO A CSV FILE
    25         ;
    26         N ZI
    27         S ZI=""
    28         S G1=$NA(^TMP($J,"C0CCSV",1))
    29         S G1A=$NA(@G1@("V"))
    30         S G2=$NA(^TMP($J,"C0CCSV",2))
    31         D GETN2^C0CRNF(G1,170) ; GET THE MATRIX
    32         F  S ZI=$O(@G1A@(ZI)) Q:ZI=""  D  ;FOR EACH ROW IN THE MATRIX
    33         . I $G(@G1A@(ZI,"MAPPING METHOD",1))'="" D  ;
    34         . . W @G1A@(ZI,"MAPPING METHOD",1),!
    35         . . ;K @G1A@(ZI,"MAPPING METHOD")
    36         . ;W !,ZI,$G(@G1A@(ZI,"MAPPING METHOD",1))
    37         D RNF2CSV^C0CRNF(G2,G1,"VN") ; PREPARE THE CVS FILE
    38         K @G1
    39         D FILEOUT^C0CRNF(G2,"FILE_"_170_".csv")
    40         K @G2
    41         Q
    42         ;
    43 GVARS(C0CVARS,C0CT)     ; Get the CCR variables from the CCR template
    44         ; and return them in C0CVARS, which is passed by name
    45         ; FIRST PIECE OF C0CVARS(x) IS THE VARIABLE NAME, SECOND PIECE
    46         ; IS THE LINE NUMBER OF THE VARIABLE IN THE TEMPLATE
    47         ; C0CT IS RETURNED AS THE CCR TEMPLATE
    48         N C0CTVARS ; ARRAY FOR THE TEMPLATE AND ARRAY FOR THE VARS
    49         D LOAD^GPLCCR0(C0CT) ; LOAD THE CCR TEMPLATE
    50         D XVARS^GPLXPATH("C0CTVARS",C0CT) ; PULL OUT THE VARS
    51         N C0CI,C0CX
    52         S @C0CVARS@(0)=C0CTVARS(0) ; SAME COUNT
    53         F C0CI=1:1:C0CTVARS(0) D  ; FOR EVERY LINE IN THE ARRAY
    54         . S C0CX=C0CTVARS(C0CI) ; THE VARIABLE - 3 PIECES, FIRST ONE NULL
    55         . S @C0CVARS@(C0CI)=$P(C0CX,"^",2)_"^"_$P(C0CX,"^",3) ; VAR NAME^LINE NUMBER
    56         ;D PARY^GPLXPATH("C0CVARS")
    57         Q
    58         ;
    59 GXPATH(C0CPVARS,C0CPT)  ; LOAD THE CCR TEMPLATE INTO C0CPT, PULL OUT VARIABLES
    60         ; AND THE XPATH TO THE VARIABLES INTO C0CPVARS
    61         ; BY INDEXING THE TEMPLATE C0CT AND MATCHING THE XPATH TO THE VARIABLE
    62         ; BOTH ARE PASSED BY NAME
    63         ; C0CPVARS(x) IS VAR^LINENUM^XPATH SORTED BY LINENUM
    64         ; C0CPVARS(0) IS NUMBER OF VARIABLES
    65         ; C0CPT(0) IS NUMBER OF LINES IN THE TEMPLATE
    66         D GVARS(C0CPVARS,C0CPT) ; GET THE VARIABLES AND LINE NUMBERS
    67         ;N C0CTVARS ; HASH TABLE FOR VARIABLE BY LINE NUMBER
    68         D HASHV ; PUT THE VARIABLES IN A LINE NUMBER HASH FOR MATCHING TO XPATHS
    69         ; NOW GO GET THE XPATH INDEXES
    70         D INDEX^GPLXPATH(C0CPT) ; ADD THE XPATH INDEXES TO THE TEMPLATE ARRAY
    71         S C0CI="" ; GOING TO LOOP THROUGH THE WHOLE ARRAY LOOKING AT XPATHS
    72         F  S C0CI=$O(@C0CPT@(C0CI)) Q:C0CI=""  D  ; VISIT EVERY LINE
    73         . I +C0CI'=0 Q  ; SKIP EVERYTHING BUT THE XPATH INDEX
    74         . I C0CI=0 Q  ; SKIP THE ZERO NODE
    75         . S C0CX=@C0CPT@(C0CI) ; PULL OUT THE LINE NUMBERS X^Y
    76         . S C0CY=$P(C0CX,"^",1) ; STARTING LINE NUMBER
    77         . S C0CZ=$P(C0CX,"^",2) ; ENDING LINE NUMBER
    78         . I C0CY=C0CZ D  ; THIS IS AN XPATH END NODE, HAS A VARIABLE (WE HOPE)
    79         . . ; W "FOUND ",C0CI,!
    80         . . I $D(C0CTVARS(C0CY)) D  ; IF THERE IS A VARIABLE THERE
    81         . . . S $P(C0CTVARS(C0CY),"^",3)=C0CI ; INSERT THE XPATH FOR THE VAR
    82         D SORTV ; SORT THE ARRAY BY LINE NUMBER
    83         Q
    84         ;
    85 HASHV   ; INTERNAL ROUTINE TO PUT VARIABLE NAMES IN A LINE NUMBER HASH
    86         ;N C0CI,C0CTVARS,C0CX,C0CY
    87         F C0CI=1:1:@C0CPVARS@(0) D  ; FOR THE ENTIRE ARRAY
    88         . S C0CX=$P(@C0CPVARS@(C0CI),"^",2) ; LINE NUMBER
    89         . S C0CY=$P(@C0CPVARS@(C0CI),"^",1) ; VARIABLE NAME
    90         . S C0CTVARS(C0CX)=C0CY ; BUILD HASH OF VARIABLES BY LINE NUMBER
    91         Q
    92         ;
    93 SORTV   ; INTERNAL ROUTINE TO OUTPUT VARIABLES (AND XPATHS) IN LINE NUMBER ORDER
    94         ;N C0CV2 ; SCRACTH SPACE FOR BUILDING SORTED ARRAY
    95         S C0CI="" ;
    96         F  S C0CI=$O(C0CTVARS(C0CI)) Q:C0CI=""  D  ; BY LINE NUMBER
    97         . S C0CX=C0CTVARS(C0CI) ;VARIABLE NAME
    98         . S $P(C0CX,"^",2)=C0CI ; LINE NUMBER IS SECOND PIECE
    99         . D PUSH^GPLXPATH("C0C2",C0CX) ; PUT ONTO ARRAY
    100         K @C0CPVARS
    101         M @C0CPVARS=C0C2
    102         Q
    103         ;
    104 LOAD    ; LOAD VARIABLE NAMES AND XPATH IN ^C0CDIC(170
    105         ; INITIAL LOAD OF THE CCR DICTIONARY
    106         ;
    107         N C0CDIC,C0CARY,C0CXML,C0CFDA,C0CI
    108         S C0CDIC="^C0CDIC(170," ; ROOT OF THE CCR DICTIONARY
    109         D GXPATH("C0CARY","C0CXML") ; FETCH THE VARIABLES AND XPATH INTO C0CARY
    110         ; C0CXML WILL CONTAIN THE TEMPLATE - NOT NEEDED FOR LOAD
    111         D PARY^GPLXPATH("C0CARY") ;TEST
    112         F C0CI=1:1:C0CARY(0) D  ; LOAD EACH VARIABLE
    113         . S C0CFDA(170,"+"_C0CI_",",.01)=$P(C0CARY(C0CI),"^",1) ; VAR NAME
    114         . S C0CFDA(170,"+"_C0CI_",",2)=$P(C0CARY(C0CI),"^",3) ; XPATH
    115         . D UPDATE^DIE("","C0CFDA")
    116         . I $D(^TMP("DIERR",$J)) U $P BREAK
    117         . W "LOADING:",C0CI," ",C0CARY(C0CI),!
    118         Q
    119         ;
    120 INIT    ; INITIALIZE CCR DICTIONARY BASED ON VARIABLE NAMES
    121         ;
    122         ; CHEAT SHEET FOR VARIABLE NAMES IN ^C0CDIC(170.xx,
    123         ; THIS IS WHAT WILL BE IN C0CA FOR EACH DICTIONARY ENTRY
    124         ;G1("CODING")="170^8"
    125         ;G1("DATA ELEMENT")="170^7"
    126         ;G1("DESCRIPTION")="170^3"
    127         ;G1("ID")="170^1"
    128         ;G1("M","170^8","CODING")="170.08^.01"
    129         ;G1("MAPPING METHOD")="170.08^1"
    130         ;G1("SECTION")="170^10"
    131         ;G1("SOURCE")="170^4"
    132         ;G1("STATUS")="170^9"
    133         ;G1("TYPE")="170^6"
    134         ;G1("VARIABLE")="170^.01"
    135         ;G1("XPATH")="170^2"
    136         ;
    137         N C0CZA,C0CZX,C0CN,C0CSTAT
    138         S C0CZX=0
    139         S C0CSTAT=0 ; INIT STATUS SET FLAG
    140         F  S C0CZX=$O(^C0CDIC(170,C0CZX)) Q:+C0CZX=0  D  ; FOR EACH DICT ENTRY
    141         . ;W C0CZX,!
    142         . K C0CA,C0CN ; CLEAR OUT THE LAST ONE
    143         . D GETN1^C0CRNF("C0CA",170,C0CZX,"","ALL") ; GET VARIABLE HASH
    144         . ;ZWR C0CA B ;
    145         . S C0CN=$$ZVALUE("VARIABLE") ;NAME OF THE VARIABLE
    146         . W "VARIABLE: ",C0CN,!
    147         . I $E(C0CN,1,5)="ACTOR" D SETFDA("SECTION","ACTORS") ;
    148         . I $E(C0CN,1,6)="SOCIAL" D  ;
    149         . . D SETFDA("SECTION","SOC") ;
    150         . . D SETFDA("STATUS","X") ;SOCIAL HISTORY NOT IMPLEMENTED
    151         . . S C0CSTAT=1
    152         . I $E(C0CN,1,6)="FAMILY" D  ;
    153         . . D SETFDA("SECTION","FAM") ;
    154         . . D SETFDA("STATUS","X") ;FAMILY HISTORY NOT IMPLEMENTED
    155         . . S C0CSTAT=1
    156         . ;D SETFDA("TYPE","") ;CORRECT FOR TYPE ERRORS
    157         . I $E(C0CN,1,5)="ALERT" D SETFDA("SECTION","ALERTS")
    158         . I $E(C0CN,1,5)="VITAL" D SETFDA("SECTION","VITALS")
    159         . I $E(C0CN,1,7)="PROBLEM" D SETFDA("SECTION","PROBLEMS")
    160         . I $E(C0CN,1,10)="RESULTTEST" D SETFDA("SECTION","TEST")
    161         . E  I $E(C0CN,1,6)="RESULT" D SETFDA("SECTION","LABS")
    162         . I C0CN["CODEVALUE" D SETFDA("TYPE","CD") ;CODES
    163         . I C0CN["CODEVERSION" D SETFDA("TYPE","CV") ; CODE VERSION
    164         . I C0CN["CODINGSYSTEM" D SETFDA("TYPE","CS") ;CODING SYSTEM
    165         . I $$ZVALUE("STATUS")=""!'C0CSTAT D SETFDA("STATUS","N") ;BLANK STATUS TO N
    166         . I $$ZVALUE("XPATH")["/Medication/Directions/" D  ; MEDS DIRECTIONS VAR
    167         . . D SETFDA("SECTION","DIR") ; SPECIAL SECTION FOR DIRECTIONS
    168         . E  I $$ZVALUE("XPATH")["/Medications/Medication/" D  ; ALL OTHER MEDS
    169         . . D SETFDA("SECTION","MEDS") ; A MEDS VAR
    170         . I $E(C0CN,($L(C0CN)-1),$L(C0CN))="ID" D SETFDA("TYPE","ID") ;CATCH THE IDS
    171         . I C0CN["DATETIME" D SETFDA("TYPE","DT") ; DATE/TIME VARIABLE
    172         . W "VARIABLE: ",C0CZX," ",C0CA("VARIABLE"),!
    173         . ;ZWR C0CFDA
    174         . I $D(C0CFDA) D  ; WE HAVE CHANGES ON THIS VARIABLE
    175         . . ;ZWR C0CFDA
    176         . . D UPDATE^DIE("","C0CFDA(C0CZX)")
    177         . . I $D(^TMP("DIERR",$J)) U $P BREAK
    178         . . D CLEAN^DILF ; CLEAN UP
    179         . ;ZWR C0CFDA
    180         Q
    181         ;
    182 SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
    183         ; TO SET TO VALUE C0CSV.
    184         ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
    185         ; C0CSN,C0CSV ARE PASSED BY VALUE
    186         ;
    187         N C0CSI,C0CSJ
    188         S C0CSI=$$ZFILE(C0CSN,"C0CA") ; FILE NUMBER
    189         S C0CSJ=$$ZFIELD(C0CSN,"C0CA") ; FIELD NUMBER
    190         S C0CFDA(C0CZX,C0CSI,C0CZX_",",C0CSJ)=C0CSV
    191         Q
    192 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
    193         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
    194         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    195         I '$D(ZTAB) S ZTAB="C0CA"
    196         Q $P(@ZTAB@(ZFN),"^",1)
    197 ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
    198         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
    199         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    200         I '$D(ZTAB) S ZTAB="C0CA"
    201         Q $P(@ZTAB@(ZFN),"^",2)
    202 ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
    203         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
    204         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    205         I '$D(ZTAB) S ZTAB="C0CA"
    206         Q $P(@ZTAB@(ZFN),"^",3)
    207         ;
     1C0CDIC   ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08
     2 ;;0.1;CCDCCR;nopatch;noreleasedate
     3 ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 W "This is the CCR Dictionary Utility Library ",!
     21 W !
     22 Q
     23 ;
     24DIC2CSV ;OUTPUT THE CCR DICTIONARY TO A CSV FILE
     25 ;
     26 N ZI
     27 S ZI=""
     28 S G1=$NA(^TMP($J,"C0CCSV",1))
     29 S G1A=$NA(@G1@("V"))
     30 S G2=$NA(^TMP($J,"C0CCSV",2))
     31 D GETN2^C0CRNF(G1,170) ; GET THE MATRIX
     32 F  S ZI=$O(@G1A@(ZI)) Q:ZI=""  D  ;FOR EACH ROW IN THE MATRIX
     33 . I $G(@G1A@(ZI,"MAPPING METHOD",1))'="" D  ;
     34 . . W @G1A@(ZI,"MAPPING METHOD",1),!
     35 . . ;K @G1A@(ZI,"MAPPING METHOD")
     36 . ;W !,ZI,$G(@G1A@(ZI,"MAPPING METHOD",1))
     37 D RNF2CSV^C0CRNF(G2,G1,"VN") ; PREPARE THE CVS FILE
     38 K @G1
     39 D FILEOUT^C0CRNF(G2,"FILE_"_170_".csv")
     40 K @G2
     41 Q
     42 ;
     43GVARS(C0CVARS,C0CT) ; Get the CCR variables from the CCR template
     44 ; and return them in C0CVARS, which is passed by name
     45 ; FIRST PIECE OF C0CVARS(x) IS THE VARIABLE NAME, SECOND PIECE
     46 ; IS THE LINE NUMBER OF THE VARIABLE IN THE TEMPLATE
     47 ; C0CT IS RETURNED AS THE CCR TEMPLATE
     48 N C0CTVARS ; ARRAY FOR THE TEMPLATE AND ARRAY FOR THE VARS
     49 D LOAD^GPLCCR0(C0CT) ; LOAD THE CCR TEMPLATE
     50 D XVARS^GPLXPATH("C0CTVARS",C0CT) ; PULL OUT THE VARS
     51 N C0CI,C0CX
     52 S @C0CVARS@(0)=C0CTVARS(0) ; SAME COUNT
     53 F C0CI=1:1:C0CTVARS(0) D  ; FOR EVERY LINE IN THE ARRAY
     54 . S C0CX=C0CTVARS(C0CI) ; THE VARIABLE - 3 PIECES, FIRST ONE NULL
     55 . S @C0CVARS@(C0CI)=$P(C0CX,"^",2)_"^"_$P(C0CX,"^",3) ; VAR NAME^LINE NUMBER
     56 ;D PARY^GPLXPATH("C0CVARS")
     57 Q
     58 ;
     59GXPATH(C0CPVARS,C0CPT) ; LOAD THE CCR TEMPLATE INTO C0CPT, PULL OUT VARIABLES
     60 ; AND THE XPATH TO THE VARIABLES INTO C0CPVARS
     61 ; BY INDEXING THE TEMPLATE C0CT AND MATCHING THE XPATH TO THE VARIABLE
     62 ; BOTH ARE PASSED BY NAME
     63 ; C0CPVARS(x) IS VAR^LINENUM^XPATH SORTED BY LINENUM
     64 ; C0CPVARS(0) IS NUMBER OF VARIABLES
     65 ; C0CPT(0) IS NUMBER OF LINES IN THE TEMPLATE
     66 D GVARS(C0CPVARS,C0CPT) ; GET THE VARIABLES AND LINE NUMBERS
     67 ;N C0CTVARS ; HASH TABLE FOR VARIABLE BY LINE NUMBER
     68 D HASHV ; PUT THE VARIABLES IN A LINE NUMBER HASH FOR MATCHING TO XPATHS
     69 ; NOW GO GET THE XPATH INDEXES
     70 D INDEX^GPLXPATH(C0CPT) ; ADD THE XPATH INDEXES TO THE TEMPLATE ARRAY
     71 S C0CI="" ; GOING TO LOOP THROUGH THE WHOLE ARRAY LOOKING AT XPATHS
     72 F  S C0CI=$O(@C0CPT@(C0CI)) Q:C0CI=""  D  ; VISIT EVERY LINE
     73 . I +C0CI'=0 Q  ; SKIP EVERYTHING BUT THE XPATH INDEX
     74 . I C0CI=0 Q  ; SKIP THE ZERO NODE
     75 . S C0CX=@C0CPT@(C0CI) ; PULL OUT THE LINE NUMBERS X^Y
     76 . S C0CY=$P(C0CX,"^",1) ; STARTING LINE NUMBER
     77 . S C0CZ=$P(C0CX,"^",2) ; ENDING LINE NUMBER
     78 . I C0CY=C0CZ D  ; THIS IS AN XPATH END NODE, HAS A VARIABLE (WE HOPE)
     79 . . ; W "FOUND ",C0CI,!
     80 . . I $D(C0CTVARS(C0CY)) D  ; IF THERE IS A VARIABLE THERE
     81 . . . S $P(C0CTVARS(C0CY),"^",3)=C0CI ; INSERT THE XPATH FOR THE VAR
     82 D SORTV ; SORT THE ARRAY BY LINE NUMBER
     83 Q
     84 ;
     85HASHV ; INTERNAL ROUTINE TO PUT VARIABLE NAMES IN A LINE NUMBER HASH
     86 ;N C0CI,C0CTVARS,C0CX,C0CY
     87 F C0CI=1:1:@C0CPVARS@(0) D  ; FOR THE ENTIRE ARRAY
     88 . S C0CX=$P(@C0CPVARS@(C0CI),"^",2) ; LINE NUMBER
     89 . S C0CY=$P(@C0CPVARS@(C0CI),"^",1) ; VARIABLE NAME
     90 . S C0CTVARS(C0CX)=C0CY ; BUILD HASH OF VARIABLES BY LINE NUMBER
     91 Q
     92 ;
     93SORTV ; INTERNAL ROUTINE TO OUTPUT VARIABLES (AND XPATHS) IN LINE NUMBER ORDER
     94 ;N C0CV2 ; SCRACTH SPACE FOR BUILDING SORTED ARRAY
     95 S C0CI="" ;
     96 F  S C0CI=$O(C0CTVARS(C0CI)) Q:C0CI=""  D  ; BY LINE NUMBER
     97 . S C0CX=C0CTVARS(C0CI) ;VARIABLE NAME
     98 . S $P(C0CX,"^",2)=C0CI ; LINE NUMBER IS SECOND PIECE
     99 . D PUSH^GPLXPATH("C0C2",C0CX) ; PUT ONTO ARRAY
     100 K @C0CPVARS
     101 M @C0CPVARS=C0C2
     102 Q
     103 ;
     104LOAD ; LOAD VARIABLE NAMES AND XPATH IN ^C0CDIC(170
     105 ; INITIAL LOAD OF THE CCR DICTIONARY
     106 ;
     107 N C0CDIC,C0CARY,C0CXML,C0CFDA,C0CI
     108 S C0CDIC="^C0CDIC(170," ; ROOT OF THE CCR DICTIONARY
     109 D GXPATH("C0CARY","C0CXML") ; FETCH THE VARIABLES AND XPATH INTO C0CARY
     110 ; C0CXML WILL CONTAIN THE TEMPLATE - NOT NEEDED FOR LOAD
     111 D PARY^GPLXPATH("C0CARY") ;TEST
     112 F C0CI=1:1:C0CARY(0) D  ; LOAD EACH VARIABLE
     113 . S C0CFDA(170,"+"_C0CI_",",.01)=$P(C0CARY(C0CI),"^",1) ; VAR NAME
     114 . S C0CFDA(170,"+"_C0CI_",",2)=$P(C0CARY(C0CI),"^",3) ; XPATH
     115 . D UPDATE^DIE("","C0CFDA")
     116 . I $D(^TMP("DIERR",$J)) U $P BREAK
     117 . W "LOADING:",C0CI," ",C0CARY(C0CI),!
     118 Q
     119 ;
     120INIT ; INITIALIZE CCR DICTIONARY BASED ON VARIABLE NAMES
     121 ;
     122 ; CHEAT SHEET FOR VARIABLE NAMES IN ^C0CDIC(170.xx,
     123 ; THIS IS WHAT WILL BE IN C0CA FOR EACH DICTIONARY ENTRY
     124 ;G1("CODING")="170^8"
     125 ;G1("DATA ELEMENT")="170^7"
     126 ;G1("DESCRIPTION")="170^3"
     127 ;G1("ID")="170^1"
     128 ;G1("M","170^8","CODING")="170.08^.01"
     129 ;G1("MAPPING METHOD")="170.08^1"
     130 ;G1("SECTION")="170^10"
     131 ;G1("SOURCE")="170^4"
     132 ;G1("STATUS")="170^9"
     133 ;G1("TYPE")="170^6"
     134 ;G1("VARIABLE")="170^.01"
     135 ;G1("XPATH")="170^2"
     136 ;
     137 N C0CZA,C0CZX,C0CN,C0CSTAT
     138 S C0CZX=0
     139 S C0CSTAT=0 ; INIT STATUS SET FLAG
     140 F  S C0CZX=$O(^C0CDIC(170,C0CZX)) Q:+C0CZX=0  D  ; FOR EACH DICT ENTRY
     141 . ;W C0CZX,!
     142 . K C0CA,C0CN ; CLEAR OUT THE LAST ONE
     143 . D GETN1^C0CRNF("C0CA",170,C0CZX,"","ALL") ; GET VARIABLE HASH
     144 . ;ZWR C0CA B ;
     145 . S C0CN=$$ZVALUE("VARIABLE") ;NAME OF THE VARIABLE
     146 . W "VARIABLE: ",C0CN,!
     147 . I $E(C0CN,1,5)="ACTOR" D SETFDA("SECTION","ACTORS") ;
     148 . I $E(C0CN,1,6)="SOCIAL" D  ;
     149 . . D SETFDA("SECTION","SOC") ;
     150 . . D SETFDA("STATUS","X") ;SOCIAL HISTORY NOT IMPLEMENTED
     151 . . S C0CSTAT=1
     152 . I $E(C0CN,1,6)="FAMILY" D  ;
     153 . . D SETFDA("SECTION","FAM") ;
     154 . . D SETFDA("STATUS","X") ;FAMILY HISTORY NOT IMPLEMENTED
     155 . . S C0CSTAT=1
     156 . ;D SETFDA("TYPE","") ;CORRECT FOR TYPE ERRORS
     157 . I $E(C0CN,1,5)="ALERT" D SETFDA("SECTION","ALERTS")
     158 . I $E(C0CN,1,5)="VITAL" D SETFDA("SECTION","VITALS")
     159 . I $E(C0CN,1,7)="PROBLEM" D SETFDA("SECTION","PROBLEMS")
     160 . I $E(C0CN,1,10)="RESULTTEST" D SETFDA("SECTION","TEST")
     161 . E  I $E(C0CN,1,6)="RESULT" D SETFDA("SECTION","LABS")
     162 . I C0CN["CODEVALUE" D SETFDA("TYPE","CD") ;CODES
     163 . I C0CN["CODEVERSION" D SETFDA("TYPE","CV") ; CODE VERSION
     164 . I C0CN["CODINGSYSTEM" D SETFDA("TYPE","CS") ;CODING SYSTEM
     165 . I $$ZVALUE("STATUS")=""!'C0CSTAT D SETFDA("STATUS","N") ;BLANK STATUS TO N
     166 . I $$ZVALUE("XPATH")["/Medication/Directions/" D  ; MEDS DIRECTIONS VAR
     167 . . D SETFDA("SECTION","DIR") ; SPECIAL SECTION FOR DIRECTIONS
     168 . E  I $$ZVALUE("XPATH")["/Medications/Medication/" D  ; ALL OTHER MEDS
     169 . . D SETFDA("SECTION","MEDS") ; A MEDS VAR
     170 . I $E(C0CN,($L(C0CN)-1),$L(C0CN))="ID" D SETFDA("TYPE","ID") ;CATCH THE IDS
     171 . I C0CN["DATETIME" D SETFDA("TYPE","DT") ; DATE/TIME VARIABLE
     172 . W "VARIABLE: ",C0CZX," ",C0CA("VARIABLE"),!
     173 . ;ZWR C0CFDA
     174 . I $D(C0CFDA) D  ; WE HAVE CHANGES ON THIS VARIABLE
     175 . . ;ZWR C0CFDA
     176 . . D UPDATE^DIE("","C0CFDA(C0CZX)")
     177 . . I $D(^TMP("DIERR",$J)) U $P BREAK
     178 . . D CLEAN^DILF ; CLEAN UP
     179 . ;ZWR C0CFDA
     180 Q
     181 ;
     182SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
     183 ; TO SET TO VALUE C0CSV.
     184 ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
     185 ; C0CSN,C0CSV ARE PASSED BY VALUE
     186 ;
     187 N C0CSI,C0CSJ
     188 S C0CSI=$$ZFILE(C0CSN,"C0CA") ; FILE NUMBER
     189 S C0CSJ=$$ZFIELD(C0CSN,"C0CA") ; FIELD NUMBER
     190 S C0CFDA(C0CZX,C0CSI,C0CZX_",",C0CSJ)=C0CSV
     191 Q
     192ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
     193 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
     194 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     195 I '$D(ZTAB) S ZTAB="C0CA"
     196 Q $P(@ZTAB@(ZFN),"^",1)
     197ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
     198 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
     199 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     200 I '$D(ZTAB) S ZTAB="C0CA"
     201 Q $P(@ZTAB@(ZFN),"^",2)
     202ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
     203 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
     204 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     205 I '$D(ZTAB) S ZTAB="C0CA"
     206 Q $P(@ZTAB@(ZFN),"^",3)
     207 ;
  • ccr/branches/ohum/p/C0CDOM.m

    r1330 r1332  
    11C0CDOM    ; GPL - DOM PROCESSING ROUTINES ;6/6/11  17:05
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21         ;
     2 ;;0.1;C0C;nopatch;noreleasedate;Build 38
     3 ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 Q
     21 ;
    2222DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE
    23         ; THE XPATH INDEX ZXIDX, PASSED BY NAME
    24         ; THE XPATH ARRAY XPARY, PASSED BY NAME
    25         ; ZOID IS THE STARTING OID
    26         ; ZPATH IS THE STARTING XPATH, USUALLY "/"
    27         ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
    28         ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
    29         I $G(ZREDUX)="" S ZREDUX=""
    30         N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY
    31         N NEWNUM S NEWNUM=""
    32         I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
    33         S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
    34         I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
    35         . N GT S GT=$P(NEWPATH,ZREDUX,2)
    36         . I GT'="" S NEWPATH=GT
    37         S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
    38         N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE
    39         I $D(GA) D  ; PROCESS THE ATTRIBUTES
    40         . N ZI S ZI=""
    41         . F  S ZI=$O(GA(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
    42         . . N ZP S ZP=NEWPATH_"@"_ZI ; PATH FOR ATTRIBUTE
    43         . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY
    44         . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE
    45         N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
    46         I $D(GD(2)) D  ;
    47         . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
    48         E  I $D(GD(1)) D  ;
    49         . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
    50         . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY
    51         N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
    52         I ZFRST'=0 D  ; THERE IS A CHILD
    53         . N ZNUM
    54         . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
    55         . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD
    56         N GNXT S GNXT=$$NXTSIB(ZOID)
    57         I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES
    58         I GNXT'=0 D  ;
    59         . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE?
    60         . I (ZNUM="")&(ZMULT) D  ; SIBLING IS FIRST OF MULTIPLES
    61         . . N ZNUM S ZNUM=1 ;
    62         . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
    63         . E  D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB
    64         Q
    65         ;
    66 ADDNARY(ZXP,ZVALUE)     ; ADD AN NHIN ARRAY VALUE TO ZNARY
    67         ;
    68         ; IF ZATT=1 THE ARRAY IS ADDED AS ATTRIBUTES
    69         ;
    70         N ZZI,ZZJ,ZZN
    71         S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY
    72         I ZZI="" Q  ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE
    73         S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY
    74         S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH .
    75         I ZZI'["]" D  ; A SINGLETON
    76         . S ZZN=1
    77         E  D  ; THERE IS AN [x] OCCURANCE
    78         . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE
    79         . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X]
    80         I ZZJ'="" D  ; TIME TO ADD THE VALUE
    81         . S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE
    82         Q
    83         ;
     23 ; THE XPATH INDEX ZXIDX, PASSED BY NAME
     24 ; THE XPATH ARRAY XPARY, PASSED BY NAME
     25 ; ZOID IS THE STARTING OID
     26 ; ZPATH IS THE STARTING XPATH, USUALLY "/"
     27 ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
     28 ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
     29 I $G(ZREDUX)="" S ZREDUX=""
     30 N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY
     31 N NEWNUM S NEWNUM=""
     32 I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
     33 S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
     34 I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
     35 . N GT S GT=$P(NEWPATH,ZREDUX,2)
     36 . I GT'="" S NEWPATH=GT
     37 S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
     38 N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE
     39 I $D(GA) D  ; PROCESS THE ATTRIBUTES
     40 . N ZI S ZI=""
     41 . F  S ZI=$O(GA(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
     42 . . N ZP S ZP=NEWPATH_"@"_ZI ; PATH FOR ATTRIBUTE
     43 . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY
     44 . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE
     45 N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
     46 I $D(GD(2)) D  ;
     47 . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
     48 E  I $D(GD(1)) D  ;
     49 . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
     50 . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY
     51 N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
     52 I ZFRST'=0 D  ; THERE IS A CHILD
     53 . N ZNUM
     54 . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
     55 . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD
     56 N GNXT S GNXT=$$NXTSIB(ZOID)
     57 I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES
     58 I GNXT'=0 D  ;
     59 . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE?
     60 . I (ZNUM="")&(ZMULT) D  ; SIBLING IS FIRST OF MULTIPLES
     61 . . N ZNUM S ZNUM=1 ;
     62 . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
     63 . E  D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB
     64 Q
     65 ;
     66ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY
     67 ;
     68 ; IF ZATT=1 THE ARRAY IS ADDED AS ATTRIBUTES
     69 ;
     70 N ZZI,ZZJ,ZZN
     71 S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY
     72 I ZZI="" Q  ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE
     73 S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY
     74 S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH .
     75 I ZZI'["]" D  ; A SINGLETON
     76 . S ZZN=1
     77 E  D  ; THERE IS AN [x] OCCURANCE
     78 . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE
     79 . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X]
     80 I ZZJ'="" D  ; TIME TO ADD THE VALUE
     81 . S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE
     82 Q
     83 ;
    8484PARSE(INXML,INDOC)      ;CALL THE MXML PARSER ON INXML, PASSED BY NAME
    85         ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW
    86         ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML
    87         ;Q $$EN^MXMLDOM(INXML)
    88         Q $$EN^MXMLDOM(INXML,"W")
    89         ;
     85 ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW
     86 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML
     87 ;Q $$EN^MXMLDOM(INXML)
     88 Q $$EN^MXMLDOM(INXML,"W")
     89 ;
    9090ISMULT(ZOID)    ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
    91         N ZN
    92         ;I $$TAG(ZOID)["entry" B
    93         S ZN=$$NXTSIB(ZOID)
    94         I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
    95         Q 0
    96         ;
     91 N ZN
     92 ;I $$TAG(ZOID)["entry" B
     93 S ZN=$$NXTSIB(ZOID)
     94 I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
     95 Q 0
     96 ;
    9797FIRST(ZOID)     ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
    98         Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
    99         ;
     98 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
     99 ;
    100100PARENT(ZOID)    ;RETURNS THE OID OF THE PARENT OF ZOID
    101         Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
    102         ;
     101 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
     102 ;
    103103ATT(RTN,NODE)   ;GET ATTRIBUTES FOR ZOID
    104         S HANDLE=C0CDOCID
    105         K @RTN
    106         D GETTXT^MXMLDOM("A")
    107         Q
    108         ;
     104 S HANDLE=C0CDOCID
     105 K @RTN
     106 D GETTXT^MXMLDOM("A")
     107 Q
     108 ;
    109109TAG(ZOID)       ; RETURNS THE XML TAG FOR THE NODE
    110         ;I ZOID=149 B ;GPLTEST
    111         N X,Y
    112         S Y=""
    113         S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
    114         I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
    115         I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
    116         Q Y
    117         ;
     110 ;I ZOID=149 B ;GPLTEST
     111 N X,Y
     112 S Y=""
     113 S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
     114 I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
     115 I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
     116 Q Y
     117 ;
    118118NXTSIB(ZOID)    ; RETURNS THE NEXT SIBLING
    119         Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
    120         ;
     119 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
     120 ;
    121121DATA(ZT,ZOID)   ; RETURNS DATA FOR THE NODE
    122         ;N ZT,ZN S ZT=""
    123         ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
    124         ;Q $G(@C0CDOM@(ZOID,"T",1))
    125         S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
    126         Q
    127         ;
     122 ;N ZT,ZN S ZT=""
     123 ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
     124 ;Q $G(@C0CDOM@(ZOID,"T",1))
     125 S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
     126 Q
     127 ;
    128128OUTXML(ZRTN,INID,NO1ST) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM
    129         ;
    130         S C0CDOCID=INID
    131         I '$D(NO1ST) S NO1ST=0 ; DO NOT SURPRESS THE <?xml tag generation
    132         D START^C0CMXMLB($$TAG(1),,"G",NO1ST)
    133         D NDOUT($$FIRST(1))
    134         D END^C0CMXMLB ;END THE DOCUMENT
    135         M @ZRTN=^TMP("MXMLBLD",$J)
    136         K ^TMP("MXMLBLD",$J)
    137         Q
    138         ;
     129 ;
     130 S C0CDOCID=INID
     131 I '$D(NO1ST) S NO1ST=0 ; DO NOT SURPRESS THE <?xml tag generation
     132 D START^C0CMXMLB($$TAG(1),,"G",NO1ST)
     133 D NDOUT($$FIRST(1))
     134 D END^C0CMXMLB ;END THE DOCUMENT
     135 M @ZRTN=^TMP("MXMLBLD",$J)
     136 K ^TMP("MXMLBLD",$J)
     137 Q
     138 ;
    139139NDOUT(ZOID)     ;CALLBACK ROUTINE - IT IS RECURSIVE
    140         N ZI S ZI=$$FIRST(ZOID)
    141         I ZI'=0 D  ; THERE IS A CHILD
    142         . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT
    143         . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN
    144         E  D  ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT
    145         . ;W "DOING",ZOID,!
    146         . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA
    147         . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES
    148         . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN
    149         I $$NXTSIB(ZOID)'=0 D  ; THERE IS A SIBLING
    150         . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS
    151         Q
    152         ;
    153 WNHIN(ZDFN)     ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE
    154         ;
    155         N GN,GN2
    156         D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML
    157         S GN2=$NA(@GN@(1))
    158         W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/")
    159         Q
    160         ;
    161 NARY2XML(ZGOUT,ZGIN)    ; CREATE XML FROM AN NHIN ARRAY
    162         ; ZGOUT AND ZGIN ARE PASSED BY NAME
    163         N C0CDOCID
    164         W !,ZGOUT," ",ZGIN
    165         S C0CDOCID=$$DOMI(ZGIN) ; PUT IT INTO THE DOM
    166         D OUTXML(ZGOUT,C0CDOCID)
    167         Q
    168         ;
    169         ; EXAMPLE OF NHIN ARRAY FORMAT - THIS IS AN OUTPUT OF DOMO ABOVE WHEN RUN
    170         ; AGAINST THE OUTPUT OF THE GET^NHINV ROUTINE. (THIS IS NOT REAL PATIENT DATA)
    171         ;
    172         ;GNARY("med",1,"doses.dose@dose")=10
    173         ;GNARY("med",1,"doses.dose@noun")="TABLET"
    174         ;GNARY("med",1,"doses.dose@route")="PO"
    175         ;GNARY("med",1,"doses.dose@schedule")="QD"
    176         ;GNARY("med",1,"doses.dose@units")="MG"
    177         ;GNARY("med",1,"doses.dose@unitsPerDose")=1
    178         ;GNARY("med",1,"facility@code")=100
    179         ;GNARY("med",1,"facility@name")="VOE OFFICE INSTITUTION"
    180         ;GNARY("med",1,"form@value")="TAB"
    181         ;GNARY("med",1,"id@value")="1N;O"
    182         ;GNARY("med",1,"location@code")=5
    183         ;GNARY("med",1,"location@name")="3 WEST"
    184         ;GNARY("med",1,"name@value")="LISINOPRIL TAB"
    185         ;GNARY("med",1,"orderID@value")=294
    186         ;GNARY("med",1,"ordered@value")=3110531.001233
    187         ;GNARY("med",1,"orderingProvider@code")=63
    188         ;GNARY("med",1,"orderingProvider@name")="KING,MATTHEW MICHAEL"
    189         ;GNARY("med",1,"products.product.class@code")="ACE INHIBITORS"
    190         ;GNARY("med",1,"products.product.vaGeneric@code")=1990
    191         ;GNARY("med",1,"products.product.vaGeneric@name")="LISINOPRIL"
    192         ;GNARY("med",1,"products.product.vaGeneric@vuid")=4019380
    193         ;GNARY("med",1,"products.product.vaProduct@code")=8118
    194         ;GNARY("med",1,"products.product.vaProduct@name")="LISINOPRIL 10MG TAB"
    195         ;GNARY("med",1,"products.product.vaProduct@vuid")=4008593
    196         ;GNARY("med",1,"products.product@code")=6174
    197         ;GNARY("med",1,"products.product@name")="LISINOPRIL 10MG U/D"
    198         ;GNARY("med",1,"products.product@role")="D"
    199         ;GNARY("med",1,"sig")="10MG BY MOUTH EVERY DAY"
    200         ;GNARY("med",1,"sig@xml:space")="preserve"
    201         ;GNARY("med",1,"status@value")="active"
    202         ;GNARY("med",1,"type@value")="OTC"
    203         ;GNARY("med",1,"vaType@value")="N"
    204         ;
    205         ; DOMI is an extrinsic to insert NHIN ARRAY FORMAT arrays into the DOM
    206         ; it returns 0 or 1 based on success.
    207         ;
    208         ; INARY is passed by name and has the format shown above
    209         ; HANDLE is the document number in the DOM (both MXML and EWD DOMs will
    210         ; be supported eventually - initial implementation is for MXML
    211         ;
    212         ; PARENT is the node id or tag of the parent under which the DOM will
    213         ; be populated. If it is numeric, it is a node. If it is a string, the DOM
    214         ; will be searched to find the tag. If not found and there is no root,
    215         ; it will be inserted as the root. If not found and there is a root, it
    216         ; will be inserted under the root.
    217         ;
    218         ; For the above example the call would be OK=$$DOMI("GNARY",0,"results")
    219         ; because "results" is the root tag. Use OUTXML to render the xml from
    220         ; the DOM.
    221         ;
    222 DOMI(INARY,HANDLE,PARENT)       ; EXTRINSIC TO INSERT NHIN ARRAYS TO A DOM
    223         ;
    224         N ZPARNODE
    225         S (SUCCESS,LEVEL,LEVEL(0),NODE)=0
    226         I '$D(INARY) Q 0 ; NO ARRAY PASSED
    227         I '$D(HANDLE) S HANDLE=$$NEWDOM() ; MAKE A NEW DOM
    228         ;I PARENT="" S PARENT="root"
    229         I +$G(PARENT)>0 S ZPARNODE=PARENT ; WE HAVE BEEN PASSED A PARENT NODE ID
    230         E  I $L($G(PARENT))>0 D  ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL
    231         . D STARTELE^MXMLDOM(PARENT) ; INSERT THE PARENT NODE
    232         . S ZPARNODE=1 ;
    233         ; WE NOW HAVE A HANDLE AND A PARENT NODE AND LEVEL HAS BEEN SET
    234         N ZEXARY
    235         D EXPAND("ZEXARY",INARY) ; EXPAND THE NHIN ARRAY
    236         D MAJOR("ZEXARY") ; PROCESS ALL THE NODES TO BE ADDED
    237         I $L($G(PARENT))>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE
    238         Q HANDLE ; SUCCESS
    239         ;
    240 MAJOR(ZARY)     ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES
    241         N ZI S ZI=""
    242         N ZTAG
    243         F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH SECTION
    244         . N ZELEADD S ZELEADD=0
    245         . I ZI["@" D  ; END NODE HAS NO VALUE, ONLY ATTRIBUTES
    246         . . S ZTAG=$P(ZI,"@",1) ; PULL OUT THE TAG
    247         . . K ZATT ; CLEAR OUT LAST ONE
    248         . . M ZATT=@ZARY@(ZI,1) ; GET ATTRIBUTE ARRAY
    249         . . D STARTELE^MXMLDOM(ZTAG,.ZATT) ; ADD THE NODE
    250         . . S ZELEADD=1 ; FLAG TO NOT ADD THE ELEMENT TWICE
    251         . I $O(@ZARY@(ZI,""))="" D  ;END NODE
    252         . . S ZTAG=ZI ; USE ZI FOR THE TAG
    253         . . I 'ZELEADD D STARTELE^MXMLDOM(ZTAG) ; ADD ELEMENT IF NOT THERE
    254         . . S ZELEADD=1 ; ADDED AN ELEMENT
    255         . . D CHAR^MXMLDOM($G(@ZARY@(ZI))) ; INSERT THE VALUE
    256         . I ZELEADD D  Q  ; NO MORE TO DO ON THIS LEVEL
    257         . . D ENDELE^MXMLDOM(ZTAG) ; CLOSE THE ELEMENT BEFORE LEAVING
    258         . N NEWARY ; INDENTED ARRAY
    259         . N ZN S ZN=0
    260         . F  S ZN=$O(@ZARY@(ZI,ZN)) Q:ZN=""  D  ; FOR EACH MULTIPLE
    261         . . D STARTELE^MXMLDOM(ZI) ; ADD THE INTERMEDIATE TAG
    262         . . S NEWARY=$NA(@ZARY@(ZI,ZN)) ; INDENT THE ARRAY
    263         . . D MAJOR(NEWARY) ; RECURSE FOR INDENTED ARRAY
    264         . . D ENDELE^MXMLDOM(ZI) ; END THE INTERMEDIATE TAG
    265         Q
    266         ;
    267 EXPAND(ZZOUT,ZZIN)      ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED
    268         ; CONSISTENT FORMAT
    269         ; GNARY("patient",1,"facilities[2].facility@code")="050"
    270         ; becomes G2ARY("patient",1,"facilities",2,"facility@",1,"code")="050"
    271         ; for easier processing (this is fileman format genius)
    272         ; basically removes the dot notation from the strings
    273         ;
    274         N ZZI
    275         S ZZI=""
    276         F  S ZZI=$O(@ZZIN@(ZZI)) Q:ZZI=""  D  ;
    277         . N ZZN S ZZN=0
    278         . F  S ZZN=$O(@ZZIN@(ZZI,ZZN)) Q:ZZN=""  D  ;
    279         . . N ZZS S ZZS=""
    280         . . N GA ;PUSH STACK
    281         . . F  S ZZS=$O(@ZZIN@(ZZI,ZZN,ZZS)) Q:ZZS=""  D  ;
    282         . . . K GA ; NEW STACK
    283         . . . D PUSH^C0CXPATH("GA",ZZI_"^"_ZZN) ; PUSH PARENT
    284         . . . N ZZV ; PLACE TO STASH THE VALUE
    285         . . . S ZZV=@ZZIN@(ZZI,ZZN,ZZS) ; VALUE
    286         . . . W !,"VALUE:",ZZV
    287         . . . N GK ; COUNTER
    288         . . . F GK=1:1:$L(ZZS,".") D  ; FOR EACH INTERMEDIATE NODE
    289         . . . . N ZZN2 S ZZN2=1 ; DEFAULT IF NO [X]
    290         . . . . N GM S GM=$P(ZZS,".",GK) ; TAG
    291         . . . . I GM["[" D  ; IT'S A MULTIPLE
    292         . . . . . S ZZN2=$P($P(GM,"[",2),"]",1) ; PULL OUT THE NUMBER
    293         . . . . . S GM=$P(GM,"[",1) ; PULL OUT THE TAG
    294         . . . . I GM["@" D  ; IT'S GOT ATTRIBUTES
    295         . . . . . N GM2 S GM2=$P(GM,"@",2) ; PULLOUT THE ATTRIBUTE NAME
    296         . . . . . D PUSH^C0CXPATH("GA",$P(GM,"@",1)_"@"_"^"_ZZN2) ; PUSH THE TAG
    297         . . . . . D PUSH^C0CXPATH("GA",GM2_"^"_ZZN2)
    298         . . . . E  D PUSH^C0CXPATH("GA",GM_"^"_ZZN2) ;
    299         . . . S GA(GA(0))=$P(GA(GA(0)),"^",1)_"^" ; GET RID OF THE LAST "1"
    300         . . . N GZI S GZI="" ; STRING FOR THE INDEX
    301         . . . F GK=1:1:GA(0) D  ; TIME TO REVERSE POP THE TAGS
    302         . . . . S GM=$P(GA(GK),"^",1) ; THE TAG
    303         . . . . S ZZN2=$P(GA(GK),"^",2) ; THE NUMBER IF ANY
    304         . . . . I ZZN2="" S GZI=GZI_""""_GM_"""" ; FOR THE LAST ONE
    305         . . . . E  S GZI=GZI_""""_GM_""""_","_ZZN2_"," ; FOR THE REST
    306         . . . S GZI2=ZZOUT_"("_GZI_")" ; INCLUDE THE ARRAY NAME
    307         . . . W !,GZI
    308         . . . S @GZI2=ZZV ; REMEMBER THE VALUE?
    309         Q
    310         ;
    311 NEWDOM()        ; extrinsic which creates a new DOM and returns the HANDLE
    312         N CBK,SUCCESS,LEVEL,NODE,HANDLE
    313         K ^TMP("MXMLERR",$J)
    314         L +^TMP("MXMLDOM",$J):5
    315         E  Q 0
    316         S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)=""
    317         L -^TMP("MXMLDOM",$J)
    318         Q HANDLE
    319         ;
     140 N ZI S ZI=$$FIRST(ZOID)
     141 I ZI'=0 D  ; THERE IS A CHILD
     142 . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT
     143 . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN
     144 E  D  ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT
     145 . ;W "DOING",ZOID,!
     146 . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA
     147 . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES
     148 . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN
     149 I $$NXTSIB(ZOID)'=0 D  ; THERE IS A SIBLING
     150 . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS
     151 Q
     152 ;
     153WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE
     154 ;
     155 N GN,GN2
     156 D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML
     157 S GN2=$NA(@GN@(1))
     158 W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/")
     159 Q
     160 ;
     161NARY2XML(ZGOUT,ZGIN) ; CREATE XML FROM AN NHIN ARRAY
     162 ; ZGOUT AND ZGIN ARE PASSED BY NAME
     163 N C0CDOCID
     164 W !,ZGOUT," ",ZGIN
     165 S C0CDOCID=$$DOMI(ZGIN) ; PUT IT INTO THE DOM
     166 D OUTXML(ZGOUT,C0CDOCID)
     167 Q
     168 ;
     169 ; EXAMPLE OF NHIN ARRAY FORMAT - THIS IS AN OUTPUT OF DOMO ABOVE WHEN RUN
     170 ; AGAINST THE OUTPUT OF THE GET^NHINV ROUTINE. (THIS IS NOT REAL PATIENT DATA)
     171 ;
     172 ;GNARY("med",1,"doses.dose@dose")=10
     173 ;GNARY("med",1,"doses.dose@noun")="TABLET"
     174 ;GNARY("med",1,"doses.dose@route")="PO"
     175 ;GNARY("med",1,"doses.dose@schedule")="QD"
     176 ;GNARY("med",1,"doses.dose@units")="MG"
     177 ;GNARY("med",1,"doses.dose@unitsPerDose")=1
     178 ;GNARY("med",1,"facility@code")=100
     179 ;GNARY("med",1,"facility@name")="VOE OFFICE INSTITUTION"
     180 ;GNARY("med",1,"form@value")="TAB"
     181 ;GNARY("med",1,"id@value")="1N;O"
     182 ;GNARY("med",1,"location@code")=5
     183 ;GNARY("med",1,"location@name")="3 WEST"
     184 ;GNARY("med",1,"name@value")="LISINOPRIL TAB"
     185 ;GNARY("med",1,"orderID@value")=294
     186 ;GNARY("med",1,"ordered@value")=3110531.001233
     187 ;GNARY("med",1,"orderingProvider@code")=63
     188 ;GNARY("med",1,"orderingProvider@name")="KING,MATTHEW MICHAEL"
     189 ;GNARY("med",1,"products.product.class@code")="ACE INHIBITORS"
     190 ;GNARY("med",1,"products.product.vaGeneric@code")=1990
     191 ;GNARY("med",1,"products.product.vaGeneric@name")="LISINOPRIL"
     192 ;GNARY("med",1,"products.product.vaGeneric@vuid")=4019380
     193 ;GNARY("med",1,"products.product.vaProduct@code")=8118
     194 ;GNARY("med",1,"products.product.vaProduct@name")="LISINOPRIL 10MG TAB"
     195 ;GNARY("med",1,"products.product.vaProduct@vuid")=4008593
     196 ;GNARY("med",1,"products.product@code")=6174
     197 ;GNARY("med",1,"products.product@name")="LISINOPRIL 10MG U/D"
     198 ;GNARY("med",1,"products.product@role")="D"
     199 ;GNARY("med",1,"sig")="10MG BY MOUTH EVERY DAY"
     200 ;GNARY("med",1,"sig@xml:space")="preserve"
     201 ;GNARY("med",1,"status@value")="active"
     202 ;GNARY("med",1,"type@value")="OTC"
     203 ;GNARY("med",1,"vaType@value")="N"
     204 ;
     205 ; DOMI is an extrinsic to insert NHIN ARRAY FORMAT arrays into the DOM
     206 ; it returns 0 or 1 based on success.
     207 ;
     208 ; INARY is passed by name and has the format shown above
     209 ; HANDLE is the document number in the DOM (both MXML and EWD DOMs will
     210 ; be supported eventually - initial implementation is for MXML
     211 ;
     212 ; PARENT is the node id or tag of the parent under which the DOM will
     213 ; be populated. If it is numeric, it is a node. If it is a string, the DOM
     214 ; will be searched to find the tag. If not found and there is no root,
     215 ; it will be inserted as the root. If not found and there is a root, it
     216 ; will be inserted under the root.
     217 ;
     218 ; For the above example the call would be OK=$$DOMI("GNARY",0,"results")
     219 ; because "results" is the root tag. Use OUTXML to render the xml from
     220 ; the DOM.
     221 ;
     222DOMI(INARY,HANDLE,PARENT) ; EXTRINSIC TO INSERT NHIN ARRAYS TO A DOM
     223 ;
     224 N ZPARNODE
     225 S (SUCCESS,LEVEL,LEVEL(0),NODE)=0
     226 I '$D(INARY) Q 0 ; NO ARRAY PASSED
     227 I '$D(HANDLE) S HANDLE=$$NEWDOM() ; MAKE A NEW DOM
     228 ;I PARENT="" S PARENT="root"
     229 I +$G(PARENT)>0 S ZPARNODE=PARENT ; WE HAVE BEEN PASSED A PARENT NODE ID
     230 E  I $L($G(PARENT))>0 D  ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL
     231 . D STARTELE^MXMLDOM(PARENT) ; INSERT THE PARENT NODE
     232 . S ZPARNODE=1 ;
     233 ; WE NOW HAVE A HANDLE AND A PARENT NODE AND LEVEL HAS BEEN SET
     234 N ZEXARY
     235 D EXPAND("ZEXARY",INARY) ; EXPAND THE NHIN ARRAY
     236 D MAJOR("ZEXARY") ; PROCESS ALL THE NODES TO BE ADDED
     237 I $L($G(PARENT))>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE
     238 Q HANDLE ; SUCCESS
     239 ;
     240MAJOR(ZARY) ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES
     241 N ZI S ZI=""
     242 N ZTAG
     243 F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH SECTION
     244 . N ZELEADD S ZELEADD=0
     245 . I ZI["@" D  ; END NODE HAS NO VALUE, ONLY ATTRIBUTES
     246 . . S ZTAG=$P(ZI,"@",1) ; PULL OUT THE TAG
     247 . . K ZATT ; CLEAR OUT LAST ONE
     248 . . M ZATT=@ZARY@(ZI,1) ; GET ATTRIBUTE ARRAY
     249 . . D STARTELE^MXMLDOM(ZTAG,.ZATT) ; ADD THE NODE
     250 . . S ZELEADD=1 ; FLAG TO NOT ADD THE ELEMENT TWICE
     251 . I $O(@ZARY@(ZI,""))="" D  ;END NODE
     252 . . S ZTAG=ZI ; USE ZI FOR THE TAG
     253 . . I 'ZELEADD D STARTELE^MXMLDOM(ZTAG) ; ADD ELEMENT IF NOT THERE
     254 . . S ZELEADD=1 ; ADDED AN ELEMENT
     255 . . D CHAR^MXMLDOM($G(@ZARY@(ZI))) ; INSERT THE VALUE
     256 . I ZELEADD D  Q  ; NO MORE TO DO ON THIS LEVEL
     257 . . D ENDELE^MXMLDOM(ZTAG) ; CLOSE THE ELEMENT BEFORE LEAVING
     258 . N NEWARY ; INDENTED ARRAY
     259 . N ZN S ZN=0
     260 . F  S ZN=$O(@ZARY@(ZI,ZN)) Q:ZN=""  D  ; FOR EACH MULTIPLE
     261 . . D STARTELE^MXMLDOM(ZI) ; ADD THE INTERMEDIATE TAG
     262 . . S NEWARY=$NA(@ZARY@(ZI,ZN)) ; INDENT THE ARRAY
     263 . . D MAJOR(NEWARY) ; RECURSE FOR INDENTED ARRAY
     264 . . D ENDELE^MXMLDOM(ZI) ; END THE INTERMEDIATE TAG
     265 Q
     266 ;
     267EXPAND(ZZOUT,ZZIN) ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED
     268 ; CONSISTENT FORMAT
     269 ; GNARY("patient",1,"facilities[2].facility@code")="050"
     270 ; becomes G2ARY("patient",1,"facilities",2,"facility@",1,"code")="050"
     271 ; for easier processing (this is fileman format genius)
     272 ; basically removes the dot notation from the strings
     273 ;
     274 N ZZI
     275 S ZZI=""
     276 F  S ZZI=$O(@ZZIN@(ZZI)) Q:ZZI=""  D  ;
     277 . N ZZN S ZZN=0
     278 . F  S ZZN=$O(@ZZIN@(ZZI,ZZN)) Q:ZZN=""  D  ;
     279 . . N ZZS S ZZS=""
     280 . . N GA ;PUSH STACK
     281 . . F  S ZZS=$O(@ZZIN@(ZZI,ZZN,ZZS)) Q:ZZS=""  D  ;
     282 . . . K GA ; NEW STACK
     283 . . . D PUSH^C0CXPATH("GA",ZZI_"^"_ZZN) ; PUSH PARENT
     284 . . . N ZZV ; PLACE TO STASH THE VALUE
     285 . . . S ZZV=@ZZIN@(ZZI,ZZN,ZZS) ; VALUE
     286 . . . W !,"VALUE:",ZZV
     287 . . . N GK ; COUNTER
     288 . . . F GK=1:1:$L(ZZS,".") D  ; FOR EACH INTERMEDIATE NODE
     289 . . . . N ZZN2 S ZZN2=1 ; DEFAULT IF NO [X]
     290 . . . . N GM S GM=$P(ZZS,".",GK) ; TAG
     291 . . . . I GM["[" D  ; IT'S A MULTIPLE
     292 . . . . . S ZZN2=$P($P(GM,"[",2),"]",1) ; PULL OUT THE NUMBER
     293 . . . . . S GM=$P(GM,"[",1) ; PULL OUT THE TAG
     294 . . . . I GM["@" D  ; IT'S GOT ATTRIBUTES
     295 . . . . . N GM2 S GM2=$P(GM,"@",2) ; PULLOUT THE ATTRIBUTE NAME
     296 . . . . . D PUSH^C0CXPATH("GA",$P(GM,"@",1)_"@"_"^"_ZZN2) ; PUSH THE TAG
     297 . . . . . D PUSH^C0CXPATH("GA",GM2_"^"_ZZN2)
     298 . . . . E  D PUSH^C0CXPATH("GA",GM_"^"_ZZN2) ;
     299 . . . S GA(GA(0))=$P(GA(GA(0)),"^",1)_"^" ; GET RID OF THE LAST "1"
     300 . . . N GZI S GZI="" ; STRING FOR THE INDEX
     301 . . . F GK=1:1:GA(0) D  ; TIME TO REVERSE POP THE TAGS
     302 . . . . S GM=$P(GA(GK),"^",1) ; THE TAG
     303 . . . . S ZZN2=$P(GA(GK),"^",2) ; THE NUMBER IF ANY
     304 . . . . I ZZN2="" S GZI=GZI_""""_GM_"""" ; FOR THE LAST ONE
     305 . . . . E  S GZI=GZI_""""_GM_""""_","_ZZN2_"," ; FOR THE REST
     306 . . . S GZI2=ZZOUT_"("_GZI_")" ; INCLUDE THE ARRAY NAME
     307 . . . W !,GZI
     308 . . . S @GZI2=ZZV ; REMEMBER THE VALUE?
     309 Q
     310 ;
     311NEWDOM() ; extrinsic which creates a new DOM and returns the HANDLE
     312 N CBK,SUCCESS,LEVEL,NODE,HANDLE
     313 K ^TMP("MXMLERR",$J)
     314 L +^TMP("MXMLDOM",$J):5
     315 E  Q 0
     316 S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)=""
     317 L -^TMP("MXMLDOM",$J)
     318 Q HANDLE
     319 ;
  • ccr/branches/ohum/p/C0CDPT.m

    r1330 r1332  
    11C0CDPT  ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;
    44        ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
  • ccr/branches/ohum/p/C0CENC.m

    r1330 r1332  
    11C0CENC   ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10
    2         ;;1.0;C0C;;May 21, 2010;Build 1
     2        ;;1.0;C0C;;May 21, 2010;Build 38
    33        ;Copyright 2010 George Lilly, University of Minnesota and others.
    44        ;Licensed under the terms of the GNU General Public License.
  • ccr/branches/ohum/p/C0CENV.m

    r1330 r1332  
    1 C0CENV  ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     1C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009
     2 ;;1.0;C0C;;May 19, 2009;
     3 ;
     4 ;
     5ENV ; Does not prevent loading of the transport global.
     6 ; Environment check is done only during the install.
     7 ;
     8 N XQA,XQAMSG
     9 ;
     10 ;
     11 ; Make sure the patch name exist
     12 ;
     13 I '$D(XPDNM) D  Q
     14 . D BMES("No valid patch name exist")
     15 . S XPDQUIT=2
     16 . D EXIT
     17 ;
     18 D CHECK
     19 D EXIT
     20 Q
     21 ;
     22 ;
     23CHECK ; Perform environment check
    324        ;
    4         ;
    5 ENV     ; Does not prevent loading of the transport global.
    6         ; Environment check is done only during the install.
    7         ;
    8         N XQA,XQAMSG
    9         ;
    10         ;
    11         ; Make sure the patch name exist
    12         ;
    13         I '$D(XPDNM) D  Q
    14         . D BMES("No valid patch name exist")
    15         . S XPDQUIT=2
    16         . D EXIT
    17         ;
    18         D CHECK
    19         D EXIT
     25 I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D
     26 . D BMES("Terminal Device is not defined")
     27 . S XPDQUIT=2
     28 ;
     29 I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D
     30 . D BMES("Please log in to set local DUZ... variables")
     31 . S XPDQUIT=2
     32 ;
     33 I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D
     34 . D BMES("You are not a valid user on this system")
     35 . S XPDQUIT=2
    2036        Q
    2137        ;
    2238        ;
    23 CHECK   ; Perform environment check
    24         ;
    25         I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D
    26         . D BMES("Terminal Device is not defined")
    27         . S XPDQUIT=2
    28         ;
    29         I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D
    30         . D BMES("Please log in to set local DUZ... variables")
    31         . S XPDQUIT=2
    32         ;
    33         I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D
    34         . D BMES("You are not a valid user on this system")
    35         . S XPDQUIT=2
    36         Q
     39EXIT ;
    3740        ;
    3841        ;
    39 EXIT    ;
     42 I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q
     43 D BMES("--- Environment Check is Ok ---")
     44        ;
     45 Q
    4046        ;
    4147        ;
    42         I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q
    43         D BMES("--- Environment Check is Ok ---")
    44         ;
    45         Q
    46         ;
    47         ;
    48 PRE     ;Pre-install entry point
     48PRE ;Pre-install entry point
    4949        ;
    5050        ; No action needed in pre-install
     
    5454        ;
    5555        ;
    56 POST    ;Post install
     56POST ;Post install
    5757        ;
    5858        ; Check for RPMS system with V LAB file.
     
    131131        ;
    132132        ;
    133 POST6   ; Checkpoint call back entry point.
     133POST6 ; Checkpoint call back entry point.
    134134        ; Check for RPMS system and determine LAB patch level
    135135        ;  and need to load in C0C version of LA7 routines.
     
    174174        ;
    175175        ;
    176 BMES(STR)       ; Write BMES^XPDUTL statements
     176BMES(STR) ; Write BMES^XPDUTL statements
    177177        ;
    178178        D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
  • ccr/branches/ohum/p/C0CEVC.m

    r1330 r1332  
    11C0CEVC    ; CCDCCR/GPL - SUPPORT FOR EWD VISTCOM PAGES ; 3/1/2010
    2         ;;1.0;C0C;;Mar 1, 2010;Build 1
    3 gpltest2        ; experiment with sending a CCR to an ewd page
    4         N ZI
    5         S ZI=""
    6         D PSEUDO
    7         N ZIO
    8         S ZIO=IO
    9         S IO="/dev/null"
    10         OPEN IO
    11         U IO
    12         N G
    13         S G=$$URLTOKEN^C0CEWD
    14         D CCRRPC^C0CCCR(.GPL,2)
    15         S IO=ZIO
    16         OPEN IO
    17         U IO
    18         K GPL(0)
    19         F  S ZI=$O(GPL(ZI)) Q:ZI=""  W GPL(ZI),!
    20         Q
    21         ;
    22 gpltest ; experiment with sending a CCR to an ewd page
    23         N ZI
    24         S ZI=""
    25         K ^GPL(0)
    26         S ^GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>"
    27         F  S ZI=$O(^GPL(ZI)) Q:ZI=""  W ^GPL(ZI),!
    28         Q
    29         ;
    30 TEST(sessid);   
    31         d setSessionValue^%zewdAPI("person.Name","Rob",sessid)
    32         d setSessionValue^%zewdAPI("person.DateOfBirth","13/06/55",sessid)
    33         d setSessionValue^%zewdAPI("person.Address.PostCode","SW1 3QA",sessid)
    34         d setSessionValue^%zewdAPI("person.Address.Line1","1 The Street",sessid)
    35         d setSessionValue^%zewdAPI("person.Address.2.hello","world",sessid)
    36         d setJSONValue^%zewdAPI("json","person",sessid)
    37         Q ""
    38        
    39 PARSE(INXML,INDOC)      ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
    40         ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
    41         ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
    42         N ZR
    43         M ^CacheTempEWD($j)=@INXML ;
    44         S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
    45         Q ZR
    46         ;
    47 TEST2(sessid)   ; try to put a ccr in the session
    48         S U="^"
    49         D PSEUDO ; FAKE LOGIN
    50         S ZIO=$IO
    51         S DEV="/dev/null"
    52         O DEV U DEV
    53         N G
    54         N ZDFN
    55         S ZDFN=$$getSessionValue^%zewdAPI("vista.dfn",sessid)
    56         I ZDFN="" S ZDFN=2
    57         ;K ^TMP("GPL")
    58         ;M ^TMP("GPL")=^%zewdSession("session",sessid)
    59         D CCRRPC^C0CCCR(.GPL,ZDFN)
    60         K GPL(0)   
    61         S GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>"
    62         C DEV U ZIO
    63         ;M ^CacheTempEWD($j)=GPL
    64         S DOCNAME="CCR"
    65         ;ZWR GPL
    66         ;S ZR=$$parseDocument^%zewdHTMLParser(DOCNAME)
    67         ;d setSessionValues^%zewdAPI(DOCNAME,GPL,sessid)
    68         d mergeArrayToSession^%zewdAPI(.GPL,DOCNAME,sessid)
    69         Q ""
    70         ;
    71 INITSES(sessid) ;initialize an EWD/CPRS session
    72         K ^TMP("GPL")
    73         ;M ^TMP("GPL")=^%zewdSession("session",sessid)
    74         N ZT,ZDFN
    75         S ZT=$$URLTOKEN^C0CEWD(sessid)
    76         ;S ^TMP("GPL")=ZT
    77         d trace^%zewdAPI("*********************ZT="_ZT)
    78         S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN
    79         S ^TMP("GPL","DFN")=ZDFN
    80         I ZDFN=0 S DFN=2 ; DEFAULT TEST PATIENT
    81         D setSessionValue^%zewdAPI("vista.dfn",ZDFN,sessid)
    82         ;M ^TMP("GPL","request")=requestArray
    83         ;D PSEUDO
    84         ;D ^%ZTER
    85         q ""
    86         ;
    87 PRSEORTK(ZTOKEN)        ;PARSES THE TOKEN SENT BY CPRS AND RETURNS THE DFN
    88         ; OF THE PATIENT ; HERE'S WHAT THE TOKEN LOOKS LIKE:
    89         ; ^TMP('ORWCHART',6547,'192.168.169.8',002E0FE6)
    90         N ZX,ZN1,ZIP,ZN2,ZDFN,ZG
    91         S ZDFN=0 ; DEFAULT RETURN
    92         S ZN1=$P(ZTOKEN,",",2) ; FIRST NUMBER
    93         S ZIP=$P(ZTOKEN,",",3) ; IP NUMBER
    94         S ZIP=$P(ZIP,"'",2) ; GET RID OF '
    95         S ZN2=$P(ZTOKEN,",",4) ; SECOND NUMBER
    96         S ZN2=$P(ZN2,")",1) ; GET RID OF )
    97         S ZG=$NA(^TMP("ORWCHART",ZN1,ZIP,ZN2)) ; BUILD THE GLOBAL NAME
    98         I $G(@ZG)'="" S ZDFN=@ZG ; ACCESS THE GLOBAL
    99         S ^TMP("GPL","FIRSTDFN")=ZDFN
    100         S ^TMP("GPL","FIRSTGLB")=ZG
    101         Q ZDFN
    102         ;
    103 GETPATIENTLIST(sessid)  ;
    104         D PSEUDO
    105         D LISTALL^ORWPT(.RTN,"NAME","1")
    106         N ZI
    107         S ZI=""
    108         F  S ZI=$O(RTN(ZI)) Q:ZI=""  D  ;
    109         . S data(ZI,"DFN")=$P(RTN(ZI),"^",1)
    110         . S data(ZI,"Name")=$P(RTN(ZI),"^",2)
    111         ; ZWR data
    112         ;S data(1,"DFN")=$P(RTN(1),"^",1)
    113         ;S data(1,"Name")=$P(RTN(1),"^",2)
    114         d deleteFromSession^%zewdAPI("patients",sessid)
    115         d createDataTableStore^%zewdYUIRuntime(.data,"patients",sessid)
    116         ;d mergeArrayToSession^%zewdAPI(.data,"patients",sessid)
    117         Q ""
    118         ;
    119 PSEUDO 
    120         S U="^"
    121         S DILOCKTM=3
    122         S DISYS=19
    123         S DT=3100219
    124         S DTIME=999
    125         S DUZ=10
    126         S DUZ(0)="@"
    127         S DUZ(1)=""
    128         S DUZ(2)=1
    129         S DUZ("AG")="V"
    130         S DUZ("BUF")=1
    131         S DUZ("LANG")=""
    132         ;S IO="/dev/pts/2"
    133         ;S IO(0)="/dev/pts/2"
    134         ;S IO(1,"/dev/pts/2")=""
    135         ;S IO("ERROR")=""
    136         ;S IO("HOME")="41^/dev/pts/2"
    137         ;S IO("ZIO")="/dev/pts/2"
    138         ;S IOBS="$C(8)"
    139         ;S IOF="#,$C(27,91,50,74,27,91,72)"
    140         ;S SIOM=80
    141         Q
    142         ;
    143 PSEUDO2 ; FAKE LOGIN SETS SOME LOCAL VARIABLE TO FOOL FILEMAN
    144         S DILOCKTM=3
    145         S DISYS=19
    146         S DT=3100112
    147         S DTIME=9999
    148         S DUZ=10000000020
    149         S DUZ(0)="@"
    150         S DUZ(1)=""
    151         S DUZ(2)=67
    152         S DUZ("AG")="E"
    153         S DUZ("BUF")=1
    154         S DUZ("LANG")=1
    155         S IO="/dev/pts/0"
    156         ;S IO(0)="/dev/pts/0"
    157         ;S IO(1,"/dev/pts/0")=""
    158         ;S IO("ERROR")=""
    159         ;S IO("HOME")="50^/dev/pts/0"
    160         ;S IO("ZIO")="/dev/pts/0"
    161         ;S IOBS="$C(8)"
    162         ;S IOF="!!!!!!!!!!!!!!!!!!!!!!!!,#,$C(27,91,50,74,27,91,72)"
    163         ;S IOM=80
    164         ;S ION="GTM/UNIX TELNET"
    165         ;S IOS=50
    166         ;S IOSL=24
    167         ;S IOST="C-VT100"
    168         ;S IOST(0)=9
    169         ;S IOT="VTRM"
    170         ;S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)"
    171         S U="^"
    172         S X="1;DIC(4.2,"
    173         S XPARSYS="1;DIC(4.2,"
    174         S XQXFLG="^^XUP"
    175         S Y="DEV^VISTA^hollywood^VISTA:hollywood"
    176         Q
    177         ;
     2 ;;1.0;C0C;;Mar 1, 2010;
     3gpltest2 ; experiment with sending a CCR to an ewd page
     4 N ZI
     5 S ZI=""
     6 D PSEUDO
     7 N ZIO
     8 S ZIO=IO
     9 S IO="/dev/null"
     10 OPEN IO
     11 U IO
     12 N G
     13 S G=$$URLTOKEN^C0CEWD
     14 D CCRRPC^C0CCCR(.GPL,2)
     15 S IO=ZIO
     16 OPEN IO
     17 U IO
     18 K GPL(0)
     19 F  S ZI=$O(GPL(ZI)) Q:ZI=""  W GPL(ZI),!
     20 Q
     21 ;
     22gpltest ; experiment with sending a CCR to an ewd page
     23 N ZI
     24 S ZI=""
     25 K ^GPL(0)
     26 S ^GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>"
     27 F  S ZI=$O(^GPL(ZI)) Q:ZI=""  W ^GPL(ZI),!
     28 Q
     29 ;
     30TEST(sessid); 
     31 d setSessionValue^%zewdAPI("person.Name","Rob",sessid)
     32 d setSessionValue^%zewdAPI("person.DateOfBirth","13/06/55",sessid)
     33 d setSessionValue^%zewdAPI("person.Address.PostCode","SW1 3QA",sessid)
     34 d setSessionValue^%zewdAPI("person.Address.Line1","1 The Street",sessid)
     35 d setSessionValue^%zewdAPI("person.Address.2.hello","world",sessid)
     36 d setJSONValue^%zewdAPI("json","person",sessid)
     37 Q ""
     38
     39PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
     40 ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
     41 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
     42 N ZR
     43 M ^CacheTempEWD($j)=@INXML ;
     44 S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
     45 Q ZR
     46 ;
     47TEST2(sessid) ; try to put a ccr in the session
     48 S U="^"
     49 D PSEUDO ; FAKE LOGIN
     50 S ZIO=$IO
     51 S DEV="/dev/null"
     52 O DEV U DEV
     53 N G
     54 N ZDFN
     55 S ZDFN=$$getSessionValue^%zewdAPI("vista.dfn",sessid)
     56 I ZDFN="" S ZDFN=2
     57 ;K ^TMP("GPL")
     58 ;M ^TMP("GPL")=^%zewdSession("session",sessid)
     59 D CCRRPC^C0CCCR(.GPL,ZDFN)
     60 K GPL(0)   
     61 S GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>"
     62 C DEV U ZIO
     63 ;M ^CacheTempEWD($j)=GPL
     64 S DOCNAME="CCR"
     65 ;ZWR GPL
     66 ;S ZR=$$parseDocument^%zewdHTMLParser(DOCNAME)
     67 ;d setSessionValues^%zewdAPI(DOCNAME,GPL,sessid)
     68 d mergeArrayToSession^%zewdAPI(.GPL,DOCNAME,sessid)
     69 Q ""
     70 ;
     71INITSES(sessid) ;initialize an EWD/CPRS session
     72 K ^TMP("GPL")
     73 ;M ^TMP("GPL")=^%zewdSession("session",sessid)
     74 N ZT,ZDFN
     75 S ZT=$$URLTOKEN^C0CEWD(sessid)
     76 ;S ^TMP("GPL")=ZT
     77 d trace^%zewdAPI("*********************ZT="_ZT)
     78 S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN
     79 S ^TMP("GPL","DFN")=ZDFN
     80 I ZDFN=0 S DFN=2 ; DEFAULT TEST PATIENT
     81 D setSessionValue^%zewdAPI("vista.dfn",ZDFN,sessid)
     82 ;M ^TMP("GPL","request")=requestArray
     83 ;D PSEUDO
     84 ;D ^%ZTER
     85 q ""
     86 ;
     87PRSEORTK(ZTOKEN) ;PARSES THE TOKEN SENT BY CPRS AND RETURNS THE DFN
     88 ; OF THE PATIENT ; HERE'S WHAT THE TOKEN LOOKS LIKE:
     89 ; ^TMP('ORWCHART',6547,'192.168.169.8',002E0FE6)
     90 N ZX,ZN1,ZIP,ZN2,ZDFN,ZG
     91 S ZDFN=0 ; DEFAULT RETURN
     92 S ZN1=$P(ZTOKEN,",",2) ; FIRST NUMBER
     93 S ZIP=$P(ZTOKEN,",",3) ; IP NUMBER
     94 S ZIP=$P(ZIP,"'",2) ; GET RID OF '
     95 S ZN2=$P(ZTOKEN,",",4) ; SECOND NUMBER
     96 S ZN2=$P(ZN2,")",1) ; GET RID OF )
     97 S ZG=$NA(^TMP("ORWCHART",ZN1,ZIP,ZN2)) ; BUILD THE GLOBAL NAME
     98 I $G(@ZG)'="" S ZDFN=@ZG ; ACCESS THE GLOBAL
     99 S ^TMP("GPL","FIRSTDFN")=ZDFN
     100 S ^TMP("GPL","FIRSTGLB")=ZG
     101 Q ZDFN
     102 ;
     103GETPATIENTLIST(sessid) ;
     104 D PSEUDO
     105 D LISTALL^ORWPT(.RTN,"NAME","1")
     106 N ZI
     107 S ZI=""
     108 F  S ZI=$O(RTN(ZI)) Q:ZI=""  D  ;
     109 . S data(ZI,"DFN")=$P(RTN(ZI),"^",1)
     110 . S data(ZI,"Name")=$P(RTN(ZI),"^",2)
     111 ; ZWR data
     112 ;S data(1,"DFN")=$P(RTN(1),"^",1)
     113 ;S data(1,"Name")=$P(RTN(1),"^",2)
     114 d deleteFromSession^%zewdAPI("patients",sessid)
     115 d createDataTableStore^%zewdYUIRuntime(.data,"patients",sessid)
     116 ;d mergeArrayToSession^%zewdAPI(.data,"patients",sessid)
     117 Q ""
     118 ;
     119PSEUDO
     120 S U="^"
     121 S DILOCKTM=3
     122 S DISYS=19
     123 S DT=3100219
     124 S DTIME=999
     125 S DUZ=10
     126 S DUZ(0)="@"
     127 S DUZ(1)=""
     128 S DUZ(2)=1
     129 S DUZ("AG")="V"
     130 S DUZ("BUF")=1
     131 S DUZ("LANG")=""
     132 ;S IO="/dev/pts/2"
     133 ;S IO(0)="/dev/pts/2"
     134 ;S IO(1,"/dev/pts/2")=""
     135 ;S IO("ERROR")=""
     136 ;S IO("HOME")="41^/dev/pts/2"
     137 ;S IO("ZIO")="/dev/pts/2"
     138 ;S IOBS="$C(8)"
     139 ;S IOF="#,$C(27,91,50,74,27,91,72)"
     140 ;S SIOM=80
     141 Q
     142 ;
     143PSEUDO2 ; FAKE LOGIN SETS SOME LOCAL VARIABLE TO FOOL FILEMAN
     144 S DILOCKTM=3
     145 S DISYS=19
     146 S DT=3100112
     147 S DTIME=9999
     148 S DUZ=10000000020
     149 S DUZ(0)="@"
     150 S DUZ(1)=""
     151 S DUZ(2)=67
     152 S DUZ("AG")="E"
     153 S DUZ("BUF")=1
     154 S DUZ("LANG")=1
     155 S IO="/dev/pts/0"
     156 ;S IO(0)="/dev/pts/0"
     157 ;S IO(1,"/dev/pts/0")=""
     158 ;S IO("ERROR")=""
     159 ;S IO("HOME")="50^/dev/pts/0"
     160 ;S IO("ZIO")="/dev/pts/0"
     161 ;S IOBS="$C(8)"
     162 ;S IOF="!!!!!!!!!!!!!!!!!!!!!!!!,#,$C(27,91,50,74,27,91,72)"
     163 ;S IOM=80
     164 ;S ION="GTM/UNIX TELNET"
     165 ;S IOS=50
     166 ;S IOSL=24
     167 ;S IOST="C-VT100"
     168 ;S IOST(0)=9
     169 ;S IOT="VTRM"
     170 ;S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)"
     171 S U="^"
     172 S X="1;DIC(4.2,"
     173 S XPARSYS="1;DIC(4.2,"
     174 S XQXFLG="^^XUP"
     175 S Y="DEV^VISTA^hollywood^VISTA:hollywood"
     176 Q
     177 ;
  • ccr/branches/ohum/p/C0CEWD.m

    r1330 r1332  
    11C0CEWD    ; CCDCCR/GPL - CCR EWD utilities; 1/6/11
    2         ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
     2        ;;0.1;CCDCCR;nopatch;noreleasedate;Build 77
    33        ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.
  • ccr/branches/ohum/p/C0CEWD1.m

    r1330 r1332  
    1 C0CEWD1   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2         ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21         ;
    22 TEST(filepath)  ; filepath IS THE PATH/FILE TO BE READ IN
    23         i $g(^%ZISH)["" d  ; if the VistA Kernal routine %ZISH exists
    24         . n zfile,zpath,ztmp s (zfile,zpath,ztmp)=""
    25         . s zfile=$re($p($re(filepath),"/",1)) ;file name
    26         . s zpath=$p(filepath,zfile,1) ; file path
    27         . s ztmp=$na(^CacheTempEWD($j,0))
    28         . s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2
    29         q
    30         ;
    31 TEST2   ;
    32         s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml"
    33         ;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath)
    34         s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global
    35         s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0)
    36         ;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM")
    37         w ok,!
    38         q
    39         ;
    40 LOAD(filepath)  ; load an xml file into the EWD global for DOM processing
    41         ; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML)
    42         ; after to process it to the DOM - isHTML=0 for XML files
    43         n i
    44         i $g(^%ZISH)["" d  QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09
    45         . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)=""
    46         . s zfile=$re($p($re(filepath),"/",1)) ;file name
    47         . s zpath=$p(filepath,zfile,1) ; file path
    48         . s ztmp=$na(^CacheTempEWD($j,0))
    49         . s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2
    50         . s i=$o(^CacheTempEWD($j,""),-1) ; highest line number
    51         q i
    52         ;
    53 Q(ZQ,ZD)        ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED
    54         I '$D(ZD) S ZD="DerekDOM"
    55         s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ;
    56         d displayNodes^%zewdXPath(.nodes)
    57         q
    58         ;
    59 GET1URL0(URL)   ;
    60         s ok=$$httpGET^%zewdGTM(URL,.gpl)
    61         D INDEX^C0CXPATH("gpl","gpl2")
    62         W !,"S URL=""",URL,"""",!
    63         S G=""
    64         F  S G=$O(gpl2(G)) Q:G=""  D  ;
    65         . W " S VDX(""",G,""")=""",gpl2(G),"""",!
    66         W !
    67         Q
     1C0CEWD1   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
     2 ;;0.1;CCDCCR;nopatch;noreleasedate
     3 ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 Q
     21 ;
     22TEST(filepath) ; filepath IS THE PATH/FILE TO BE READ IN
     23 i $g(^%ZISH)["" d  ; if the VistA Kernal routine %ZISH exists
     24 . n zfile,zpath,ztmp s (zfile,zpath,ztmp)=""
     25 . s zfile=$re($p($re(filepath),"/",1)) ;file name
     26 . s zpath=$p(filepath,zfile,1) ; file path
     27 . s ztmp=$na(^CacheTempEWD($j,0))
     28 . s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2
     29 q
     30 ;
     31TEST2 ;
     32 s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml"
     33 ;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath)
     34 s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global
     35 s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0)
     36 ;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM")
     37 w ok,!
     38 q
     39 ;
     40LOAD(filepath) ; load an xml file into the EWD global for DOM processing
     41 ; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML)
     42 ; after to process it to the DOM - isHTML=0 for XML files
     43 n i
     44 i $g(^%ZISH)["" d  QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09
     45 . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)=""
     46 . s zfile=$re($p($re(filepath),"/",1)) ;file name
     47 . s zpath=$p(filepath,zfile,1) ; file path
     48 . s ztmp=$na(^CacheTempEWD($j,0))
     49 . s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2
     50 . s i=$o(^CacheTempEWD($j,""),-1) ; highest line number
     51 q i
     52 ;
     53Q(ZQ,ZD) ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED
     54 I '$D(ZD) S ZD="DerekDOM"
     55 s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ;
     56 d displayNodes^%zewdXPath(.nodes)
     57 q
     58 ;
     59GET1URL0(URL) ;
     60 s ok=$$httpGET^%zewdGTM(URL,.gpl)
     61 D INDEX^C0CXPATH("gpl","gpl2")
     62 W !,"S URL=""",URL,"""",!
     63 S G=""
     64 F  S G=$O(gpl2(G)) Q:G=""  D  ;
     65 . W " S VDX(""",G,""")=""",gpl2(G),"""",!
     66 W !
     67 Q
  • ccr/branches/ohum/p/C0CFM1.m

    r1330 r1332  
    11C0CFM1    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.
  • ccr/branches/ohum/p/C0CFM2.m

    r1330 r1332  
    11C0CFM2    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.
  • ccr/branches/ohum/p/C0CFM3.m

    r1330 r1332  
    1 C0CFM3    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2         ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "This is the CCR FILEMAN Utility Library ",!
    21         ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF
    22         ; CCR ELEMENTS (^C0C(179.201,
    23         ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE
    24         ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT
    25         ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS
    26         ; ALL SUB-VARIABLES HAVE BEEN REMOVED
    27         W !
    28         Q
    29         ;
    30 RIMTBL(ZWHICH)  ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE
    31         ; '
    32         I '$D(RIMBASE) D ASETUP^GPLRIMA ; FOR COMMAND LINE CALLS
    33         N ZI,ZJ,ZC,ZPATBASE
    34         S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH))
    35         S ZI=""
    36         F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
    37         . S ZI=$O(@ZPATBASE@(ZI))
    38         . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE
    39         Q
    40         ;
    41 PUTRIM(DFN,ZWHICH)      ;DFN IS PATIENT , WHICH IS ELEMENT TYPE
    42         ;
    43         S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN))
    44         I '$D(ZWHICH) S ZWHICH="ALL"
    45         I ZWHICH'="ALL" D  ; SINGLE SECTION REQUESTED
    46         . S C0CVARS=$NA(@C0CGLB@(ZWHICH))
    47         . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION
    48         E  D  ; MULTIPLE SECTIONS
    49         . S C0CVARS=$NA(@C0CGLB)
    50         . S C0CI=""
    51         . F  S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI=""  D  ;FOR EACH SECTION
    52         . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION
    53         . . D PUTRIM1(DFN,C0CI,C0CVARSN)
    54         Q
    55         ;
    56 PUTRIM1(DFN,ZZTYP,ZVARS)        ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS
    57         ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1"
    58         S C0CX=0
    59         F  S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX=""  D  ; FOR EACH OCCURANCE
    60         . W "ZOCC=",C0CX,!
    61         . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME
    62         . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE
    63         . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE
    64         . I $D(C0CMDO) D  ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :()
    65         . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
    66         . . S ZZCNT=0
    67         . . S ZZC0CI=0
    68         . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE
    69         . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
    70         . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
    71         . . W "MULTIPLE:",ZZVALS,!
    72         . . ;B
    73         . . F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
    74         . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
    75         . . . W "COUNT:",ZZCNT,!
    76         . . . S ZV=$NA(@ZZVALS@(ZZC0CI))
    77         . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV)
    78         Q
    79         ;
    80 PUTELS(DFN,ZTYPE,ZOCC,ZVALS)    ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
    81         ; 171.601, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
    82         ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
    83         ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
    84         ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
    85         ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
    86         ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
    87         ;
    88         N ZSRC,PATN,ZTYPN,XD0,ZTYP
    89         S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
    90         ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
    91         N C0CF S C0CF=171.601 ; FILE AT ELEMENT LEVEL
    92         N C0CFV S C0CFV=171.6011 ; FILE AT VARIABLE LVL
    93         N C0CFDA
    94         N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
    95         W "ZTYPE: ",ZTYPE," ",ZTYPN,!
    96         N ZVARN ; IEN OF VARIABLE BEING PROCESSED
    97         ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
    98         S C0CFDA(C0CF,"+1,",.01)=ZTYPN
    99         S C0CFDA(C0CF,"+1,",.02)=DFN
    100         S C0CFDA(C0CF,"+1,",.03)=ZSRC
    101         S C0CFDA(C0CF,"+1,",.04)=" "_ZOCC ;CREATE OCCURANCE with leading space
    102         D UPDIE ; CREATE THE RECORD
    103         S C0CIEN=$O(^C0CE4("C",DFN,ZSRC,ZTYPN," "_ZOCC,""))
    104         N ZCNT,ZC0CI,ZVARN,C0CZ1
    105         S ZCNT=0
    106         S ZC0CI="" ;
    107         F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
    108         . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
    109         . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
    110         . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
    111         . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
    112         . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",.01)=ZVARN
    113         . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",1)=@ZVALS@(ZC0CI)
    114         . E  D  ; THIS IS A SUBELEMENT
    115         . . ;PUT THE FOLLOWING BACK TO USE RECURSION
    116         . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
    117         . . ;S ZZCNT=0
    118         . . ;S ZZC0CI=0
    119         . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE
    120         . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
    121         . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
    122         . . ;W "MULTIPLE:",ZZVALS,!
    123         . . ;B
    124         . . ;F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
    125         . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
    126         . . ;. W "COUNT:",ZZCNT,!
    127         . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI))
    128         . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION
    129         . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION)
    130         D UPDIE ; UPDATE
    131         Q
    132         ;
    133 UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
    134         K ZERR
    135         D CLEAN^DILF
    136         D UPDATE^DIE("","C0CFDA","","ZERR")
    137         I $D(ZERR) D  ;
    138         . W "ERROR",!
    139         . ZWR ZERR
    140         . B
    141         K C0CFDA
    142         Q
    143         ;
    144 PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
    145         ; 171.101, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
    146         ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
    147         ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
    148         ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
    149         ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
    150         ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
    151         ;
    152         S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
    153         ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
    154         N ZF,ZFV S ZF=171.101 S ZFV=171.1011
    155         ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS
    156         ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER
    157         N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
    158         W "ZTYPE: ",ZTYPE," ",ZTYPN,!
    159         N ZVARN ; IEN OF VARIABLE BEING PROCESSED
    160         ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
    161         K C0CFDA
    162         S C0CFDA(ZF,"?+1,",.01)=DFN
    163         S C0CFDA(ZF,"?+1,",.02)=ZSRC
    164         S C0CFDA(ZF,"?+1,",.03)=ZTYPN
    165         S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE
    166         K ZERR
    167         ;B
    168         D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER
    169         I $D(ZERR) B  ;OOPS
    170         K C0CFDA
    171         S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,""))
    172         W "RECORD NUMBER: ",ZD0,!
    173         ;B
    174         S ZCNT=0
    175         S ZC0CI="" ;
    176         F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
    177         . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
    178         . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
    179         . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
    180         . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
    181         . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN
    182         . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI)
    183         . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN
    184         . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI)
    185         ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT"
    186         ;S GT1(170,"?+1,",12)="DIR"
    187         ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT"
    188         ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT"
    189         D CLEAN^DILF
    190         D UPDATE^DIE("","C0CFDA","","ZERR")
    191         I $D(ZERR) D  ;
    192         . W "ERROR",!
    193         . ZWR ZERR
    194         . B
    195         K C0CFDA
    196         Q
    197         ;
    198 VARPTR(ZVAR,ZTYP)       ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
    199         ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
    200         ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
    201         ;
    202         N ZCCRD,ZVARN,C0CFDA2
    203         S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
    204         S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    205         I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
    206         . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
    207         . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
    208         . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
    209         . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
    210         . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
    211         . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
    212         . I $D(ZERR) D  ; LAYGO ERROR
    213         . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
    214         . E  D  ;
    215         . . D CLEAN^DILF ; CLEAN UP
    216         . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    217         . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
    218         Q ZVARN
    219         ;
    220 BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,)
    221         ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED
    222         ;
    223         N C0CDIC,C0CNODE ;
    224         S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY
    225         S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE
    226         Q
    227         ;
    228 FIXSEC  ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED
    229         ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET
    230         ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS
    231         ; CONVERSION
    232         ;N C0CC,C0CI,C0CJ,C0CN,C0CZX
    233         D FIELDS^C0CRNF("C0CC",170)
    234         S C0CI=""
    235         F  S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI=""  D  ; EACH SECTION
    236         . S C0CZX=""
    237         . F  S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX=""  D  ; EACH VARIABLE
    238         . . W "SECTION ",C0CI," VAR ",C0CZX
    239         . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,""))
    240         . . W " TYPE: ",C0CV,!
    241         . . D SETFDA("SECTION",C0CV)
    242         . . ;ZWR C0CFDA
    243         Q
    244         ;
    245 SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
    246         ; TO SET TO VALUE C0CSV.
    247         ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
    248         ; C0CSN,C0CSV ARE PASSED BY VALUE
    249         ;
    250         N C0CSI,C0CSJ
    251         S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
    252         S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
    253         S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
    254         Q
    255 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
    256         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
    257         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    258         I '$D(ZTAB) S ZTAB="C0CA"
    259         N ZR
    260         I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
    261         E  S ZR=""
    262         Q ZR
    263 ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
    264         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
    265         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    266         I '$D(ZTAB) S ZTAB="C0CA"
    267         N ZR
    268         I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
    269         E  S ZR=""
    270         Q ZR
    271         ;
    272 ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
    273         ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
    274         ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    275         I '$D(ZTAB) S ZTAB="C0CA"
    276         N ZR
    277         I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
    278         E  S ZR=""
    279         Q ZR
    280         ;
    281 SHOWE4(DFN)     ;
    282         ;
    283         N ZG
    284         S ZG=""
    285         F  S ZG=$O(^C0CE4("P",DFN,ZG)) Q:ZG=""  D  ZWR ^C0CE4(ZG,*)
    286         Q
    287         ;
     1C0CFM3   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
     2 ;;0.1;CCDCCR;nopatch;noreleasedate
     3 ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 W "This is the CCR FILEMAN Utility Library ",!
     21 ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF
     22 ; CCR ELEMENTS (^C0C(179.201,
     23 ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE
     24 ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT
     25 ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS
     26 ; ALL SUB-VARIABLES HAVE BEEN REMOVED
     27 W !
     28 Q
     29 ;
     30RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE
     31 ; '
     32 I '$D(RIMBASE) D ASETUP^GPLRIMA ; FOR COMMAND LINE CALLS
     33 N ZI,ZJ,ZC,ZPATBASE
     34 S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH))
     35 S ZI=""
     36 F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
     37 . S ZI=$O(@ZPATBASE@(ZI))
     38 . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE
     39 Q
     40 ;
     41PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE
     42 ;
     43 S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN))
     44 I '$D(ZWHICH) S ZWHICH="ALL"
     45 I ZWHICH'="ALL" D  ; SINGLE SECTION REQUESTED
     46 . S C0CVARS=$NA(@C0CGLB@(ZWHICH))
     47 . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION
     48 E  D  ; MULTIPLE SECTIONS
     49 . S C0CVARS=$NA(@C0CGLB)
     50 . S C0CI=""
     51 . F  S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI=""  D  ;FOR EACH SECTION
     52 . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION
     53 . . D PUTRIM1(DFN,C0CI,C0CVARSN)
     54 Q
     55 ;
     56PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS
     57 ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1"
     58 S C0CX=0
     59 F  S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX=""  D  ; FOR EACH OCCURANCE
     60 . W "ZOCC=",C0CX,!
     61 . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME
     62 . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE
     63 . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE
     64 . I $D(C0CMDO) D  ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :()
     65 . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
     66 . . S ZZCNT=0
     67 . . S ZZC0CI=0
     68 . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE
     69 . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
     70 . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
     71 . . W "MULTIPLE:",ZZVALS,!
     72 . . ;B
     73 . . F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
     74 . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
     75 . . . W "COUNT:",ZZCNT,!
     76 . . . S ZV=$NA(@ZZVALS@(ZZC0CI))
     77 . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV)
     78 Q
     79 ;
     80PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
     81 ; 171.601, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
     82 ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
     83 ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
     84 ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
     85 ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
     86 ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
     87 ;
     88 N ZSRC,PATN,ZTYPN,XD0,ZTYP
     89 S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
     90 ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
     91 N C0CF S C0CF=171.601 ; FILE AT ELEMENT LEVEL
     92 N C0CFV S C0CFV=171.6011 ; FILE AT VARIABLE LVL
     93 N C0CFDA
     94 N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
     95 W "ZTYPE: ",ZTYPE," ",ZTYPN,!
     96 N ZVARN ; IEN OF VARIABLE BEING PROCESSED
     97 ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
     98 S C0CFDA(C0CF,"+1,",.01)=ZTYPN
     99 S C0CFDA(C0CF,"+1,",.02)=DFN
     100 S C0CFDA(C0CF,"+1,",.03)=ZSRC
     101 S C0CFDA(C0CF,"+1,",.04)=" "_ZOCC ;CREATE OCCURANCE with leading space
     102 D UPDIE ; CREATE THE RECORD
     103 S C0CIEN=$O(^C0CE4("C",DFN,ZSRC,ZTYPN," "_ZOCC,""))
     104 N ZCNT,ZC0CI,ZVARN,C0CZ1
     105 S ZCNT=0
     106 S ZC0CI="" ;
     107 F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
     108 . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
     109 . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
     110 . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
     111 . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
     112 . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",.01)=ZVARN
     113 . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",1)=@ZVALS@(ZC0CI)
     114 . E  D  ; THIS IS A SUBELEMENT
     115 . . ;PUT THE FOLLOWING BACK TO USE RECURSION
     116 . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
     117 . . ;S ZZCNT=0
     118 . . ;S ZZC0CI=0
     119 . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE
     120 . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
     121 . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
     122 . . ;W "MULTIPLE:",ZZVALS,!
     123 . . ;B
     124 . . ;F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
     125 . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
     126 . . ;. W "COUNT:",ZZCNT,!
     127 . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI))
     128 . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION
     129 . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION)
     130 D UPDIE ; UPDATE
     131 Q
     132 ;
     133UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
     134 K ZERR
     135 D CLEAN^DILF
     136 D UPDATE^DIE("","C0CFDA","","ZERR")
     137 I $D(ZERR) D  ;
     138 . W "ERROR",!
     139 . ZWR ZERR
     140 . B
     141 K C0CFDA
     142 Q
     143 ;
     144PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
     145 ; 171.101, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
     146 ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
     147 ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
     148 ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
     149 ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
     150 ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
     151 ;
     152 S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
     153 ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
     154 N ZF,ZFV S ZF=171.101 S ZFV=171.1011
     155 ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS
     156 ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER
     157 N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
     158 W "ZTYPE: ",ZTYPE," ",ZTYPN,!
     159 N ZVARN ; IEN OF VARIABLE BEING PROCESSED
     160 ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
     161 K C0CFDA
     162 S C0CFDA(ZF,"?+1,",.01)=DFN
     163 S C0CFDA(ZF,"?+1,",.02)=ZSRC
     164 S C0CFDA(ZF,"?+1,",.03)=ZTYPN
     165 S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE
     166 K ZERR
     167 ;B
     168 D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER
     169 I $D(ZERR) B  ;OOPS
     170 K C0CFDA
     171 S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,""))
     172 W "RECORD NUMBER: ",ZD0,!
     173 ;B
     174 S ZCNT=0
     175 S ZC0CI="" ;
     176 F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
     177 . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
     178 . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
     179 . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
     180 . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
     181 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN
     182 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI)
     183 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN
     184 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI)
     185 ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT"
     186 ;S GT1(170,"?+1,",12)="DIR"
     187 ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT"
     188 ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT"
     189 D CLEAN^DILF
     190 D UPDATE^DIE("","C0CFDA","","ZERR")
     191 I $D(ZERR) D  ;
     192 . W "ERROR",!
     193 . ZWR ZERR
     194 . B
     195 K C0CFDA
     196 Q
     197 ;
     198VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
     199 ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
     200 ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
     201 ;
     202 N ZCCRD,ZVARN,C0CFDA2
     203 S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
     204 S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     205 I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
     206 . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
     207 . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
     208 . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
     209 . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
     210 . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
     211 . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
     212 . I $D(ZERR) D  ; LAYGO ERROR
     213 . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
     214 . E  D  ;
     215 . . D CLEAN^DILF ; CLEAN UP
     216 . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     217 . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
     218 Q ZVARN
     219 ;
     220BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,)
     221 ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED
     222 ;
     223 N C0CDIC,C0CNODE ;
     224 S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY
     225 S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE
     226 Q
     227 ;
     228FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED
     229 ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET
     230 ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS
     231 ; CONVERSION
     232 ;N C0CC,C0CI,C0CJ,C0CN,C0CZX
     233 D FIELDS^C0CRNF("C0CC",170)
     234 S C0CI=""
     235 F  S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI=""  D  ; EACH SECTION
     236 . S C0CZX=""
     237 . F  S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX=""  D  ; EACH VARIABLE
     238 . . W "SECTION ",C0CI," VAR ",C0CZX
     239 . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,""))
     240 . . W " TYPE: ",C0CV,!
     241 . . D SETFDA("SECTION",C0CV)
     242 . . ;ZWR C0CFDA
     243 Q
     244 ;
     245SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
     246 ; TO SET TO VALUE C0CSV.
     247 ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
     248 ; C0CSN,C0CSV ARE PASSED BY VALUE
     249 ;
     250 N C0CSI,C0CSJ
     251 S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
     252 S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
     253 S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
     254 Q
     255ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
     256 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
     257 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     258 I '$D(ZTAB) S ZTAB="C0CA"
     259 N ZR
     260 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
     261 E  S ZR=""
     262 Q ZR
     263ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
     264 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
     265 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     266 I '$D(ZTAB) S ZTAB="C0CA"
     267 N ZR
     268 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
     269 E  S ZR=""
     270 Q ZR
     271 ;
     272ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
     273 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
     274 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     275 I '$D(ZTAB) S ZTAB="C0CA"
     276 N ZR
     277 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
     278 E  S ZR=""
     279 Q ZR
     280 ;
     281SHOWE4(DFN) ;
     282 ;
     283 N ZG
     284 S ZG=""
     285 F  S ZG=$O(^C0CE4("P",DFN,ZG)) Q:ZG=""  D  ZWR ^C0CE4(ZG,*)
     286 Q
     287 ;
  • ccr/branches/ohum/p/C0CIM2.m

    r1330 r1332  
    11C0CIM2   ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10
    2         ;;1.0;C0C;;Feb 16, 2010;Build 1
     2        ;;1.0;C0C;;Feb 16, 2010;Build 38
    33        ;Copyright 2010 George Lilly, University of Minnesota and others.
    44        ;Licensed under the terms of the GNU General Public License.
  • ccr/branches/ohum/p/C0CIMMU.m

    r1330 r1332  
    11C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.
  • ccr/branches/ohum/p/C0CIN.m

    r1330 r1332  
    11C0CIN     ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08
    2         ;;1.0;C0C;;Sep 20, 2009;Build 1
     2        ;;1.0;C0C;;Sep 20, 2009;Build 38
    33        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    44        ;General Public License See attached copy of the License.
  • ccr/branches/ohum/p/C0CLA7DD.m

    r1330 r1332  
    1 C0CLA7DD        ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    3         ;
    4         ; Tasked by C0C post-install routine C0CENV to create C0C cross-references on V LAB file.
    5         ;
    6         Q
    7         ;
    8         ;
    9 EN      ; Add new style cross-references to V LAB file if it exists.
    10         ; OLD entry point - see new KIDS check points in C0CENV.
    11         ;
    12         ;
    13         ; Quit if AUPNVLAB global does not exist.
    14         I $$VFILE^DILFD(9000010.09)'=1 Q
    15         ;
    16         N MSG
    17         ;
    18         S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    19         D BMES(MSG)
    20         D ALR1
    21         S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    22         D BMES(MSG)
    23         ;
    24         S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    25         D BMES(MSG)
    26         D ALR2
    27         S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    28         D BMES(MSG)
    29         ;
    30         S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    31         D BMES(MSG)
    32         D ALR3
    33         S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    34         D BMES(MSG)
    35         ;
    36         S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    37         D BMES(MSG)
    38         D ALR4
    39         S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    40         D BMES(MSG)
    41         ;
    42         S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    43         D BMES(MSG)
    44         D ALR5
    45         S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    46         D BMES(MSG)
    47         ;
    48         Q
    49         ;
    50         ;
    51 ALR1    ; Installation of ALR1 cross-reference
    52         ;
    53         N C0CFLAG,C0CXR,C0CRES,C0COUT
    54         ;
    55         S C0CFLAG=""
    56         ;
    57         S C0CXR("FILE")=9000010.09
    58         S C0CXR("NAME")="ALR1"
    59         S C0CXR("TYPE")="R"
    60         S C0CXR("USE")="S"
    61         S C0CXR("EXECUTION")="R"
    62         S C0CXR("ACTIVITY")="IR"
    63         S C0CXR("SHORT DESCR")="X-ref to link entry with parent in LAB DATA file (#63)"
    64         S C0CXR("VAL",1)=.02
    65         S C0CXR("VAL",1,"SUBSCRIPT")=1
    66         S C0CXR("VAL",1,"COLLATION")="F"
    67         S C0CXR("VAL",2)=.06
    68         S C0CXR("VAL",2,"SUBSCRIPT")=2
    69         S C0CXR("VAL",2,"LENGTH")=30
    70         S C0CXR("VAL",2,"COLLATION")="F"
    71         S C0CXR("VAL",3)=.01
    72         S C0CXR("VAL",3,"SUBSCRIPT")=3
    73         S C0CXR("VAL",3,"COLLATION")="F"
    74         S C0CXR("VAL",4)=1201
    75         S C0CXR("VAL",4,"SUBSCRIPT")=4
    76         S C0CXR("VAL",4,"COLLATION")="F"
    77         D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
    78         ;
    79         Q
    80         ;
    81         ;
    82 ALR2    ; Installation of ALR2 cross-reference
    83         ;
    84         N C0CFLAG,C0CXR,C0CRES,C0COUT
    85         ;
    86         S C0CFLAG=""
    87         ;
    88         S C0CXR("FILE")=9000010.09
    89         S C0CXR("NAME")="ALR2"
    90         S C0CXR("TYPE")="MU"
    91         S C0CXR("USE")="S"
    92         S C0CXR("EXECUTION")="R"
    93         S C0CXR("ACTIVITY")="IR"
    94         S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result."
    95         S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes"
    96         S C0CXR("DESCR",2)="that has been assigned to a lab result. Allows queries to"
    97         S C0CXR("DESCR",3)="retrieve the LOINC code associated with a specific test"
    98         S C0CXR("DESCR",4)="result."
    99         S C0CXR("SET")="S ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)="""""
    100         S C0CXR("KILL")="K ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)"
    101         S C0CXR("WHOLE KILL")="K ^AUPNVLAB(""ALR2"")"
    102         S C0CXR("VAL",1)=.02
    103         S C0CXR("VAL",1,"SUBSCRIPT")=1
    104         S C0CXR("VAL",1,"COLLATION")="F"
    105         S C0CXR("VAL",2)=1201
    106         S C0CXR("VAL",2,"SUBSCRIPT")=2
    107         S C0CXR("VAL",2,"COLLATION")="F"
    108         S C0CXR("VAL",3)=.06
    109         S C0CXR("VAL",3,"SUBSCRIPT")=3
    110         S C0CXR("VAL",3,"COLLATION")="F"
    111         S C0CXR("VAL",4)=.01
    112         S C0CXR("VAL",4,"SUBSCRIPT")=4
    113         S C0CXR("VAL",4,"COLLATION")="F"
    114         S C0CXR("VAL",5)=1113
    115         S C0CXR("VAL",5,"SUBSCRIPT")=5
    116         S C0CXR("VAL",5,"COLLATION")="F"
    117         D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
    118         ;
    119         Q
    120         ;
    121         ;
    122 ALR3    ; Installation of ALR3 cross-reference
    123         ;
    124         N C0CFLAG,C0CXR,C0CRES,C0COUT
    125         ;
    126         S C0CFLAG=""
    127         ;
    128         S C0CXR("FILE")=9000010.09
    129         S C0CXR("NAME")="ALR3"
    130         S C0CXR("TYPE")="R"
    131         S C0CXR("USE")="S"
    132         S C0CXR("EXECUTION")="F"
    133         S C0CXR("ACTIVITY")="IR"
    134         S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result - any patient"
    135         S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes that has been assigned to a lab result. Allows queries"
    136         S C0CXR("DESCR",2)="to retrieve the LOINC code associated with a specific test result. It allows any patient"
    137         S C0CXR("DESCR",3)="lab results to be identified by LOINC"
    138         S C0CXR("VAL",1)=1113
    139         S C0CXR("VAL",1,"SUBSCRIPT")=1
    140         S C0CXR("VAL",1,"COLLATION")="F"
    141         ;
    142         D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
    143         ;
    144         Q
    145         ;
    146         ;
    147 ALR4    ; Installation of ALR4 cross-reference
    148         ;
    149         N C0CFLAG,C0CXR,C0CRES,C0COUT
    150         ;
    151         S C0CFLAG=""
    152         ;
    153         S C0CXR("FILE")=9000010.09
    154         S C0CXR("NAME")="ALR4"
    155         S C0CXR("TYPE")="R"
    156         S C0CXR("USE")="S"
    157         S C0CXR("EXECUTION")="R"
    158         S C0CXR("ACTIVITY")="IR"
    159         S C0CXR("SHORT DESCR")="X-ref by patient and collection date/time"
    160         S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a"
    161         S C0CXR("DESCR",2)="patient by collection date/time. This includes results that are only in"
    162         S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA"
    163         S C0CXR("DESCR",4)="file (#63)."
    164         S C0CXR("VAL",1)=.02
    165         S C0CXR("VAL",1,"SUBSCRIPT")=1
    166         S C0CXR("VAL",1,"COLLATION")="F"
    167         S C0CXR("VAL",2)=1201
    168         S C0CXR("VAL",2,"SUBSCRIPT")=2
    169         S C0CXR("VAL",2,"COLLATION")="F"
    170         ;
    171         D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
    172         ;
    173         Q
    174         ;
    175         ;
    176 ALR5    ; Installation of ALR5 cross-reference
    177         ;
    178         N C0CFLAG,C0CXR,C0CRES,C0COUT
    179         ;
    180         S C0CFLAG=""
    181         ;
    182         S C0CXR("FILE")=9000010.09
    183         S C0CXR("NAME")="ALR5"
    184         S C0CXR("TYPE")="R"
    185         S C0CXR("USE")="S"
    186         S C0CXR("EXECUTION")="R"
    187         S C0CXR("ACTIVITY")="IR"
    188         S C0CXR("SHORT DESCR")="X-ref by patient and results availble date/time"
    189         S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a"
    190         S C0CXR("DESCR",2)="patient by results available date/time. This includes results that are only in"
    191         S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA"
    192         S C0CXR("DESCR",4)="file (#63)."
    193         S C0CXR("VAL",1)=.02
    194         S C0CXR("VAL",1,"SUBSCRIPT")=1
    195         S C0CXR("VAL",1,"COLLATION")="F"
    196         S C0CXR("VAL",2)=1212
    197         S C0CXR("VAL",2,"SUBSCRIPT")=2
    198         S C0CXR("VAL",2,"COLLATION")="F"
    199         ;
    200         D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
    201         ;
    202         Q
    203         ;
    204         ;
    205 REINDEX ; Set data into indexes for current entries.
    206         ;
    207         ;
    208         N C0CHLOG,DA,DIK,MSG
    209         ;
    210         S C0CHLOG("START")=$H
    211         S MSG="Starting indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z")
    212         D BMES(MSG),SENDXQA(MSG)
    213         ;
    214         S DIK="^AUPNVLAB("
    215         S DIK(1)=".02^ALR1^ALR2^ALR4^ALR5"
    216         D ENALL^DIK
    217         ;
    218         S C0CHLOG("END")=$H
    219         S MSG="Finished indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z")
    220         D BMES(MSG),SENDXQA(MSG)
    221         ;
    222         S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3)
    223         D BMES(MSG)
    224         ;
    225         S C0CHLOG("START")=$H
    226         S MSG="Starting indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z")
    227         D BMES(MSG),SENDXQA(MSG)
    228         ;
    229         K DA,DIK
    230         S DIK="^AUPNVLAB("
    231         S DIK(1)="1113^ALR3"
    232         D ENALL^DIK
    233         ;
    234         S C0CHLOG("END")=$H
    235         S MSG="Finished indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z")
    236         D BMES(MSG),SENDXQA(MSG)
    237         ;
    238         S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3)
    239         D BMES(MSG)
    240         ;
    241         Q
    242         ;
    243         ;
    244 BMES(STR)       ; Write BMES^XPDUTL statements
    245         ;
    246         D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
    247         ;
    248         Q
    249         ;
    250         ;
     1C0CLA7DD ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009
     2 ;;1.0;C0C;;May 19, 2009;
     3 ;
     4 ; Tasked by C0C post-install routine C0CENV to create C0C cross-references on V LAB file.
     5 ;
     6 Q
     7 ;
     8 ;
     9EN ; Add new style cross-references to V LAB file if it exists.
     10 ; OLD entry point - see new KIDS check points in C0CENV.
     11 ;
     12 ;
     13 ; Quit if AUPNVLAB global does not exist.
     14 I $$VFILE^DILFD(9000010.09)'=1 Q
     15 ;
     16 N MSG
     17 ;
     18 S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     19 D BMES(MSG)
     20 D ALR1
     21 S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     22 D BMES(MSG)
     23 ;
     24 S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     25 D BMES(MSG)
     26 D ALR2
     27 S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     28 D BMES(MSG)
     29 ;
     30 S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     31 D BMES(MSG)
     32 D ALR3
     33 S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     34 D BMES(MSG)
     35 ;
     36 S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     37 D BMES(MSG)
     38 D ALR4
     39 S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     40 D BMES(MSG)
     41 ;
     42 S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     43 D BMES(MSG)
     44 D ALR5
     45 S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     46 D BMES(MSG)
     47 ;
     48 Q
     49 ;
     50 ;
     51ALR1 ; Installation of ALR1 cross-reference
     52 ;
     53 N C0CFLAG,C0CXR,C0CRES,C0COUT
     54 ;
     55 S C0CFLAG=""
     56 ;
     57 S C0CXR("FILE")=9000010.09
     58 S C0CXR("NAME")="ALR1"
     59 S C0CXR("TYPE")="R"
     60 S C0CXR("USE")="S"
     61 S C0CXR("EXECUTION")="R"
     62 S C0CXR("ACTIVITY")="IR"
     63 S C0CXR("SHORT DESCR")="X-ref to link entry with parent in LAB DATA file (#63)"
     64 S C0CXR("VAL",1)=.02
     65 S C0CXR("VAL",1,"SUBSCRIPT")=1
     66 S C0CXR("VAL",1,"COLLATION")="F"
     67 S C0CXR("VAL",2)=.06
     68 S C0CXR("VAL",2,"SUBSCRIPT")=2
     69 S C0CXR("VAL",2,"LENGTH")=30
     70 S C0CXR("VAL",2,"COLLATION")="F"
     71 S C0CXR("VAL",3)=.01
     72 S C0CXR("VAL",3,"SUBSCRIPT")=3
     73 S C0CXR("VAL",3,"COLLATION")="F"
     74 S C0CXR("VAL",4)=1201
     75 S C0CXR("VAL",4,"SUBSCRIPT")=4
     76 S C0CXR("VAL",4,"COLLATION")="F"
     77 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
     78 ;
     79 Q
     80 ;
     81 ;
     82ALR2 ; Installation of ALR2 cross-reference
     83 ;
     84 N C0CFLAG,C0CXR,C0CRES,C0COUT
     85 ;
     86 S C0CFLAG=""
     87 ;
     88 S C0CXR("FILE")=9000010.09
     89 S C0CXR("NAME")="ALR2"
     90 S C0CXR("TYPE")="MU"
     91 S C0CXR("USE")="S"
     92 S C0CXR("EXECUTION")="R"
     93 S C0CXR("ACTIVITY")="IR"
     94 S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result."
     95 S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes"
     96 S C0CXR("DESCR",2)="that has been assigned to a lab result. Allows queries to"
     97 S C0CXR("DESCR",3)="retrieve the LOINC code associated with a specific test"
     98 S C0CXR("DESCR",4)="result."
     99 S C0CXR("SET")="S ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)="""""
     100 S C0CXR("KILL")="K ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)"
     101 S C0CXR("WHOLE KILL")="K ^AUPNVLAB(""ALR2"")"
     102 S C0CXR("VAL",1)=.02
     103 S C0CXR("VAL",1,"SUBSCRIPT")=1
     104 S C0CXR("VAL",1,"COLLATION")="F"
     105 S C0CXR("VAL",2)=1201
     106 S C0CXR("VAL",2,"SUBSCRIPT")=2
     107 S C0CXR("VAL",2,"COLLATION")="F"
     108 S C0CXR("VAL",3)=.06
     109 S C0CXR("VAL",3,"SUBSCRIPT")=3
     110 S C0CXR("VAL",3,"COLLATION")="F"
     111 S C0CXR("VAL",4)=.01
     112 S C0CXR("VAL",4,"SUBSCRIPT")=4
     113 S C0CXR("VAL",4,"COLLATION")="F"
     114 S C0CXR("VAL",5)=1113
     115 S C0CXR("VAL",5,"SUBSCRIPT")=5
     116 S C0CXR("VAL",5,"COLLATION")="F"
     117 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
     118 ;
     119 Q
     120 ;
     121 ;
     122ALR3 ; Installation of ALR3 cross-reference
     123 ;
     124 N C0CFLAG,C0CXR,C0CRES,C0COUT
     125 ;
     126 S C0CFLAG=""
     127 ;
     128 S C0CXR("FILE")=9000010.09
     129 S C0CXR("NAME")="ALR3"
     130 S C0CXR("TYPE")="R"
     131 S C0CXR("USE")="S"
     132 S C0CXR("EXECUTION")="F"
     133 S C0CXR("ACTIVITY")="IR"
     134 S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result - any patient"
     135 S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes that has been assigned to a lab result. Allows queries"
     136 S C0CXR("DESCR",2)="to retrieve the LOINC code associated with a specific test result. It allows any patient"
     137 S C0CXR("DESCR",3)="lab results to be identified by LOINC"
     138 S C0CXR("VAL",1)=1113
     139 S C0CXR("VAL",1,"SUBSCRIPT")=1
     140 S C0CXR("VAL",1,"COLLATION")="F"
     141 ;
     142 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
     143 ;
     144 Q
     145 ;
     146 ;
     147ALR4 ; Installation of ALR4 cross-reference
     148 ;
     149 N C0CFLAG,C0CXR,C0CRES,C0COUT
     150 ;
     151 S C0CFLAG=""
     152 ;
     153 S C0CXR("FILE")=9000010.09
     154 S C0CXR("NAME")="ALR4"
     155 S C0CXR("TYPE")="R"
     156 S C0CXR("USE")="S"
     157 S C0CXR("EXECUTION")="R"
     158 S C0CXR("ACTIVITY")="IR"
     159 S C0CXR("SHORT DESCR")="X-ref by patient and collection date/time"
     160 S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a"
     161 S C0CXR("DESCR",2)="patient by collection date/time. This includes results that are only in"
     162 S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA"
     163 S C0CXR("DESCR",4)="file (#63)."
     164 S C0CXR("VAL",1)=.02
     165 S C0CXR("VAL",1,"SUBSCRIPT")=1
     166 S C0CXR("VAL",1,"COLLATION")="F"
     167 S C0CXR("VAL",2)=1201
     168 S C0CXR("VAL",2,"SUBSCRIPT")=2
     169 S C0CXR("VAL",2,"COLLATION")="F"
     170 ;
     171 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
     172 ;
     173 Q
     174 ;
     175 ;
     176ALR5 ; Installation of ALR5 cross-reference
     177 ;
     178 N C0CFLAG,C0CXR,C0CRES,C0COUT
     179 ;
     180 S C0CFLAG=""
     181 ;
     182 S C0CXR("FILE")=9000010.09
     183 S C0CXR("NAME")="ALR5"
     184 S C0CXR("TYPE")="R"
     185 S C0CXR("USE")="S"
     186 S C0CXR("EXECUTION")="R"
     187 S C0CXR("ACTIVITY")="IR"
     188 S C0CXR("SHORT DESCR")="X-ref by patient and results availble date/time"
     189 S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a"
     190 S C0CXR("DESCR",2)="patient by results available date/time. This includes results that are only in"
     191 S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA"
     192 S C0CXR("DESCR",4)="file (#63)."
     193 S C0CXR("VAL",1)=.02
     194 S C0CXR("VAL",1,"SUBSCRIPT")=1
     195 S C0CXR("VAL",1,"COLLATION")="F"
     196 S C0CXR("VAL",2)=1212
     197 S C0CXR("VAL",2,"SUBSCRIPT")=2
     198 S C0CXR("VAL",2,"COLLATION")="F"
     199 ;
     200 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
     201 ;
     202 Q
     203 ;
     204 ;
     205REINDEX ; Set data into indexes for current entries.
     206 ;
     207 ;
     208 N C0CHLOG,DA,DIK,MSG
     209 ;
     210 S C0CHLOG("START")=$H
     211 S MSG="Starting indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z")
     212 D BMES(MSG),SENDXQA(MSG)
     213        ;
     214 S DIK="^AUPNVLAB("
     215 S DIK(1)=".02^ALR1^ALR2^ALR4^ALR5"
     216 D ENALL^DIK
     217 ;
     218 S C0CHLOG("END")=$H
     219 S MSG="Finished indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z")
     220 D BMES(MSG),SENDXQA(MSG)
     221 ;
     222 S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3)
     223 D BMES(MSG)
     224        ;
     225 S C0CHLOG("START")=$H
     226 S MSG="Starting indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z")
     227 D BMES(MSG),SENDXQA(MSG)
     228 ;
     229 K DA,DIK
     230 S DIK="^AUPNVLAB("
     231 S DIK(1)="1113^ALR3"
     232 D ENALL^DIK
     233 ;
     234 S C0CHLOG("END")=$H
     235 S MSG="Finished indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z")
     236 D BMES(MSG),SENDXQA(MSG)
     237 ;
     238 S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3)
     239 D BMES(MSG)
     240 ;
     241 Q
     242 ;
     243 ;
     244BMES(STR) ; Write BMES^XPDUTL statements
     245 ;
     246 D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
     247 ;
     248 Q
     249 ;
     250 ;
    251251SENDXQA(MSG)    ; Send alert for reindex status
    252252        ;
  • ccr/branches/ohum/p/C0CLA7Q.m

    r1330 r1332  
    11C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;
    44        ;
  • ccr/branches/ohum/p/C0CLABS.m

    r1330 r1332  
    11C0CALABS        ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
     2        ;;1.0;C0C;;May 19, 2009;Build 38
    33        ;Copyright 2008,2009 George Lilly, University of Minnesota.
    44        ;Licensed under the terms of the GNU General Public License.
  • ccr/branches/ohum/p/C0CMAIL.m

    r1330 r1332  
    11C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
    2 V       ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2011 Chris Richardson, Richardson Computer Research
    4         ; Modified 3110516@1818
    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         ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
    26         ;  Input:
    27         ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
    28         ;                      or "*" for all boxes, default is "IN" if missing]"
    29         ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
    30         ;                                     "*" for All or 9,999 maximum
    31         ;                    MALL?1.n = that number of the n most recent
    32         ;  Internally:
    33         ;    BNAM = Box Name
    34         ;  Output:
    35         ;    C0CDATA
    36         ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
    37         ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
    38         ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
    39         ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
    40         ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
    41         ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
    42         ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
    43         ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
    44         ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
    45         ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
    46         ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
    47         ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
    48         ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
    49         ;
    50         ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
    51         ;   Input;
    52         ;     D0     - The IEN for the message in file 3.9, MESSAGE global
    53         ;   Output
    54         ;     OUTBF  - The array of your choice to save the expanded and decoded message.
    55         ;
    56 GETMSG(C0CDATA,C0CINPUT)        ; Common Entry Point for Mailbox Data
    57         K:'$G(C0CDATA("KEEP")) C0CDATA
    58         N U
    59         S U="^"
    60         D:$G(C0CINPUT)
    61         . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
    62         . S INPUT=C0CINPUT
    63         . S DUZ=+INPUT
    64         . D:$D(^XMB(3.7,DUZ,0))#2
    65         . . S MBLST=$P(INPUT,";",2)
    66         . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
    67         . . S:MALL["*" MALL=99999
    68         . . ; Only one of these can be correct
    69         . . D
    70         . . . ;  If nul, make it "IN" only
    71         . . . I MBLST="" D  QUIT
    72         . . . . S MBLST("IN")=0,I=0
    73         . . . . D GATHER(DUZ,"IN",.LST)
    74         . . . .QUIT
    75         . . . ;
    76         . . . ;  If "*", Get all Mailboxes and look for New Messages
    77         . . . I MBLST["*" D  QUIT
    78         . . . . N NAM,NUM
    79         . . . . S NUM=0
    80         . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
    81         . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
    82         . . . . . D GATHER(DUZ,NAM,.LST)
    83         . . . . .QUIT
    84         . . . .QUIT
    85         . . . ;
    86         . . . ;  If comma separated, look for mailboxes with new messages
    87         . . . I $L(MBLST,",")>1 D  QUIT
    88         . . . . S NAM=""
    89         . . . . N T,V
    90         . . . . F T=1:1:$L(MBLST,",")  S V=$P(MBLST,",",T)  I $L(V) D
    91         . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
    92         . . . . . S:NAM="" NAM=V
    93         . . . . . D GATHER(DUZ,NAM,.LST)
    94         . . . . .QUIT
    95         . . . .QUIT
    96         . . . ;
    97         . . . ;  If only 1 mailbox named, go get it
    98         . . . I $L(MBLST) D GATHER(DUZ,MBLST,.LST) QUIT
    99         . . .QUIT
    100         . . MERGE C0CDATA=LST
    101         . .QUIT
    102         .QUIT
    103         QUIT
    104         ;  ===================
    105 GATHER(DUZ,NAM,LST)     ; Gather Data about the Baskets and their mail
    106         N I,J,K,L
    107         S (I,K)=0
    108         S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
    109         F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
    110         . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
    111         . D   ; :L
    112         . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
    113         . . S LST(NAM,"MSG",I)=L
    114         . . D GETTYP(I)
    115         . .QUIT
    116         .QUIT
    117         S LST(NAM,"NUMBER")=K
    118         QUIT
    119         ;  ===================
    120         ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
    121         ; The products of these emails are scanned to identify
    122         ;  the number of documents stored in the MIME package.
    123         ;  The protocol runs like this;
    124         ; Line 1 is the --separator
    125         ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
    126         ; Line n+2 thru t-1 where t does NOT have "Content-"
    127         ; Line t   is Next Section Terminator, or Message Terminator, --separator
    128         ; Line t+1 should not exist in the data set if Message Terminator
    129         ; CON = "Content-"
    130         ; FLG = "--"
    131         ; SEP = FLG+7 or more characters  ; Separator
    132         ; END = SEP+FLG
    133         ; SGC = Segment Count
    134         ; Note: separator is a string of specific characters of
    135         ;        indeterminate length 
    136         ; LST() the transfer array
    137         ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
    138         ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
    139         ;
    140 GETTYP(D0)      ; Look for the goodies in the Mail
    141         N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
    142         S CON="Content-"
    143         S FLG="--"
    144         S SEP=""  ; Start SEP as null, so we can use this to help identify the type
    145         S (BCN,CNT,D1,END,SGC)=0
    146         S XX=$G(^XMB(3.9,D0,0))
    147         S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
    148         S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
    149         F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
    150         S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
    151         S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
    152         ; Get the folks the email is sent to.
    153         S D1=0
    154         F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
    155         . N T
    156         . S T=+$G(^XMB(3.9,D0,1,D1,0))
    157         . S:T T=$P($G(^VA(200,+T,0)),"^")
    158         . S LST("TO",D1)=T
    159         . S T=$G(^XMB(3.9,D0,6,D1,0))
    160         . S:T T=$P($G(^VA(200,+T,0)),"^")
    161         . S:T="" T="<Unknown>"
    162         . S LST("TO NAME",D1)=T
    163         .QUIT
    164         ; Preload first Segment (0) with beginning on Line 1
    165         ;  if not a 64bit
    166         S LST(NAM,"MSG",D0,"SEG",0)=1
    167         S D1=.9999,SEP="--"
    168         F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
    169         . ; Clear any control characters (cr/lf/ff) off
    170         . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
    171         . ; Enter once to set the SEP to capture the separator
    172         . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
    173         . . S SEP=X,END=X_FLG
    174         . . S (CNT,SGC)=1,BCN=0
    175         . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
    176         . .QUIT
    177         . ;
    178         . ; A new separator is set, process original
    179         . I X=SEP  D  QUIT
    180         . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN
    181         . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
    182         . . S SGC=SGC+1,BCN=0
    183         . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
    184         . .QUIT
    185         . ;
    186         . S BCN=BCN+$L(X)
    187         . I X[CON D  Q
    188         . . S J=$P($P(X,";"),CON,2)
    189         . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
    190         . .QUIT
    191         . ;
    192         . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
    193         .QUIT
    194         QUIT
    195         ;  ===================
    196 NAME(NM)        ; Return the name of the Sender
    197         N NAME
    198         S NAME="<Unknown Sender>"
    199         D
    200         . ; Look first for a value to use with the NEW PERSON file
    201         . ;
    202         . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
    203         . ;
    204         . I $L(NM) S NAME=NM                    Q
    205         . ;
    206         . ; Else, pull the data from the message and display the foreign source
    207         . ;   of the message.
    208         . N T
    209         . S VAL=$G(^XMB(3.9,D0,.7))
    210         . S:VAL T=$P(^VA(200,VAL,0),U)
    211         . I $L($G(T)) S NAME=T                  Q
    212         . ;
    213         .QUIT
    214         QUIT NAME
    215         ;  ===================
    216 TIME(Y) ; The time and date of the sending
    217         X ^DD("DD")
    218         QUIT Y
    219         ;  ===================
    220         ;  Segments in Message need to be identified and decoded properly
    221         ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
    222         ;   ARRAY will have the details of this one call
    223         ;   
    224         ; Inputs;
    225         ;   C0CINPUT    - The IEN of the message to expand
    226         ; Outputs;
    227         ;   C0CDATA     - Carrier for the returned structure of the Message
    228         ;  C0CDATA(D0,"SEG")=number of SEGMENTS
    229         ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details
    230         ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
    231         ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
    232         ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
    233         ;
    234 DETAIL(C0CDATA,C0CINPUT)        ; Message Detail Delivery
    235         N LST,D0,D1,U
    236         S U="^"
    237         S D0=+$G(C0CINPUT)
    238         I D0   D    QUIT
    239         . D GETTYP2(D0)
    240         . I $D(LST)   M C0CDATA(D0)=LST
    241         .QUIT
    242         QUIT
    243         ;  ===================
    244         ;  End note if needed
    245         ; MSK   - Set of characters that do not exist in 64 bit encoding
    246 GETTYP2(D0)     ; Try to get the types and MSK for the
    247         N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
    248         S CON="Content-",U="^"
    249         S FLG="--"
    250         S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
    251         S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
    252         S (BCN,CNT,D1,END,SGC)=0
    253         S XX=$G(^XMB(3.9,D0,0))
    254         ; S K=$P(^XMB(3.9,D0,2,0),U,3)
    255         S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
    256         S LST("CREATED")=$$TIME($P(XX,U,3))
    257         F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
    258         S LST("FROM")=$$NAME(XXNM)
    259         ; Get the folks the email is sent to.
    260         S D1=0
    261         F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
    262         . N I,T
    263         . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
    264         . S:T T=$P($G(^VA(200,T,0)),"^")
    265         . S LST("TO",+D1)=T
    266         . S T=$G(^XMB(3.9,D0,6,+D1,0))
    267         . S:T="" T=$P($G(^VA(200,+T,0)),"^")
    268         . S:T="" T="<Unknown>"
    269         . S LST("TO NAME",D1)=T
    270         .QUIT
    271         ; Get the Header for the message
    272         S D1=0
    273         F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
    274         . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
    275         .QUIT
    276         ; Start walking the different sections
    277         S D1=.99999,SEP="--"
    278         F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
    279         . ; Clear any control characters (cr/lf/ff) off
    280         . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
    281         . ; Enter once to set the SEP to capture the separator
    282         . I (SEP="--")&($E(X,1,2)=FLG)&($L(X,FLG)=2)  D   Q
    283         . . S SEP=X,END=X_FLG
    284         . . S (CNT,SGC)=1,BCN=0
    285         . . S LST("SEG",SGC)=D1
    286         . .QUIT
    287         . ;
    288         . ; A new SEGMENT separator is set, process original
    289         . I X=SEP  D  QUIT
    290         . . ; Save Current Values
    291         . . S LST("SEG",SGC,"SIZE")=BCN
    292         . . ;  Close this Segment and prepare to start a New Segment
    293         . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
    294         . . ;  Put the result in LST("SEG",SGC,"XML")
    295         . . I $L(BF) D
    296         . . . S ZN=1
    297         . . . N I,T,TBF
    298         . . . S TBF=BF
    299         . . . F I=1:1:($L(TBF,"="))  D
    300         . . . . S BF=$P(TBF,"=",I)_"="
    301         . . . . I BF'="="  D DECODER
    302         . . . .QUIT
    303         . . . S BF=""
    304         . . .QUIT
    305         . . S SGC=SGC+1,BCN=0
    306         . . ; Incriment SGC to start a new Segment
    307         . . S LST("SEG",SGC)=D1
    308         . .QUIT
    309         . ;
    310         . ; Accumulate the 64 bit encoding
    311         . I X=$TR(X,MSK)&$L(X) D   Q
    312         . . S BF=BF_X
    313         . . S BCN=BCN+$L(X)
    314         . .QUIT
    315         . ;
    316         . ; Ending Condition, close out the Segment
    317         . I X=END D  QUIT
    318         . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
    319         . . I $L(BF) S ZN=1 D DECODER  S BF="" Q
    320         . .QUIT
    321         . ;
    322         . S BCN=BCN+$L(X)
    323         . ; Split out the Content Info
    324         . I X[CON D  Q
    325         . . S J=$P(X,CON,2)
    326         . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9)
    327         . .QUIT
    328         . ;
    329         . ; Everything else is Text
    330         . S LST("SEG",SGC,"TXT",D1)=X
    331         .QUIT
    332         QUIT
    333         ;  ===================
    334         ; Break down the Buffer Array so it can be saved.
    335         ;  BF is passed in.
    336 DECODER ;
    337         N RCNT,TBF,ZBF,ZI,ZJ,ZK,ZSIZE
    338         S ZBF=BF
    339         ;  Full Buffer, BF, now check for Encryption and Unpack
    340         F RCNT=1:1:$L(ZBF,"=")   D
    341         . N BF
    342         . S BF=$P(ZBF,"=",RCNT)
    343         . ;  Unpacking the 64 bit encoding
    344         . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
    345         . D:$L(TBF)
    346         . . N XBF
    347         . . S BF=BF_"="
    348         . . D NORMAL(.XBF,.TBF)
    349         . . M LST("SEG",SGC,"XML",RCNT)=XBF
    350         . .QUIT
    351         .QUIT
    352         QUIT
    353         ;  ===================
    354         ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
    355         ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
    356         ;   >D NORMAL^C0CMAIL(.OUT,BF)
    357 NORMAL(OUTXML,INXML)       ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
    358         ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
    359         ;
    360         N ZN,OUTBF
    361         S ZN=1
    362         S OUTBF(ZN)=$P(INXML,"><",ZN)_">"
    363         F ZN=ZN+1:1 S OUTBF(ZN)="<"_$P(INXML,"><",ZN) Q:$P(INXML,"><",ZN+1)=""  D  ;
    364         . S OUTBF(ZN)=OUTBF(ZN)_">"
    365         .QUIT
    366         M OUTXML=OUTBF
    367         QUIT
    368         ;  ===================
    369         ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
    370         ;  End note if needed
    371         QUIT
    372         ;  ===================
     2V ;;0.1;C0C;nopatch;noreleasedate
     3 ;Copyright 2011 Chris Richardson, Richardson Computer Research
     4 ; Modified 3110516@1818
     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 ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
     26 ;  Input:
     27 ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
     28 ;                      or "*" for all boxes, default is "IN" if missing]"
     29 ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
     30 ;                                     "*" for All or 9,999 maximum
     31 ;                    MALL?1.n = that number of the n most recent
     32 ;  Internally:
     33 ;    BNAM = Box Name
     34 ;  Output:
     35 ;    C0CDATA
     36 ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
     37 ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
     38 ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
     39 ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
     40 ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
     41 ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
     42 ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
     43 ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
     44 ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
     45 ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
     46 ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
     47 ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
     48 ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
     49 ;
     50 ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
     51 ;   Input;
     52 ;     D0     - The IEN for the message in file 3.9, MESSAGE global
     53 ;   Output
     54 ;     OUTBF  - The array of your choice to save the expanded and decoded message.
     55 ;
     56GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data
     57 K:'$G(C0CDATA("KEEP")) C0CDATA
     58 N U
     59 S U="^"
     60 D:$G(C0CINPUT)
     61 . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
     62 . S INPUT=C0CINPUT
     63 . S DUZ=+INPUT
     64 . D:$D(^XMB(3.7,DUZ,0))#2
     65 . . S MBLST=$P(INPUT,";",2)
     66 . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
     67 . . S:MALL["*" MALL=99999
     68 . . ; Only one of these can be correct
     69 . . D
     70 . . . ;  If nul, make it "IN" only
     71 . . . I MBLST="" D  QUIT
     72 . . . . S MBLST("IN")=0,I=0
     73 . . . . D GATHER(DUZ,"IN",.LST)
     74 . . . .QUIT
     75 . . . ;
     76 . . . ;  If "*", Get all Mailboxes and look for New Messages
     77 . . . I MBLST["*" D  QUIT
     78 . . . . N NAM,NUM
     79 . . . . S NUM=0
     80 . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
     81 . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
     82 . . . . . D GATHER(DUZ,NAM,.LST)
     83 . . . . .QUIT
     84 . . . .QUIT
     85 . . . ;
     86 . . . ;  If comma separated, look for mailboxes with new messages
     87 . . . I $L(MBLST,",")>1 D  QUIT
     88 . . . . S NAM=""
     89 . . . . N T,V
     90 . . . . F T=1:1:$L(MBLST,",")  S V=$P(MBLST,",",T)  I $L(V) D
     91 . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
     92 . . . . . S:NAM="" NAM=V
     93 . . . . . D GATHER(DUZ,NAM,.LST)
     94 . . . . .QUIT
     95 . . . .QUIT
     96 . . . ;
     97 . . . ;  If only 1 mailbox named, go get it
     98 . . . I $L(MBLST) D GATHER(DUZ,MBLST,.LST) QUIT
     99 . . .QUIT
     100 . . MERGE C0CDATA=LST
     101 . .QUIT
     102 .QUIT
     103 QUIT
     104 ;  ===================
     105GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail
     106 N I,J,K,L
     107 S (I,K)=0
     108 S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
     109 F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
     110 . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
     111 . D   ; :L
     112 . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
     113 . . S LST(NAM,"MSG",I)=L
     114 . . D GETTYP(I)
     115 . .QUIT
     116 .QUIT
     117 S LST(NAM,"NUMBER")=K
     118 QUIT
     119 ;  ===================
     120 ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
     121 ; The products of these emails are scanned to identify
     122 ;  the number of documents stored in the MIME package.
     123 ;  The protocol runs like this;
     124 ; Line 1 is the --separator
     125 ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
     126 ; Line n+2 thru t-1 where t does NOT have "Content-"
     127 ; Line t   is Next Section Terminator, or Message Terminator, --separator
     128 ; Line t+1 should not exist in the data set if Message Terminator
     129 ; CON = "Content-"
     130 ; FLG = "--"
     131 ; SEP = FLG+7 or more characters  ; Separator
     132 ; END = SEP+FLG
     133 ; SGC = Segment Count
     134 ; Note: separator is a string of specific characters of
     135 ;        indeterminate length 
     136 ; LST() the transfer array
     137 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
     138 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
     139 ;
     140GETTYP(D0) ; Look for the goodies in the Mail
     141 N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
     142 S CON="Content-"
     143 S FLG="--"
     144 S SEP=""  ; Start SEP as null, so we can use this to help identify the type
     145 S (BCN,CNT,D1,END,SGC)=0
     146 S XX=$G(^XMB(3.9,D0,0))
     147 S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
     148 S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
     149 F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
     150 S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
     151 S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
     152 ; Get the folks the email is sent to.
     153 S D1=0
     154 F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
     155 . N T
     156 . S T=+$G(^XMB(3.9,D0,1,D1,0))
     157 . S:T T=$P($G(^VA(200,+T,0)),"^")
     158 . S LST("TO",D1)=T
     159 . S T=$G(^XMB(3.9,D0,6,D1,0))
     160 . S:T T=$P($G(^VA(200,+T,0)),"^")
     161 . S:T="" T="<Unknown>"
     162 . S LST("TO NAME",D1)=T
     163 .QUIT
     164 ; Preload first Segment (0) with beginning on Line 1
     165 ;  if not a 64bit
     166 S LST(NAM,"MSG",D0,"SEG",0)=1
     167 S D1=.9999,SEP="--"
     168 F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
     169 . ; Clear any control characters (cr/lf/ff) off
     170 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
     171 . ; Enter once to set the SEP to capture the separator
     172 . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
     173 . . S SEP=X,END=X_FLG
     174 . . S (CNT,SGC)=1,BCN=0
     175 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
     176 . .QUIT
     177 . ;
     178 . ; A new separator is set, process original
     179 . I X=SEP  D  QUIT
     180 . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN
     181 . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
     182 . . S SGC=SGC+1,BCN=0
     183 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
     184 . .QUIT
     185 . ;
     186 . S BCN=BCN+$L(X)
     187 . I X[CON D  Q
     188 . . S J=$P($P(X,";"),CON,2)
     189 . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
     190 . .QUIT
     191 . ;
     192 . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
     193 .QUIT
     194 QUIT
     195 ;  ===================
     196NAME(NM) ; Return the name of the Sender
     197 N NAME
     198 S NAME="<Unknown Sender>"
     199 D
     200 . ; Look first for a value to use with the NEW PERSON file
     201 . ;
     202 . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
     203 . ;
     204 . I $L(NM) S NAME=NM                    Q
     205 . ;
     206 . ; Else, pull the data from the message and display the foreign source
     207 . ;   of the message.
     208 . N T
     209 . S VAL=$G(^XMB(3.9,D0,.7))
     210 . S:VAL T=$P(^VA(200,VAL,0),U)
     211 . I $L($G(T)) S NAME=T                  Q
     212 . ;
     213 .QUIT
     214 QUIT NAME
     215 ;  ===================
     216TIME(Y) ; The time and date of the sending
     217 X ^DD("DD")
     218 QUIT Y
     219 ;  ===================
     220 ;  Segments in Message need to be identified and decoded properly
     221 ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
     222 ;   ARRAY will have the details of this one call
     223 ;   
     224 ; Inputs;
     225 ;   C0CINPUT    - The IEN of the message to expand
     226 ; Outputs;
     227 ;   C0CDATA     - Carrier for the returned structure of the Message
     228 ;  C0CDATA(D0,"SEG")=number of SEGMENTS
     229 ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details
     230 ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
     231 ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
     232 ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
     233 ;
     234DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery
     235 N LST,D0,D1,U
     236 S U="^"
     237 S D0=+$G(C0CINPUT)
     238 I D0   D    QUIT
     239 . D GETTYP2(D0)
     240 . I $D(LST)   M C0CDATA(D0)=LST
     241 .QUIT
     242 QUIT
     243 ;  ===================
     244 ;  End note if needed
     245 ; MSK   - Set of characters that do not exist in 64 bit encoding
     246GETTYP2(D0) ; Try to get the types and MSK for the
     247 N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
     248 S CON="Content-",U="^"
     249 S FLG="--"
     250 S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
     251 S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
     252 S (BCN,CNT,D1,END,SGC)=0
     253 S XX=$G(^XMB(3.9,D0,0))
     254 ; S K=$P(^XMB(3.9,D0,2,0),U,3)
     255 S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
     256 S LST("CREATED")=$$TIME($P(XX,U,3))
     257 F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
     258 S LST("FROM")=$$NAME(XXNM)
     259 ; Get the folks the email is sent to.
     260 S D1=0
     261 F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
     262 . N I,T
     263 . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
     264 . S:T T=$P($G(^VA(200,T,0)),"^")
     265 . S LST("TO",+D1)=T
     266 . S T=$G(^XMB(3.9,D0,6,+D1,0))
     267 . S:T="" T=$P($G(^VA(200,+T,0)),"^")
     268 . S:T="" T="<Unknown>"
     269 . S LST("TO NAME",D1)=T
     270 .QUIT
     271 ; Get the Header for the message
     272 S D1=0
     273 F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
     274 . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
     275 .QUIT
     276 ; Start walking the different sections
     277 S D1=.99999,SEP="--"
     278 F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
     279 . ; Clear any control characters (cr/lf/ff) off
     280 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
     281 . ; Enter once to set the SEP to capture the separator
     282 . I (SEP="--")&($E(X,1,2)=FLG)&($L(X,FLG)=2)  D   Q
     283 . . S SEP=X,END=X_FLG
     284 . . S (CNT,SGC)=1,BCN=0
     285 . . S LST("SEG",SGC)=D1
     286 . .QUIT
     287 . ;
     288 . ; A new SEGMENT separator is set, process original
     289 . I X=SEP  D  QUIT
     290 . . ; Save Current Values
     291 . . S LST("SEG",SGC,"SIZE")=BCN
     292 . . ;  Close this Segment and prepare to start a New Segment
     293 . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
     294 . . ;  Put the result in LST("SEG",SGC,"XML")
     295 . . I $L(BF) D
     296 . . . S ZN=1
     297 . . . N I,T,TBF
     298 . . . S TBF=BF
     299 . . . F I=1:1:($L(TBF,"="))  D
     300 . . . . S BF=$P(TBF,"=",I)_"="
     301 . . . . I BF'="="  D DECODER
     302 . . . .QUIT
     303 . . . S BF=""
     304 . . .QUIT
     305 . . S SGC=SGC+1,BCN=0
     306 . . ; Incriment SGC to start a new Segment
     307 . . S LST("SEG",SGC)=D1
     308 . .QUIT
     309 . ;
     310 . ; Accumulate the 64 bit encoding
     311 . I X=$TR(X,MSK)&$L(X) D   Q
     312 . . S BF=BF_X
     313 . . S BCN=BCN+$L(X)
     314 . .QUIT
     315 . ;
     316 . ; Ending Condition, close out the Segment
     317 . I X=END D  QUIT
     318 . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
     319 . . I $L(BF) S ZN=1 D DECODER  S BF="" Q
     320 . .QUIT
     321 . ;
     322 . S BCN=BCN+$L(X)
     323 . ; Split out the Content Info
     324 . I X[CON D  Q
     325 . . S J=$P(X,CON,2)
     326 . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9)
     327 . .QUIT
     328 . ;
     329 . ; Everything else is Text
     330 . S LST("SEG",SGC,"TXT",D1)=X
     331 .QUIT
     332 QUIT
     333 ;  ===================
     334 ; Break down the Buffer Array so it can be saved.
     335 ;  BF is passed in.
     336DECODER ;
     337 N RCNT,TBF,ZBF,ZI,ZJ,ZK,ZSIZE
     338 S ZBF=BF
     339 ;  Full Buffer, BF, now check for Encryption and Unpack
     340 F RCNT=1:1:$L(ZBF,"=")   D
     341 . N BF
     342 . S BF=$P(ZBF,"=",RCNT)
     343 . ;  Unpacking the 64 bit encoding
     344 . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
     345 . D:$L(TBF)
     346 . . N XBF
     347 . . S BF=BF_"="
     348 . . D NORMAL(.XBF,.TBF)
     349 . . M LST("SEG",SGC,"XML",RCNT)=XBF
     350 . .QUIT
     351 .QUIT
     352 QUIT
     353 ;  ===================
     354 ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
     355 ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
     356 ;   >D NORMAL^C0CMAIL(.OUT,BF)
     357NORMAL(OUTXML,INXML)    ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
     358 ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
     359 ;
     360 N ZN,OUTBF
     361 S ZN=1
     362 S OUTBF(ZN)=$P(INXML,"><",ZN)_">"
     363 F ZN=ZN+1:1 S OUTBF(ZN)="<"_$P(INXML,"><",ZN) Q:$P(INXML,"><",ZN+1)=""  D  ;
     364 . S OUTBF(ZN)=OUTBF(ZN)_">"
     365 .QUIT
     366 M OUTXML=OUTBF
     367 QUIT
     368 ;  ===================
     369 ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
     370 ;  End note if needed
     371 QUIT
     372 ;  ===================
  • ccr/branches/ohum/p/C0CMAIL2.m

    r1330 r1332  
    11C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    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         ;  ===================
     2V ;;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 ;
     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 ;  ===================
  • ccr/branches/ohum/p/C0CMAIL3.m

    r1330 r1332  
    11C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    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         ;
    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="--",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         ;  ===================
    408 CONTENT(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         ;  ===================
    426 BOUNDARY(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
    439 DECODER(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)
    475 NORMAL(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         ;  ===================
    503 UPPER(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
    507 ERROR(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         ;  ===================
    519 ER01    ;;Message Missing
    520 ER02    ;;Message Text Missing
    521 ER03    ;;Message Not Identifiable
    522 ER04    ;;Segment is too large
    523 ER05    ;;Mailbox Missing
    524 ER06    ;;"User Missing = "_$G(DUZ)
    525 ER07    ;;"Bad DUZ = "_DUZ
    526 ER08    ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN)
    527 ER10    ;;"Bad Separator found = "_X
    528 ER11    ;;"Non-Standard Separator Found:>"_$G(J)
    529 ER12    ;;"Spaces are not allowed in Separators:>"_$G(J)
    530 ER13    ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X
    531         ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
    532         ;  End note if needed
    533         QUIT
    534         ;  ===================
     2V ;;0.1;C0C;nopatch;noreleasedate
     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 ;  ===================
  • ccr/branches/ohum/p/C0CMCCD.m

    r1330 r1332  
    11C0CMCCD   ; GPL - MXML based CCD utilities;12/04/09  17:05
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21         ;
    22 PARSCCD(DOC,OPTION)     ; THIS WAS COPIED FROM EN^MXMLDOM TO CUSTIMIZE FOR
    23         ; PROCESSING CCDS
    24         N CBK,SUCCESS,LEVEL,NODE,HANDLE
    25         K ^TMP("MXMLERR",$J)
    26         L +^TMP("MXMLDOM",$J):5
    27         E  Q 0
    28         S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)=""
    29         L -^TMP("MXMLDOM",$J)
    30         S CBK("STARTELEMENT")="STARTELE^C0CMCCD" ; ONLY THIS ONE IS CHANGED ;GPL
    31         S CBK("ENDELEMENT")="ENDELE^MXMLDOM"
    32         S CBK("COMMENT")="COMMENT^MXMLDOM"
    33         S CBK("CHARACTERS")="CHAR^MXMLDOM"
    34         S CBK("ENDDOCUMENT")="ENDDOC^MXMLDOM"
    35         S CBK("ERROR")="ERROR^MXMLDOM"
    36         S (SUCCESS,LEVEL,LEVEL(0),NODE)=0,OPTION=$G(OPTION,"V1")
    37         D EN^MXMLPRSE(DOC,.CBK,OPTION)
    38         D:'SUCCESS DELETE^MXMLDOM(HANDLE)
    39         Q $S(SUCCESS:HANDLE,1:0)
    40         ; Start element
    41         ; Create new child node and push info on stack
    42 STARTELE(ELE,ATTR)      ; COPIED FROM STARTELE^MXMLDOM AND MODIFIED TO TREAT
    43         ; ATTRIBUTES AS SUBELEMENTS TO MAKE CCD XPATH PROCESSING EASIER
    44         N PARENT
    45         S PARENT=LEVEL(LEVEL),NODE=NODE+1
    46         S:PARENT ^TMP("MXMLDOM",$J,HANDLE,PARENT,"C",NODE)=ELE
    47         S LEVEL=LEVEL+1,LEVEL(LEVEL)=NODE,LEVEL(LEVEL,0)=ELE
    48         S ^TMP("MXMLDOM",$J,HANDLE,NODE)=ELE,^(NODE,"P")=PARENT
    49         ;M ^("A")=ATTR
    50         N ZI S ZI="" ; INDEX FOR ATTR
    51         F  S ZI=$O(ATTR(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
    52         . N ELE,TXT ; ABOUT TO RECURSE
    53         . S ELE=ZI ; TAG
    54         . S TXT=ATTR(ZI) ; DATA
    55         . D STARTELE(ELE,"") ; CREATE A NEW SUBNODE
    56         . D TXT^MXMLDOM("T") ; INSERT DATA TO TAG
    57         . D ENDELE^MXMLDOM(ELE) ; POP BACK UP A LEVEL
    58         Q
    59         ;
    60 ISMULT(ZOID)    ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
    61         N ZN
    62         ;I $$TAG(ZOID)["entry" B
    63         S ZN=$$NXTSIB(ZOID)
    64         I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
    65         Q 0
    66         ;
    67 FIRST(ZOID)     ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
    68         Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
    69         ;
    70 PARENT(ZOID)    ;RETURNS THE OID OF THE PARENT OF ZOID
    71         Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
    72         ;
    73 ATT(RTN,NODE)   ;GET ATTRIBUTES FOR ZOID
    74         S HANDLE=C0CDOCID
    75         K @RTN
    76         D GETTXT^MXMLDOM("A")
    77         Q
    78         ;
    79 TAG(ZOID)       ; RETURNS THE XML TAG FOR THE NODE
    80         ;I ZOID=149 B ;GPLTEST
    81         N X,Y
    82         S Y=""
    83         S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
    84         I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
    85         I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
    86         Q Y
    87         ;
    88 NXTSIB(ZOID)    ; RETURNS THE NEXT SIBLING
    89         Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
    90         ;
    91 DATA(ZT,ZOID)   ; RETURNS DATA FOR THE NODE
    92         ;N ZT,ZN S ZT=""
    93         ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
    94         ;Q $G(@C0CDOM@(ZOID,"T",1))
    95         S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
    96         Q
    97         ;
    98 CLEANARY(OUTARY,INARY)  ; GOES THROUGH AN ARRAY AND CALLS CLEAN ON EACH NODE
    99         ; INARY AND OUTARY PASSED BY NAME
    100         N ZI S ZI=""
    101         F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ; FOR EACH NODE
    102         . S @OUTARY@(ZI)=$$CLEAN(@INARY@(ZI)) ; CLEAN THE NODE
    103         Q
    104         ;
    105 CLEAN(STR)      ; extrinsic function; returns string
    106         ;; Removes all non printable characters from a string.
    107         ;; STR by Value
    108         N TR,I
    109         F I=0:1:31 S TR=$G(TR)_$C(I)
    110         S TR=TR_$C(127)
    111         QUIT $TR(STR,TR)
    112         ;
    113 STRIPTXT(OUTARY,ZARY)   ; STRIPS THE "TEXT" PORTION OUT OF AN XML FILE
    114         ; THIS IS USED TO DELETE THE NARATIVE HTML OUT OF THE CCD XML FILES BECAUSE
    115         ; THEY DO NOT WORK RIGHT WITH THE PARSER
    116         ;N ZWRK,ZBLD,ZI ; WORK ARRAY,BUILD ARRAY, AND COUNTER
    117         S ZI=$O(@ZARY@("")) ; GET FIRST LINE NUMBER
    118         D C0CBEGIN("ZWRK",ZI) ; INSERT FIRST LINE IN WORK ARRAY
    119         F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH LINE OF THE ARRAY
    120         . I $O(@ZARY@(ZI))="" D  Q  ; AT THE END
    121         . . D C0CEND("ZWRK",ZI) ; INCLUDE LAST LINE IN WORK ARRAY
    122         . I ZI=1 D C0CBEGIN("ZWRK",ZI) ; START WITH FIRST LINE
    123         . I @ZARY@(ZI)["<text" D C0CEND("ZWRK",ZI-1) ;PREV LINE IS AN END
    124         . I @ZARY@(ZI)["</text>" D C0CBEGIN("ZWRK",ZI+1) ;NEXT LINE IS A BEGIN
    125         S ZI=""
    126         F  S ZI=$O(ZWRK(ZI)) Q:ZI=""  D  ; MAKE A BUILD LIST FROM THE WORK ARRAY
    127         . D QUEUE^C0CXPATH("ZBLD",ZARY,$P(ZWRK(ZI),"^",1),$P(ZWRK(ZI),"^",2))
    128         D BUILD^C0CXPATH("ZBLD",OUTARY) ; BUILD NEW ARRAY WITHOUT TEXT SECTIONS
    129         K @OUTARY@(0) ; GET RID OF THE LINE COUNT
    130         Q
    131         ;
    132 C0CBEGIN(ZA,LN) ; INSERTS A BEGIN LINE LN INTO ARRAY ZWRK, PASSED BY NAME
    133         N ZI
    134         S ZI=$O(@ZA@(""),-1)
    135         I ZI="" S ZI=1
    136         E  S ZI=ZI+1 ; INCREMENT COUNT IN WORK ARRAY
    137         S $P(@ZA@(ZI),"^",1)=LN
    138         Q
    139         ;
    140 C0CEND(ZB,LN)   ; INSERTS AN END LINE LN INTO ARRAY ZWRK, PASSED BY NAME
    141         N ZI
    142         S ZI=$O(@ZB@(""),-1)
    143         I ZI="" S ZI=1
    144         S $P(@ZB@(ZI),"^",2)=LN
    145         Q
    146         ;
    147 SEPARATE(OUTARY,INARY)  ; SEPARATES XPATH VARIABLES ACCORDING TO THEIR
    148         ; ROOT ; /Problems/etc/etc goes to @OUTARY@("Problems","/Problems/etc/etc")
    149         S ZI=""
    150         F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ; FOR EACH ELEMENT OF THE ARRAY
    151         . I $P(ZI,"//",2)'="" D  ; FOR NON-BODY ENTRIES
    152         . . S ZJ=$P(ZI,"/",4) ; things like From Patient Actor
    153         . E  D  ; FOR BODY PARTS
    154         . . S ZJ=$P(ZI,"/",2) ;
    155         . . I ZJ="" S ZJ=$P(ZI,"/",3) ;
    156         . S @OUTARY@(ZJ,ZI)=$G(@INARY@(ZI)) ;FIX THIS FOR MULTILINE COMMENTS
    157         Q
    158         ;
    159 FINDTID ; FIND TEMPLATE IDS IN DOM 1
    160         S C0CDOCID=1
    161         S ZD=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
    162         S ZN=""
    163         S CURSEC=""
    164         S TID=""
    165         F  S ZN=$O(@ZD@(ZN)) Q:ZN=""  D  ;
    166         . I $$TAG(ZN)="root" D  ;
    167         . . I $$TAG($$PARENT(ZN))="templateId" D  ; ONLY LOOKING FOR TEMPLATES
    168         . . . S ZG=$$PARENT($$PARENT(ZN))
    169         . . . S ZG2=$$PARENT(ZG) ;COMPONENT THAT HOLDS THIS SECTION
    170         . . . S CMT=$G(@ZD@(ZG,"X",1))
    171         . . . I CMT="" S CMT="?"
    172         . . . I $$TAG(ZG)="section" D  ;START OF A SECTION
    173         . . . . S CURSEC=$$PARENT(ZG)
    174         . . . . S SECCMT=$G(@ZD@(CURSEC,"X",1))
    175         . . . . I SECCMT="" S SECCMT="?"
    176         . . . . S SECTID=$G(@ZD@(ZN,"T",1)) ;SECTION TEMPLATE ID
    177         . . . S TID=$G(@ZD@(ZN,"T",1)) ;TEMPLATE ID
    178         . . . I CURSEC'="" D  ; IF WE ARE IN A SECTION
    179         . . . . S CCDDIR(ZG2,CURSEC,$$TAG(ZG2),CMT,SECCMT)=TID
    180         . . . . S DOMMAP(ZG2)=CURSEC_U_$$TAG(ZG2)_U_TID_U_SECTID
    181         . . . W !,$$TAG(ZG2)," ",$G(@ZD@(ZG,"X",1))
    182         . . . W " root ",ZN," ",@ZD@(ZN,"T",1)
    183         Q
    184         ;
    185 FINDALT ; PROCESS THE DOMMAP AND FIND THE ALT TAGS FOR COMPONENTS
    186         ;
    187         S ZI=""
    188         F  S ZI=$O(DOMMAP(ZI)) Q:ZI=""  D  ; FOR EACH NODE IN THE MAP
    189         . S ZJ=DOMMAP(ZI) ;
    190         . S PARNODE=$P(ZJ,U,1) ;PARENT NODE
    191         . S TAG=$P(ZJ,U,2) ;THIS TAG
    192         . S TID=$P(ZJ,U,3) ;THIS TEMPLATE ID
    193         . S PARTID=$P(ZJ,U,4) ;PARENT TEMPLATE ID
    194         . S ZIEN=$O(^C0CXDS(178.101,"TID",TID,"")) ;THIS NODE IEN
    195         . S PARIEN=$O(^C0CXDS(178.101,"TID",PARTID,"")) ;PARENT NODE IEN
    196         . I ZI=PARNODE D  ; IF THIS IS A SECTION NODE
    197         . . S ALTTAG=$$GET1^DIQ(178.101,PARIEN_",",.03) ;ALT TAG FIELD FOR PARENT
    198         . . S NAME=$$GET1^DIQ(178.101,ZIEN_",",.01) ;NAME OF THIS NODE'S TEMPLATE
    199         . . W ZI," ",TAG," ",ALTTAG," ",NAME,!
    200         . . S C0CTAGS(ZI)=ALTTAG
    201         . E  D  ; NOT A SECTION NODE
    202         . . N ZJ S ZJ=""
    203         . . S ZJ=$O(^C0CXDS(178.101,"D",PARIEN,ZIEN,"")) ;A WHEREUSED POINTER?
    204         . . I ZJ'="" D  ; THERE IS A NEW LABEL FOR THIS NODE
    205         . . . N ZK
    206         . . . S ZK=$$GET1^DIQ(178.111,ZJ_","_ZIEN_",",2)
    207         . . . I ZK'="" D  ;
    208         . . . . W "FOUND ",ZK,!
    209         . . . . S C0CTAGS(ZI)=ZK ; NEW TAG FOR INTERSECTION
    210         Q
    211         ;
    212 ALTTAG(NODE)    ; SET Y EQUAL TO THE ALT TAG FOUND IN C0CTAGS IF NODE IF FOUND
    213         ;
    214         S Y=$G(C0CTAGS(NODE))
    215         Q
    216         ;
    217 SETCBK  ; SET THE TAG CALLBACK FOR XPATH PROCESSSING OF THE CCD
    218         S C0CCBK("TAG")="D ALTTAG^C0CMCCD(ZOID)"
    219         Q
    220         ;
    221 OUTCCD(GARYIN)  ; OUTPUT THE PARSED CCD TO A TEXT FILE
    222         ;D TEST3^C0CMXML
    223         N ZT S ZT=$NA(^TMP("CCDOUT",$J))
    224         N ZI,ZJ
    225         S ZI=1 S ZJ=""
    226         K @ZT
    227         F  S ZJ=$O(GARYIN(ZJ)) Q:ZJ=""  D  ;
    228         . S @ZT@(ZI)=ZJ_"^"_GARYIN(ZJ)
    229         . S ZI=ZI+1
    230         S ONAME=$NA(@ZT@(1))
    231         W $$OUTPUT^C0CXPATH(ONAME,"CCDOUT.txt","/home/vademo2/CCR")
    232         K @ZT
    233         Q
    234         ;
    235 GENXDS(ZD)      ; GENERATE THE XDS PROTOTYPE RECORDS FROM A CCDDIR ARRAY
    236         ; ARRAY ELEMENTS LOOK LIKE:
    237         ; CCDDIR(1659,1634,"observation"," Result observaion template "," Vital signs section template ")="2.16.840.1.113883.10.20.1.31"
    238         ;or CCDDIR(cur node,section node,cur tag,cur name,sec name)=templateId
    239         S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE
    240         S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT
    241         S DONE=0
    242         F  Q:DONE  D  ;
    243         . W @ZI,!
    244         . S ZJ=$QS(ZI,5)
    245         . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE
    246         . S C0CFDA(ZF,"?+1,",.01)=ZJ
    247         . S C0CFDA(ZF,"?+1,",.02)=$QS(ZI,4) ; TAG FOR THIS TEMPLATE
    248         . S C0CFDA(ZF,"?+1,",1)=@ZI
    249         . D UPDIE
    250         . S ZI=$Q(@ZI)
    251         . I ZI="" S DONE=1
    252         Q
    253         ;
    254 WHRUSD(ZD)      ; UPDATE THE C0C XDS FILE WITH WHERE USED DATA FROM
    255         ; CCDDIR PASS BY NAME
    256         ; ARRAY ELEMENTS LOOK LIKE:
    257         ; CCDDIR(1634," Vital signs section template ",1659,"observation"," Result observaion template ")="2.16.840.1.113883.10.20.1.31"
    258         ;or CCDDIR(section node,sec name, cur node,cur tag,cur name)=templateId
    259         S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE
    260         S ZSF=178.111 ; WHERE USED SUBFILE OF C0C XDS PROTOTYPE FILE
    261         S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT
    262         S DONE=0
    263         F  Q:DONE  D  ;
    264         . W @ZI
    265         . S ZIEN=$O(^C0CXDS(178.101,"TID",@ZI,"")) ; IEN FOR THIS NODE'S TEMPLATE
    266         . W " IEN:",ZIEN
    267         . S ZJ=$QS(ZI,2)
    268         . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE
    269         . S ZPIEN=$O(^C0CXDS(178.101,"B",ZJ,"")) ; PARENT IEN
    270         . W " PARENT IEN:",ZPIEN
    271         . S ZTAG=$QS(ZI,4) ; TAG FOR THIS TEMPLATE
    272         . W " TAG:",ZTAG,!
    273         . I ZIEN'=ZPIEN D  ; ONLY FOR CHILD TEMPLATES
    274         . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",.01)=ZPIEN ; NEW SUBFILE ENTRY WITH PAR PTR
    275         . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",1)=ZTAG ; TAG FOR NEW ENTRY
    276         . . D UPDIE
    277         . ;S C0CFDA(ZF,"?+1,",1)=@ZI
    278         . ;D UPDIE
    279         . S ZI=$Q(@ZI)
    280         . I ZI="" S DONE=1
    281         Q
    282         ;
     2 ;;0.1;C0C;nopatch;noreleasedate
     3 ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 Q
     21 ;
     22PARSCCD(DOC,OPTION) ; THIS WAS COPIED FROM EN^MXMLDOM TO CUSTIMIZE FOR
     23 ; PROCESSING CCDS
     24 N CBK,SUCCESS,LEVEL,NODE,HANDLE
     25 K ^TMP("MXMLERR",$J)
     26 L +^TMP("MXMLDOM",$J):5
     27 E  Q 0
     28 S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)=""
     29 L -^TMP("MXMLDOM",$J)
     30 S CBK("STARTELEMENT")="STARTELE^C0CMCCD" ; ONLY THIS ONE IS CHANGED ;GPL
     31 S CBK("ENDELEMENT")="ENDELE^MXMLDOM"
     32 S CBK("COMMENT")="COMMENT^MXMLDOM"
     33 S CBK("CHARACTERS")="CHAR^MXMLDOM"
     34 S CBK("ENDDOCUMENT")="ENDDOC^MXMLDOM"
     35 S CBK("ERROR")="ERROR^MXMLDOM"
     36 S (SUCCESS,LEVEL,LEVEL(0),NODE)=0,OPTION=$G(OPTION,"V1")
     37 D EN^MXMLPRSE(DOC,.CBK,OPTION)
     38 D:'SUCCESS DELETE^MXMLDOM(HANDLE)
     39 Q $S(SUCCESS:HANDLE,1:0)
     40 ; Start element
     41 ; Create new child node and push info on stack
     42STARTELE(ELE,ATTR) ; COPIED FROM STARTELE^MXMLDOM AND MODIFIED TO TREAT
     43 ; ATTRIBUTES AS SUBELEMENTS TO MAKE CCD XPATH PROCESSING EASIER
     44 N PARENT
     45 S PARENT=LEVEL(LEVEL),NODE=NODE+1
     46 S:PARENT ^TMP("MXMLDOM",$J,HANDLE,PARENT,"C",NODE)=ELE
     47 S LEVEL=LEVEL+1,LEVEL(LEVEL)=NODE,LEVEL(LEVEL,0)=ELE
     48 S ^TMP("MXMLDOM",$J,HANDLE,NODE)=ELE,^(NODE,"P")=PARENT
     49 ;M ^("A")=ATTR
     50 N ZI S ZI="" ; INDEX FOR ATTR
     51 F  S ZI=$O(ATTR(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
     52 . N ELE,TXT ; ABOUT TO RECURSE
     53 . S ELE=ZI ; TAG
     54 . S TXT=ATTR(ZI) ; DATA
     55 . D STARTELE(ELE,"") ; CREATE A NEW SUBNODE
     56 . D TXT^MXMLDOM("T") ; INSERT DATA TO TAG
     57 . D ENDELE^MXMLDOM(ELE) ; POP BACK UP A LEVEL
     58 Q
     59 ;
     60ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
     61 N ZN
     62 ;I $$TAG(ZOID)["entry" B
     63 S ZN=$$NXTSIB(ZOID)
     64 I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
     65 Q 0
     66 ;
     67FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
     68 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
     69 ;
     70PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID
     71 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
     72 ;
     73ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID
     74 S HANDLE=C0CDOCID
     75 K @RTN
     76 D GETTXT^MXMLDOM("A")
     77 Q
     78 ;
     79TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE
     80 ;I ZOID=149 B ;GPLTEST
     81 N X,Y
     82 S Y=""
     83 S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
     84 I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
     85 I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
     86 Q Y
     87 ;
     88NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING
     89 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
     90 ;
     91DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE
     92 ;N ZT,ZN S ZT=""
     93 ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
     94 ;Q $G(@C0CDOM@(ZOID,"T",1))
     95 S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
     96 Q
     97 ;
     98CLEANARY(OUTARY,INARY) ; GOES THROUGH AN ARRAY AND CALLS CLEAN ON EACH NODE
     99 ; INARY AND OUTARY PASSED BY NAME
     100 N ZI S ZI=""
     101 F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ; FOR EACH NODE
     102 . S @OUTARY@(ZI)=$$CLEAN(@INARY@(ZI)) ; CLEAN THE NODE
     103 Q
     104 ;
     105CLEAN(STR) ; extrinsic function; returns string
     106 ;; Removes all non printable characters from a string.
     107 ;; STR by Value
     108 N TR,I
     109 F I=0:1:31 S TR=$G(TR)_$C(I)
     110 S TR=TR_$C(127)
     111 QUIT $TR(STR,TR)
     112 ;
     113STRIPTXT(OUTARY,ZARY) ; STRIPS THE "TEXT" PORTION OUT OF AN XML FILE
     114 ; THIS IS USED TO DELETE THE NARATIVE HTML OUT OF THE CCD XML FILES BECAUSE
     115 ; THEY DO NOT WORK RIGHT WITH THE PARSER
     116 ;N ZWRK,ZBLD,ZI ; WORK ARRAY,BUILD ARRAY, AND COUNTER
     117 S ZI=$O(@ZARY@("")) ; GET FIRST LINE NUMBER
     118 D C0CBEGIN("ZWRK",ZI) ; INSERT FIRST LINE IN WORK ARRAY
     119 F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH LINE OF THE ARRAY
     120 . I $O(@ZARY@(ZI))="" D  Q  ; AT THE END
     121 . . D C0CEND("ZWRK",ZI) ; INCLUDE LAST LINE IN WORK ARRAY
     122 . I ZI=1 D C0CBEGIN("ZWRK",ZI) ; START WITH FIRST LINE
     123 . I @ZARY@(ZI)["<text" D C0CEND("ZWRK",ZI-1) ;PREV LINE IS AN END
     124 . I @ZARY@(ZI)["</text>" D C0CBEGIN("ZWRK",ZI+1) ;NEXT LINE IS A BEGIN
     125 S ZI=""
     126 F  S ZI=$O(ZWRK(ZI)) Q:ZI=""  D  ; MAKE A BUILD LIST FROM THE WORK ARRAY
     127 . D QUEUE^C0CXPATH("ZBLD",ZARY,$P(ZWRK(ZI),"^",1),$P(ZWRK(ZI),"^",2))
     128 D BUILD^C0CXPATH("ZBLD",OUTARY) ; BUILD NEW ARRAY WITHOUT TEXT SECTIONS
     129 K @OUTARY@(0) ; GET RID OF THE LINE COUNT
     130 Q
     131 ;
     132C0CBEGIN(ZA,LN) ; INSERTS A BEGIN LINE LN INTO ARRAY ZWRK, PASSED BY NAME
     133 N ZI
     134 S ZI=$O(@ZA@(""),-1)
     135 I ZI="" S ZI=1
     136 E  S ZI=ZI+1 ; INCREMENT COUNT IN WORK ARRAY
     137 S $P(@ZA@(ZI),"^",1)=LN
     138 Q
     139 ;