Changeset 1571


Ignore:
Timestamp:
Oct 13, 2012, 2:49:26 PM (12 years ago)
Author:
George Lilly
Message:

fix for lab units not found and C0STBL analysis routines

Location:
smart/trunk
Files:
1 added
13 edited

Legend:

Unmodified
Added
Removed
  • smart/trunk/p/C0SDEM.m

    r1569 r1571  
    1 C0SDEM   ; GPL - Smart Demographics Processing ;2/22/12  17:05
    2  ;;0.1;C0S;nopatch;noreleasedate;Build 2
    3  ;Copyright 2012 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  ;<?xml version="1.0" encoding="utf-8"?>
    23  ;<rdf:RDF
    24  ;  xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
    25  ;  xmlns:sp="http://smartplatforms.org/terms#"
    26  ;  xmlns:dcterms="http://purl.org/dc/terms/"
    27  ;  xmlns:v="http://www.w3.org/2006/vcard/ns#"
    28  ;  xmlns:foaf="http://xmlns.com/foaf/0.1/">
    29  ;   <sp:Demographics>
    30  ;
    31  ;     <v:n>
    32  ;        <v:Name>
    33  ;            <v:given-name>Bob</v:given-name>
    34  ;            <v:additional-name>J</v:additional-name>
    35  ;            <v:family-name>Odenkirk</v:family-name>
    36  ;        </v:Name>
    37  ;     </v:n>
    38  ;
    39  ;     <v:adr>
    40  ;        <v:Address>
    41  ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Home" />
    42  ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Pref" />
    43  ;
    44  ;          <v:street-address>15 Main St</v:street-address>
    45  ;          <v:extended-address>Apt 2</v:extended-address>
    46  ;          <v:locality>Wonderland</v:locality>
    47  ;          <v:region>OZ</v:region>
    48  ;          <v:postal-code>54321</v:postal-code>
    49  ;          <v:country>USA</v:country>
    50  ;        </v:Address>
    51  ;     </v:adr>
    52  ;
    53  ;     <v:tel>
    54  ;        <v:Tel>
    55  ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Home" />
    56  ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Pref" />
    57  ;          <rdf:value>800-555-1212</rdf:value>
    58  ;        </v:Tel>
    59  ;     </v:tel>
    60  ;
    61  ;     <v:tel>
    62  ;        <v:Tel>
    63  ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Cell" />
    64  ;          <rdf:value>800-555-1515</rdf:value>
    65  ;        </v:Tel>
    66  ;     </v:tel>
    67  ;
    68  ;     <foaf:gender>male</foaf:gender>
    69  ;     <v:bday>1959-12-25</v:bday>
    70  ;     <v:email>bob.odenkirk@example.com</v:email>
    71  ;
    72  ;     <sp:medicalRecordNumber>
    73  ;       <sp:Code>
    74  ;        <dcterms:title>My Hospital Record 2304575</dcterms:title>
    75  ;        <dcterms:identifier>2304575</dcterms:identifier>
    76  ;        <sp:system>My Hospital Record</sp:system>
    77  ;       </sp:Code>
    78  ;     </sp:medicalRecordNumber>
    79  ;
    80  ;   </sp:Demographics>
    81  ;</rdf:RDF><?xml version="1.0" encoding="utf-8"?>
    82  ;<rdf:RDF
    83  ;  xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
    84  ;  xmlns:sp="http://smartplatforms.org/terms#"
    85  ;  xmlns:dcterms="http://purl.org/dc/terms/"
    86  ;  xmlns:v="http://www.w3.org/2006/vcard/ns#"
    87  ;  xmlns:foaf="http://xmlns.com/foaf/0.1/">
    88  ;   <sp:Demographics>
    89  ;
    90  ;     <v:n>
    91  ;        <v:Name>
    92  ;            <v:given-name>Bob</v:given-name>
    93  ;            <v:additional-name>J</v:additional-name>
    94  ;            <v:family-name>Odenkirk</v:family-name>
    95  ;        </v:Name>
    96  ;     </v:n>
    97  ;
    98  ;     <v:adr>
    99  ;        <v:Address>
    100  ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Home" />
    101  ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Pref" />
    102  ;
    103  ;          <v:street-address>15 Main St</v:street-address>
    104  ;          <v:extended-address>Apt 2</v:extended-address>
    105  ;          <v:locality>Wonderland</v:locality>
    106  ;          <v:region>OZ</v:region>
    107  ;          <v:postal-code>54321</v:postal-code>
    108  ;          <v:country>USA</v:country>
    109  ;        </v:Address>
    110  ;     </v:adr>
    111  ;
    112  ;     <v:tel>
    113  ;        <v:Tel>
    114  ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Home" />
    115  ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Pref" />
    116  ;          <rdf:value>800-555-1212</rdf:value>
    117  ;        </v:Tel>
    118  ;     </v:tel>
    119  ;
    120  ;     <v:tel>
    121  ;        <v:Tel>
    122  ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Cell" />
    123  ;          <rdf:value>800-555-1515</rdf:value>
    124  ;        </v:Tel>
    125  ;     </v:tel>
    126  ;
    127  ;     <foaf:gender>male</foaf:gender>
    128  ;     <v:bday>1959-12-25</v:bday>
    129  ;     <v:email>bob.odenkirk@example.com</v:email>
    130  ;
    131  ;     <sp:medicalRecordNumber>
    132  ;       <sp:Code>
    133  ;        <dcterms:title>My Hospital Record 2304575</dcterms:title>
    134  ;        <dcterms:identifier>2304575</dcterms:identifier>
    135  ;        <sp:system>My Hospital Record</sp:system>
    136  ;       </sp:Code>
    137  ;     </sp:medicalRecordNumber>
    138  ;
    139  ;   </sp:Demographics>
    140  ;</rdf:RDF>
    141  ;G(1)="nodeID:25591^rdf:type^v:Home"
    142  ;G(2)="nodeID:25591^rdf:type^v:Pref"
    143  ;G(3)="nodeID:25591^rdf:type^v:Tel"
    144  ;G(4)="nodeID:25591^rdf:value^800-369-6403"
    145  ;G(5)="nodeID:25611^rdf:type^v:Name"
    146  ;G(6)="nodeID:25611^v:additional-name^N"
    147  ;G(7)="nodeID:25611^v:family-name^Brooks"
    148  ;G(8)="nodeID:25611^v:given-name^Brian"
    149  ;G(9)="nodeID:25622^dcterms:identifier^981968"
    150  ;G(10)="nodeID:25622^dcterms:title^My Hospital Record 981968"
    151  ;G(11)="nodeID:25622^rdf:type^sp:Code"
    152  ;G(12)="nodeID:25622^sp:system^My Hospital Record"
    153  ;G(13)="nodeID:25623^rdf:type^v:Address"
    154  ;G(14)="nodeID:25623^rdf:type^v:Home"
    155  ;G(15)="nodeID:25623^rdf:type^v:Pref"
    156  ;G(16)="nodeID:25623^v:locality^Bixby"
    157  ;G(17)="nodeID:25623^v:postal-code^74008"
    158  ;G(18)="nodeID:25623^v:region^OK"
    159  ;G(19)="nodeID:25623^v:street-address^82 Lake St"
    160  ;G(20)="smart:981968/demographics^foaf:gender^male"
    161  ;G(21)="smart:981968/demographics^rdf:type^sp:Demographics"
    162  ;G(22)="smart:981968/demographics^sp:belongsTo^smart:981968"
    163  ;G(23)="smart:981968/demographics^sp:medicalRecordNumber^nodeID:25622"
    164  ;G(24)="smart:981968/demographics^v:adr^nodeID:25623"
    165  ;G(25)="smart:981968/demographics^v:bday^1956-03-23"
    166  ;G(26)="smart:981968/demographics^v:email^brian.brooks@example.com"
    167  ;G(27)="smart:981968/demographics^v:n^nodeID:25611"
    168  ;G(28)="smart:981968/demographics^v:tel^nodeID:25591"
    169  Q
    170  ;
    171 PATIENT(GRTN,C0SARY) ; GRTN, passed by reference,
    172  ; is the return name of the graph created. "" if none
    173  ; C0SARY is passed in by reference and is the NHIN array of patient
    174  ;
    175  I $O(C0SARY("patient",""))="" D  Q  ;
    176  . I $D(DEBUG) W !,"No Patient array"
    177  . S GRTN=""
    178  S GRTN="" ; default to no patient
    179  N C0SGRF
    180  S C0SGRF="vistaSmart:"_ZPATID_"/patient"
    181  S ZPAT=C0SGRF ; subject is the same as the graph name
    182  I $D(DEBUG) W !,"Processing ",C0SGRF
    183  D DELGRAPH^C0XF2N(C0SGRF) ; delete the old graph
    184  D INITFARY^C0XF2N("C0XFARY") ; which triple store to use
    185  N FARY S FARY="C0XFARY"
    186  D USEFARY^C0XF2N(FARY)
    187  D VOCINIT^C0XUTIL
    188  ;
    189  N ZPN,ZR
    190  D STARTADD^C0XF2N
    191  ;
    192  ; First do the base demographic graph
    193  ;
    194  S ZPN=$NA(C0SARY("patient",1)) ; name of predicate array for this patient
    195  N SEX S SEX=$G(@ZPN@("gender@value"))
    196  I SEX="M" S SEX="male"
    197  I SEX="F" S SEX="female"
    198  S ZR("foaf:gender")=SEX
    199  S ZR("rdf:type")="sp:Demographics"
    200  S ZR("sp:belongsTo")=ZPAT
    201  N PATIENT
    202  S PATIENT=$P(ZPAT,"#",2)
    203  I $D(DEBUG) W !,"PROCESSING PATIENT ",PATIENT
    204  N NMREC S NMREC=$$ANONS^C0XF2N ; new anonomous subject for med rec graph
    205  S ZR("sp:medicalRecordNumber")=NMREC
    206  N NVADR S NVADR=$$ANONS^C0XF2N ; for address
    207  S ZR("v:adr")=NVADR
    208  N NNAME S NNAME=$$ANONS^C0XF2N ; for name
    209  S ZR("v:n")=NNAME
    210  N NTEL S NTEL=$$ANONS^C0XF2N ; for telephone
    211  I $D(@ZPN@("telecomList.telecom@value")) S ZR("v:tel")=NTEL ; only if exists
    212  N BDATE
    213  S ZX=""
    214  S ZX=$G(@ZPN@("dob@value")) ; date of birth in fileman format
    215  S BDATE=$$FMTE^XLFDT(ZX,"7D") ; ordered date
    216  S BDATE=$TR(BDATE,"/","-") ; change slashes to hyphens
    217  I BDATE="" S BDATE="UNKNOWN"
    218  N Z2,Z3
    219  S Z2=$P(BDATE,"-",2)
    220  S Z3=$P(BDATE,"-",3)
    221  I $L(Z2)=1 S $P(BDATE,"-",2)="0"_Z2
    222  I $L(Z3)=1 S $P(BDATE,"-",3)="0"_Z3
    223  S ZR("v:bday")=BDATE
    224  I $D(C0SVISTA) D  ;
    225  . S ZR("vista:SSN")=$G(@ZPN@("ssn@value")) ; SSN
    226  . S ZR("vista:DFN")=$G(@ZPN@("id@value")) ; DFN
    227  D ADDINN^C0XF2N(C0SGRF,ZPAT,.ZR) ; create base graph
    228  K ZR
    229  ;
    230  ; create address sub-graph
    231  ;
    232  S ZR("rdf:type")="v:Address"
    233  S ZR("rdf:type")="v:Home"
    234  S ZR("v:locality")=$G(@ZPN@("address@city"))
    235  S ZR("v:postal-code")=$G(@ZPN@("address@postalCode"))
    236  S ZR("v:region")=$G(@ZPN@("address@stateProvince"))
    237  S ZR("v:street-address")=$G(@ZPN@("address@streetLine1"))
    238  D ADDINN^C0XF2N(C0SGRF,NVADR,.ZR) ; create the vcard address
    239  K ZR
    240  ;
    241  ; create medical record subgraph
    242  ;
    243  S ZR("dcterms:identifier")=$G(@ZPN@("id@value"))
    244  S ZR("dcterms:title")="VistA Patient Record "_ZR("dcterms:identifier")
    245  S ZR("rdf:type")="sp:Code"
    246  S ZR("sp:system")="VistA Patient Record"
    247  D ADDINN^C0XF2N(C0SGRF,NMREC,.ZR) ; create medical record graph
    248  K ZR
    249  ;
    250  ; create name subgraph
    251  ;
    252  N ZNF,ZNL,ZNM,ZNAM
    253  S ZR("rdf:type")="v:Name"
    254  S ZX=$G(@ZPN@("givenNames@value")) ; first name and middle names
    255  S ZNF=$P(ZX," ",1) ; first name is first piece
    256  S ZNM=$P(ZX," ",2) ; middle names are the rest
    257  S ZR("v:additional-name")=ZNM
    258  S ZR("v:family-name")=$G(@ZPN@("familyName@value"))
    259  S ZR("v:given-name")=ZNF
    260  D ADDINN^C0XF2N(C0SGRF,NNAME,.ZR) ; insert name graph
    261  K ZR
    262  ;
    263  ; create telephone subgraph
    264  ;
    265  D  ;
    266  . S ZR("rdf:value")=$G(@ZPN@("telecomList.telecom@value"))
    267  . I ZR("rdf:value")="" Q  ; telephone number missing, no subgraph
    268  . S ZR("rdf:type")="v:Tel"
    269  . D ADDINN^C0XF2N(C0SGRF,NTEL,.ZR)
    270  K ZR
    271  ;
    272  ; load the demographics graph and all sub graphs to the triple store
    273  ;
    274  D BULKLOAD^C0XF2N(.C0XFDA)
    275  S GRTN=C0SGRF
    276  Q
    277  ;
    278 AGES ; LIST ALL PATIENTS AND THEIR AGES
    279  N ZI S ZI=0
    280  F  S ZI=$O(^DPT(ZI)) Q:+ZI=0  D  ; FOR EVERY PATIENT
    281  . N ZDOB
    282  . S ZDOB=$$GET1^DIQ(2,ZI_",","DOB","I") ; FILEMAN DOB
    283  . N ZNAME
    284  . S ZNAME=$P(^DPT(ZI,0),U)
    285  . N ZSEX
    286  . S ZSEX=$$GET1^DIQ(2,ZI_",","SEX")
    287  . W !,"DFN:",ZI," ",ZNAME," AGE: ",+$$BRIEF^VWTIME(ZDOB)," YEAR OLD ",ZSEX
    288  Q
    289  ;
     1C0SDEM    ; GPL - Smart Demographics Processing ;2/22/12  17:05
     2        ;;1.0;VISTA SMART CONTAINER;;Sep 26, 2012;Build 4
     3        ;Copyright 2012 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        ;<?xml version="1.0" encoding="utf-8"?>
     23        ;<rdf:RDF
     24        ;  xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
     25        ;  xmlns:sp="http://smartplatforms.org/terms#"
     26        ;  xmlns:dcterms="http://purl.org/dc/terms/"
     27        ;  xmlns:v="http://www.w3.org/2006/vcard/ns#"
     28        ;  xmlns:foaf="http://xmlns.com/foaf/0.1/">
     29        ;   <sp:Demographics>
     30        ;
     31        ;     <v:n>
     32        ;        <v:Name>
     33        ;            <v:given-name>Bob</v:given-name>
     34        ;            <v:additional-name>J</v:additional-name>
     35        ;            <v:family-name>Odenkirk</v:family-name>
     36        ;        </v:Name>
     37        ;     </v:n>
     38        ;
     39        ;     <v:adr>
     40        ;        <v:Address>
     41        ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Home" />
     42        ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Pref" />
     43        ;
     44        ;          <v:street-address>15 Main St</v:street-address>
     45        ;          <v:extended-address>Apt 2</v:extended-address>
     46        ;          <v:locality>Wonderland</v:locality>
     47        ;          <v:region>OZ</v:region>
     48        ;          <v:postal-code>54321</v:postal-code>
     49        ;          <v:country>USA</v:country>
     50        ;        </v:Address>
     51        ;     </v:adr>
     52        ;
     53        ;     <v:tel>
     54        ;        <v:Tel>
     55        ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Home" />
     56        ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Pref" />
     57        ;          <rdf:value>800-555-1212</rdf:value>
     58        ;        </v:Tel>
     59        ;     </v:tel>
     60        ;
     61        ;     <v:tel>
     62        ;        <v:Tel>
     63        ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Cell" />
     64        ;          <rdf:value>800-555-1515</rdf:value>
     65        ;        </v:Tel>
     66        ;     </v:tel>
     67        ;
     68        ;     <foaf:gender>male</foaf:gender>
     69        ;     <v:bday>1959-12-25</v:bday>
     70        ;     <v:email>bob.odenkirk@example.com</v:email>
     71        ;
     72        ;     <sp:medicalRecordNumber>
     73        ;       <sp:Code>
     74        ;        <dcterms:title>My Hospital Record 2304575</dcterms:title>
     75        ;        <dcterms:identifier>2304575</dcterms:identifier>
     76        ;        <sp:system>My Hospital Record</sp:system>
     77        ;       </sp:Code>
     78        ;     </sp:medicalRecordNumber>
     79        ;
     80        ;   </sp:Demographics>
     81        ;</rdf:RDF><?xml version="1.0" encoding="utf-8"?>
     82        ;<rdf:RDF
     83        ;  xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
     84        ;  xmlns:sp="http://smartplatforms.org/terms#"
     85        ;  xmlns:dcterms="http://purl.org/dc/terms/"
     86        ;  xmlns:v="http://www.w3.org/2006/vcard/ns#"
     87        ;  xmlns:foaf="http://xmlns.com/foaf/0.1/">
     88        ;   <sp:Demographics>
     89        ;
     90        ;     <v:n>
     91        ;        <v:Name>
     92        ;            <v:given-name>Bob</v:given-name>
     93        ;            <v:additional-name>J</v:additional-name>
     94        ;            <v:family-name>Odenkirk</v:family-name>
     95        ;        </v:Name>
     96        ;     </v:n>
     97        ;
     98        ;     <v:adr>
     99        ;        <v:Address>
     100        ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Home" />
     101        ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Pref" />
     102        ;
     103        ;          <v:street-address>15 Main St</v:street-address>
     104        ;          <v:extended-address>Apt 2</v:extended-address>
     105        ;          <v:locality>Wonderland</v:locality>
     106        ;          <v:region>OZ</v:region>
     107        ;          <v:postal-code>54321</v:postal-code>
     108        ;          <v:country>USA</v:country>
     109        ;        </v:Address>
     110        ;     </v:adr>
     111        ;
     112        ;     <v:tel>
     113        ;        <v:Tel>
     114        ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Home" />
     115        ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Pref" />
     116        ;          <rdf:value>800-555-1212</rdf:value>
     117        ;        </v:Tel>
     118        ;     </v:tel>
     119        ;
     120        ;     <v:tel>
     121        ;        <v:Tel>
     122        ;          <rdf:type rdf:resource="http://www.w3.org/2006/vcard/ns#Cell" />
     123        ;          <rdf:value>800-555-1515</rdf:value>
     124        ;        </v:Tel>
     125        ;     </v:tel>
     126        ;
     127        ;     <foaf:gender>male</foaf:gender>
     128        ;     <v:bday>1959-12-25</v:bday>
     129        ;     <v:email>bob.odenkirk@example.com</v:email>
     130        ;
     131        ;     <sp:medicalRecordNumber>
     132        ;       <sp:Code>
     133        ;        <dcterms:title>My Hospital Record 2304575</dcterms:title>
     134        ;        <dcterms:identifier>2304575</dcterms:identifier>
     135        ;        <sp:system>My Hospital Record</sp:system>
     136        ;       </sp:Code>
     137        ;     </sp:medicalRecordNumber>
     138        ;
     139        ;   </sp:Demographics>
     140        ;</rdf:RDF>
     141        ;G(1)="nodeID:25591^rdf:type^v:Home"
     142        ;G(2)="nodeID:25591^rdf:type^v:Pref"
     143        ;G(3)="nodeID:25591^rdf:type^v:Tel"
     144        ;G(4)="nodeID:25591^rdf:value^800-369-6403"
     145        ;G(5)="nodeID:25611^rdf:type^v:Name"
     146        ;G(6)="nodeID:25611^v:additional-name^N"
     147        ;G(7)="nodeID:25611^v:family-name^Brooks"
     148        ;G(8)="nodeID:25611^v:given-name^Brian"
     149        ;G(9)="nodeID:25622^dcterms:identifier^981968"
     150        ;G(10)="nodeID:25622^dcterms:title^My Hospital Record 981968"
     151        ;G(11)="nodeID:25622^rdf:type^sp:Code"
     152        ;G(12)="nodeID:25622^sp:system^My Hospital Record"
     153        ;G(13)="nodeID:25623^rdf:type^v:Address"
     154        ;G(14)="nodeID:25623^rdf:type^v:Home"
     155        ;G(15)="nodeID:25623^rdf:type^v:Pref"
     156        ;G(16)="nodeID:25623^v:locality^Bixby"
     157        ;G(17)="nodeID:25623^v:postal-code^74008"
     158        ;G(18)="nodeID:25623^v:region^OK"
     159        ;G(19)="nodeID:25623^v:street-address^82 Lake St"
     160        ;G(20)="smart:981968/demographics^foaf:gender^male"
     161        ;G(21)="smart:981968/demographics^rdf:type^sp:Demographics"
     162        ;G(22)="smart:981968/demographics^sp:belongsTo^smart:981968"
     163        ;G(23)="smart:981968/demographics^sp:medicalRecordNumber^nodeID:25622"
     164        ;G(24)="smart:981968/demographics^v:adr^nodeID:25623"
     165        ;G(25)="smart:981968/demographics^v:bday^1956-03-23"
     166        ;G(26)="smart:981968/demographics^v:email^brian.brooks@example.com"
     167        ;G(27)="smart:981968/demographics^v:n^nodeID:25611"
     168        ;G(28)="smart:981968/demographics^v:tel^nodeID:25591"
     169        Q
     170        ;
     171PATIENT(GRTN,C0SARY)    ; GRTN, passed by reference,
     172        ; is the return name of the graph created. "" if none
     173        ; C0SARY is passed in by reference and is the NHIN array of patient
     174        ;
     175        I $O(C0SARY("patient",""))="" D  Q  ;
     176        . I $D(DEBUG) W !,"No Patient array"
     177        . S GRTN=""
     178        S GRTN="" ; default to no patient
     179        N C0SGRF
     180        S C0SGRF="vistaSmart:"_ZPATID_"/patient"
     181        S ZPAT=C0SGRF ; subject is the same as the graph name
     182        I $D(DEBUG) W !,"Processing ",C0SGRF
     183        D DELGRAPH^C0XF2N(C0SGRF) ; delete the old graph
     184        D INITFARY^C0XF2N("C0XFARY") ; which triple store to use
     185        N FARY S FARY="C0XFARY"
     186        D USEFARY^C0XF2N(FARY)
     187        D VOCINIT^C0XUTIL
     188        ;
     189        N ZPN,ZR
     190        D STARTADD^C0XF2N
     191        ;
     192        ; First do the base demographic graph
     193        ;
     194        S ZPN=$NA(C0SARY("patient",1)) ; name of predicate array for this patient
     195        N SEX S SEX=$G(@ZPN@("gender@value"))
     196        I SEX="M" S SEX="male"
     197        I SEX="F" S SEX="female"
     198        S ZR("foaf:gender")=SEX
     199        S ZR("rdf:type")="sp:Demographics"
     200        S ZR("sp:belongsTo")=ZPAT
     201        N PATIENT
     202        S PATIENT=$P(ZPAT,"#",2)
     203        I $D(DEBUG) W !,"PROCESSING PATIENT ",PATIENT
     204        N NMREC S NMREC=$$ANONS^C0XF2N ; new anonomous subject for med rec graph
     205        S ZR("sp:medicalRecordNumber")=NMREC
     206        N NVADR S NVADR=$$ANONS^C0XF2N ; for address
     207        S ZR("v:adr")=NVADR
     208        N NNAME S NNAME=$$ANONS^C0XF2N ; for name
     209        S ZR("v:n")=NNAME
     210        N NTEL S NTEL=$$ANONS^C0XF2N ; for telephone
     211        I $D(@ZPN@("telecomList.telecom@value")) S ZR("v:tel")=NTEL ; only if exists
     212        N BDATE
     213        S ZX=""
     214        S ZX=$G(@ZPN@("dob@value")) ; date of birth in fileman format
     215        S BDATE=$$FMTE^XLFDT(ZX,"7D") ; ordered date
     216        S BDATE=$TR(BDATE,"/","-") ; change slashes to hyphens
     217        I BDATE="" S BDATE="UNKNOWN"
     218        N Z2,Z3
     219        S Z2=$P(BDATE,"-",2)
     220        S Z3=$P(BDATE,"-",3)
     221        I $L(Z2)=1 S $P(BDATE,"-",2)="0"_Z2
     222        I $L(Z3)=1 S $P(BDATE,"-",3)="0"_Z3
     223        S ZR("v:bday")=BDATE
     224        I $D(C0SVISTA) D  ;
     225        . S ZR("vista:SSN")=$G(@ZPN@("ssn@value")) ; SSN
     226        . S ZR("vista:DFN")=$G(@ZPN@("id@value")) ; DFN
     227        D ADDINN^C0XF2N(C0SGRF,ZPAT,.ZR) ; create base graph
     228        K ZR
     229        ;
     230        ; create address sub-graph
     231        ;
     232        S ZR("rdf:type")="v:Address"
     233        S ZR("rdf:type")="v:Home"
     234        S ZR("v:locality")=$G(@ZPN@("address@city"))
     235        S ZR("v:postal-code")=$G(@ZPN@("address@postalCode"))
     236        S ZR("v:region")=$G(@ZPN@("address@stateProvince"))
     237        S ZR("v:street-address")=$G(@ZPN@("address@streetLine1"))
     238        D ADDINN^C0XF2N(C0SGRF,NVADR,.ZR) ; create the vcard address
     239        K ZR
     240        ;
     241        ; create medical record subgraph
     242        ;
     243        S ZR("dcterms:identifier")=$G(@ZPN@("id@value"))
     244        S ZR("dcterms:title")="VistA Patient Record "_ZR("dcterms:identifier")
     245        S ZR("rdf:type")="sp:Code"
     246        S ZR("sp:system")="VistA Patient Record"
     247        D ADDINN^C0XF2N(C0SGRF,NMREC,.ZR) ; create medical record graph
     248        K ZR
     249        ;
     250        ; create name subgraph
     251        ;
     252        N ZNF,ZNL,ZNM,ZNAM
     253        S ZR("rdf:type")="v:Name"
     254        S ZX=$G(@ZPN@("givenNames@value")) ; first name and middle names
     255        S ZNF=$P(ZX," ",1) ; first name is first piece
     256        S ZNM=$P(ZX," ",2) ; middle names are the rest
     257        S ZR("v:additional-name")=ZNM
     258        S ZR("v:family-name")=$G(@ZPN@("familyName@value"))
     259        S ZR("v:given-name")=ZNF
     260        D ADDINN^C0XF2N(C0SGRF,NNAME,.ZR) ; insert name graph
     261        K ZR
     262        ;
     263        ; create telephone subgraph
     264        ;
     265        D  ;
     266        . S ZR("rdf:value")=$G(@ZPN@("telecomList.telecom@value"))
     267        . I ZR("rdf:value")="" Q  ; telephone number missing, no subgraph
     268        . S ZR("rdf:type")="v:Tel"
     269        . D ADDINN^C0XF2N(C0SGRF,NTEL,.ZR)
     270        K ZR
     271        ;
     272        ; load the demographics graph and all sub graphs to the triple store
     273        ;
     274        D BULKLOAD^C0XF2N(.C0XFDA)
     275        S GRTN=C0SGRF
     276        Q
     277        ;
     278AGES    ; LIST ALL PATIENTS AND THEIR AGES
     279        N ZI S ZI=0
     280        F  S ZI=$O(^DPT(ZI)) Q:+ZI=0  D  ; FOR EVERY PATIENT
     281        . N ZDOB
     282        . S ZDOB=$$GET1^DIQ(2,ZI_",","DOB","I") ; FILEMAN DOB
     283        . N ZNAME
     284        . S ZNAME=$P(^DPT(ZI,0),U)
     285        . N ZSEX
     286        . S ZSEX=$$GET1^DIQ(2,ZI_",","SEX")
     287        . W !,"DFN:",ZI," ",ZNAME," AGE: ",+$$BRIEF^VWTIME(ZDOB)," YEAR OLD ",ZSEX
     288        Q
     289        ;
  • smart/trunk/p/C0SDOM.m

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

    r1569 r1571  
    1 C0SLAB   ; GPL - Smart Lab Processing ;4/15/12  17:05
    2  ;;0.1;C0S;nopatch;noreleasedate;Build 2
    3  ;Copyright 2012 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  ; sample VistA NHIN lab result
    23  ;
    24  ;^TMP("C0STBL",32,"lab",8,"collected@value")=3110626.16
    25  ;^TMP("C0STBL",32,"lab",8,"comment")="Report Released Date/Time: Jun 26, 2011@19:00"
    26  ;^TMP("C0STBL",32,"lab",8,"comment@xml:space")="preserve"
    27  ;^TMP("C0STBL",32,"lab",8,"facility@code")=100
    28  ;^TMP("C0STBL",32,"lab",8,"facility@name")="VOE OFFICE INSTITUTION"
    29  ;^TMP("C0STBL",32,"lab",8,"groupName@value")="CH 0626 47"
    30  ;^TMP("C0STBL",32,"lab",8,"high@value")=" 101"
    31  ;^TMP("C0STBL",32,"lab",8,"id@value")="CH;6889372.84;67003"
    32  ;^TMP("C0STBL",32,"lab",8,"interpretation@value")="H"
    33  ;^TMP("C0STBL",32,"lab",8,"labOrderID@value")=336
    34  ;^TMP("C0STBL",32,"lab",8,"localName@value")="FBLDGLU"
    35  ;^TMP("C0STBL",32,"lab",8,"loinc@value")="14771-0"
    36  ;^TMP("C0STBL",32,"lab",8,"low@value")="69 "
    37  ;^TMP("C0STBL",32,"lab",8,"orderID@value")=807
    38  ;^TMP("C0STBL",32,"lab",8,"result@value")=178
    39  ;^TMP("C0STBL",32,"lab",8,"resulted@value")=3110626.190006
    40  ;^TMP("C0STBL",32,"lab",8,"sample@value")="SERUM"
    41  ;^TMP("C0STBL",32,"lab",8,"specimen@code")="0X500"
    42  ;^TMP("C0STBL",32,"lab",8,"specimen@name")="SERUM"
    43  ;^TMP("C0STBL",32,"lab",8,"status@value")="completed"
    44  ;^TMP("C0STBL",32,"lab",8,"test@value")="FASTING BLOOD GLUCOSE"
    45  ;^TMP("C0STBL",32,"lab",8,"type@value")="CH"
    46  ;^TMP("C0STBL",32,"lab",8,"units@value")="MG/DL"
    47  ;^TMP("C0STBL",32,"lab",8,"vuid@value")=4656342
    48  ;
    49  ; sample Smart lab result triples
    50  ;
    51  ;G("loinc:29571-7","dcterms:identifier")="29571-7"
    52  ;G("loinc:29571-7","dcterms:title")="Phe DBS Ql"
    53  ;G("loinc:29571-7","rdf:type")="sp:Code"
    54  ;G("loinc:29571-7","sp:system")="http://loinc.org/codes/"
    55  ;G("loinc:38478-4","dcterms:identifier")="38478-4"
    56  ;G("loinc:38478-4","dcterms:title")="Biotinidase DBS Ql"
    57  ;G("loinc:38478-4","rdf:type")="sp:Code"
    58  ;G("loinc:38478-4","sp:system")="http://loinc.org/codes/"
    59  ;G("qqWZZIew993","rdf:type")="sp:Attribution"
    60  ;G("qqWZZIew993","sp:startDate")="2007-04-21"
    61  ;G("qqWZZIew994","rdf:type")="sp:NarrativeResult"
    62  ;G("qqWZZIew994","sp:value")="Normal"
    63  ;G("qqWZZIew995","dcterms:title")="Biotinidase DBS Ql"
    64  ;G("qqWZZIew995","rdf:type")="sp:CodedValue"
    65  ;G("qqWZZIew995","sp:code")="loinc:38478-4"
    66  ;G("qqWZZIew997","rdf:type")="sp:Attribution"
    67  ;G("qqWZZIew997","sp:startDate")="2007-09-08"
    68  ;G("qqWZZIew998","rdf:type")="sp:NarrativeResult"
    69  ;G("qqWZZIew998","sp:value")="Normal"
    70  ;G("qqWZZIew999","dcterms:title")="Phe DBS Ql"
    71  ;G("qqWZZIew999","rdf:type")="sp:CodedValue"
    72  ;G("qqWZZIew999","sp:code")="loinc:29571-7"
    73  ;G("smart:99912345/lab_results/3d9b39249193","rdf:type")="sp:LabResult"
    74  ;G("smart:99912345/lab_results/3d9b39249193","sp:belongsTo")="smart:99912345"
    75  ;G("smart:99912345/lab_results/3d9b39249193","sp:labName")="qqWZZIew995"
    76  ;G("smart:99912345/lab_results/3d9b39249193","sp:narrativeResult")="qqWZZIew994"
    77  ;G("smart:99912345/lab_results/3d9b39249193","sp:specimenCollected")="qqWZZIew993"
    78  ;G("smart:99912345/lab_results/426c7adc4f54","rdf:type")="sp:LabResult"
    79  ;G("smart:99912345/lab_results/426c7adc4f54","sp:belongsTo")="smart:99912345"
    80  ;G("smart:99912345/lab_results/426c7adc4f54","sp:labName")="qqWZZIew999"
    81  ;G("smart:99912345/lab_results/426c7adc4f54","sp:narrativeResult")="qqWZZIew998"
    82  ;G("smart:99912345/lab_results/426c7adc4f54","sp:specimenCollected")="qqWZZIew997"
    83  ;
    84  ;
    85  ;  another Smart example, this one with sp:quantitativeResult
    86  ;
    87  ;G("loinc:786-4","dcterms:identifier")="786-4"
    88  ;G("loinc:786-4","dcterms:title")="MCHC RBC Auto-mCnc"
    89  ;G("loinc:786-4","rdf:type")="sp:Code"
    90  ;G("loinc:786-4","sp:system")="http://loinc.org/codes/"
    91  ;G("nodeID:4439","rdf:type")="sp:ValueAndUnit"
    92  ;G("nodeID:4439","sp:unit")="g/dL"
    93  ;G("nodeID:4439","sp:value")=36.6
    94  ;G("nodeID:4613","rdf:type")="sp:ValueAndUnit"
    95  ;G("nodeID:4613","sp:unit")="g/dL"
    96  ;G("nodeID:4613","sp:value")=32
    97  ;G("nodeID:4672","rdf:type")="sp:Attribution"
    98  ;G("nodeID:4672","sp:startDate")="2005-03-10"
    99  ;G("nodeID:4866","rdf:type")="sp:ValueAndUnit"
    100  ;G("nodeID:4866","sp:unit")="g/dL"
    101  ;G("nodeID:4866","sp:value")=36
    102  ;G("nodeID:4871","dcterms:title")="MCHC RBC Auto-mCnc"
    103  ;G("nodeID:4871","rdf:type")="sp:CodedValue"
    104  ;G("nodeID:4871","sp:code")="loinc:786-4"
    105  ;G("nodeID:5221","rdf:type")="sp:QuantitativeResult"
    106  ;G("nodeID:5221","sp:normalRange")="nodeID:5282"
    107  ;G("nodeID:5221","sp:valueAndUnit")="nodeID:4439"
    108  ;G("nodeID:5282","rdf:type")="sp:ValueRange"
    109  ;G("nodeID:5282","sp:maximum")="nodeID:4866"
    110  ;G("nodeID:5282","sp:minimum")="nodeID:4613"
    111  ;G("smart:1540505/lab_results/2fc100850766","rdf:type")="sp:LabResult"
    112  ;G("smart:1540505/lab_results/2fc100850766","sp:belongsTo")="smart:1540505"
    113  ;G("smart:1540505/lab_results/2fc100850766","sp:labName")="nodeID:4871"
    114  ;G("smart:1540505/lab_results/2fc100850766","sp:quantitativeResult")="nodeID:5221"
    115  ;G("smart:1540505/lab_results/2fc100850766","sp:specimenCollected")="nodeID:4672"
    116  ;
    117 LAB(GRTN,C0SARY) ; GRTN, passed by reference,
    118  ; is the return name of the graph created. "" if none
    119  ; C0SARY is passed in by reference and is the NHIN array of lab
    120  ;
    121  I $O(C0SARY("lab",""))="" D  Q  ;
    122  . I $D(DEBUG) W !,"No Labs"
    123  S GRTN="" ; default to no labs
    124  N C0SGRF
    125  S C0SGRF="vistaSmart:"_ZPATID_"/lab_results"
    126  I $D(DEBUG) W !,"Processing ",C0SGRF
    127  D DELGRAPH^C0XF2N(C0SGRF) ; delete the old graph
    128  D INITFARY^C0XF2N("C0XFARY") ; which triple store to use
    129  N FARY S FARY="C0XFARY"
    130  D USEFARY^C0XF2N(FARY)
    131  D VOCINIT^C0XUTIL
    132  ;
    133  D STARTADD^C0XF2N ; initialize to create triples
    134  ;
    135  N ZI S ZI=""
    136  F  S ZI=$O(C0SARY("lab",ZI)) Q:ZI=""  D  ;
    137  . N LRN,ZR ; ZR is the local array for building the new triples
    138  . S LRN=$NA(C0SARY("lab",ZI)) ; base for values in this lab result
    139  . ;
    140  . N RSLTID ; unique Id for this lab result
    141  . S RSLTID=C0SGRF_"/"_$$LKY17^C0XF2N ; use a random number
    142  . ;
    143  . ; i don't like this because the same labs result gets a
    144  . ; different ID every time it's reported. Can't trace it back to VistA
    145  . ; I'd rather be using id@value ie "id@value")="CH;6889372.84;67003"
    146  . ; .. either that or store an OID with the lab result - but that
    147  . ; will have to wait for the redesign of file 60.. - gpl 4/16/2012
    148  . ;
    149  . N LOINC S LOINC=$G(@LRN@("loinc@value"))
    150  . I LOINC="" D  Q  ;
    151  . . I $D(DEBUG) W !,"NO LOINC VALUE, SKIPPING"
    152  . N LABTST S LABTST=$G(@LRN@("test@value"))
    153  . I $D(DEBUG) D  ;
    154  . . W !,"Processing Lab Result ",RSLTID
    155  . . W !,"test: ",LABTST
    156  . . W !,"loinc: ",LOINC
    157  . ;
    158  . ; first do the base result graph
    159  . ;
    160  . S ZR("rdf:type")="sp:LabResult"
    161  . S ZR("sp:belongsTo")=C0SGRF ; the subject for this patient's lab results
    162  . ; ie /vista/smart/99912345/lab_results
    163  . ;
    164  . N LABNAME S LABNAME=$$ANONS^C0XF2N ; new node for lab name
    165  . S ZR("sp:labName")=LABNAME
    166  . ;
    167  . N NARRSLT S NARRSLT=$$ANONS^C0XF2N ; new node for narrative result
    168  . S ZR("sp:narrativeResult")=NARRSLT
    169  . ;
    170  . N QNTRSLT S QNTRSLT=$$ANONS^C0XF2N ; new node for narrative result
    171  . S ZR("sp:quantitativeResult")=QNTRSLT
    172  . ;
    173  . N SPECCOLL S SPECCOLL=$$ANONS^C0XF2N ; new node for specimen collected
    174  . S ZR("sp:specimenCollected")=SPECCOLL
    175  . ;
    176  . D ADDINN^C0XF2N(C0SGRF,RSLTID,.ZR) ; addIfNotNull the triples
    177  . K ZR ; clean up
    178  . ;
    179  . ; create the narrative result graph
    180  . ;
    181  . N IVAL S IVAL=$G(@LRN@("interpretation@value"))'="" D  ; H OR L
    182  . I IVAL'=""
    183  . . S ZR("rdf:type")="sp:NarrativeResult"
    184  . . S ZR("sp:value")=$G(@LRN@("interpretation@value")) ; H or L
    185  . . I ZR("sp:value")="L" S ZR("sp:value")="abnormal"
    186  . . I ZR("sp:value")="H" S ZR("sp:value")="abnormal"
    187  . . I ZR("sp:value")="HH" S ZR("sp:value")="critical"
    188  . . I ZR("sp:value")="LL" S ZR("sp:value")="critical"
    189  . . D ADDINN^C0XF2N(C0SGRF,NARRSLT,.ZR)
    190  . . K ZR
    191  . ;
    192  . ; create the quantitative result graph
    193  . ;
    194  . S ZR("rdf:type")="sp:QuantitativeResult"
    195  . N NORMNM S NORMNM=$$ANONS^C0XF2N ; new node for normal range graph
    196  . N VUNM S VUNM=$$ANONS^C0XF2N ; new node for value and unit graph
    197  . N HASNORMAL S HASNORMAL=0
    198  . I $G(@LRN@("high@value"))'="" S HASNORMAL=1
    199  . I HASNORMAL S ZR("sp:normalRange")=NORMNM
    200  . S ZR("sp:valueAndUnit")=VUNM
    201  . D ADDINN^C0XF2N(C0SGRF,QNTRSLT,.ZR)
    202  . K ZR
    203  . ;
    204  . ; create the normal range graph
    205  . ;
    206  . I HASNORMAL D  ;
    207  . . S ZR("rdf:type")="sp:ValueRange"
    208  . . N MAXNM S MAXNM=$$ANONS^C0XF2N ; new node for maximum graph
    209  . . N MINNM S MINNM=$$ANONS^C0XF2N ; new node for minimum graph
    210  . . S ZR("sp:maximum")=MAXNM
    211  . . S ZR("sp:minimum")=MINNM
    212  . . D ADDINN^C0XF2N(C0SGRF,NORMNM,.ZR)
    213  . . K ZR
    214  . . ;
    215  . . ; create the maximum graph
    216  . . ;
    217  . . S ZR("rdf:type")="sp:ValueAndUnit"
    218  . . S ZR("sp:unit")=$G(@LRN@("units@value"))
    219  . . S ZR("sp:value")=$G(@LRN@("high@value"))
    220  . . D ADDINN^C0XF2N(C0SGRF,MAXNM,.ZR)
    221  . . K ZR
    222  . . ;
    223  . . ; create the minimum graph
    224  . . ;
    225  . . S ZR("rdf:type")="sp:ValueAndUnit"
    226  . . S ZR("sp:unit")=$G(@LRN@("units@value"))
    227  . . S ZR("sp:value")=$G(@LRN@("low@value"))
    228  . . D ADDINN^C0XF2N(C0SGRF,MINNM,.ZR)
    229  . . K ZR
    230  . ;
    231  . ; create the value and unit graph
    232  . ;
    233  . S ZR("rdf:type")="sp:ValueAndUnit"
    234  . S ZR("sp:unit")=$G(@LRN@("units@value"))
    235  . I ZR("sp:unit")="" S ZR("sp:unit")="{unknown}" ;$G(@LRN@("test@value"))
    236  . S ZR("sp:value")=$G(@LRN@("result@value"))
    237  . D ADDINN^C0XF2N(C0SGRF,VUNM,.ZR)
    238  . K ZR
    239  . ;
    240  . ; create specimen collected graph
    241  . ;
    242  . S ZR("rdf:type")="sp:Attribution"
    243  . S ZR("sp:startDate")=$$SPDATE^C0SUTIL($G(@LRN@("collected@value")))
    244  . D ADDINN^C0XF2N(C0SGRF,SPECCOLL,.ZR)
    245  . K ZR
    246  . ;
    247  . ; create lab name graph - this contains the test name and code
    248  . ;
    249  . I LOINC'="" D  ;
    250  . . S ZR("rdf:type")="sp:CodedValue"
    251  . . S ZR("dcterms:title")=LABTST
    252  . . N LOINCNM S LOINCNM="loinc:"_LOINC
    253  . . S ZR("sp:code")="loinc:"_LOINC
    254  . . D ADDINN^C0XF2N(C0SGRF,LABNAME,.ZR)
    255  . . K ZR
    256  . . S ZR("dcterms:identifier")=LOINC
    257  . . S ZR("dcterms:title")=LABTST
    258  . . S ZR("rdf:type")="sp:Code"
    259  . . S ZR("sp:system")="http://loinc.org/codes/"
    260  . . D ADDINN^C0XF2N(C0SGRF,LOINCNM,.ZR)
    261  . . K ZR
    262  . ;
    263  . ; that's all for now folks (there is more to do like reference ranges
    264  . ; and result values)
    265  . ;
    266  D BULKLOAD^C0XF2N(.C0XFDA)
    267  S GRTN=C0SGRF
    268  Q
    269  ;
    270 SAMPLE ; import sample lab tests to the triplestore
    271  N GN
    272  S GN=$NA(^rdf("lab_results"))
    273  D INSRDF^C0XF2N(GN,"/smart/lab/samples")
    274  Q
    275  ;
     1C0SLAB    ; GPL - Smart Lab Processing ;4/15/12  17:05
     2        ;;1.0;VISTA SMART CONTAINER;;Sep 26, 2012;Build 4
     3        ;Copyright 2012 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        ; sample VistA NHIN lab result
     23        ;
     24        ;^TMP("C0STBL",32,"lab",8,"collected@value")=3110626.16
     25        ;^TMP("C0STBL",32,"lab",8,"comment")="Report Released Date/Time: Jun 26, 2011@19:00"
     26        ;^TMP("C0STBL",32,"lab",8,"comment@xml:space")="preserve"
     27        ;^TMP("C0STBL",32,"lab",8,"facility@code")=100
     28        ;^TMP("C0STBL",32,"lab",8,"facility@name")="VOE OFFICE INSTITUTION"
     29        ;^TMP("C0STBL",32,"lab",8,"groupName@value")="CH 0626 47"
     30        ;^TMP("C0STBL",32,"lab",8,"high@value")=" 101"
     31        ;^TMP("C0STBL",32,"lab",8,"id@value")="CH;6889372.84;67003"
     32        ;^TMP("C0STBL",32,"lab",8,"interpretation@value")="H"
     33        ;^TMP("C0STBL",32,"lab",8,"labOrderID@value")=336
     34        ;^TMP("C0STBL",32,"lab",8,"localName@value")="FBLDGLU"
     35        ;^TMP("C0STBL",32,"lab",8,"loinc@value")="14771-0"
     36        ;^TMP("C0STBL",32,"lab",8,"low@value")="69 "
     37        ;^TMP("C0STBL",32,"lab",8,"orderID@value")=807
     38        ;^TMP("C0STBL",32,"lab",8,"result@value")=178
     39        ;^TMP("C0STBL",32,"lab",8,"resulted@value")=3110626.190006
     40        ;^TMP("C0STBL",32,"lab",8,"sample@value")="SERUM"
     41        ;^TMP("C0STBL",32,"lab",8,"specimen@code")="0X500"
     42        ;^TMP("C0STBL",32,"lab",8,"specimen@name")="SERUM"
     43        ;^TMP("C0STBL",32,"lab",8,"status@value")="completed"
     44        ;^TMP("C0STBL",32,"lab",8,"test@value")="FASTING BLOOD GLUCOSE"
     45        ;^TMP("C0STBL",32,"lab",8,"type@value")="CH"
     46        ;^TMP("C0STBL",32,"lab",8,"units@value")="MG/DL"
     47        ;^TMP("C0STBL",32,"lab",8,"vuid@value")=4656342
     48        ;
     49        ; sample Smart lab result triples
     50        ;
     51        ;G("loinc:29571-7","dcterms:identifier")="29571-7"
     52        ;G("loinc:29571-7","dcterms:title")="Phe DBS Ql"
     53        ;G("loinc:29571-7","rdf:type")="sp:Code"
     54        ;G("loinc:29571-7","sp:system")="http://loinc.org/codes/"
     55        ;G("loinc:38478-4","dcterms:identifier")="38478-4"
     56        ;G("loinc:38478-4","dcterms:title")="Biotinidase DBS Ql"
     57        ;G("loinc:38478-4","rdf:type")="sp:Code"
     58        ;G("loinc:38478-4","sp:system")="http://loinc.org/codes/"
     59        ;G("qqWZZIew993","rdf:type")="sp:Attribution"
     60        ;G("qqWZZIew993","sp:startDate")="2007-04-21"
     61        ;G("qqWZZIew994","rdf:type")="sp:NarrativeResult"
     62        ;G("qqWZZIew994","sp:value")="Normal"
     63        ;G("qqWZZIew995","dcterms:title")="Biotinidase DBS Ql"
     64        ;G("qqWZZIew995","rdf:type")="sp:CodedValue"
     65        ;G("qqWZZIew995","sp:code")="loinc:38478-4"
     66        ;G("qqWZZIew997","rdf:type")="sp:Attribution"
     67        ;G("qqWZZIew997","sp:startDate")="2007-09-08"
     68        ;G("qqWZZIew998","rdf:type")="sp:NarrativeResult"
     69        ;G("qqWZZIew998","sp:value")="Normal"
     70        ;G("qqWZZIew999","dcterms:title")="Phe DBS Ql"
     71        ;G("qqWZZIew999","rdf:type")="sp:CodedValue"
     72        ;G("qqWZZIew999","sp:code")="loinc:29571-7"
     73        ;G("smart:99912345/lab_results/3d9b39249193","rdf:type")="sp:LabResult"
     74        ;G("smart:99912345/lab_results/3d9b39249193","sp:belongsTo")="smart:99912345"
     75        ;G("smart:99912345/lab_results/3d9b39249193","sp:labName")="qqWZZIew995"
     76        ;G("smart:99912345/lab_results/3d9b39249193","sp:narrativeResult")="qqWZZIew994"
     77        ;G("smart:99912345/lab_results/3d9b39249193","sp:specimenCollected")="qqWZZIew993"
     78        ;G("smart:99912345/lab_results/426c7adc4f54","rdf:type")="sp:LabResult"
     79        ;G("smart:99912345/lab_results/426c7adc4f54","sp:belongsTo")="smart:99912345"
     80        ;G("smart:99912345/lab_results/426c7adc4f54","sp:labName")="qqWZZIew999"
     81        ;G("smart:99912345/lab_results/426c7adc4f54","sp:narrativeResult")="qqWZZIew998"
     82        ;G("smart:99912345/lab_results/426c7adc4f54","sp:specimenCollected")="qqWZZIew997"
     83        ;
     84        ;
     85        ;  another Smart example, this one with sp:quantitativeResult
     86        ;
     87        ;G("loinc:786-4","dcterms:identifier")="786-4"
     88        ;G("loinc:786-4","dcterms:title")="MCHC RBC Auto-mCnc"
     89        ;G("loinc:786-4","rdf:type")="sp:Code"
     90        ;G("loinc:786-4","sp:system")="http://loinc.org/codes/"
     91        ;G("nodeID:4439","rdf:type")="sp:ValueAndUnit"
     92        ;G("nodeID:4439","sp:unit")="g/dL"
     93        ;G("nodeID:4439","sp:value")=36.6
     94        ;G("nodeID:4613","rdf:type")="sp:ValueAndUnit"
     95        ;G("nodeID:4613","sp:unit")="g/dL"
     96        ;G("nodeID:4613","sp:value")=32
     97        ;G("nodeID:4672","rdf:type")="sp:Attribution"
     98        ;G("nodeID:4672","sp:startDate")="2005-03-10"
     99        ;G("nodeID:4866","rdf:type")="sp:ValueAndUnit"
     100        ;G("nodeID:4866","sp:unit")="g/dL"
     101        ;G("nodeID:4866","sp:value")=36
     102        ;G("nodeID:4871","dcterms:title")="MCHC RBC Auto-mCnc"
     103        ;G("nodeID:4871","rdf:type")="sp:CodedValue"
     104        ;G("nodeID:4871","sp:code")="loinc:786-4"
     105        ;G("nodeID:5221","rdf:type")="sp:QuantitativeResult"
     106        ;G("nodeID:5221","sp:normalRange")="nodeID:5282"
     107        ;G("nodeID:5221","sp:valueAndUnit")="nodeID:4439"
     108        ;G("nodeID:5282","rdf:type")="sp:ValueRange"
     109        ;G("nodeID:5282","sp:maximum")="nodeID:4866"
     110        ;G("nodeID:5282","sp:minimum")="nodeID:4613"
     111        ;G("smart:1540505/lab_results/2fc100850766","rdf:type")="sp:LabResult"
     112        ;G("smart:1540505/lab_results/2fc100850766","sp:belongsTo")="smart:1540505"
     113        ;G("smart:1540505/lab_results/2fc100850766","sp:labName")="nodeID:4871"
     114        ;G("smart:1540505/lab_results/2fc100850766","sp:quantitativeResult")="nodeID:5221"
     115        ;G("smart:1540505/lab_results/2fc100850766","sp:specimenCollected")="nodeID:4672"
     116        ;
     117LAB(GRTN,C0SARY)        ; GRTN, passed by reference,
     118        ; is the return name of the graph created. "" if none
     119        ; C0SARY is passed in by reference and is the NHIN array of lab
     120        ;
     121        I $O(C0SARY("lab",""))="" D  Q  ;
     122        . I $D(DEBUG) W !,"No Labs"
     123        S GRTN="" ; default to no labs
     124        N C0SGRF
     125        S C0SGRF="vistaSmart:"_ZPATID_"/lab_results"
     126        I $D(DEBUG) W !,"Processing ",C0SGRF
     127        D DELGRAPH^C0XF2N(C0SGRF) ; delete the old graph
     128        D INITFARY^C0XF2N("C0XFARY") ; which triple store to use
     129        N FARY S FARY="C0XFARY"
     130        D USEFARY^C0XF2N(FARY)
     131        D VOCINIT^C0XUTIL
     132        ;
     133        D STARTADD^C0XF2N ; initialize to create triples
     134        ;
     135        N ZI S ZI=""
     136        F  S ZI=$O(C0SARY("lab",ZI)) Q:ZI=""  D  ;
     137        . N LRN,ZR ; ZR is the local array for building the new triples
     138        . S LRN=$NA(C0SARY("lab",ZI)) ; base for values in this lab result
     139        . ;
     140        . N RSLTID ; unique Id for this lab result
     141        . S RSLTID=C0SGRF_"/"_$$LKY17^C0XF2N ; use a random number
     142        . ;
     143        . ; i don't like this because the same labs result gets a
     144        . ; different ID every time it's reported. Can't trace it back to VistA
     145        . ; I'd rather be using id@value ie "id@value")="CH;6889372.84;67003"
     146        . ; .. either that or store an OID with the lab result - but that
     147        . ; will have to wait for the redesign of file 60.. - gpl 4/16/2012
     148        . ;
     149        . N LOINC S LOINC=$G(@LRN@("loinc@value"))
     150        . I LOINC="" D  Q  ;
     151        . . I $D(DEBUG) W !,"NO LOINC VALUE, SKIPPING"
     152        . N LABTST S LABTST=$G(@LRN@("test@value"))
     153        . I $D(DEBUG) D  ;
     154        . . W !,"Processing Lab Result ",RSLTID
     155        . . W !,"test: ",LABTST
     156        . . W !,"loinc: ",LOINC
     157        . ;
     158        . ; first do the base result graph
     159        . ;
     160        . S ZR("rdf:type")="sp:LabResult"
     161        . S ZR("sp:belongsTo")=C0SGRF ; the subject for this patient's lab results
     162        . ; ie /vista/smart/99912345/lab_results
     163        . ;
     164        . N LABNAME S LABNAME=$$ANONS^C0XF2N ; new node for lab name
     165        . S ZR("sp:labName")=LABNAME
     166        . ;
     167        . N NARRSLT S NARRSLT=$$ANONS^C0XF2N ; new node for narrative result
     168        . S ZR("sp:narrativeResult")=NARRSLT
     169        . ;
     170        . N QNTRSLT S QNTRSLT=$$ANONS^C0XF2N ; new node for narrative result
     171        . S ZR("sp:quantitativeResult")=QNTRSLT
     172        . ;
     173        . N SPECCOLL S SPECCOLL=$$ANONS^C0XF2N ; new node for specimen collected
     174        . S ZR("sp:specimenCollected")=SPECCOLL
     175        . ;
     176        . D ADDINN^C0XF2N(C0SGRF,RSLTID,.ZR) ; addIfNotNull the triples
     177        . K ZR ; clean up
     178        . ;
     179        . ; create the narrative result graph
     180        . ;
     181        . N IVAL S IVAL=$G(@LRN@("interpretation@value"))'="" D  ; H OR L
     182        . I IVAL'=""
     183        . . S ZR("rdf:type")="sp:NarrativeResult"
     184        . . S ZR("sp:value")=$G(@LRN@("interpretation@value")) ; H or L
     185        . . I ZR("sp:value")="L" S ZR("sp:value")="abnormal"
     186        . . I ZR("sp:value")="H" S ZR("sp:value")="abnormal"
     187        . . I ZR("sp:value")="HH" S ZR("sp:value")="critical"
     188        . . I ZR("sp:value")="LL" S ZR("sp:value")="critical"
     189        . . D ADDINN^C0XF2N(C0SGRF,NARRSLT,.ZR)
     190        . . K ZR
     191        . ;
     192        . ; create the quantitative result graph
     193        . ;
     194        . S ZR("rdf:type")="sp:QuantitativeResult"
     195        . N NORMNM S NORMNM=$$ANONS^C0XF2N ; new node for normal range graph
     196        . N VUNM S VUNM=$$ANONS^C0XF2N ; new node for value and unit graph
     197        . N HASNORMAL S HASNORMAL=0
     198        . I $G(@LRN@("high@value"))'="" S HASNORMAL=1
     199        . I HASNORMAL S ZR("sp:normalRange")=NORMNM
     200        . S ZR("sp:valueAndUnit")=VUNM
     201        . D ADDINN^C0XF2N(C0SGRF,QNTRSLT,.ZR)
     202        . K ZR
     203        . ;
     204        . ; create the normal range graph
     205        . ;
     206        . I HASNORMAL D  ;
     207        . . S ZR("rdf:type")="sp:ValueRange"
     208        . . N MAXNM S MAXNM=$$ANONS^C0XF2N ; new node for maximum graph
     209        . . N MINNM S MINNM=$$ANONS^C0XF2N ; new node for minimum graph
     210        . . S ZR("sp:maximum")=MAXNM
     211        . . S ZR("sp:minimum")=MINNM
     212        . . D ADDINN^C0XF2N(C0SGRF,NORMNM,.ZR)
     213        . . K ZR
     214        . . ;
     215        . . ; create the maximum graph
     216        . . ;
     217        . . S ZR("rdf:type")="sp:ValueAndUnit"
     218        . . S ZR("sp:unit")=$G(@LRN@("units@value"))
     219        . . S ZR("sp:value")=$G(@LRN@("high@value"))
     220        . . D ADDINN^C0XF2N(C0SGRF,MAXNM,.ZR)
     221        . . K ZR
     222        . . ;
     223        . . ; create the minimum graph
     224        . . ;
     225        . . S ZR("rdf:type")="sp:ValueAndUnit"
     226        . . S ZR("sp:unit")=$G(@LRN@("units@value"))
     227        . . S ZR("sp:value")=$G(@LRN@("low@value"))
     228        . . D ADDINN^C0XF2N(C0SGRF,MINNM,.ZR)
     229        . . K ZR
     230        . ;
     231        . ; create the value and unit graph
     232        . ;
     233        . S ZR("rdf:type")="sp:ValueAndUnit"
     234        . S ZR("sp:unit")=$G(@LRN@("units@value"))
     235        . I ZR("sp:unit")="" S ZR("sp:unit")="{unknown}" ; was $G(@LRN@("test@value")) gpl
     236        . S ZR("sp:value")=$G(@LRN@("result@value"))
     237        . D ADDINN^C0XF2N(C0SGRF,VUNM,.ZR)
     238        . K ZR
     239        . ;
     240        . ; create specimen collected graph
     241        . ;
     242        . S ZR("rdf:type")="sp:Attribution"
     243        . S ZR("sp:startDate")=$$SPDATE^C0SUTIL($G(@LRN@("collected@value")))
     244        . D ADDINN^C0XF2N(C0SGRF,SPECCOLL,.ZR)
     245        . K ZR
     246        . ;
     247        . ; create lab name graph - this contains the test name and code
     248        . ;
     249        . I LOINC'="" D  ;
     250        . . S ZR("rdf:type")="sp:CodedValue"
     251        . . S ZR("dcterms:title")=LABTST
     252        . . N LOINCNM S LOINCNM="loinc:"_LOINC
     253        . . S ZR("sp:code")="loinc:"_LOINC
     254        . . D ADDINN^C0XF2N(C0SGRF,LABNAME,.ZR)
     255        . . K ZR
     256        . . S ZR("dcterms:identifier")=LOINC
     257        . . S ZR("dcterms:title")=LABTST
     258        . . S ZR("rdf:type")="sp:Code"
     259        . . S ZR("sp:system")="http://loinc.org/codes/"
     260        . . D ADDINN^C0XF2N(C0SGRF,LOINCNM,.ZR)
     261        . . K ZR
     262        . ;
     263        . ; that's all for now folks (there is more to do like reference ranges
     264        . ; and result values)
     265        . ;
     266        D BULKLOAD^C0XF2N(.C0XFDA)
     267        S GRTN=C0SGRF
     268        Q
     269        ;
     270SAMPLE  ; import sample lab tests to the triplestore
     271        N GN
     272        S GN=$NA(^rdf("lab_results"))
     273        D INSRDF^C0XF2N(GN,"/smart/lab/samples")
     274        Q
     275        ;
  • smart/trunk/p/C0SMART.m

    r1569 r1571  
    1 C0SMART   ; GPL - Smart Container Entry Points;2/22/12  17:05
    2  ;;0.1;C0S;nopatch;noreleasedate;Build 2
    3  ;Copyright 2012 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 EN(ZRTN,ZPATID,ZTYP,ZFORM,DEBUG) ; return a Smart RDF file section ZTYP
    22  ;  for patient ZPATID; ZFORM defaults to rdf
    23  ; ZRTN is passed by reference
    24  ; For now, ZPATID is the DFN
    25  ;
    26  I '$D(ZFORM) S ZFORM="rdf"
    27  K ZRTN ; CLEAN RETURN
    28  N C0SARY
    29  I ZTYP="patient" D EN^C0SNHIN(.C0SARY,ZPATID,"patient")
    30  E  D EN^C0SNHIN(.C0SARY,ZPATID,"patient;"_ZTYP)
    31  I $G(C0SARY("patient",1,"id@value"))'=ZPATID D  Q  ;
    32  . W !,"Error Retreiving Patient Record"
    33  ;
    34  K C0XFDA
    35  ;
    36  N C0SGR ; graph
    37  ;
    38  ; processing table
    39  ;
    40  N C0SCTRL
    41  S C0SCTRL("med")="D MED^C0SMED(.C0SGR,.C0SARY)"
    42  S C0SCTRL("patient")="D PATIENT^C0SDEM(.C0SGR,.C0SARY)"
    43  S C0SCTRL("lab")="D LAB^C0SLAB(.C0SGR,.C0SARY)"
    44  S C0SCTRL("problem")="D PROB^C0SPROB2(.C0SGR,.C0SARY)"
    45  ;
    46  I '$D(C0SCTRL(ZTYP)) W !,ZTYP," ","Not Supported" Q  ;
    47  N ZX
    48  S ZX=C0SCTRL(ZTYP)
    49  X ZX ;
    50  ;
    51  I '$D(C0SGR) Q  ;
    52  ;
    53  D getGraph^C0XGET1(.ZRTN,C0SGR,ZFORM)
    54  ;
    55  Q
    56  ;
     1C0SMART   ; GPL - Smart Container Entry Points;2/22/12  17:05
     2        ;;1.0;VISTA SMART CONTAINER;;Sep 26, 2012;Build 4
     3        ;Copyright 2012 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
     21EN(ZRTN,ZPATID,ZTYP,ZFORM,DEBUG)        ; return a Smart RDF file section ZTYP
     22        ;  for patient ZPATID; ZFORM defaults to rdf
     23        ; ZRTN is passed by reference
     24        ; For now, ZPATID is the DFN
     25        ;
     26        I '$D(ZFORM) S ZFORM="rdf"
     27        K ZRTN ; CLEAN RETURN
     28        N C0SARY
     29        I ZTYP="patient" D EN^C0SNHIN(.C0SARY,ZPATID,"patient")
     30        E  D EN^C0SNHIN(.C0SARY,ZPATID,"patient;"_ZTYP)
     31        I $G(C0SARY("patient",1,"id@value"))'=ZPATID D  Q  ;
     32        . W !,"Error Retreiving Patient Record"
     33        ;
     34        K C0XFDA
     35        ;
     36        N C0SGR ; graph
     37        ;
     38        ; processing table
     39        ;
     40        N C0SCTRL
     41        S C0SCTRL("med")="D MED^C0SMED(.C0SGR,.C0SARY)"
     42        S C0SCTRL("patient")="D PATIENT^C0SDEM(.C0SGR,.C0SARY)"
     43        S C0SCTRL("lab")="D LAB^C0SLAB(.C0SGR,.C0SARY)"
     44        S C0SCTRL("problem")="D PROB^C0SPROB2(.C0SGR,.C0SARY)"
     45        ;
     46        I '$D(C0SCTRL(ZTYP)) W !,ZTYP," ","Not Supported" Q  ;
     47        N ZX
     48        S ZX=C0SCTRL(ZTYP)
     49        X ZX ;
     50        ;
     51        I '$D(C0SGR) Q  ;
     52        ;
     53        D getGraph^C0XGET1(.ZRTN,C0SGR,ZFORM)
     54        ;
     55        Q
     56        ;
  • smart/trunk/p/C0SMED.m

    r1569 r1571  
    1 C0SMED   ; GPL - Smart Meds Processing ;2/22/12  17:05
    2  ;;0.1;C0S;nopatch;noreleasedate;Build 2
    3  ;Copyright 2012 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 MED(GRTN,C0SARY) ; GRTN, passed by reference,
    23  ; is the return name of the graph created. "" if none
    24  ; C0SARY is passed in by reference and is the NHIN array of meds
    25  ;
    26  I $O(C0SARY("med",""))="" D  Q  ;
    27  . I $D(DEBUG) W !,"No Meds"
    28  S GRTN="" ; default to no meds
    29  N C0SGRF
    30  S C0SGRF="vistaSmart:"_ZPATID_"/"_ZTYP
    31  I $D(DEBUG) W !,"Processing ",C0SGRF
    32  D DELGRAPH^C0XF2N(C0SGRF) ; delete the old graph
    33  N MEDTRP ; MEDS TRIPLES
    34  D INITFARY^C0XF2N("C0XFARY") ; which triple store to use
    35  N FARY S FARY="C0XFARY"
    36  D USEFARY^C0XF2N(FARY)
    37  D VOCINIT^C0XUTIL
    38  ;
    39  N DUPCHK S DUPCHK="" ; check for no duplicates
    40  N ZI S ZI=""
    41  F  S ZI=$O(C0SARY("med",ZI)) Q:ZI=""  D  ;
    42  . N SDATE,SDTMP
    43  . I $G(C0SARY("med",ZI,"vaStatus@value"))="EXPIRED" D  Q  ;
    44  . . I $D(DEBUG) W !,"Expired Mediation, Skipping"
    45  . I $G(COSARY("med",ZI,"vaType@value"))="I" D  Q  ;
    46  . . I $D(DEBUG) W !,"Inpatient Med, skipping"
    47  . I $G(COSARY("med",ZI,"vaType@value"))="V" D  Q  ;
    48  . . I $D(DEBUG) W !,"IV Inpatient Med, skipping"
    49  . ;
    50  . S SDTMP=$G(C0SARY("med",ZI,"ordered@value"))
    51  . I SDTMP="" D  ;
    52  . . S SDTMP=$G(C0SARY("med",ZI,"start@value"))
    53  . S SDATE=$$FMTE^XLFDT(SDTMP,"7D") ; ordered date
    54  . S SDATE=$TR(SDATE,"/","-") ; change slashes to hyphens
    55  . I SDATE="" S SDATE="UNKNOWN"
    56  . N DNAME,VUID,DCODE,RXNORM,SIG
    57  . S DNAME=$G(C0SARY("med",ZI,"name@value"))
    58  . I DNAME="" D  ;
    59  . . S DNAME=$G(C0SARY("med",ZI,"products.product@name"))
    60  . S VUID=$G(C0SARY("med",ZI,"products.product.vaProduct@vuid"))
    61  . S DCODE=$G(C0SARY("med",ZI,"products.product.vaProduct@code"))
    62  . I DCODE="" S DCODE=$G(C0SARY("med",ZI,"id@value"))
    63  . S RXNORM=$$RXCUI(VUID) ; look up RxNorm code
    64  . I $P(RXNORM,"^",2)="RXNORM" D  ;
    65  . . S RXVER=$P(RXNORM,"^",3)
    66  . . S RXNORM=$P(RXNORM,"^",1)
    67  . E  D  Q  ;
    68  . . I $D(DEBUG) W !,"NO RXNORM NUMBER AVAILABLE"
    69  . . I $D(DEBUG) W !,RXNORM
    70  . I DNAME="" D  Q  ;
    71  . . I $D(DEBUG) W !,"Error No Drug Name"
    72  . S MEDGRF=C0SGRF_"/"_DCODE_"-"_$G(SDTMP)
    73  . I +$D(DUPCHK(MEDGRF)) D  Q  ; NO DUPS ALLOWED
    74  . . I $D(DEBUG) W !,"Found Duplicate Medication ",MEDGRF
    75  . S DUPCHK(MEDGRF)=""
    76  . I $D(DEBUG) D  ;
    77  . . W !,"Processing Medication ",MEDGRF
    78  . . W !,DNAME
    79  . . W !,RXNORM
    80  . S SIG=$G(C0SARY("med",ZI,"sig"))
    81  . I SIG["|" D  ;
    82  . . N SIGTMP
    83  . . S SIGTMP=SIG
    84  . . S SIG=$P(SIGTMP,"|",2) ; remove the drug name from the sig
    85  . . I DNAME["FREE TXT" D  ; eRx free text drug, get drug name from sig
    86  . . . S DNAME=$P(SIGTMP,"|",1) ; eRx Drug name is stored as the first piece of the sig
    87  . K C0XFARY
    88  . D ADD^C0XF2N(C0SGRF,MEDGRF,"rdf:type","sp:Medication",FARY)
    89  . D ADD^C0XF2N(C0SGRF,MEDGRF,"sp:belongsTo",C0SGRF,FARY)
    90  . N DSUBJ S DSUBJ=$$ANONS^C0XF2N ; anonomous subject
    91  . D ADD^C0XF2N(C0SGRF,MEDGRF,"sp:drugName",DSUBJ,FARY)
    92  . I SIG'="" D ADD^C0XF2N(C0SGRF,MEDGRF,"sp:instructions",SIG,FARY)
    93  . N NQTY,NQTY2,NFREQ,NFREQ2
    94  . S NQTY=$$ANONS^C0XF2N ; anonomous subject
    95  . D ADD^C0XF2N(C0SGRF,MEDGRF,"sp:quantity",NQTY,FARY)
    96  . S NQTY2=$$ANONS^C0XF2N ; anonomous subject
    97  . D ADD^C0XF2N(C0SGRF,NQTY,"sp:ValueAndUnit",NQTY2,FARY)
    98  . N DOSE S DOSE=$G(C0SARY("med",ZI,"doses.dose@dose"))
    99  . I DOSE="" S DOSE="UNKNOWN"
    100  . N UNIT S UNIT=$G(C0SARY("med",ZI,"doses.dose@units"))
    101  . I UNIT="" S UNIT="UNKNOWN"
    102  . D ADD^C0XF2N(C0SGRF,NQTY2,"sp:value",DOSE,FARY)
    103  . D ADD^C0XF2N(C0SGRF,NQTY2,"sp:unit",UNIT,FARY)
    104  . S NFREQ=$$ANONS^C0XF2N ; anonomous subject
    105  . S NFREQ2=$$ANONS^C0XF2N ; anonomous subject
    106  . D ADD^C0XF2N(C0SGRF,MEDGRF,"sp:frequency",NFREQ,FARY)
    107  . D ADD^C0XF2N(C0SGRF,NFREQ,"sp:ValueAndUnit",NFREQ2,FARY)
    108  . N SCHED S SCHED=$G(C0SARY("med",ZI,"doses.dose@schedule"))
    109  . I SCHED="" S SCHED="UNKNOWN"
    110  . N SCHUNIT S SCHUNIT=$G(C0SARY("med",ZI,"doses.dose@route"))
    111  . I SCHUNIT="" S SCHUNIT="UNKNOWN"
    112  . D ADD^C0XF2N(C0SGRF,NFREQ2,"sp:value",SCHED,FARY)
    113  . D ADD^C0XF2N(C0SGRF,NFREQ2,"sp:unit",SCHUNIT,FARY)
    114  . D ADD^C0XF2N(C0SGRF,DSUBJ,"rdf:type","sp:CodedValue",FARY)
    115  . D ADD^C0XF2N(C0SGRF,DSUBJ,"sp:code","rxnorm:"_RXNORM,FARY)
    116  . D ADD^C0XF2N(C0SGRF,"rxnorm:"_RXNORM,"rdf:type","sp:Code",FARY)
    117  . D ADD^C0XF2N(C0SGRF,"rxnorm:"_RXNORM,"dcterms:title",DNAME,FARY)
    118  . D ADD^C0XF2N(C0SGRF,"rxnorm:"_RXNORM,"sp:system","rxnorm:",FARY)
    119  . D ADD^C0XF2N(C0SGRF,"rxnorm:"_RXNORM,"dcterms:identifier",RXNORM,FARY)
    120  . D ADD^C0XF2N(C0SGRF,DSUBJ,"dcterms:title",DNAME,FARY)
    121  . D ADD^C0XF2N(C0SGRF,MEDGRF,"sp:startDate",SDATE,FARY)
    122  . D ADD^C0XF2N(C0SGRF,"rxnorm:"_RXNORM,"rdf:type","http://smartplatforms.org/terms/codes/RxNorm_Semantic",FARY)
    123  . D BULKLOAD^C0XF2N(.C0XFDA)
    124  . K C0XFDA
    125  S GRTN=C0SGRF
    126  q
    127  ;
    128 RXNFN() Q 1130590011.001 ; RxNorm Concepts file number
    129  ;
    130 RXCUI(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF
    131  ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR
    132  N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT
    133  I $G(ZVUID)="" Q ""
    134  I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED
    135  N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID")
    136  S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES
    137  N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01)
    138  S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED
    139  I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F"
    140  Q ZRSLT
    141  ;
    142 NISTMAP(ZRXN) ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO
    143  ; CONFORM TO NIST REQUIREMENTS
    144  ;INPATIENT CERTIFICATION
    145  I ZRXN=309362 S ZRXN=213169
    146  I ZRXN=855318 S ZRXN=855320
    147  I ZRXN=197361 S ZRXN=212549
    148  ;OUTPATIENT CERTIFICATION
    149  I ZRXN=310534 S ZRXN=205875
    150  I ZRXN=617312 S ZRXN=617314
    151  I ZRXN=310429 S ZRXN=200801
    152  I ZRXN=628953 S ZRXN=628958
    153  I ZRXN=745679 S ZRXN=630208
    154  I ZRXN=311564 S ZRXN=979334
    155  I ZRXN=836343 S ZRXN=836370
    156  Q ZRXN
    157  ;
     1C0SMED    ; GPL - Smart Meds Processing ;2/22/12  17:05
     2        ;;1.0;VISTA SMART CONTAINER;;Sep 26, 2012;Build 4
     3        ;Copyright 2012 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        ;
     22MED(GRTN,C0SARY)        ; GRTN, passed by reference,
     23        ; is the return name of the graph created. "" if none
     24        ; C0SARY is passed in by reference and is the NHIN array of meds
     25        ;
     26        I $O(C0SARY("med",""))="" D  Q  ;
     27        . I $D(DEBUG) W !,"No Meds"
     28        S GRTN="" ; default to no meds
     29        N C0SGRF
     30        S C0SGRF="vistaSmart:"_ZPATID_"/"_ZTYP
     31        I $D(DEBUG) W !,"Processing ",C0SGRF
     32        D DELGRAPH^C0XF2N(C0SGRF) ; delete the old graph
     33        N MEDTRP ; MEDS TRIPLES
     34        D INITFARY^C0XF2N("C0XFARY") ; which triple store to use
     35        N FARY S FARY="C0XFARY"
     36        D USEFARY^C0XF2N(FARY)
     37        D VOCINIT^C0XUTIL
     38        ;
     39        N DUPCHK S DUPCHK="" ; check for no duplicates
     40        N ZI S ZI=""
     41        F  S ZI=$O(C0SARY("med",ZI)) Q:ZI=""  D  ;
     42        . N SDATE,SDTMP
     43        . I $G(C0SARY("med",ZI,"vaStatus@value"))="EXPIRED" D  Q  ;
     44        . . I $D(DEBUG) W !,"Expired Mediation, Skipping"
     45        . I $G(COSARY("med",ZI,"vaType@value"))="I" D  Q  ;
     46        . . I $D(DEBUG) W !,"Inpatient Med, skipping"
     47        . I $G(COSARY("med",ZI,"vaType@value"))="V" D  Q  ;
     48        . . I $D(DEBUG) W !,"IV Inpatient Med, skipping"
     49        . ;
     50        . S SDTMP=$G(C0SARY("med",ZI,"ordered@value"))
     51        . I SDTMP="" D  ;
     52        . . S SDTMP=$G(C0SARY("med",ZI,"start@value"))
     53        . S SDATE=$$FMTE^XLFDT(SDTMP,"7D") ; ordered date
     54        . S SDATE=$TR(SDATE,"/","-") ; change slashes to hyphens
     55        . I SDATE="" S SDATE="UNKNOWN"
     56        . N DNAME,VUID,DCODE,RXNORM,SIG
     57        . S DNAME=$G(C0SARY("med",ZI,"name@value"))
     58        . I DNAME="" D  ;
     59        . . S DNAME=$G(C0SARY("med",ZI,"products.product@name"))
     60        . S VUID=$G(C0SARY("med",ZI,"products.product.vaProduct@vuid"))
     61        . S DCODE=$G(C0SARY("med",ZI,"products.product.vaProduct@code"))
     62        . I DCODE="" S DCODE=$G(C0SARY("med",ZI,"id@value"))
     63        . S RXNORM=$$RXCUI(VUID) ; look up RxNorm code
     64        . I $P(RXNORM,"^",2)="RXNORM" D  ;
     65        . . S RXVER=$P(RXNORM,"^",3)
     66        . . S RXNORM=$P(RXNORM,"^",1)
     67        . E  D  Q  ;
     68        . . I $D(DEBUG) W !,"NO RXNORM NUMBER AVAILABLE"
     69        . . I $D(DEBUG) W !,RXNORM
     70        . I DNAME="" D  Q  ;
     71        . . I $D(DEBUG) W !,"Error No Drug Name"
     72        . S MEDGRF=C0SGRF_"/"_DCODE_"-"_$G(SDTMP)
     73        . I +$D(DUPCHK(MEDGRF)) D  Q  ; NO DUPS ALLOWED
     74        . . I $D(DEBUG) W !,"Found Duplicate Medication ",MEDGRF
     75        . S DUPCHK(MEDGRF)=""
     76        . I $D(DEBUG) D  ;
     77        . . W !,"Processing Medication ",MEDGRF
     78        . . W !,DNAME
     79        . . W !,RXNORM
     80        . S SIG=$G(C0SARY("med",ZI,"sig"))
     81        . I SIG["|" D  ;
     82        . . N SIGTMP
     83        . . S SIGTMP=SIG
     84        . . S SIG=$P(SIGTMP,"|",2) ; remove the drug name from the sig
     85        . . I DNAME["FREE TXT" D  ; eRx free text drug, get drug name from sig
     86        . . . S DNAME=$P(SIGTMP,"|",1) ; eRx Drug name is stored as the first piece of the sig
     87        . K C0XFARY
     88        . D ADD^C0XF2N(C0SGRF,MEDGRF,"rdf:type","sp:Medication",FARY)
     89        . D ADD^C0XF2N(C0SGRF,MEDGRF,"sp:belongsTo",C0SGRF,FARY)
     90        . N DSUBJ S DSUBJ=$$ANONS^C0XF2N ; anonomous subject
     91        . D ADD^C0XF2N(C0SGRF,MEDGRF,"sp:drugName",DSUBJ,FARY)
     92        . I SIG'="" D ADD^C0XF2N(C0SGRF,MEDGRF,"sp:instructions",SIG,FARY)
     93        . N NQTY,NQTY2,NFREQ,NFREQ2
     94        . S NQTY=$$ANONS^C0XF2N ; anonomous subject
     95        . D ADD^C0XF2N(C0SGRF,MEDGRF,"sp:quantity",NQTY,FARY)
     96        . S NQTY2=$$ANONS^C0XF2N ; anonomous subject
     97        . D ADD^C0XF2N(C0SGRF,NQTY,"sp:ValueAndUnit",NQTY2,FARY)
     98        . N DOSE S DOSE=$G(C0SARY("med",ZI,"doses.dose@dose"))
     99        . I DOSE="" S DOSE="UNKNOWN"
     100        . N UNIT S UNIT=$G(C0SARY("med",ZI,"doses.dose@units"))
     101        . I UNIT="" S UNIT="UNKNOWN"
     102        . D ADD^C0XF2N(C0SGRF,NQTY2,"sp:value",DOSE,FARY)
     103        . D ADD^C0XF2N(C0SGRF,NQTY2,"sp:unit",UNIT,FARY)
     104        . S NFREQ=$$ANONS^C0XF2N ; anonomous subject
     105        . S NFREQ2=$$ANONS^C0XF2N ; anonomous subject
     106        . D ADD^C0XF2N(C0SGRF,MEDGRF,"sp:frequency",NFREQ,FARY)
     107        . D ADD^C0XF2N(C0SGRF,NFREQ,"sp:ValueAndUnit",NFREQ2,FARY)
     108        . N SCHED S SCHED=$G(C0SARY("med",ZI,"doses.dose@schedule"))
     109        . I SCHED="" S SCHED="UNKNOWN"
     110        . N SCHUNIT S SCHUNIT=$G(C0SARY("med",ZI,"doses.dose@route"))
     111        . I SCHUNIT="" S SCHUNIT="UNKNOWN"
     112        . D ADD^C0XF2N(C0SGRF,NFREQ2,"sp:value",SCHED,FARY)
     113        . D ADD^C0XF2N(C0SGRF,NFREQ2,"sp:unit",SCHUNIT,FARY)
     114        . D ADD^C0XF2N(C0SGRF,DSUBJ,"rdf:type","sp:CodedValue",FARY)
     115        . D ADD^C0XF2N(C0SGRF,DSUBJ,"sp:code","rxnorm:"_RXNORM,FARY)
     116        . D ADD^C0XF2N(C0SGRF,"rxnorm:"_RXNORM,"rdf:type","sp:Code",FARY)
     117        . D ADD^C0XF2N(C0SGRF,"rxnorm:"_RXNORM,"dcterms:title",DNAME,FARY)
     118        . D ADD^C0XF2N(C0SGRF,"rxnorm:"_RXNORM,"sp:system","rxnorm:",FARY)
     119        . D ADD^C0XF2N(C0SGRF,"rxnorm:"_RXNORM,"dcterms:identifier",RXNORM,FARY)
     120        . D ADD^C0XF2N(C0SGRF,DSUBJ,"dcterms:title",DNAME,FARY)
     121        . D ADD^C0XF2N(C0SGRF,MEDGRF,"sp:startDate",SDATE,FARY)
     122        . D ADD^C0XF2N(C0SGRF,"rxnorm:"_RXNORM,"rdf:type","http://smartplatforms.org/terms/codes/RxNorm_Semantic",FARY)
     123        . D BULKLOAD^C0XF2N(.C0XFDA)
     124        . K C0XFDA
     125        S GRTN=C0SGRF
     126        q
     127        ;
     128RXNFN() Q 1130590011.001 ; RxNorm Concepts file number
     129        ;
     130RXCUI(ZVUID)    ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF
     131        ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR
     132        N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT
     133        I $G(ZVUID)="" Q ""
     134        I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED
     135        N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID")
     136        S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES
     137        N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01)
     138        S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED
     139        I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F"
     140        Q ZRSLT
     141        ;
     142NISTMAP(ZRXN)   ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO
     143        ; CONFORM TO NIST REQUIREMENTS
     144        ;INPATIENT CERTIFICATION
     145        I ZRXN=309362 S ZRXN=213169
     146        I ZRXN=855318 S ZRXN=855320
     147        I ZRXN=197361 S ZRXN=212549
     148        ;OUTPATIENT CERTIFICATION
     149        I ZRXN=310534 S ZRXN=205875
     150        I ZRXN=617312 S ZRXN=617314
     151        I ZRXN=310429 S ZRXN=200801
     152        I ZRXN=628953 S ZRXN=628958
     153        I ZRXN=745679 S ZRXN=630208
     154        I ZRXN=311564 S ZRXN=979334
     155        I ZRXN=836343 S ZRXN=836370
     156        Q ZRXN
     157        ;
  • smart/trunk/p/C0SMXMLB.m

    r1569 r1571  
    1 MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09  16:55 - Smart Container Ver.
    2  ;;8.0;KERNEL;;;Build 2
    3  QUIT
    4  ;
    5  ;DOC - The top level tag
    6  ;DOCTYPE - Want to include a DOCTYPE node
    7  ;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J,
    8 START(DOC,DOCTYPE,FLAG,NO1ST) ;Call this once at the begining.
    9  K ^TMP("MXMLBLD",$J)
    10  S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0
    11  I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1
    12  I $G(NO1ST)'=1 D OUTPUT($$XMLHDR)
    13  D:$L($G(DOCTYPE)) OUTPUT("<!DOCTYPE "_DOCTYPE_">") D OUTPUT("<"_DOC_">")
    14  Q
    15  ;
    16 END ;Call this once to close out the document
    17  D OUTPUT("</"_$G(^TMP("MXMLBLD",$J,"DOC"))_">")
    18  I '$G(^TMP("MXMLBLD",$J,"CNT")) K ^TMP("MXMLBLD",$J)
    19  K ^TMP("MXMLBLD",$J,"DOC"),^("CNT"),^("STK")
    20  Q
    21  ;
    22 ITEM(INDENT,TAG,ATT,VALUE) ;Output a Item
    23  N I,X
    24  S ATT=$G(ATT)
    25  I '$D(VALUE) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_" />") Q
    26  D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">"_$$CHARCHK(VALUE)_"</"_TAG_">")
    27  Q
    28  ;DOITEM is a callback to output the lower level.
    29 MULTI(INDENT,TAG,ATT,DOITEM) ;Output a Multipule
    30  N I,X,S
    31  S ATT=$G(ATT)
    32  D PUSH($G(INDENT),TAG,.ATT)
    33  D @DOITEM
    34  D POP
    35  Q
    36  ;
    37 ATT(ATT) ;Output a string of attributes
    38  I $D(ATT)<9 Q ""
    39  N I,S,V
    40  S S="",I=""
    41  F  S I=$O(ATT(I)) Q:I=""  S S=S_" "_I_"="_$$Q(ATT(I))
    42  Q S
    43  ;
    44 Q(X) ;Add Quotes - Changed by gpl to use single instead of double quotes 6/11
    45  ;I X'[$C(34) Q $C(34)_X_$C(34)
    46  I X'[$C(39) Q $C(39)_X_$C(39)
    47  ;N Q,Y,I,Z S Q=$C(34),(Y,Z)=""
    48  N Q,Y,I,Z S Q=$C(39),(Y,Z)=""
    49  F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q
    50  S Y=Y_$P(X,Q,$L(X,Q))
    51  ;Q $C(34)_Y_$C(34)
    52  Q $C(39)_Y_$C(39)
    53  ;
    54 XMLHDR() ; -- provides current XML standard header
    55  Q "<?xml version=""1.0"" encoding=""utf-8"" ?>"
    56  ;
    57 OUTPUT(S) ;Output
    58  N C S C=$G(^TMP("MXMLBLD",$J,"CNT"))
    59  I C S ^TMP("MXMLBLD",$J,C)=S,^TMP("MXMLBLD",$J,"CNT")=C+1 Q
    60  W S,!
    61  Q
    62  ;
    63 CHARCHK(STR) ; -- replace xml character limits with entities
    64  N A,I,X,Y,Z,NEWSTR
    65  S (Y,Z)=""
    66  ;IF STR["&" SET NEWSTR=STR DO  SET STR=Y_Z
    67  ;. FOR X=1:1  SET Y=Y_$PIECE(NEWSTR,"&",X)_"&amp;",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&"
    68  I STR["&" F I=1:1:$L(STR,"&")-1 S STR=$P(STR,"&",1,I)_"&amp;"_$P(STR,"&",I+1,999)
    69  I STR["<" F  S STR=$PIECE(STR,"<",1)_"&lt;"_$PIECE(STR,"<",2,99) Q:STR'["<"
    70  I STR[">" F  S STR=$PIECE(STR,">",1)_"&gt;"_$PIECE(STR,">",2,99) Q:STR'[">"
    71  I STR["'" F  S STR=$PIECE(STR,"'",1)_"&apos;"_$PIECE(STR,"'",2,99) Q:STR'["'"
    72  I STR["""" F  S STR=$PIECE(STR,"""",1)_"&quot;"_$PIECE(STR,"""",2,99) Q:STR'[""""
    73  ;
    74  S STR=$TR(STR,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31))
    75  QUIT STR
    76  ;
    77 COMMENT(VAL) ;Add Comments
    78  N I,L
    79  ;I $D($G(VAL))=1 D OUTPUT("<!-- "_ATT_" -->") Q
    80  I $D(VAL) D OUTPUT("<!-- "_ATT_" -->") Q  ;CHANGED BY GPL FOR GTM
    81  S I="",L="<!--"
    82  F  S I=$O(ATT(I)) Q:I=""  D OUTPUT(L_ATT(I)) S L=""
    83  D OUTPUT("-->")
    84  Q
    85  ;
    86 PUSH(INDENT,TAG,ATT) ;Write a TAG and save.
    87  N CNT
    88  S ATT=$G(ATT)
    89  D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">")
    90  S CNT=$G(^TMP("MXMLBLD",$J,"STK"))+1,^TMP("MXMLBLD",$J,"STK")=CNT,^TMP("MXMLBLD",$J,"STK",CNT)=INDENT_"^"_TAG
    91  Q
    92  ;
    93 POP ;Write last pushed tag and pop
    94  N CNT,TAG,INDENT,X
    95  S CNT=$G(^TMP("MXMLBLD",$J,"STK")),X=^TMP("MXMLBLD",$J,"STK",CNT),^TMP("MXMLBLD",$J,"STK")=CNT-1
    96  S INDENT=+X,TAG=$P(X,"^",2)
    97  D OUTPUT($$BLS(INDENT)_"</"_TAG_">")
    98  Q
    99  ;
    100 BLS(I) ;Return INDENT string
    101  N S
    102  S S="",I=$G(I) S:I>0 $P(S," ",I)=" "
    103  Q S
    104  ;
    105 INDENT() ;Renturn indent level
    106  Q +$G(^TMP("MXMLBLD",$J,"STK"))
     1MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09  16:55 - Smart Container Ver.
     2        ;;1.0;VISTA SMART CONTAINER;;Sep 26, 2012;Build 4
     3        QUIT
     4        ;
     5        ;DOC - The top level tag
     6        ;DOCTYPE - Want to include a DOCTYPE node
     7        ;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J,
     8START(DOC,DOCTYPE,FLAG,NO1ST)   ;Call this once at the begining.
     9        K ^TMP("MXMLBLD",$J)
     10        S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0
     11        I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1
     12        I $G(NO1ST)'=1 D OUTPUT($$XMLHDR)
     13        D:$L($G(DOCTYPE)) OUTPUT("<!DOCTYPE "_DOCTYPE_">") D OUTPUT("<"_DOC_">")
     14        Q
     15        ;
     16END     ;Call this once to close out the document
     17        D OUTPUT("</"_$G(^TMP("MXMLBLD",$J,"DOC"))_">")
     18        I '$G(^TMP("MXMLBLD",$J,"CNT")) K ^TMP("MXMLBLD",$J)
     19        K ^TMP("MXMLBLD",$J,"DOC"),^("CNT"),^("STK")
     20        Q
     21        ;
     22ITEM(INDENT,TAG,ATT,VALUE)      ;Output a Item
     23        N I,X
     24        S ATT=$G(ATT)
     25        I '$D(VALUE) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_" />") Q
     26        D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">"_$$CHARCHK(VALUE)_"</"_TAG_">")
     27        Q
     28        ;DOITEM is a callback to output the lower level.
     29MULTI(INDENT,TAG,ATT,DOITEM)    ;Output a Multipule
     30        N I,X,S
     31        S ATT=$G(ATT)
     32        D PUSH($G(INDENT),TAG,.ATT)
     33        D @DOITEM
     34        D POP
     35        Q
     36        ;
     37ATT(ATT)        ;Output a string of attributes
     38        I $D(ATT)<9 Q ""
     39        N I,S,V
     40        S S="",I=""
     41        F  S I=$O(ATT(I)) Q:I=""  S S=S_" "_I_"="_$$Q(ATT(I))
     42        Q S
     43        ;
     44Q(X)    ;Add Quotes - Changed by gpl to use single instead of double quotes 6/11
     45        ;I X'[$C(34) Q $C(34)_X_$C(34)
     46        I X'[$C(39) Q $C(39)_X_$C(39)
     47        ;N Q,Y,I,Z S Q=$C(34),(Y,Z)=""
     48        N Q,Y,I,Z S Q=$C(39),(Y,Z)=""
     49        F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q
     50        S Y=Y_$P(X,Q,$L(X,Q))
     51        ;Q $C(34)_Y_$C(34)
     52        Q $C(39)_Y_$C(39)
     53        ;
     54XMLHDR()        ; -- provides current XML standard header
     55        Q "<?xml version=""1.0"" encoding=""utf-8"" ?>"
     56        ;
     57OUTPUT(S)       ;Output
     58        N C S C=$G(^TMP("MXMLBLD",$J,"CNT"))
     59        I C S ^TMP("MXMLBLD",$J,C)=S,^TMP("MXMLBLD",$J,"CNT")=C+1 Q
     60        W S,!
     61        Q
     62        ;
     63CHARCHK(STR)    ; -- replace xml character limits with entities
     64        N A,I,X,Y,Z,NEWSTR
     65        S (Y,Z)=""
     66        ;IF STR["&" SET NEWSTR=STR DO  SET STR=Y_Z
     67        ;. FOR X=1:1  SET Y=Y_$PIECE(NEWSTR,"&",X)_"&amp;",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&"
     68        I STR["&" F I=1:1:$L(STR,"&")-1 S STR=$P(STR,"&",1,I)_"&amp;"_$P(STR,"&",I+1,999)
     69        I STR["<" F  S STR=$PIECE(STR,"<",1)_"&lt;"_$PIECE(STR,"<",2,99) Q:STR'["<"
     70        I STR[">" F  S STR=$PIECE(STR,">",1)_"&gt;"_$PIECE(STR,">",2,99) Q:STR'[">"
     71        I STR["'" F  S STR=$PIECE(STR,"'",1)_"&apos;"_$PIECE(STR,"'",2,99) Q:STR'["'"
     72        I STR["""" F  S STR=$PIECE(STR,"""",1)_"&quot;"_$PIECE(STR,"""",2,99) Q:STR'[""""
     73        ;
     74        S STR=$TR(STR,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31))
     75        QUIT STR
     76        ;
     77COMMENT(VAL)    ;Add Comments
     78        N I,L
     79        ;I $D($G(VAL))=1 D OUTPUT("<!-- "_ATT_" -->") Q
     80        I $D(VAL) D OUTPUT("<!-- "_ATT_" -->") Q  ;CHANGED BY GPL FOR GTM
     81        S I="",L="<!--"
     82        F  S I=$O(ATT(I)) Q:I=""  D OUTPUT(L_ATT(I)) S L=""
     83        D OUTPUT("-->")
     84        Q
     85        ;
     86PUSH(INDENT,TAG,ATT)    ;Write a TAG and save.
     87        N CNT
     88        S ATT=$G(ATT)
     89        D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">")
     90        S CNT=$G(^TMP("MXMLBLD",$J,"STK"))+1,^TMP("MXMLBLD",$J,"STK")=CNT,^TMP("MXMLBLD",$J,"STK",CNT)=INDENT_"^"_TAG
     91        Q
     92        ;
     93POP     ;Write last pushed tag and pop
     94        N CNT,TAG,INDENT,X
     95        S CNT=$G(^TMP("MXMLBLD",$J,"STK")),X=^TMP("MXMLBLD",$J,"STK",CNT),^TMP("MXMLBLD",$J,"STK")=CNT-1
     96        S INDENT=+X,TAG=$P(X,"^",2)
     97        D OUTPUT($$BLS(INDENT)_"</"_TAG_">")
     98        Q
     99        ;
     100BLS(I)  ;Return INDENT string
     101        N S
     102        S S="",I=$G(I) S:I>0 $P(S," ",I)=" "
     103        Q S
     104        ;
     105INDENT()        ;Renturn indent level
     106        Q +$G(^TMP("MXMLBLD",$J,"STK"))
  • smart/trunk/p/C0SNHIN.m

    r1569 r1571  
    1 C0SNHIN   ; GPL - Smart Container - OUTPUT OF NHINV ROUTINES;6/3/11  17:05
    2  ;;0.1;C0S;nopatch;noreleasedate;Build 2
    3  ;Copyright 2011-2012 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 EN(ZRTN,ZDFN,ZPART,KEEP) ; GENERATE AN NHIN ARRAY FOR A PATIENT
    22  ;
    23  K GARY,GNARY,GIDX,C0SDOCID
    24  K ZRTN
    25  N GN
    26  K ^TMP("NHINV",$J) ; CLEAN UP FROM LAST CALL
    27  K ^TMP("MXMLDOM",$J) ; CLEAN UP DOM
    28  K ^TMP("MXMLERR",$J) ; CLEAN UP MXML ERRORS
    29  D GET^C0SNHINV(.GN,ZDFN,ZPART) ; CALL NHINV ROUTINES TO PULL XML
    30  S GN=$P(GN,")",1)_")" ; CUT OFF THE REST OF LINE PROTOCOL
    31  S C0SDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML
    32  D DOMO^C0SDOM(C0SDOCID,"/","ZRTN","GIDX","GARY",,"/results/") ; BLD ARRAYS
    33  I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
    34  ;D PROCESS("ZRTN",GN,"/result/",$G(KEEP))
    35  Q
    36  ;
    37 PQRI(ZOUT,KEEP) ; RETURN THE NHIN ARRAY FOR THE PQRI XML TEMPLATE
    38  ;
    39  N ZG
    40  S ZG=$NA(^TMP("PQRIXML",$J))
    41  K @ZG
    42  D GETXML^C0SMXP(ZG,"PQRIXML") ; GET THE XML FROM C0S MISC XML
    43  N C0SDOCID
    44  S C0SDOCID=$$PARSE^C0SDOM(ZG,"PQRIXML") ; PARSE THE XML
    45  D DOMO^C0SDOM(C0SDOCID,"/","ZOUT","GIDX","GARY",,"//submission") ; BLD ARRAYS
    46  I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
    47  Q
    48  ;
    49 PQRI2(ZRTN) ; RETURN THE NHIN ARRAY FOR PQRI ONE MEASURE
    50  ;
    51  ;N GG
    52  D GETXML^C0SMXP("GG","PQRI ONE MEASURE")
    53  D PROCESS(ZRTN,"GG","root",1)
    54  Q
    55  ;
    56 PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP) ; PARSE AND RUN DOMO ON XML
    57  ; ZRTN IS PASSED BY REFERENCE
    58  ; ZXML IS PASSED BY NAME
    59  ; IF KEEP IS 1, GARY AND GIDX ARE NOT KILLED
    60  ;
    61  N GN
    62  S GN=$NA(^TMP("C0SPROCESS",$J))
    63  K @GN
    64  M @GN=@ZXML
    65  S C0SDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML
    66  K @GN
    67  D DOMO^C0SDOM(C0SDOCID,"/","ZRSLT","GIDX","GARY",,$G(ZREDUCE)) ; BLD ARRAYS
    68  I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
    69  Q
    70  ;
    71 LOADSMRT ;
    72  ;
    73  K ^GPL("SMART")
    74  S GN=$NA(^GPL("SMART",1))
    75  I $$FTG^%ZISH("/home/george/","alex-lewis2.xml",GN,2) W !,"SMART FILE LOADED"
    76  Q
    77  ;
    78 SMART ; TRY IT WITH SMART
    79  ;
    80  S GN=$NA(^GPL("SMART"))
    81  ;K ^TMP("MXMLDOM",$J)
    82  K ^TMP("MXMLERR",$J)
    83  S C0SDOCID=$$PARSE(GN,"SMART")
    84  D DOMO^C0SDOM(C0SDOCID,"/","GNARY","GIDX","GARY",,"//rdf:RDF/")
    85  ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
    86  Q
    87  ;
    88 CCR ; TRY IT WITH A CCR
    89  ;
    90  S GN=$NA(^GPL("CCR"))
    91  ;K ^TMP("MXMLDOM",$J)
    92  K ^TMP("MXMLERR",$J)
    93  S C0SDOCID=$$PARSE(GN,"CCR")
    94  D DOMO^C0SDOM(C0SDOCID,"/","GNARY","GIDX","GARY",,"//ContinuityOfCareRecord/Body/")
    95  ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
    96  Q
    97  ;
    98 MED ; TRY IT WITH A CCR MED SECTION
    99  ;
    100  S GN=$NA(^GPL("MED"))
    101  K ^TMP("MXMLDOM",$J)
    102  K ^TMP("MXMLERR",$J)
    103  S C0SDOCID=$$PARSE(GN,"MED")
    104  D DOMO^C0SDOM(C0SDOCID,"/","GNARY","GIDX","GARY",,"//Medications/")
    105  ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
    106  Q
    107  ;
    108 CCD ; TRY IT WITH A CCD
    109  ;
    110  S GN=$NA(^GPL("CCD"))
    111  ;K ^TMP("MXMLDOM",$J)
    112  K ^TMP("MXMLERR",$J)
    113  S C0SDOCID=$$PARSE(GN,"CCD")
    114  D DOMO^C0SDOM(C0SDOCID,"/","GNARY","GIDX","GARY",,"//ClinicalDocument/component/structuredBody/")
    115  ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
    116  Q
    117  ;
    118 TEST1 ; TEST NHINV OUTPUT IN ^GPL("NIHIN")
    119  ; PARSED WITH MXML
    120  ; RUN THROUGH XPATH
    121  K GARY,GIDX,C0SDOCID
    122  S GN=$NA(^GPL("NHIN"))
    123  ;S GN=$NA(^GPL("DOMI"))
    124  S C0SDOCID=$$PARSE(GN,"GPLTEST")
    125  D DOMO^C0SDOM(C0SDOCID,"/","GNARY","GIDX","GARY",,"/results/")
    126  K ^GPL("GNARY")
    127  M ^GPL("GNARY")=GNARY
    128  Q
    129  ;
    130 TEST2 ; PUT GNARY THROUGH DOMI AND STORE XML IN ^GPL("DOMI")
    131  ;
    132  S GN=$NA(^GPL("GNARY"))
    133  S C0SDOCID=$$DOMI^C0SDOM(GN,,"results")
    134  D OUTXML^C0SDOM("G",C0SDOCID)
    135  K ^GPL("DOMI")
    136  M ^GPL("DOMI")=G
    137  Q
    138  ;
    139 TEST3 ; TEST NHINV OUTPUT IN ^GPL("NIHIN")
    140  ; PARSED WITH MXML
    141  ; RUN THROUGH XPATH
    142  K GARY,GIDX,C0SDOCID
    143  ;S GN=$NA(^GPL("NHIN"))
    144  S GN=$NA(^GPL("DOMI"))
    145  S C0SDOCID=$$PARSE(GN,"GPLTEST")
    146  D DOMO^C0SDOM(C0SDOCID,"/","GNARY","GIDX","GARY",,"/results/")
    147  Q
    148  ;
    149 DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE
    150  ; THE XPATH INDEX ZXIDX, PASSED BY NAME
    151  ; THE XPATH ARRAY XPARY, PASSED BY NAME
    152  ; ZOID IS THE STARTING OID
    153  ; ZPATH IS THE STARTING XPATH, USUALLY "/"
    154  ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
    155  ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
    156  I $G(ZREDUX)="" S ZREDUX=""
    157  N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY
    158  N NEWNUM S NEWNUM=""
    159  I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
    160  S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
    161  I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
    162  . N GT S GT=$P(NEWPATH,ZREDUX,2)
    163  . I GT'="" S NEWPATH=GT
    164  S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
    165  N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE
    166  I $D(GA) D  ; PROCESS THE ATTRIBUTES
    167  . N ZI S ZI=""
    168  . F  S ZI=$O(GA(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
    169  . . N ZP S ZP=NEWPATH_"/"_ZI ; PATH FOR ATTRIBUTE
    170  . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY
    171  . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE
    172  N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
    173  I $D(GD(2)) D  ;
    174  . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
    175  E  I $D(GD(1)) D  ;
    176  . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
    177  . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY
    178  N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
    179  I ZFRST'=0 D  ; THERE IS A CHILD
    180  . N ZNUM
    181  . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
    182  . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD
    183  N GNXT S GNXT=$$NXTSIB(ZOID)
    184  I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES
    185  I GNXT'=0 D  ;
    186  . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE?
    187  . I (ZNUM="")&(ZMULT) D  ; SIBLING IS FIRST OF MULTIPLES
    188  . . N ZNUM S ZNUM=1 ;
    189  . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
    190  . E  D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB
    191  Q
    192  ;
    193 ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY
    194  ;
    195  N ZZI,ZZJ,ZZN
    196  S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY
    197  I ZZI="" Q  ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE
    198  S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY
    199  S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH .
    200  I ZZI'["]" D  ; A SINGLETON
    201  . S ZZN=1
    202  E  D  ; THERE IS AN [x] OCCURANCE
    203  . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE
    204  . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X]
    205  I ZZJ'="" S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE
    206  Q
    207  ;
    208 PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME
    209  ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW
    210  ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML
    211  ;Q $$EN^MXMLDOM(INXML)
    212  Q $$EN^MXMLDOM(INXML,"W")
    213  ;
    214 ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
    215  N ZN
    216  ;I $$TAG(ZOID)["entry" B
    217  S ZN=$$NXTSIB(ZOID)
    218  I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
    219  Q 0
    220  ;
    221 FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
    222  Q $$CHILD^MXMLDOM(C0SDOCID,ZOID)
    223  ;
    224 PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID
    225  Q $$PARENT^MXMLDOM(C0SDOCID,ZOID)
    226  ;
    227 ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID
    228  S HANDLE=C0SDOCID
    229  K @RTN
    230  D GETTXT^MXMLDOM("A")
    231  Q
    232  ;
    233 TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE
    234  ;I ZOID=149 B ;GPLTEST
    235  N X,Y
    236  S Y=""
    237  S X=$G(C0SCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
    238  I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
    239  I Y="" S Y=$$NAME^MXMLDOM(C0SDOCID,ZOID)
    240  Q Y
    241  ;
    242 NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING
    243  Q $$SIBLING^MXMLDOM(C0SDOCID,ZOID)
    244  ;
    245 DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE
    246  ;N ZT,ZN S ZT=""
    247  ;S C0SDOM=$NA(^TMP("MXMLDOM",$J,C0SDOCID))
    248  ;Q $G(@C0SDOM@(ZOID,"T",1))
    249  S ZN=$$TEXT^MXMLDOM(C0SDOCID,ZOID,ZT)
    250  Q
    251  ;
    252 OUTXML(ZRTN,INID) ; USES C0SMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM
    253  ;
    254  S C0SDOCID=INID
    255  D START^C0SMXMLB($$TAG(1),,"G")
    256  D NDOUT($$FIRST(1))
    257  D END^C0SMXMLB ;END THE DOCUMENT
    258  M @ZRTN=^TMP("MXMLBLD",$J)
    259  K ^TMP("MXMLBLD",$J)
    260  Q
    261  ;
    262 NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE
    263  N ZI S ZI=$$FIRST(ZOID)
    264  I ZI'=0 D  ; THERE IS A CHILD
    265  . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT
    266  . D MULTI^C0SMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0SMXML(ZI)") ;HAVE CHILDREN
    267  E  D  ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT
    268  . ;W "DOING",ZOID,!
    269  . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA
    270  . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES
    271  . D ITEM^C0SMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN
    272  I $$NXTSIB(ZOID)'=0 D  ; THERE IS A SIBLING
    273  . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS
    274  Q
    275  ;
    276 WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE
    277  ;
    278  N GN,GN2
    279  D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML
    280  S GN2=$NA(@GN@(1))
    281  W $$OUTPUT^C0SXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/")
    282  Q
    283  ;
    284 TESTNARY ; TEST MAKING A NHIN ARRAY
    285  N ZI S ZI=""
    286  N ZH ; DOM HANDLE
    287  D TEST1 ; PARSE AN NHIN RESULT INTO THE DOM
    288  S ZH=C0SDOCID ; SET THE HANDLE
    289  N ZD S ZD=$NA(^TMP("MXMLDOM",$J,ZH))
    290  F  S ZI=$O(@ZD@(ZI)) Q:ZI=""  D  ; FOR EACH NODE
    291  . N ZATT
    292  . D MNARY(.ZATT,ZH,ZI)
    293  . N ZPRE,ZN
    294  . S ZPRE=$$PRE(ZI)
    295  . S ZN=$P(ZPRE,",",2)
    296  . S ZPRE=$P(ZPRE,",",1)
    297  . ;I $D(ZATT) ZWR ZATT
    298  . N ZJ S ZJ=""
    299  . F  S ZJ=$O(ZATT(ZJ)) Q:ZJ=""  D  ; FOR EACH ATTRIBUTE
    300  . . W ZPRE_"["_ZN_"]"_$$TAG(ZI)_"."_ZJ_"="_ZATT(ZJ),!
    301  . . S GOUT(ZPRE,ZN,$$TAG(ZI)_"."_ZJ)=ZATT(ZJ)
    302  Q
    303  ;
    304 PRE(ZNODE) ; EXTRINSIC WHICH RETURNS THE PREFIX FOR A NODE
    305  ;
    306  N GI,GI2,GPT,GJ,GN
    307  S GI=$$PARENT(ZNODE) ; PARENT NODE
    308  I GI=0 Q ""  ; NO PARENT
    309  S GPT=$$TAG(GI) ; TAG OF PARENT
    310  S GI2=$$PARENT(GI) ; PARENT OF PARENT
    311  I (GI2'=0)&($$TAG(GI2)'="results") S GPT=$$TAG(GI2)_"."_GPT
    312  S GJ=$$FIRST(GI) ; NODE OF FIRST SIB
    313  I GJ=ZNODE Q:$$TAG(GI)_",1"
    314  F GN=2:1 Q:GJ=ZNODE  D  ;
    315  . S GJ=$$NXTSIB(GJ) ; NEXT SIBLING
    316  Q GPT_","_GN
    317  ;
    318 MNARY(ZRTN,ZHANDLE,ZOID) ; MAKE A NHIN ARRAY FROM A DOM NODE
    319  ; RETURNED IN ZRTN, PASSED BY REFERENCE
    320  ; ZHANDLE IS THE DOM DOCUMENT ID
    321  ; ZOID IS THE DOM NODE
    322  D ATT("ZRTN",ZOID)
    323  Q
    324  ;
     1C0SNHIN   ; GPL - Smart Container - OUTPUT OF NHINV ROUTINES;6/3/11  17:05
     2        ;;1.0;VISTA SMART CONTAINER;;Sep 26, 2012;Build 4
     3        ;Copyright 2011-2012 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
     21EN(ZRTN,ZDFN,ZPART,KEEP)        ; GENERATE AN NHIN ARRAY FOR A PATIENT
     22        ;
     23        K GARY,GNARY,GIDX,C0SDOCID
     24        K ZRTN
     25        N GN
     26        K ^TMP("NHINV",$J) ; CLEAN UP FROM LAST CALL
     27        K ^TMP("MXMLDOM",$J) ; CLEAN UP DOM
     28        K ^TMP("MXMLERR",$J) ; CLEAN UP MXML ERRORS
     29        D GET^C0SNHINV(.GN,ZDFN,ZPART) ; CALL NHINV ROUTINES TO PULL XML
     30        S GN=$P(GN,")",1)_")" ; CUT OFF THE REST OF LINE PROTOCOL
     31        S C0SDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML
     32        D DOMO^C0SDOM(C0SDOCID,"/","ZRTN","GIDX","GARY",,"/results/") ; BLD ARRAYS
     33        I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
     34        ;D PROCESS("ZRTN",GN,"/result/",$G(KEEP))
     35        Q
     36        ;
     37PQRI(ZOUT,KEEP) ; RETURN THE NHIN ARRAY FOR THE PQRI XML TEMPLATE
     38        ;
     39        N ZG
     40        S ZG=$NA(^TMP("PQRIXML",$J))
     41        K @ZG
     42        D GETXML^C0SMXP(ZG,"PQRIXML") ; GET THE XML FROM C0S MISC XML
     43        N C0SDOCID
     44        S C0SDOCID=$$PARSE^C0SDOM(ZG,"PQRIXML") ; PARSE THE XML
     45        D DOMO^C0SDOM(C0SDOCID,"/","ZOUT","GIDX","GARY",,"//submission") ; BLD ARRAYS
     46        I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
     47        Q
     48        ;
     49PQRI2(ZRTN)     ; RETURN THE NHIN ARRAY FOR PQRI ONE MEASURE
     50        ;
     51        ;N GG
     52        D GETXML^C0SMXP("GG","PQRI ONE MEASURE")
     53        D PROCESS(ZRTN,"GG","root",1)
     54        Q
     55        ;
     56PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP)        ; PARSE AND RUN DOMO ON XML
     57        ; ZRTN IS PASSED BY REFERENCE
     58        ; ZXML IS PASSED BY NAME
     59        ; IF KEEP IS 1, GARY AND GIDX ARE NOT KILLED
     60        ;
     61        N GN
     62        S GN=$NA(^TMP("C0SPROCESS",$J))
     63        K @GN
     64        M @GN=@ZXML
     65        S C0SDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML
     66        K @GN
     67        D DOMO^C0SDOM(C0SDOCID,"/","ZRSLT","GIDX","GARY",,$G(ZREDUCE)) ; BLD ARRAYS
     68        I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
     69        Q
     70        ;
     71LOADSMRT        ;
     72        ;
     73        K ^GPL("SMART")
     74        S GN=$NA(^GPL("SMART",1))
     75        I $$FTG^%ZISH("/home/george/","alex-lewis2.xml",GN,2) W !,"SMART FILE LOADED"
     76        Q
     77        ;
     78SMART   ; TRY IT WITH SMART
     79        ;
     80        S GN=$NA(^GPL("SMART"))
     81        ;K ^TMP("MXMLDOM",$J)
     82        K ^TMP("MXMLERR",$J)
     83        S C0SDOCID=$$PARSE(GN,"SMART")
     84        D DOMO^C0SDOM(C0SDOCID,"/","GNARY","GIDX","GARY",,"//rdf:RDF/")
     85        ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
     86        Q
     87        ;
     88CCR     ; TRY IT WITH A CCR
     89        ;
     90        S GN=$NA(^GPL("CCR"))
     91        ;K ^TMP("MXMLDOM",$J)
     92        K ^TMP("MXMLERR",$J)
     93        S C0SDOCID=$$PARSE(GN,"CCR")
     94        D DOMO^C0SDOM(C0SDOCID,"/","GNARY","GIDX","GARY",,"//ContinuityOfCareRecord/Body/")
     95        ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
     96        Q
     97        ;
     98MED     ; TRY IT WITH A CCR MED SECTION
     99        ;
     100        S GN=$NA(^GPL("MED"))
     101        K ^TMP("MXMLDOM",$J)
     102        K ^TMP("MXMLERR",$J)
     103        S C0SDOCID=$$PARSE(GN,"MED")
     104        D DOMO^C0SDOM(C0SDOCID,"/","GNARY","GIDX","GARY",,"//Medications/")
     105        ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
     106        Q
     107        ;
     108CCD     ; TRY IT WITH A CCD
     109        ;
     110        S GN=$NA(^GPL("CCD"))
     111        ;K ^TMP("MXMLDOM",$J)
     112        K ^TMP("MXMLERR",$J)
     113        S C0SDOCID=$$PARSE(GN,"CCD")
     114        D DOMO^C0SDOM(C0SDOCID,"/","GNARY","GIDX","GARY",,"//ClinicalDocument/component/structuredBody/")
     115        ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
     116        Q
     117        ;
     118TEST1   ; TEST NHINV OUTPUT IN ^GPL("NIHIN")
     119        ; PARSED WITH MXML
     120        ; RUN THROUGH XPATH
     121        K GARY,GIDX,C0SDOCID
     122        S GN=$NA(^GPL("NHIN"))
     123        ;S GN=$NA(^GPL("DOMI"))
     124        S C0SDOCID=$$PARSE(GN,"GPLTEST")
     125        D DOMO^C0SDOM(C0SDOCID,"/","GNARY","GIDX","GARY",,"/results/")
     126        K ^GPL("GNARY")
     127        M ^GPL("GNARY")=GNARY
     128        Q
     129        ;
     130TEST2   ; PUT GNARY THROUGH DOMI AND STORE XML IN ^GPL("DOMI")
     131        ;
     132        S GN=$NA(^GPL("GNARY"))
     133        S C0SDOCID=$$DOMI^C0SDOM(GN,,"results")
     134        D OUTXML^C0SDOM("G",C0SDOCID)
     135        K ^GPL("DOMI")
     136        M ^GPL("DOMI")=G
     137        Q
     138        ;
     139TEST3   ; TEST NHINV OUTPUT IN ^GPL("NIHIN")
     140        ; PARSED WITH MXML
     141        ; RUN THROUGH XPATH
     142        K GARY,GIDX,C0SDOCID
     143        ;S GN=$NA(^GPL("NHIN"))
     144        S GN=$NA(^GPL("DOMI"))
     145        S C0SDOCID=$$PARSE(GN,"GPLTEST")
     146        D DOMO^C0SDOM(C0SDOCID,"/","GNARY","GIDX","GARY",,"/results/")
     147        Q
     148        ;
     149DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE
     150        ; THE XPATH INDEX ZXIDX, PASSED BY NAME
     151        ; THE XPATH ARRAY XPARY, PASSED BY NAME
     152        ; ZOID IS THE STARTING OID
     153        ; ZPATH IS THE STARTING XPATH, USUALLY "/"
     154        ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
     155        ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
     156        I $G(ZREDUX)="" S ZREDUX=""
     157        N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY
     158        N NEWNUM S NEWNUM=""
     159        I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
     160        S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
     161        I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
     162        . N GT S GT=$P(NEWPATH,ZREDUX,2)
     163        . I GT'="" S NEWPATH=GT
     164        S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
     165        N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE
     166        I $D(GA) D  ; PROCESS THE ATTRIBUTES
     167        . N ZI S ZI=""
     168        . F  S ZI=$O(GA(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
     169        . . N ZP S ZP=NEWPATH_"/"_ZI ; PATH FOR ATTRIBUTE
     170        . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY
     171        . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE
     172        N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
     173        I $D(GD(2)) D  ;
     174        . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
     175        E  I $D(GD(1)) D  ;
     176        . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
     177        . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY
     178        N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
     179        I ZFRST'=0 D  ; THERE IS A CHILD
     180        . N ZNUM
     181        . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
     182        . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD
     183        N GNXT S GNXT=$$NXTSIB(ZOID)
     184        I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES
     185        I GNXT'=0 D  ;
     186        . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE?
     187        . I (ZNUM="")&(ZMULT) D  ; SIBLING IS FIRST OF MULTIPLES
     188        . . N ZNUM S ZNUM=1 ;
     189        . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
     190        . E  D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB
     191        Q
     192        ;
     193ADDNARY(ZXP,ZVALUE)     ; ADD AN NHIN ARRAY VALUE TO ZNARY
     194        ;
     195        N ZZI,ZZJ,ZZN
     196        S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY
     197        I ZZI="" Q  ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE
     198        S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY
     199        S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH .
     200        I ZZI'["]" D  ; A SINGLETON
     201        . S ZZN=1
     202        E  D  ; THERE IS AN [x] OCCURANCE
     203        . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE
     204        . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X]
     205        I ZZJ'="" S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE
     206        Q
     207        ;
     208PARSE(INXML,INDOC)      ;CALL THE MXML PARSER ON INXML, PASSED BY NAME
     209        ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW
     210        ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML
     211        ;Q $$EN^MXMLDOM(INXML)
     212        Q $$EN^MXMLDOM(INXML,"W")
     213        ;
     214ISMULT(ZOID)    ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
     215        N ZN
     216        ;I $$TAG(ZOID)["entry" B
     217        S ZN=$$NXTSIB(ZOID)
     218        I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
     219        Q 0
     220        ;
     221FIRST(ZOID)     ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
     222        Q $$CHILD^MXMLDOM(C0SDOCID,ZOID)
     223        ;
     224PARENT(ZOID)    ;RETURNS THE OID OF THE PARENT OF ZOID
     225        Q $$PARENT^MXMLDOM(C0SDOCID,ZOID)
     226        ;
     227ATT(RTN,NODE)   ;GET ATTRIBUTES FOR ZOID
     228        S HANDLE=C0SDOCID
     229        K @RTN
     230        D GETTXT^MXMLDOM("A")
     231        Q
     232        ;
     233TAG(ZOID)       ; RETURNS THE XML TAG FOR THE NODE
     234        ;I ZOID=149 B ;GPLTEST
     235        N X,Y
     236        S Y=""
     237        S X=$G(C0SCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
     238        I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
     239        I Y="" S Y=$$NAME^MXMLDOM(C0SDOCID,ZOID)
     240        Q Y
     241        ;
     242NXTSIB(ZOID)    ; RETURNS THE NEXT SIBLING
     243        Q $$SIBLING^MXMLDOM(C0SDOCID,ZOID)
     244        ;
     245DATA(ZT,ZOID)   ; RETURNS DATA FOR THE NODE
     246        ;N ZT,ZN S ZT=""
     247        ;S C0SDOM=$NA(^TMP("MXMLDOM",$J,C0SDOCID))
     248        ;Q $G(@C0SDOM@(ZOID,"T",1))
     249        S ZN=$$TEXT^MXMLDOM(C0SDOCID,ZOID,ZT)
     250        Q
     251        ;
     252OUTXML(ZRTN,INID)       ; USES C0SMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM
     253        ;
     254        S C0SDOCID=INID
     255        D START^C0SMXMLB($$TAG(1),,"G")
     256        D NDOUT($$FIRST(1))
     257        D END^C0SMXMLB ;END THE DOCUMENT
     258        M @ZRTN=^TMP("MXMLBLD",$J)
     259        K ^TMP("MXMLBLD",$J)
     260        Q
     261        ;
     262NDOUT(ZOID)     ;CALLBACK ROUTINE - IT IS RECURSIVE
     263        N ZI S ZI=$$FIRST(ZOID)
     264        I ZI'=0 D  ; THERE IS A CHILD
     265        . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT
     266        . D MULTI^C0SMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0SMXML(ZI)") ;HAVE CHILDREN
     267        E  D  ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT
     268        . ;W "DOING",ZOID,!
     269        . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA
     270        . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES
     271        . D ITEM^C0SMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN
     272        I $$NXTSIB(ZOID)'=0 D  ; THERE IS A SIBLING
     273        . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS
     274        Q
     275        ;
     276WNHIN(ZDFN)     ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE
     277        ;
     278        N GN,GN2
     279        D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML
     280        S GN2=$NA(@GN@(1))
     281        W $$OUTPUT^C0SXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/")
     282        Q
     283        ;
     284TESTNARY        ; TEST MAKING A NHIN ARRAY
     285        N ZI S ZI=""
     286        N ZH ; DOM HANDLE
     287        D TEST1 ; PARSE AN NHIN RESULT INTO THE DOM
     288        S ZH=C0SDOCID ; SET THE HANDLE
     289        N ZD S ZD=$NA(^TMP("MXMLDOM",$J,ZH))
     290        F  S ZI=$O(@ZD@(ZI)) Q:ZI=""  D  ; FOR EACH NODE
     291        . N ZATT
     292        . D MNARY(.ZATT,ZH,ZI)
     293        . N ZPRE,ZN
     294        . S ZPRE=$$PRE(ZI)
     295        . S ZN=$P(ZPRE,",",2)
     296        . S ZPRE=$P(ZPRE,",",1)
     297        . ;I $D(ZATT) ZWR ZATT
     298        . N ZJ S ZJ=""
     299        . F  S ZJ=$O(ZATT(ZJ)) Q:ZJ=""  D  ; FOR EACH ATTRIBUTE
     300        . . W ZPRE_"["_ZN_"]"_$$TAG(ZI)_"."_ZJ_"="_ZATT(ZJ),!
     301        . . S GOUT(ZPRE,ZN,$$TAG(ZI)_"."_ZJ)=ZATT(ZJ)
     302        Q
     303        ;
     304PRE(ZNODE)      ; EXTRINSIC WHICH RETURNS THE PREFIX FOR A NODE
     305        ;
     306        N GI,GI2,GPT,GJ,GN
     307        S GI=$$PARENT(ZNODE) ; PARENT NODE
     308        I GI=0 Q ""  ; NO PARENT
     309        S GPT=$$TAG(GI) ; TAG OF PARENT
     310        S GI2=$$PARENT(GI) ; PARENT OF PARENT
     311        I (GI2'=0)&($$TAG(GI2)'="results") S GPT=$$TAG(GI2)_"."_GPT
     312        S GJ=$$FIRST(GI) ; NODE OF FIRST SIB
     313        I GJ=ZNODE Q:$$TAG(GI)_",1"
     314        F GN=2:1 Q:GJ=ZNODE  D  ;
     315        . S GJ=$$NXTSIB(GJ) ; NEXT SIBLING
     316        Q GPT_","_GN
     317        ;
     318MNARY(ZRTN,ZHANDLE,ZOID)        ; MAKE A NHIN ARRAY FROM A DOM NODE
     319        ; RETURNED IN ZRTN, PASSED BY REFERENCE
     320        ; ZHANDLE IS THE DOM DOCUMENT ID
     321        ; ZOID IS THE DOM NODE
     322        D ATT("ZRTN",ZOID)
     323        Q
     324        ;
  • smart/trunk/p/C0SNHINV.m

    r1569 r1571  
    1 C0SNHINV ;SLC/MKB - Serve VistA data as XML via RPC - Smart Container Version
    2  ;;1.0;C0S;**1**;Oct 25, 2010;Build 11
    3  ;
    4  ; External References          DBIA#
    5  ; -------------------          -----
    6  ; ^DPT                         10035
    7  ; ^SC                          10040
    8  ; DIQ                           2056
    9  ; MPIF001                       2701
    10  ; VASITE                       10112
    11  ; XLFDT                        10103
    12  ; XLFSTR                       10104
    13  ; XUAF4                         2171
    14  ;
    15 GET(NHIN,DFN,TYPE,START,STOP,MAX,ID) ; -- Return search results as XML in @NHIN@(n)
    16  ; RPC = NHIN GET VISTA DATA
    17  N ICN,NHINI,NHINTOTL
    18  S NHIN=$NA(^TMP("NHINV",$J)) K @NHIN
    19  ;
    20  ; parse & validate input parameters
    21  S ICN=+$P(DFN,";",2),DFN=+$G(DFN)
    22  I 'DFN S DFN=+$$GETDFN^MPIF001(ICN)
    23  I DFN<1!'$D(^DPT(DFN)) D ERR(1,DFN) G GTQ
    24  S TYPE=$G(TYPE) I TYPE="" S TYPE=$$ALL
    25  S:'$G(START) START=1410101 S:'$G(STOP) STOP=9999998 S:'$G(MAX) MAX=9999
    26  I START,STOP,STOP<START N X S X=START,START=STOP,STOP=X  ;switch
    27  I STOP,$L(STOP,".")<2 S STOP=STOP_".24"
    28  S ID=$G(ID)
    29  ;
    30  ; extract data
    31  N NHINTYPE,NHINP,RTN
    32  S NHINTYPE=TYPE D ADD("<results>")
    33  F NHINP=1:1:$L(NHINTYPE,";") S TYPE=$P(NHINTYPE,";",NHINP) I $L(TYPE) D
    34  . S RTN="EN^"_$$RTN(TYPE) Q:'$L($T(@RTN))  ;D ERR(2) Q
    35  . D @(RTN_"(DFN,START,STOP,MAX,ID)")
    36  D ADD("</results>")
    37  ;
    38  I $G(NHINTOTL),$G(@NHIN@(1))="<results>" S @NHIN@(1)="<results total='"_NHINTOTL_"' >"
    39  ;
    40 GTQ ; end
    41  Q
    42  ;
    43 RTN(X) ; -- Return name of NHINVxxx routine for clinical domain X
    44  S X=$$UP^XLFSTR(X),Y="NHINV"
    45  I X="ACCESSION"    S Y="NHINVLRA"
    46  I X="ALLERGY"      S Y="NHINVART"
    47  I X="APPOINTMENT"  S Y="NHINVAPT"
    48  ; X="CONSULT"      S Y="NHINVCON"
    49  I X="DOCUMENT"     S Y="NHINVTIU"
    50  I X="IMMUNIZATION" S Y="NHINVIMM"
    51  I X="LAB"          S Y="NHINVLR"
    52  I X="PANEL"        S Y="NHINVLRO"
    53  I X="MED"          S Y="NHINVPS"
    54  I X="RX"           S Y="NHINVPSO"
    55  ; X="ORDER"        S Y="NHINVOR"
    56  I X="PATIENT"      S Y="NHINVPT"
    57  I X="PROBLEM"      S Y="NHINVPL"
    58  I X="PROCEDURE"    S Y="NHINVPRC"
    59  I X="SURGERY"      S Y="NHINVSR"
    60  I X="VISIT"        S Y="NHINVSIT"
    61  I X="VITAL"        S Y="NHINVIT"
    62  I X="RADIOLOGY"    S Y="NHINVRA"
    63  I X="NEW"          S Y="NHINVPR"
    64  Q Y
    65  ;
    66 ALL() ; -- return string for all types of data
    67  ;Q "patient;allergy;problem;vital;lab;med;immunization;visit;appointment;document;procedure"
    68  Q "patient;allergy;problem;vital;lab;med;immunization;visit;appointment;procedure"
    69  ;
    70 ERR(X,VAL) ; -- return error message
    71  N MSG  S MSG="Error"
    72  I X=1  S MSG="Patient with dfn '"_$G(VAL)_"' not found"
    73  I X=2  S MSG="Requested domain type '"_$G(VAL)_"' not recognized"
    74  I X=99 S MSG="Unknown request"
    75  ;
    76  D ADD("<error>")
    77  D ADD("<message>"_MSG_"</message>")
    78  D ADD("</error>")
    79  Q
    80  ;
    81 ESC(X) ; -- escape outgoing XML
    82  ; Q $ZCONVERT(X,"O","HTML")  ; uncomment for fastest performance on Cache
    83  ;
    84  N I,Y,QOT S QOT=""""
    85  S Y=$P(X,"&") F I=2:1:$L(X,"&") S Y=Y_"&amp;"_$P(X,"&",I)
    86  S X=Y,Y=$P(X,"<") F I=2:1:$L(X,"<") S Y=Y_"&lt;"_$P(X,"<",I)
    87  S X=Y,Y=$P(X,">") F I=2:1:$L(X,">") S Y=Y_"&gt;"_$P(X,">",I)
    88  S X=Y,Y=$P(X,"'") F I=2:1:$L(X,"'") S Y=Y_"&apos;"_$P(X,"'",I)
    89  S X=Y,Y=$P(X,QOT) F I=2:1:$L(X,QOT) S Y=Y_"&quot;"_$P(X,QOT,I)
    90  Q Y
    91  ;
    92 ADD(X) ; Add a line @NHIN@(n)=X
    93  S NHINI=$G(NHINI)+1
    94  S @NHIN@(NHINI)=X
    95  Q
    96  ;
    97 STRING(ARRAY) ; -- Return text in ARRAY(n) or ARRAY(n,0) as a string
    98  N I,X,Y S Y=""
    99  S I=+$O(ARRAY("")) I I=0 S I=+$O(ARRAY(0))
    100  S Y=$S($D(ARRAY(I,0)):ARRAY(I,0),1:$G(ARRAY(I)))
    101  F  S I=$O(ARRAY(I)) Q:I<1  D
    102  . S X=$S($D(ARRAY(I,0)):ARRAY(I,0),1:ARRAY(I))
    103  . I $E(X)=" " S Y=Y_$C(13,10)_X Q
    104  . S Y=Y_$S($E(Y,$L(Y))=" ":"",1:" ")_X
    105  Q Y
    106  ;
    107 FAC(X) ; -- return Institution file station# for location X
    108  N HLOC,FAC,Y0,Y S Y=""
    109  S HLOC=$G(^SC(+$G(X),0)),FAC=$P(HLOC,U,4) ;Institution ien
    110  ; Get P:4 via Med Ctr Div, if not directly linked
    111  I 'FAC,$P(HLOC,U,15) S FAC=$$GET1^DIQ(40.8,+$P(HLOC,U,15)_",",.07,"I")
    112  S Y0=$S(FAC:$$NS^XUAF4(FAC),1:$P($$SITE^VASITE,U,2,3)) ;name^stn#
    113  S:$L(Y0) Y=$P(Y0,U,2)_U_$P(Y0,U) ;switch to stn#^name
    114  I $L(Y),'Y S $P(Y,U)=FAC
    115  Q Y
    116  ;
    117 VUID(IEN,FILE) ; -- Return VUID for item
    118  Q $$GET1^DIQ(FILE,IEN_",",99.99)
     1C0SNHINV        ;SLC/MKB - Serve VistA data as XML via RPC - Smart Container Version
     2        ;;1.0;VISTA SMART CONTAINER;;Sep 26, 2012;Build 4
     3        ;
     4        ; External References          DBIA#
     5        ; -------------------          -----
     6        ; ^DPT                         10035
     7        ; ^SC                          10040
     8        ; DIQ                           2056
     9        ; MPIF001                       2701
     10        ; VASITE                       10112
     11        ; XLFDT                        10103
     12        ; XLFSTR                       10104
     13        ; XUAF4                         2171
     14        ;
     15GET(NHIN,DFN,TYPE,START,STOP,MAX,ID)    ; -- Return search results as XML in @NHIN@(n)
     16        ; RPC = NHIN GET VISTA DATA
     17        N ICN,NHINI,NHINTOTL
     18        S NHIN=$NA(^TMP("NHINV",$J)) K @NHIN
     19        ;
     20        ; parse & validate input parameters
     21        S ICN=+$P(DFN,";",2),DFN=+$G(DFN)
     22        I 'DFN S DFN=+$$GETDFN^MPIF001(ICN)
     23        I DFN<1!'$D(^DPT(DFN)) D ERR(1,DFN) G GTQ
     24        S TYPE=$G(TYPE) I TYPE="" S TYPE=$$ALL
     25        S:'$G(START) START=1410101 S:'$G(STOP) STOP=9999998 S:'$G(MAX) MAX=9999
     26        I START,STOP,STOP<START N X S X=START,START=STOP,STOP=X  ;switch
     27        I STOP,$L(STOP,".")<2 S STOP=STOP_".24"
     28        S ID=$G(ID)
     29        ;
     30        ; extract data
     31        N NHINTYPE,NHINP,RTN
     32        S NHINTYPE=TYPE D ADD("<results>")
     33        F NHINP=1:1:$L(NHINTYPE,";") S TYPE=$P(NHINTYPE,";",NHINP) I $L(TYPE) D
     34        . S RTN="EN^"_$$RTN(TYPE) Q:'$L($T(@RTN))  ;D ERR(2) Q
     35        . D @(RTN_"(DFN,START,STOP,MAX,ID)")
     36        D ADD("</results>")
     37        ;
     38        I $G(NHINTOTL),$G(@NHIN@(1))="<results>" S @NHIN@(1)="<results total='"_NHINTOTL_"' >"
     39        ;
     40GTQ     ; end
     41        Q
     42        ;
     43RTN(X)  ; -- Return name of NHINVxxx routine for clinical domain X
     44        S X=$$UP^XLFSTR(X),Y="NHINV"
     45        I X="ACCESSION"    S Y="NHINVLRA"
     46        I X="ALLERGY"      S Y="NHINVART"
     47        I X="APPOINTMENT"  S Y="NHINVAPT"
     48        ; X="CONSULT"      S Y="NHINVCON"
     49        I X="DOCUMENT"     S Y="NHINVTIU"
     50        I X="IMMUNIZATION" S Y="NHINVIMM"
     51        I X="LAB"          S Y="NHINVLR"
     52        I X="PANEL"        S Y="NHINVLRO"
     53        I X="MED"          S Y="NHINVPS"
     54        I X="RX"           S Y="NHINVPSO"
     55        ; X="ORDER"        S Y="NHINVOR"
     56        I X="PATIENT"      S Y="NHINVPT"
     57        I X="PROBLEM"      S Y="NHINVPL"
     58        I X="PROCEDURE"    S Y="NHINVPRC"
     59        I X="SURGERY"      S Y="NHINVSR"
     60        I X="VISIT"        S Y="NHINVSIT"
     61        I X="VITAL"        S Y="NHINVIT"
     62        I X="RADIOLOGY"    S Y="NHINVRA"
     63        I X="NEW"          S Y="NHINVPR"
     64        Q Y
     65        ;
     66ALL()   ; -- return string for all types of data
     67        ;Q "patient;allergy;problem;vital;lab;med;immunization;visit;appointment;document;procedure"
     68        Q "patient;allergy;problem;vital;lab;med;immunization;visit;appointment;procedure"
     69        ;
     70ERR(X,VAL)      ; -- return error message
     71        N MSG  S MSG="Error"
     72        I X=1  S MSG="Patient with dfn '"_$G(VAL)_"' not found"
     73        I X=2  S MSG="Requested domain type '"_$G(VAL)_"' not recognized"
     74        I X=99 S MSG="Unknown request"
     75        ;
     76        D ADD("<error>")
     77        D ADD("<message>"_MSG_"</message>")
     78        D ADD("</error>")
     79        Q
     80        ;
     81ESC(X)  ; -- escape outgoing XML
     82        ; Q $ZCONVERT(X,"O","HTML")  ; uncomment for fastest performance on Cache
     83        ;
     84        N I,Y,QOT S QOT=""""
     85        S Y=$P(X,"&") F I=2:1:$L(X,"&") S Y=Y_"&amp;"_$P(X,"&",I)
     86        S X=Y,Y=$P(X,"<") F I=2:1:$L(X,"<") S Y=Y_"&lt;"_$P(X,"<",I)
     87        S X=Y,Y=$P(X,">") F I=2:1:$L(X,">") S Y=Y_"&gt;"_$P(X,">",I)
     88        S X=Y,Y=$P(X,"'") F I=2:1:$L(X,"'") S Y=Y_"&apos;"_$P(X,"'",I)
     89        S X=Y,Y=$P(X,QOT) F I=2:1:$L(X,QOT) S Y=Y_"&quot;"_$P(X,QOT,I)
     90        Q Y
     91        ;
     92ADD(X)  ; Add a line @NHIN@(n)=X
     93        S NHINI=$G(NHINI)+1
     94        S @NHIN@(NHINI)=X
     95        Q
     96        ;
     97STRING(ARRAY)   ; -- Return text in ARRAY(n) or ARRAY(n,0) as a string
     98        N I,X,Y S Y=""
     99        S I=+$O(ARRAY("")) I I=0 S I=+$O(ARRAY(0))
     100        S Y=$S($D(ARRAY(I,0)):ARRAY(I,0),1:$G(ARRAY(I)))
     101        F  S I=$O(ARRAY(I)) Q:I<1  D
     102        . S X=$S($D(ARRAY(I,0)):ARRAY(I,0),1:ARRAY(I))
     103        . I $E(X)=" " S Y=Y_$C(13,10)_X Q
     104        . S Y=Y_$S($E(Y,$L(Y))=" ":"",1:" ")_X
     105        Q Y
     106        ;
     107FAC(X)  ; -- return Institution file station# for location X
     108        N HLOC,FAC,Y0,Y S Y=""
     109        S HLOC=$G(^SC(+$G(X),0)),FAC=$P(HLOC,U,4) ;Institution ien
     110        ; Get P:4 via Med Ctr Div, if not directly linked
     111        I 'FAC,$P(HLOC,U,15) S FAC=$$GET1^DIQ(40.8,+$P(HLOC,U,15)_",",.07,"I")
     112        S Y0=$S(FAC:$$NS^XUAF4(FAC),1:$P($$SITE^VASITE,U,2,3)) ;name^stn#
     113        S:$L(Y0) Y=$P(Y0,U,2)_U_$P(Y0,U) ;switch to stn#^name
     114        I $L(Y),'Y S $P(Y,U)=FAC
     115        Q Y
     116        ;
     117VUID(IEN,FILE)  ; -- Return VUID for item
     118        Q $$GET1^DIQ(FILE,IEN_",",99.99)
  • smart/trunk/p/C0SPROB.m

    r1569 r1571  
    1 C0SPROB   ; GPL - Smart Problem Processing ;5/01/12  17:05
    2  ;;0.1;C0S;nopatch;noreleasedate;Build 2
    3  ;Copyright 2012 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  ; sample VistA NHIN problem list
    23  ;
    24  ;^TMP("C0STBL",91,"problem",1,"acuity@value")="C"
    25  ;^TMP("C0STBL",91,"problem",1,"entered@value")=3110531
    26  ;^TMP("C0STBL",91,"problem",1,"facility@code")=100
    27  ;^TMP("C0STBL",91,"problem",1,"facility@name")="VOE OFFICE INSTITUTION"
    28  ;^TMP("C0STBL",91,"problem",1,"icd@value")=414.9
    29  ;^TMP("C0STBL",91,"problem",1,"id@value")=100
    30  ;^TMP("C0STBL",91,"problem",1,"location@value")="DR OFFICE"
    31  ;^TMP("C0STBL",91,"problem",1,"name@value")="Coronary Artery Disease"
    32  ;^TMP("C0STBL",91,"problem",1,"onset@value")=3100201
    33  ;^TMP("C0STBL",91,"problem",1,"provider@code")=63
    34  ;^TMP("C0STBL",91,"problem",1,"provider@name")="KING,MATTHEW MICHAEL"
    35  ;^TMP("C0STBL",91,"problem",1,"removed@value")=0
    36  ;^TMP("C0STBL",91,"problem",1,"sc@value")=0
    37  ;^TMP("C0STBL",91,"problem",1,"status@value")="A"
    38  ;^TMP("C0STBL",91,"problem",1,"unverified@value")=0
    39  ;^TMP("C0STBL",91,"problem",1,"updated@value")=3110531
    40  ;^TMP("C0STBL",91,"problem",2,"acuity@value")="C"
    41  ;^TMP("C0STBL",91,"problem",2,"entered@value")=3110602
    42  ;^TMP("C0STBL",91,"problem",2,"facility@code")=100
    43  ;^TMP("C0STBL",91,"problem",2,"facility@name")="VOE OFFICE INSTITUTION"
    44  ;^TMP("C0STBL",91,"problem",2,"icd@value")=780.2
    45  ;^TMP("C0STBL",91,"problem",2,"id@value")=108
    46  ;^TMP("C0STBL",91,"problem",2,"name@value")="Syncope and collapse"
    47  ;^TMP("C0STBL",91,"problem",2,"onset@value")=3110102
    48  ;^TMP("C0STBL",91,"problem",2,"provider@code")=63
    49  ;^TMP("C0STBL",91,"problem",2,"provider@name")="KING,MATTHEW MICHAEL"
    50  ;^TMP("C0STBL",91,"problem",2,"removed@value")=0
    51  ;^TMP("C0STBL",91,"problem",2,"sc@value")=0
    52  ;^TMP("C0STBL",91,"problem",2,"status@value")="A"
    53  ;^TMP("C0STBL",91,"problem",2,"unverified@value")=0
    54  ;^TMP("C0STBL",91,"problem",2,"updated@value")=3110602
    55  ;^TMP("C0STBL",91,"problem",3,"acuity@value")="C"
    56  ;^TMP("C0STBL",91,"problem",3,"entered@value")=3110602
    57  ;^TMP("C0STBL",91,"problem",3,"facility@code")=100
    58  ;^TMP("C0STBL",91,"problem",3,"facility@name")="VOE OFFICE INSTITUTION"
    59  ;^TMP("C0STBL",91,"problem",3,"icd@value")=433.91
    60  ;^TMP("C0STBL",91,"problem",3,"id@value")=109
    61  ;^TMP("C0STBL",91,"problem",3,"name@value")="Occlusion and Stenosis of Unspecifid Precerebral Artery with Cerebral Infarctio"
    62  ;^TMP("C0STBL",91,"problem",3,"onset@value")=3100101
    63  ;^TMP("C0STBL",91,"problem",3,"provider@code")=63
    64  ;^TMP("C0STBL",91,"problem",3,"provider@name")="KING,MATTHEW MICHAEL"
    65  ;^TMP("C0STBL",91,"problem",3,"removed@value")=0
    66  ;^TMP("C0STBL",91,"problem",3,"sc@value")=0
    67  ;^TMP("C0STBL",91,"problem",3,"status@value")="A"
    68  ;^TMP("C0STBL",91,"problem",3,"unverified@value")=0
    69  ;^TMP("C0STBL",91,"problem",3,"updated@value")=3110602
    70  ;^TMP("C0STBL",91,"problem",4,"entered@value")=3110603
    71  ;^TMP("C0STBL",91,"problem",4,"facility@code")=100
    72  ;^TMP("C0STBL",91,"problem",4,"facility@name")="VOE OFFICE INSTITUTION"
    73  ;^TMP("C0STBL",91,"problem",4,"icd@value")="00.66"
    74  ;^TMP("C0STBL",91,"problem",4,"id@value")=115
    75  ;^TMP("C0STBL",91,"problem",4,"location@value")="DR OFFICE"
    76  ;^TMP("C0STBL",91,"problem",4,"name@value")="00.66"
    77  ;^TMP("C0STBL",91,"problem",4,"provider@code")=63
    78  ;^TMP("C0STBL",91,"problem",4,"provider@name")="KING,MATTHEW MICHAEL"
    79  ;^TMP("C0STBL",91,"problem",4,"removed@value")=0
    80  ;^TMP("C0STBL",91,"problem",4,"status@value")="A"
    81  ;^TMP("C0STBL",91,"problem",4,"unverified@value")=0
    82  ;^TMP("C0STBL",91,"problem",4,"updated@value")=3110603
    83  ;^TMP("C0STBL",91,"problem",5,"entered@value")=3110603
    84  ;^TMP("C0STBL",91,"problem",5,"facility@code")=100
    85  ;^TMP("C0STBL",91,"problem",5,"facility@name")="VOE OFFICE INSTITUTION"
    86  ;^TMP("C0STBL",91,"problem",5,"icd@value")=37.21
    87  ;^TMP("C0STBL",91,"problem",5,"id@value")=116
    88  ;^TMP("C0STBL",91,"problem",5,"location@value")="DR OFFICE"
    89  ;^TMP("C0STBL",91,"problem",5,"name@value")=37.21
    90  ;^TMP("C0STBL",91,"problem",5,"provider@code")=63
    91  ;^TMP("C0STBL",91,"problem",5,"provider@name")="KING,MATTHEW MICHAEL"
    92  ;^TMP("C0STBL",91,"problem",5,"removed@value")=0
    93  ;^TMP("C0STBL",91,"problem",5,"status@value")="A"
    94  ;^TMP("C0STBL",91,"problem",5,"unverified@value")=0
    95  ;^TMP("C0STBL",91,"problem",5,"updated@value")=3110603
    96  ;^TMP("C0STBL",91,"problem",6,"entered@value")=3110603
    97  ;^TMP("C0STBL",91,"problem",6,"facility@code")=100
    98  ;^TMP("C0STBL",91,"problem",6,"facility@name")="VOE OFFICE INSTITUTION"
    99  ;^TMP("C0STBL",91,"problem",6,"icd@value")=81.51
    100  ;^TMP("C0STBL",91,"problem",6,"id@value")=117
    101  ;^TMP("C0STBL",91,"problem",6,"location@value")="DR OFFICE"
    102  ;^TMP("C0STBL",91,"problem",6,"name@value")=81.51
    103  ;^TMP("C0STBL",91,"problem",6,"provider@code")=63
    104  ;^TMP("C0STBL",91,"problem",6,"provider@name")="KING,MATTHEW MICHAEL"
    105  ;^TMP("C0STBL",91,"problem",6,"removed@value")=0
    106  ;^TMP("C0STBL",91,"problem",6,"status@value")="A"
    107  ;^TMP("C0STBL",91,"problem",6,"unverified@value")=0
    108  ;^TMP("C0STBL",91,"problem",6,"updated@value")=3110603
    109  ;^TMP("C0STBL",91,"problem",7,"entered@value")=3110603
    110  ;^TMP("C0STBL",91,"problem",7,"facility@code")=100
    111  ;^TMP("C0STBL",91,"problem",7,"facility@name")="VOE OFFICE INSTITUTION"
    112  ;^TMP("C0STBL",91,"problem",7,"icd@value")=47.09
    113  ;^TMP("C0STBL",91,"problem",7,"id@value")=118
    114  ;^TMP("C0STBL",91,"problem",7,"location@value")="DR OFFICE"
    115  ;^TMP("C0STBL",91,"problem",7,"name@value")=47.09
    116  ;^TMP("C0STBL",91,"problem",7,"provider@code")=63
    117  ;^TMP("C0STBL",91,"problem",7,"provider@name")="KING,MATTHEW MICHAEL"
    118  ;^TMP("C0STBL",91,"problem",7,"removed@value")=0
    119  ;^TMP("C0STBL",91,"problem",7,"status@value")="A"
    120  ;^TMP("C0STBL",91,"problem",7,"unverified@value")=0
    121  ;^TMP("C0STBL",91,"problem",7,"updated@value")=3110603
    122  ;^TMP("C0STBL",91,"problem",8,"entered@value")=3110603
    123  ;^TMP("C0STBL",91,"problem",8,"facility@code")=100
    124  ;^TMP("C0STBL",91,"problem",8,"facility@name")="VOE OFFICE INSTITUTION"
    125  ;^TMP("C0STBL",91,"problem",8,"icd@value")="250.00"
    126  ;^TMP("C0STBL",91,"problem",8,"id@value")=119
    127  ;^TMP("C0STBL",91,"problem",8,"location@value")="DR OFFICE"
    128  ;^TMP("C0STBL",91,"problem",8,"name@value")="Diabetes Mellitus without mentionof Complication, type II or unspecified type,"
    129  ;^TMP("C0STBL",91,"problem",8,"provider@code")=63
    130  ;^TMP("C0STBL",91,"problem",8,"provider@name")="KING,MATTHEW MICHAEL"
    131  ;^TMP("C0STBL",91,"problem",8,"removed@value")=0
    132  ;^TMP("C0STBL",91,"problem",8,"status@value")="A"
    133  ;^TMP("C0STBL",91,"problem",8,"unverified@value")=0
    134  ;^TMP("C0STBL",91,"problem",8,"updated@value")=3110603
    135  ;
    136  ; sample Smart lab result triples
    137  ;
    138  ;G("node16rk1fgdvx10882","code")="snomed:40930008"
    139  ;G("node16rk1fgdvx10882","dcterms:title")="Hypothyroidism"
    140  ;G("node16rk1fgdvx10882","rdf:type")="sp:CodedValue"
    141  ;G("node16rk1fgdvx11051","code")="snomed:188155002"
    142  ;G("node16rk1fgdvx11051","dcterms:title")="Primary malignant neoplasm of lower outer quadrant of female breast"
    143  ;G("node16rk1fgdvx11051","rdf:type")="sp:CodedValue"
    144  ;G("node16rk1fgdvx11073","code")="snomed:353295004"
    145  ;G("node16rk1fgdvx11073","dcterms:title")="Toxic diffuse goiter"
    146  ;G("node16rk1fgdvx11073","rdf:type")="sp:CodedValue"
    147  ;G("node16rk1fgdvx11089","code")="snomed:54302000"
    148  ;G("node16rk1fgdvx11089","dcterms:title")="Disorder of breast"
    149  ;G("node16rk1fgdvx11089","rdf:type")="sp:CodedValue"
    150  ;G("node16rk1fgdvx11351","code")="snomed:38341003"
    151  ;G("node16rk1fgdvx11351","dcterms:title")="Essential hypertension"
    152  ;G("node16rk1fgdvx11351","rdf:type")="sp:CodedValue"
    153  ;G("node16rk1fgdvx11390","code")="snomed:44054006"
    154  ;G("node16rk1fgdvx11390","dcterms:title")="Diabetes mellitus type 2"
    155  ;G("node16rk1fgdvx11390","rdf:type")="sp:CodedValue"
    156  ;G("node16rk1fgdvx11558","code")="snomed:195967001"
    157  ;G("node16rk1fgdvx11558","dcterms:title")="Asthma"
    158  ;G("node16rk1fgdvx11558","rdf:type")="sp:CodedValue"
    159  ;G("node16rk1fgdvx11578","code")="snomed:254837009"
    160  ;G("node16rk1fgdvx11578","dcterms:title")="Primary malignant neoplasm of female breast"
    161  ;G("node16rk1fgdvx11578","rdf:type")="sp:CodedValue"
    162  ;G("node16rk1fgdvx11687","code")="snomed:8517006"
    163  ;G("node16rk1fgdvx11687","dcterms:title")="History of tobacco use"
    164  ;G("node16rk1fgdvx11687","rdf:type")="sp:CodedValue"
    165  ;G("node16rk1fgdvx11716","code")="snomed:55822004"
    166  ;G("node16rk1fgdvx11716","dcterms:title")="Hyperlipidemia"
    167  ;G("node16rk1fgdvx11716","rdf:type")="sp:CodedValue"
    168  ;G("smart:1577780/problems/69560e4721e1","belongsTo")="smart:1577780"
    169  ;G("smart:1577780/problems/69560e4721e1","problemName")="node16rk1fgdvx11089"
    170  ;G("smart:1577780/problems/69560e4721e1","rdf:type")="sp:Problem"
    171  ;G("smart:1577780/problems/69560e4721e1","startDate")="2005-08-02"
    172  ;G("smart:1577780/problems/06ef10c4e92c","belongsTo")="smart:1577780"
    173  ;G("smart:1577780/problems/06ef10c4e92c","problemName")="node16rk1fgdvx11051"
    174  ;G("smart:1577780/problems/06ef10c4e92c","rdf:type")="sp:Problem"
    175  ;G("smart:1577780/problems/06ef10c4e92c","startDate")="2006-02-20"
    176  ;G("smart:1577780/problems/9894ba9dfe5a","belongsTo")="smart:1577780"
    177  ;G("smart:1577780/problems/9894ba9dfe5a","problemName")="node16rk1fgdvx11578"
    178  ;G("smart:1577780/problems/9894ba9dfe5a","rdf:type")="sp:Problem"
    179  ;G("smart:1577780/problems/9894ba9dfe5a","startDate")="2005-08-22"
    180  ;G("smart:1577780/problems/c109aa7a0675","belongsTo")="smart:1577780"
    181  ;G("smart:1577780/problems/c109aa7a0675","problemName")="node16rk1fgdvx11558"
    182  ;G("smart:1577780/problems/c109aa7a0675","rdf:type")="sp:Problem"
    183  ;G("smart:1577780/problems/c109aa7a0675","startDate")="2005-09-22"
    184  ;G("smart:1577780/problems/1c50100614a2","belongsTo")="smart:1577780"
    185  ;G("smart:1577780/problems/1c50100614a2","problemName")="node16rk1fgdvx11073"
    186  ;G("smart:1577780/problems/1c50100614a2","rdf:type")="sp:Problem"
    187  ;G("smart:1577780/problems/1c50100614a2","startDate")="2007-02-21"
    188  ;G("smart:1577780/problems/083dffb2c4a0","belongsTo")="smart:1577780"
    189  ;G("smart:1577780/problems/083dffb2c4a0","problemName")="node16rk1fgdvx11390"
    190  ;G("smart:1577780/problems/083dffb2c4a0","rdf:type")="sp:Problem"
    191  ;G("smart:1577780/problems/083dffb2c4a0","startDate")="2007-01-07"
    192  ;G("smart:1577780/problems/762b5639a2d1","belongsTo")="smart:1577780"
    193  ;G("smart:1577780/problems/762b5639a2d1","problemName")="node16rk1fgdvx11687"
    194  ;G("smart:1577780/problems/762b5639a2d1","rdf:type")="sp:Problem"
    195  ;G("smart:1577780/problems/762b5639a2d1","startDate")="2006-02-20"
    196  ;G("smart:1577780/problems/9dc9053dd6f4","belongsTo")="smart:1577780"
    197  ;G("smart:1577780/problems/9dc9053dd6f4","problemName")="node16rk1fgdvx11716"
    198  ;G("smart:1577780/problems/9dc9053dd6f4","rdf:type")="sp:Problem"
    199  ;G("smart:1577780/problems/9dc9053dd6f4","startDate")="2008-04-08"
    200  ;G("smart:1577780/problems/e3fe9b7ee552","belongsTo")="smart:1577780"
    201  ;G("smart:1577780/problems/e3fe9b7ee552","problemName")="node16rk1fgdvx10882"
    202  ;G("smart:1577780/problems/e3fe9b7ee552","rdf:type")="sp:Problem"
    203  ;G("smart:1577780/problems/e3fe9b7ee552","startDate")="2005-10-27"
    204  ;G("smart:1577780/problems/9933307e8f95","belongsTo")="smart:1577780"
    205  ;G("smart:1577780/problems/9933307e8f95","problemName")="node16rk1fgdvx11351"
    206  ;G("smart:1577780/problems/9933307e8f95","rdf:type")="sp:Problem"
    207  ;G("smart:1577780/problems/9933307e8f95","startDate")="2005-08-22"
    208  ;G("snomed:188155002","dcterms:identifier")=188155002
    209  ;G("snomed:188155002","dcterms:title")="Primary malignant neoplasm of lower outer quadrant of female breast"
    210  ;G("snomed:188155002","rdf:type")="sp:Code"
    211  ;G("snomed:188155002","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    212  ;G("snomed:195967001","dcterms:identifier")=195967001
    213  ;G("snomed:195967001","dcterms:title")="Asthma"
    214  ;G("snomed:195967001","rdf:type")="sp:Code"
    215  ;G("snomed:195967001","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    216  ;G("snomed:254837009","dcterms:identifier")=254837009
    217  ;G("snomed:254837009","dcterms:title")="Primary malignant neoplasm of female breast"
    218  ;G("snomed:254837009","rdf:type")="sp:Code"
    219  ;G("snomed:254837009","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    220  ;G("snomed:353295004","dcterms:identifier")=353295004
    221  ;G("snomed:353295004","dcterms:title")="Toxic diffuse goiter"
    222  ;G("snomed:353295004","rdf:type")="sp:Code"
    223  ;G("snomed:353295004","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    224  ;G("snomed:38341003","dcterms:identifier")=38341003
    225  ;G("snomed:38341003","dcterms:title")="Essential hypertension"
    226  ;G("snomed:38341003","rdf:type")="sp:Code"
    227  ;G("snomed:38341003","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    228  ;G("snomed:40930008","dcterms:identifier")=40930008
    229  ;G("snomed:40930008","dcterms:title")="Hypothyroidism"
    230  ;G("snomed:40930008","rdf:type")="sp:Code"
    231  ;G("snomed:40930008","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    232  ;G("snomed:44054006","dcterms:identifier")=44054006
    233  ;G("snomed:44054006","dcterms:title")="Diabetes mellitus type 2"
    234  ;G("snomed:44054006","rdf:type")="sp:Code"
    235  ;G("snomed:44054006","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    236  ;G("snomed:54302000","dcterms:identifier")=54302000
    237  ;G("snomed:54302000","dcterms:title")="Disorder of breast"
    238  ;G("snomed:54302000","rdf:type")="sp:Code"
    239  ;G("snomed:54302000","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    240  ;G("snomed:55822004","dcterms:identifier")=55822004
    241  ;G("snomed:55822004","dcterms:title")="Hyperlipidemia"
    242  ;G("snomed:55822004","rdf:type")="sp:Code"
    243  ;G("snomed:55822004","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    244  ;G("snomed:8517006","dcterms:identifier")=8517006
    245  ;G("snomed:8517006","dcterms:title")="History of tobacco use"
    246  ;G("snomed:8517006","rdf:type")="sp:Code"
    247  ;G("snomed:8517006","system")="http://purl.bioontology.org/ontology/SNOMEDCT/"
    248 
    249  ;
    250 PROB(GRTN,C0SARY) ; GRTN, passed by reference,
    251  ; is the return name of the graph created. "" if none
    252  ; C0SARY is passed in by reference and is the NHIN array of problems
    253  ;
    254  I $O(C0SARY("problem",""))="" D  Q  ;
    255  . I $D(DEBUG) W !,"No Problems"
    256  S GRTN="" ; default to no problems
    257  N C0SGRF
    258  S C0SGRF="vistaSmart:"_ZPATID_"/problems"
    259  I $D(DEBUG) W !,"Processing ",C0SGRF
    260  D DELGRAPH^C0XF2N(C0SGRF) ; delete the old graph
    261  D INITFARY^C0XF2N("C0XFARY") ; which triple store to use
    262  N FARY S FARY="C0XFARY"
    263  D USEFARY^C0XF2N(FARY)
    264  D VOCINIT^C0XUTIL
    265  ;
    266  D STARTADD^C0XF2N ; initialize to create triples
    267  ;
    268  N ZI S ZI=""
    269  F  S ZI=$O(C0SARY("problem",ZI)) Q:ZI=""  D  ;
    270  . N LRN,ZR ; ZR is the local array for building the new triples
    271  . S LRN=$NA(C0SARY("problem",ZI)) ; base for values in this lab result
    272  . ;
    273  . N PROBID ; unique Id for this problem
    274  . S PROBID=C0SGRF_"/"_$$LKY17^C0XF2N ; use a random number
    275  . ;
    276  . ; i don't like this because the same problems gets a
    277  . ; different ID every time it's reported. Can't trace it back to VistA
    278  . ; I'd rather be using id@value ie "id@value")="118"
    279  . ;
    280  . N SNOMED S SNOMED=$G(@LRN@("icd@value"))
    281  . N SNOGRF S SNOGRF="snomed:"_SNOMED
    282  . N SNOTIT S SNOTIT=$G(@LRN@("name@value"))
    283  . I $D(DEBUG) D  ;
    284  . . W !,"Processing Problem List ",PROBID
    285  . . W !,"problem: ",SNOTIT
    286  . . W !,"code: ",SNOMED
    287  . ;
    288  . ; first do the base result graph
    289  . ;
    290  . S ZR("rdf:type")="sp:Problem"
    291  . S ZR("sp:belongsTo")=C0SGRF ; the subject for this patient's problems
    292  . ; ie /vista/smart/99912345/problems
    293  . ;
    294  . N PROBNAME S PROBNAME=$$ANONS^C0XF2N ; new node for problem name
    295  . S ZR("sp:problemName")=PROBNAME
    296  . ;
    297  . N STARTDT S STARTDT=$$SPDATE^C0SUTIL($G(@LRN@("entered@value")))
    298  . S ZR("sp:startDate")=STARTDT
    299  . ;
    300  . D ADDINN^C0XF2N(C0SGRF,PROBID,.ZR) ; addIfNotNull the triples
    301  . K ZR ; clean up
    302  . ;
    303  . ; create the problemName graph
    304  . ;
    305  . S ZR("rdf:type")="sp:CodedValue"
    306  . S ZR("sp:code")="snomed:"_SNOMED
    307  . S ZR("dcterms:title")=$G(@LRN@("name@value"))
    308  . D ADDINN^C0XF2N(C0SGRF,PROBNAME,.ZR)
    309  . K ZR
    310  . ;
    311  . ; create snomed graph
    312  . ;
    313  . S ZR("rdf:type")="sp:Code"
    314  . S ZR("sp:system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    315  . S ZR("dcterms:identifier")=SNOMED
    316  . S ZR("dcterms:title")=SNOTIT
    317  . D ADDINN^C0XF2N(C0SGRF,SNOGRF,.ZR)
    318  . K ZR
    319  . ;
    320  D BULKLOAD^C0XF2N(.C0XFDA)
    321  S GRTN=C0SGRF
    322  Q
    323  ;
     1C0SPROB   ; GPL - Smart Problem Processing ;5/01/12  17:05
     2        ;;1.0;VISTA SMART CONTAINER;;Sep 26, 2012;Build 4
     3        ;Copyright 2012 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        ; sample VistA NHIN problem list
     23        ;
     24        ;^TMP("C0STBL",91,"problem",1,"acuity@value")="C"
     25        ;^TMP("C0STBL",91,"problem",1,"entered@value")=3110531
     26        ;^TMP("C0STBL",91,"problem",1,"facility@code")=100
     27        ;^TMP("C0STBL",91,"problem",1,"facility@name")="VOE OFFICE INSTITUTION"
     28        ;^TMP("C0STBL",91,"problem",1,"icd@value")=414.9
     29        ;^TMP("C0STBL",91,"problem",1,"id@value")=100
     30        ;^TMP("C0STBL",91,"problem",1,"location@value")="DR OFFICE"
     31        ;^TMP("C0STBL",91,"problem",1,"name@value")="Coronary Artery Disease"
     32        ;^TMP("C0STBL",91,"problem",1,"onset@value")=3100201
     33        ;^TMP("C0STBL",91,"problem",1,"provider@code")=63
     34        ;^TMP("C0STBL",91,"problem",1,"provider@name")="KING,MATTHEW MICHAEL"
     35        ;^TMP("C0STBL",91,"problem",1,"removed@value")=0
     36        ;^TMP("C0STBL",91,"problem",1,"sc@value")=0
     37        ;^TMP("C0STBL",91,"problem",1,"status@value")="A"
     38        ;^TMP("C0STBL",91,"problem",1,"unverified@value")=0
     39        ;^TMP("C0STBL",91,"problem",1,"updated@value")=3110531
     40        ;^TMP("C0STBL",91,"problem",2,"acuity@value")="C"
     41        ;^TMP("C0STBL",91,"problem",2,"entered@value")=3110602
     42        ;^TMP("C0STBL",91,"problem",2,"facility@code")=100
     43        ;^TMP("C0STBL",91,"problem",2,"facility@name")="VOE OFFICE INSTITUTION"
     44        ;^TMP("C0STBL",91,"problem",2,"icd@value")=780.2
     45        ;^TMP("C0STBL",91,"problem",2,"id@value")=108
     46        ;^TMP("C0STBL",91,"problem",2,"name@value")="Syncope and collapse"
     47        ;^TMP("C0STBL",91,"problem",2,"onset@value")=3110102
     48        ;^TMP("C0STBL",91,"problem",2,"provider@code")=63
     49        ;^TMP("C0STBL",91,"problem",2,"provider@name")="KING,MATTHEW MICHAEL"
     50        ;^TMP("C0STBL",91,"problem",2,"removed@value")=0
     51        ;^TMP("C0STBL",91,"problem",2,"sc@value")=0
     52        ;^TMP("C0STBL",91,"problem",2,"status@value")="A"
     53        ;^TMP("C0STBL",91,"problem",2,"unverified@value")=0
     54        ;^TMP("C0STBL",91,"problem",2,"updated@value")=3110602
     55        ;^TMP("C0STBL",91,"problem",3,"acuity@value")="C"
     56        ;^TMP("C0STBL",91,"problem",3,"entered@value")=3110602
     57        ;^TMP("C0STBL",91,"problem",3,"facility@code")=100
     58        ;^TMP("C0STBL",91,"problem",3,"facility@name")="VOE OFFICE INSTITUTION"
     59        ;^TMP("C0STBL",91,"problem",3,"icd@value")=433.91
     60        ;^TMP("C0STBL",91,"problem",3,"id@value")=109
     61        ;^TMP("C0STBL",91,"problem",3,"name@value")="Occlusion and Stenosis of Unspecifid Precerebral Artery with Cerebral Infarctio"
     62        ;^TMP("C0STBL",91,"problem",3,"onset@value")=3100101
     63        ;^TMP("C0STBL",91,"problem",3,"provider@code")=63
     64        ;^TMP("C0STBL",91,"problem",3,"provider@name")="KING,MATTHEW MICHAEL"
     65        ;^TMP("C0STBL",91,"problem",3,"removed@value")=0
     66        ;^TMP("C0STBL",91,"problem",3,"sc@value")=0
     67        ;^TMP("C0STBL",91,"problem",3,"status@value")="A"
     68        ;^TMP("C0STBL",91,"problem",3,"unverified@value")=0
     69        ;^TMP("C0STBL",91,"problem",3,"updated@value")=3110602
     70        ;^TMP("C0STBL",91,"problem",4,"entered@value")=3110603
     71        ;^TMP("C0STBL",91,"problem",4,"facility@code")=100
     72        ;^TMP("C0STBL",91,"problem",4,"facility@name")="VOE OFFICE INSTITUTION"
     73        ;^TMP("C0STBL",91,"problem",4,"icd@value")="00.66"
     74        ;^TMP("C0STBL",91,"problem",4,"id@value")=115
     75        ;^TMP("C0STBL",91,"problem",4,"location@value")="DR OFFICE"
     76        ;^TMP("C0STBL",91,"problem",4,"name@value")="00.66"
     77        ;^TMP("C0STBL",91,"problem",4,"provider@code")=63
     78        ;^TMP("C0STBL",91,"problem",4,"provider@name")="KING,MATTHEW MICHAEL"
     79        ;^TMP("C0STBL",91,"problem",4,"removed@value")=0
     80        ;^TMP("C0STBL",91,"problem",4,"status@value")="A"
     81        ;^TMP("C0STBL",91,"problem",4,"unverified@value")=0
     82        ;^TMP("C0STBL",91,"problem",4,"updated@value")=3110603
     83        ;^TMP("C0STBL",91,"problem",5,"entered@value")=3110603
     84        ;^TMP("C0STBL",91,"problem",5,"facility@code")=100
     85        ;^TMP("C0STBL",91,"problem",5,"facility@name")="VOE OFFICE INSTITUTION"
     86        ;^TMP("C0STBL",91,"problem",5,"icd@value")=37.21
     87        ;^TMP("C0STBL",91,"problem",5,"id@value")=116
     88        ;^TMP("C0STBL",91,"problem",5,"location@value")="DR OFFICE"
     89        ;^TMP("C0STBL",91,"problem",5,"name@value")=37.21
     90        ;^TMP("C0STBL",91,"problem",5,"provider@code")=63
     91        ;^TMP("C0STBL",91,"problem",5,"provider@name")="KING,MATTHEW MICHAEL"
     92        ;^TMP("C0STBL",91,"problem",5,"removed@value")=0
     93        ;^TMP("C0STBL",91,"problem",5,"status@value")="A"
     94        ;^TMP("C0STBL",91,"problem",5,"unverified@value")=0
     95        ;^TMP("C0STBL",91,"problem",5,"updated@value")=3110603
     96        ;^TMP("C0STBL",91,"problem",6,"entered@value")=3110603
     97        ;^TMP("C0STBL",91,"problem",6,"facility@code")=100
     98        ;^TMP("C0STBL",91,"problem",6,"facility@name")="VOE OFFICE INSTITUTION"
     99        ;^TMP("C0STBL",91,"problem",6,"icd@value")=81.51
     100        ;^TMP("C0STBL",91,"problem",6,"id@value")=117
     101        ;^TMP("C0STBL",91,"problem",6,"location@value")="DR OFFICE"
     102        ;^TMP("C0STBL",91,"problem",6,"name@value")=81.51
     103        ;^TMP("C0STBL",91,"problem",6,"provider@code")=63
     104        ;^TMP("C0STBL",91,"problem",6,"provider@name")="KING,MATTHEW MICHAEL"
     105        ;^TMP("C0STBL",91,"problem",6,"removed@value")=0
     106        ;^TMP("C0STBL",91,"problem",6,"status@value")="A"
     107        ;^TMP("C0STBL",91,"problem",6,"unverified@value")=0
     108        ;^TMP("C0STBL",91,"problem",6,"updated@value")=3110603
     109        ;^TMP("C0STBL",91,"problem",7,"entered@value")=3110603
     110        ;^TMP("C0STBL",91,"problem",7,"facility@code")=100
     111        ;^TMP("C0STBL",91,"problem",7,"facility@name")="VOE OFFICE INSTITUTION"
     112        ;^TMP("C0STBL",91,"problem",7,"icd@value")=47.09
     113        ;^TMP("C0STBL",91,"problem",7,"id@value")=118
     114        ;^TMP("C0STBL",91,"problem",7,"location@value")="DR OFFICE"
     115        ;^TMP("C0STBL",91,"problem",7,"name@value")=47.09
     116        ;^TMP("C0STBL",91,"problem",7,"provider@code")=63
     117        ;^TMP("C0STBL",91,"problem",7,"provider@name")="KING,MATTHEW MICHAEL"
     118        ;^TMP("C0STBL",91,"problem",7,"removed@value")=0
     119        ;^TMP("C0STBL",91,"problem",7,"status@value")="A"
     120        ;^TMP("C0STBL",91,"problem",7,"unverified@value")=0
     121        ;^TMP("C0STBL",91,"problem",7,"updated@value")=3110603
     122        ;^TMP("C0STBL",91,"problem",8,"entered@value")=3110603
     123        ;^TMP("C0STBL",91,"problem",8,"facility@code")=100
     124        ;^TMP("C0STBL",91,"problem",8,"facility@name")="VOE OFFICE INSTITUTION"
     125        ;^TMP("C0STBL",91,"problem",8,"icd@value")="250.00"
     126        ;^TMP("C0STBL",91,"problem",8,"id@value")=119
     127        ;^TMP("C0STBL",91,"problem",8,"location@value")="DR OFFICE"
     128        ;^TMP("C0STBL",91,"problem",8,"name@value")="Diabetes Mellitus without mentionof Complication, type II or unspecified type,"
     129        ;^TMP("C0STBL",91,"problem",8,"provider@code")=63
     130        ;^TMP("C0STBL",91,"problem",8,"provider@name")="KING,MATTHEW MICHAEL"
     131        ;^TMP("C0STBL",91,"problem",8,"removed@value")=0
     132        ;^TMP("C0STBL",91,"problem",8,"status@value")="A"
     133        ;^TMP("C0STBL",91,"problem",8,"unverified@value")=0
     134        ;^TMP("C0STBL",91,"problem",8,"updated@value")=3110603
     135        ;
     136        ; sample Smart lab result triples
     137        ;
     138        ;G("node16rk1fgdvx10882","code")="snomed:40930008"
     139        ;G("node16rk1fgdvx10882","dcterms:title")="Hypothyroidism"
     140        ;G("node16rk1fgdvx10882","rdf:type")="sp:CodedValue"
     141        ;G("node16rk1fgdvx11051","code")="snomed:188155002"
     142        ;G("node16rk1fgdvx11051","dcterms:title")="Primary malignant neoplasm of lower outer quadrant of female breast"
     143        ;G("node16rk1fgdvx11051","rdf:type")="sp:CodedValue"
     144        ;G("node16rk1fgdvx11073","code")="snomed:353295004"
     145        ;G("node16rk1fgdvx11073","dcterms:title")="Toxic diffuse goiter"
     146        ;G("node16rk1fgdvx11073","rdf:type")="sp:CodedValue"
     147        ;G("node16rk1fgdvx11089","code")="snomed:54302000"
     148        ;G("node16rk1fgdvx11089","dcterms:title")="Disorder of breast"
     149        ;G("node16rk1fgdvx11089","rdf:type")="sp:CodedValue"
     150        ;G("node16rk1fgdvx11351","code")="snomed:38341003"
     151        ;G("node16rk1fgdvx11351","dcterms:title")="Essential hypertension"
     152        ;G("node16rk1fgdvx11351","rdf:type")="sp:CodedValue"
     153        ;G("node16rk1fgdvx11390","code")="snomed:44054006"
     154        ;G("node16rk1fgdvx11390","dcterms:title")="Diabetes mellitus type 2"
     155        ;G("node16rk1fgdvx11390","rdf:type")="sp:CodedValue"
     156        ;G("node16rk1fgdvx11558","code")="snomed:195967001"
     157        ;G("node16rk1fgdvx11558","dcterms:title")="Asthma"
     158        ;G("node16rk1fgdvx11558","rdf:type")="sp:CodedValue"
     159        ;G("node16rk1fgdvx11578","code")="snomed:254837009"
     160        ;G("node16rk1fgdvx11578","dcterms:title")="Primary malignant neoplasm of female breast"
     161        ;G("node16rk1fgdvx11578","rdf:type")="sp:CodedValue"
     162        ;G("node16rk1fgdvx11687","code")="snomed:8517006"
     163        ;G("node16rk1fgdvx11687","dcterms:title")="History of tobacco use"
     164        ;G("node16rk1fgdvx11687","rdf:type")="sp:CodedValue"
     165        ;G("node16rk1fgdvx11716","code")="snomed:55822004"
     166        ;G("node16rk1fgdvx11716","dcterms:title")="Hyperlipidemia"
     167        ;G("node16rk1fgdvx11716","rdf:type")="sp:CodedValue"
     168        ;G("smart:1577780/problems/69560e4721e1","belongsTo")="smart:1577780"
     169        ;G("smart:1577780/problems/69560e4721e1","problemName")="node16rk1fgdvx11089"
     170        ;G("smart:1577780/problems/69560e4721e1","rdf:type")="sp:Problem"
     171        ;G("smart:1577780/problems/69560e4721e1","startDate")="2005-08-02"
     172        ;G("smart:1577780/problems/06ef10c4e92c","belongsTo")="smart:1577780"
     173        ;G("smart:1577780/problems/06ef10c4e92c","problemName")="node16rk1fgdvx11051"
     174        ;G("smart:1577780/problems/06ef10c4e92c","rdf:type")="sp:Problem"
     175        ;G("smart:1577780/problems/06ef10c4e92c","startDate")="2006-02-20"
     176        ;G("smart:1577780/problems/9894ba9dfe5a","belongsTo")="smart:1577780"
     177        ;G("smart:1577780/problems/9894ba9dfe5a","problemName")="node16rk1fgdvx11578"
     178        ;G("smart:1577780/problems/9894ba9dfe5a","rdf:type")="sp:Problem"
     179        ;G("smart:1577780/problems/9894ba9dfe5a","startDate")="2005-08-22"
     180        ;G("smart:1577780/problems/c109aa7a0675","belongsTo")="smart:1577780"
     181        ;G("smart:1577780/problems/c109aa7a0675","problemName")="node16rk1fgdvx11558"
     182        ;G("smart:1577780/problems/c109aa7a0675","rdf:type")="sp:Problem"
     183        ;G("smart:1577780/problems/c109aa7a0675","startDate")="2005-09-22"
     184        ;G("smart:1577780/problems/1c50100614a2","belongsTo")="smart:1577780"
     185        ;G("smart:1577780/problems/1c50100614a2","problemName")="node16rk1fgdvx11073"
     186        ;G("smart:1577780/problems/1c50100614a2","rdf:type")="sp:Problem"
     187        ;G("smart:1577780/problems/1c50100614a2","startDate")="2007-02-21"
     188        ;G("smart:1577780/problems/083dffb2c4a0","belongsTo")="smart:1577780"
     189        ;G("smart:1577780/problems/083dffb2c4a0","problemName")="node16rk1fgdvx11390"
     190        ;G("smart:1577780/problems/083dffb2c4a0","rdf:type")="sp:Problem"
     191        ;G("smart:1577780/problems/083dffb2c4a0","startDate")="2007-01-07"
     192        ;G("smart:1577780/problems/762b5639a2d1","belongsTo")="smart:1577780"
     193        ;G("smart:1577780/problems/762b5639a2d1","problemName")="node16rk1fgdvx11687"
     194        ;G("smart:1577780/problems/762b5639a2d1","rdf:type")="sp:Problem"
     195        ;G("smart:1577780/problems/762b5639a2d1","startDate")="2006-02-20"
     196        ;G("smart:1577780/problems/9dc9053dd6f4","belongsTo")="smart:1577780"
     197        ;G("smart:1577780/problems/9dc9053dd6f4","problemName")="node16rk1fgdvx11716"
     198        ;G("smart:1577780/problems/9dc9053dd6f4","rdf:type")="sp:Problem"
     199        ;G("smart:1577780/problems/9dc9053dd6f4","startDate")="2008-04-08"
     200        ;G("smart:1577780/problems/e3fe9b7ee552","belongsTo")="smart:1577780"
     201        ;G("smart:1577780/problems/e3fe9b7ee552","problemName")="node16rk1fgdvx10882"
     202        ;G("smart:1577780/problems/e3fe9b7ee552","rdf:type")="sp:Problem"
     203        ;G("smart:1577780/problems/e3fe9b7ee552","startDate")="2005-10-27"
     204        ;G("smart:1577780/problems/9933307e8f95","belongsTo")="smart:1577780"
     205        ;G("smart:1577780/problems/9933307e8f95","problemName")="node16rk1fgdvx11351"
     206        ;G("smart:1577780/problems/9933307e8f95","rdf:type")="sp:Problem"
     207        ;G("smart:1577780/problems/9933307e8f95","startDate")="2005-08-22"
     208        ;G("snomed:188155002","dcterms:identifier")=188155002
     209        ;G("snomed:188155002","dcterms:title")="Primary malignant neoplasm of lower outer quadrant of female breast"
     210        ;G("snomed:188155002","rdf:type")="sp:Code"
     211        ;G("snomed:188155002","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     212        ;G("snomed:195967001","dcterms:identifier")=195967001
     213        ;G("snomed:195967001","dcterms:title")="Asthma"
     214        ;G("snomed:195967001","rdf:type")="sp:Code"
     215        ;G("snomed:195967001","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     216        ;G("snomed:254837009","dcterms:identifier")=254837009
     217        ;G("snomed:254837009","dcterms:title")="Primary malignant neoplasm of female breast"
     218        ;G("snomed:254837009","rdf:type")="sp:Code"
     219        ;G("snomed:254837009","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     220        ;G("snomed:353295004","dcterms:identifier")=353295004
     221        ;G("snomed:353295004","dcterms:title")="Toxic diffuse goiter"
     222        ;G("snomed:353295004","rdf:type")="sp:Code"
     223        ;G("snomed:353295004","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     224        ;G("snomed:38341003","dcterms:identifier")=38341003
     225        ;G("snomed:38341003","dcterms:title")="Essential hypertension"
     226        ;G("snomed:38341003","rdf:type")="sp:Code"
     227        ;G("snomed:38341003","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     228        ;G("snomed:40930008","dcterms:identifier")=40930008
     229        ;G("snomed:40930008","dcterms:title")="Hypothyroidism"
     230        ;G("snomed:40930008","rdf:type")="sp:Code"
     231        ;G("snomed:40930008","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     232        ;G("snomed:44054006","dcterms:identifier")=44054006
     233        ;G("snomed:44054006","dcterms:title")="Diabetes mellitus type 2"
     234        ;G("snomed:44054006","rdf:type")="sp:Code"
     235        ;G("snomed:44054006","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     236        ;G("snomed:54302000","dcterms:identifier")=54302000
     237        ;G("snomed:54302000","dcterms:title")="Disorder of breast"
     238        ;G("snomed:54302000","rdf:type")="sp:Code"
     239        ;G("snomed:54302000","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     240        ;G("snomed:55822004","dcterms:identifier")=55822004
     241        ;G("snomed:55822004","dcterms:title")="Hyperlipidemia"
     242        ;G("snomed:55822004","rdf:type")="sp:Code"
     243        ;G("snomed:55822004","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     244        ;G("snomed:8517006","dcterms:identifier")=8517006
     245        ;G("snomed:8517006","dcterms:title")="History of tobacco use"
     246        ;G("snomed:8517006","rdf:type")="sp:Code"
     247        ;G("snomed:8517006","system")="http://purl.bioontology.org/ontology/SNOMEDCT/"
     248       
     249        ;
     250PROB(GRTN,C0SARY)       ; GRTN, passed by reference,
     251        ; is the return name of the graph created. "" if none
     252        ; C0SARY is passed in by reference and is the NHIN array of problems
     253        ;
     254        I $O(C0SARY("problem",""))="" D  Q  ;
     255        . I $D(DEBUG) W !,"No Problems"
     256        S GRTN="" ; default to no problems
     257        N C0SGRF
     258        S C0SGRF="vistaSmart:"_ZPATID_"/problems"
     259        I $D(DEBUG) W !,"Processing ",C0SGRF
     260        D DELGRAPH^C0XF2N(C0SGRF) ; delete the old graph
     261        D INITFARY^C0XF2N("C0XFARY") ; which triple store to use
     262        N FARY S FARY="C0XFARY"
     263        D USEFARY^C0XF2N(FARY)
     264        D VOCINIT^C0XUTIL
     265        ;
     266        D STARTADD^C0XF2N ; initialize to create triples
     267        ;
     268        N ZI S ZI=""
     269        F  S ZI=$O(C0SARY("problem",ZI)) Q:ZI=""  D  ;
     270        . N LRN,ZR ; ZR is the local array for building the new triples
     271        . S LRN=$NA(C0SARY("problem",ZI)) ; base for values in this lab result
     272        . ;
     273        . N PROBID ; unique Id for this problem
     274        . S PROBID=C0SGRF_"/"_$$LKY17^C0XF2N ; use a random number
     275        . ;
     276        . ; i don't like this because the same problems gets a
     277        . ; different ID every time it's reported. Can't trace it back to VistA
     278        . ; I'd rather be using id@value ie "id@value")="118"
     279        . ;
     280        . N SNOMED S SNOMED=$G(@LRN@("icd@value"))
     281        . N SNOGRF S SNOGRF="snomed:"_SNOMED
     282        . N SNOTIT S SNOTIT=$G(@LRN@("name@value"))
     283        . I $D(DEBUG) D  ;
     284        . . W !,"Processing Problem List ",PROBID
     285        . . W !,"problem: ",SNOTIT
     286        . . W !,"code: ",SNOMED
     287        . ;
     288        . ; first do the base result graph
     289        . ;
     290        . S ZR("rdf:type")="sp:Problem"
     291        . S ZR("sp:belongsTo")=C0SGRF ; the subject for this patient's problems
     292        . ; ie /vista/smart/99912345/problems
     293        . ;
     294        . N PROBNAME S PROBNAME=$$ANONS^C0XF2N ; new node for problem name
     295        . S ZR("sp:problemName")=PROBNAME
     296        . ;
     297        . N STARTDT S STARTDT=$$SPDATE^C0SUTIL($G(@LRN@("entered@value")))
     298        . S ZR("sp:startDate")=STARTDT
     299        . ;
     300        . D ADDINN^C0XF2N(C0SGRF,PROBID,.ZR) ; addIfNotNull the triples
     301        . K ZR ; clean up
     302        . ;
     303        . ; create the problemName graph
     304        . ;
     305        . S ZR("rdf:type")="sp:CodedValue"
     306        . S ZR("sp:code")="snomed:"_SNOMED
     307        . S ZR("dcterms:title")=$G(@LRN@("name@value"))
     308        . D ADDINN^C0XF2N(C0SGRF,PROBNAME,.ZR)
     309        . K ZR
     310        . ;
     311        . ; create snomed graph
     312        . ;
     313        . S ZR("rdf:type")="sp:Code"
     314        . S ZR("sp:system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     315        . S ZR("dcterms:identifier")=SNOMED
     316        . S ZR("dcterms:title")=SNOTIT
     317        . D ADDINN^C0XF2N(C0SGRF,SNOGRF,.ZR)
     318        . K ZR
     319        . ;
     320        D BULKLOAD^C0XF2N(.C0XFDA)
     321        S GRTN=C0SGRF
     322        Q
     323        ;
  • smart/trunk/p/C0SPROB2.m

    r1569 r1571  
    1 C0SPROB   ; GPL - Smart Problem Processing ;5/01/12  17:05
    2  ;;0.1;C0S;nopatch;noreleasedate;Build 2
    3  ;Copyright 2012 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  ; sample VistA NHIN problem list
    23  ;
    24  ;^TMP("C0STBL",91,"problem",1,"acuity@value")="C"
    25  ;^TMP("C0STBL",91,"problem",1,"entered@value")=3110531
    26  ;^TMP("C0STBL",91,"problem",1,"facility@code")=100
    27  ;^TMP("C0STBL",91,"problem",1,"facility@name")="VOE OFFICE INSTITUTION"
    28  ;^TMP("C0STBL",91,"problem",1,"icd@value")=414.9
    29  ;^TMP("C0STBL",91,"problem",1,"id@value")=100
    30  ;^TMP("C0STBL",91,"problem",1,"location@value")="DR OFFICE"
    31  ;^TMP("C0STBL",91,"problem",1,"name@value")="Coronary Artery Disease"
    32  ;^TMP("C0STBL",91,"problem",1,"onset@value")=3100201
    33  ;^TMP("C0STBL",91,"problem",1,"provider@code")=63
    34  ;^TMP("C0STBL",91,"problem",1,"provider@name")="KING,MATTHEW MICHAEL"
    35  ;^TMP("C0STBL",91,"problem",1,"removed@value")=0
    36  ;^TMP("C0STBL",91,"problem",1,"sc@value")=0
    37  ;^TMP("C0STBL",91,"problem",1,"status@value")="A"
    38  ;^TMP("C0STBL",91,"problem",1,"unverified@value")=0
    39  ;^TMP("C0STBL",91,"problem",1,"updated@value")=3110531
    40  ;^TMP("C0STBL",91,"problem",2,"acuity@value")="C"
    41  ;^TMP("C0STBL",91,"problem",2,"entered@value")=3110602
    42  ;^TMP("C0STBL",91,"problem",2,"facility@code")=100
    43  ;^TMP("C0STBL",91,"problem",2,"facility@name")="VOE OFFICE INSTITUTION"
    44  ;^TMP("C0STBL",91,"problem",2,"icd@value")=780.2
    45  ;^TMP("C0STBL",91,"problem",2,"id@value")=108
    46  ;^TMP("C0STBL",91,"problem",2,"name@value")="Syncope and collapse"
    47  ;^TMP("C0STBL",91,"problem",2,"onset@value")=3110102
    48  ;^TMP("C0STBL",91,"problem",2,"provider@code")=63
    49  ;^TMP("C0STBL",91,"problem",2,"provider@name")="KING,MATTHEW MICHAEL"
    50  ;^TMP("C0STBL",91,"problem",2,"removed@value")=0
    51  ;^TMP("C0STBL",91,"problem",2,"sc@value")=0
    52  ;^TMP("C0STBL",91,"problem",2,"status@value")="A"
    53  ;^TMP("C0STBL",91,"problem",2,"unverified@value")=0
    54  ;^TMP("C0STBL",91,"problem",2,"updated@value")=3110602
    55  ;^TMP("C0STBL",91,"problem",3,"acuity@value")="C"
    56  ;^TMP("C0STBL",91,"problem",3,"entered@value")=3110602
    57  ;^TMP("C0STBL",91,"problem",3,"facility@code")=100
    58  ;^TMP("C0STBL",91,"problem",3,"facility@name")="VOE OFFICE INSTITUTION"
    59  ;^TMP("C0STBL",91,"problem",3,"icd@value")=433.91
    60  ;^TMP("C0STBL",91,"problem",3,"id@value")=109
    61  ;^TMP("C0STBL",91,"problem",3,"name@value")="Occlusion and Stenosis of Unspecifid Precerebral Artery with Cerebral Infarctio"
    62  ;^TMP("C0STBL",91,"problem",3,"onset@value")=3100101
    63  ;^TMP("C0STBL",91,"problem",3,"provider@code")=63
    64  ;^TMP("C0STBL",91,"problem",3,"provider@name")="KING,MATTHEW MICHAEL"
    65  ;^TMP("C0STBL",91,"problem",3,"removed@value")=0
    66  ;^TMP("C0STBL",91,"problem",3,"sc@value")=0
    67  ;^TMP("C0STBL",91,"problem",3,"status@value")="A"
    68  ;^TMP("C0STBL",91,"problem",3,"unverified@value")=0
    69  ;^TMP("C0STBL",91,"problem",3,"updated@value")=3110602
    70  ;^TMP("C0STBL",91,"problem",4,"entered@value")=3110603
    71  ;^TMP("C0STBL",91,"problem",4,"facility@code")=100
    72  ;^TMP("C0STBL",91,"problem",4,"facility@name")="VOE OFFICE INSTITUTION"
    73  ;^TMP("C0STBL",91,"problem",4,"icd@value")="00.66"
    74  ;^TMP("C0STBL",91,"problem",4,"id@value")=115
    75  ;^TMP("C0STBL",91,"problem",4,"location@value")="DR OFFICE"
    76  ;^TMP("C0STBL",91,"problem",4,"name@value")="00.66"
    77  ;^TMP("C0STBL",91,"problem",4,"provider@code")=63
    78  ;^TMP("C0STBL",91,"problem",4,"provider@name")="KING,MATTHEW MICHAEL"
    79  ;^TMP("C0STBL",91,"problem",4,"removed@value")=0
    80  ;^TMP("C0STBL",91,"problem",4,"status@value")="A"
    81  ;^TMP("C0STBL",91,"problem",4,"unverified@value")=0
    82  ;^TMP("C0STBL",91,"problem",4,"updated@value")=3110603
    83  ;^TMP("C0STBL",91,"problem",5,"entered@value")=3110603
    84  ;^TMP("C0STBL",91,"problem",5,"facility@code")=100
    85  ;^TMP("C0STBL",91,"problem",5,"facility@name")="VOE OFFICE INSTITUTION"
    86  ;^TMP("C0STBL",91,"problem",5,"icd@value")=37.21
    87  ;^TMP("C0STBL",91,"problem",5,"id@value")=116
    88  ;^TMP("C0STBL",91,"problem",5,"location@value")="DR OFFICE"
    89  ;^TMP("C0STBL",91,"problem",5,"name@value")=37.21
    90  ;^TMP("C0STBL",91,"problem",5,"provider@code")=63
    91  ;^TMP("C0STBL",91,"problem",5,"provider@name")="KING,MATTHEW MICHAEL"
    92  ;^TMP("C0STBL",91,"problem",5,"removed@value")=0
    93  ;^TMP("C0STBL",91,"problem",5,"status@value")="A"
    94  ;^TMP("C0STBL",91,"problem",5,"unverified@value")=0
    95  ;^TMP("C0STBL",91,"problem",5,"updated@value")=3110603
    96  ;^TMP("C0STBL",91,"problem",6,"entered@value")=3110603
    97  ;^TMP("C0STBL",91,"problem",6,"facility@code")=100
    98  ;^TMP("C0STBL",91,"problem",6,"facility@name")="VOE OFFICE INSTITUTION"
    99  ;^TMP("C0STBL",91,"problem",6,"icd@value")=81.51
    100  ;^TMP("C0STBL",91,"problem",6,"id@value")=117
    101  ;^TMP("C0STBL",91,"problem",6,"location@value")="DR OFFICE"
    102  ;^TMP("C0STBL",91,"problem",6,"name@value")=81.51
    103  ;^TMP("C0STBL",91,"problem",6,"provider@code")=63
    104  ;^TMP("C0STBL",91,"problem",6,"provider@name")="KING,MATTHEW MICHAEL"
    105  ;^TMP("C0STBL",91,"problem",6,"removed@value")=0
    106  ;^TMP("C0STBL",91,"problem",6,"status@value")="A"
    107  ;^TMP("C0STBL",91,"problem",6,"unverified@value")=0
    108  ;^TMP("C0STBL",91,"problem",6,"updated@value")=3110603
    109  ;^TMP("C0STBL",91,"problem",7,"entered@value")=3110603
    110  ;^TMP("C0STBL",91,"problem",7,"facility@code")=100
    111  ;^TMP("C0STBL",91,"problem",7,"facility@name")="VOE OFFICE INSTITUTION"
    112  ;^TMP("C0STBL",91,"problem",7,"icd@value")=47.09
    113  ;^TMP("C0STBL",91,"problem",7,"id@value")=118
    114  ;^TMP("C0STBL",91,"problem",7,"location@value")="DR OFFICE"
    115  ;^TMP("C0STBL",91,"problem",7,"name@value")=47.09
    116  ;^TMP("C0STBL",91,"problem",7,"provider@code")=63
    117  ;^TMP("C0STBL",91,"problem",7,"provider@name")="KING,MATTHEW MICHAEL"
    118  ;^TMP("C0STBL",91,"problem",7,"removed@value")=0
    119  ;^TMP("C0STBL",91,"problem",7,"status@value")="A"
    120  ;^TMP("C0STBL",91,"problem",7,"unverified@value")=0
    121  ;^TMP("C0STBL",91,"problem",7,"updated@value")=3110603
    122  ;^TMP("C0STBL",91,"problem",8,"entered@value")=3110603
    123  ;^TMP("C0STBL",91,"problem",8,"facility@code")=100
    124  ;^TMP("C0STBL",91,"problem",8,"facility@name")="VOE OFFICE INSTITUTION"
    125  ;^TMP("C0STBL",91,"problem",8,"icd@value")="250.00"
    126  ;^TMP("C0STBL",91,"problem",8,"id@value")=119
    127  ;^TMP("C0STBL",91,"problem",8,"location@value")="DR OFFICE"
    128  ;^TMP("C0STBL",91,"problem",8,"name@value")="Diabetes Mellitus without mentionof Complication, type II or unspecified type,"
    129  ;^TMP("C0STBL",91,"problem",8,"provider@code")=63
    130  ;^TMP("C0STBL",91,"problem",8,"provider@name")="KING,MATTHEW MICHAEL"
    131  ;^TMP("C0STBL",91,"problem",8,"removed@value")=0
    132  ;^TMP("C0STBL",91,"problem",8,"status@value")="A"
    133  ;^TMP("C0STBL",91,"problem",8,"unverified@value")=0
    134  ;^TMP("C0STBL",91,"problem",8,"updated@value")=3110603
    135  ;
    136  ; sample Smart lab result triples
    137  ;
    138  ;G("node16rk1fgdvx10882","code")="snomed:40930008"
    139  ;G("node16rk1fgdvx10882","dcterms:title")="Hypothyroidism"
    140  ;G("node16rk1fgdvx10882","rdf:type")="sp:CodedValue"
    141  ;G("node16rk1fgdvx11051","code")="snomed:188155002"
    142  ;G("node16rk1fgdvx11051","dcterms:title")="Primary malignant neoplasm of lower outer quadrant of female breast"
    143  ;G("node16rk1fgdvx11051","rdf:type")="sp:CodedValue"
    144  ;G("node16rk1fgdvx11073","code")="snomed:353295004"
    145  ;G("node16rk1fgdvx11073","dcterms:title")="Toxic diffuse goiter"
    146  ;G("node16rk1fgdvx11073","rdf:type")="sp:CodedValue"
    147  ;G("node16rk1fgdvx11089","code")="snomed:54302000"
    148  ;G("node16rk1fgdvx11089","dcterms:title")="Disorder of breast"
    149  ;G("node16rk1fgdvx11089","rdf:type")="sp:CodedValue"
    150  ;G("node16rk1fgdvx11351","code")="snomed:38341003"
    151  ;G("node16rk1fgdvx11351","dcterms:title")="Essential hypertension"
    152  ;G("node16rk1fgdvx11351","rdf:type")="sp:CodedValue"
    153  ;G("node16rk1fgdvx11390","code")="snomed:44054006"
    154  ;G("node16rk1fgdvx11390","dcterms:title")="Diabetes mellitus type 2"
    155  ;G("node16rk1fgdvx11390","rdf:type")="sp:CodedValue"
    156  ;G("node16rk1fgdvx11558","code")="snomed:195967001"
    157  ;G("node16rk1fgdvx11558","dcterms:title")="Asthma"
    158  ;G("node16rk1fgdvx11558","rdf:type")="sp:CodedValue"
    159  ;G("node16rk1fgdvx11578","code")="snomed:254837009"
    160  ;G("node16rk1fgdvx11578","dcterms:title")="Primary malignant neoplasm of female breast"
    161  ;G("node16rk1fgdvx11578","rdf:type")="sp:CodedValue"
    162  ;G("node16rk1fgdvx11687","code")="snomed:8517006"
    163  ;G("node16rk1fgdvx11687","dcterms:title")="History of tobacco use"
    164  ;G("node16rk1fgdvx11687","rdf:type")="sp:CodedValue"
    165  ;G("node16rk1fgdvx11716","code")="snomed:55822004"
    166  ;G("node16rk1fgdvx11716","dcterms:title")="Hyperlipidemia"
    167  ;G("node16rk1fgdvx11716","rdf:type")="sp:CodedValue"
    168  ;G("smart:1577780/problems/69560e4721e1","belongsTo")="smart:1577780"
    169  ;G("smart:1577780/problems/69560e4721e1","problemName")="node16rk1fgdvx11089"
    170  ;G("smart:1577780/problems/69560e4721e1","rdf:type")="sp:Problem"
    171  ;G("smart:1577780/problems/69560e4721e1","startDate")="2005-08-02"
    172  ;G("smart:1577780/problems/06ef10c4e92c","belongsTo")="smart:1577780"
    173  ;G("smart:1577780/problems/06ef10c4e92c","problemName")="node16rk1fgdvx11051"
    174  ;G("smart:1577780/problems/06ef10c4e92c","rdf:type")="sp:Problem"
    175  ;G("smart:1577780/problems/06ef10c4e92c","startDate")="2006-02-20"
    176  ;G("smart:1577780/problems/9894ba9dfe5a","belongsTo")="smart:1577780"
    177  ;G("smart:1577780/problems/9894ba9dfe5a","problemName")="node16rk1fgdvx11578"
    178  ;G("smart:1577780/problems/9894ba9dfe5a","rdf:type")="sp:Problem"
    179  ;G("smart:1577780/problems/9894ba9dfe5a","startDate")="2005-08-22"
    180  ;G("smart:1577780/problems/c109aa7a0675","belongsTo")="smart:1577780"
    181  ;G("smart:1577780/problems/c109aa7a0675","problemName")="node16rk1fgdvx11558"
    182  ;G("smart:1577780/problems/c109aa7a0675","rdf:type")="sp:Problem"
    183  ;G("smart:1577780/problems/c109aa7a0675","startDate")="2005-09-22"
    184  ;G("smart:1577780/problems/1c50100614a2","belongsTo")="smart:1577780"
    185  ;G("smart:1577780/problems/1c50100614a2","problemName")="node16rk1fgdvx11073"
    186  ;G("smart:1577780/problems/1c50100614a2","rdf:type")="sp:Problem"
    187  ;G("smart:1577780/problems/1c50100614a2","startDate")="2007-02-21"
    188  ;G("smart:1577780/problems/083dffb2c4a0","belongsTo")="smart:1577780"
    189  ;G("smart:1577780/problems/083dffb2c4a0","problemName")="node16rk1fgdvx11390"
    190  ;G("smart:1577780/problems/083dffb2c4a0","rdf:type")="sp:Problem"
    191  ;G("smart:1577780/problems/083dffb2c4a0","startDate")="2007-01-07"
    192  ;G("smart:1577780/problems/762b5639a2d1","belongsTo")="smart:1577780"
    193  ;G("smart:1577780/problems/762b5639a2d1","problemName")="node16rk1fgdvx11687"
    194  ;G("smart:1577780/problems/762b5639a2d1","rdf:type")="sp:Problem"
    195  ;G("smart:1577780/problems/762b5639a2d1","startDate")="2006-02-20"
    196  ;G("smart:1577780/problems/9dc9053dd6f4","belongsTo")="smart:1577780"
    197  ;G("smart:1577780/problems/9dc9053dd6f4","problemName")="node16rk1fgdvx11716"
    198  ;G("smart:1577780/problems/9dc9053dd6f4","rdf:type")="sp:Problem"
    199  ;G("smart:1577780/problems/9dc9053dd6f4","startDate")="2008-04-08"
    200  ;G("smart:1577780/problems/e3fe9b7ee552","belongsTo")="smart:1577780"
    201  ;G("smart:1577780/problems/e3fe9b7ee552","problemName")="node16rk1fgdvx10882"
    202  ;G("smart:1577780/problems/e3fe9b7ee552","rdf:type")="sp:Problem"
    203  ;G("smart:1577780/problems/e3fe9b7ee552","startDate")="2005-10-27"
    204  ;G("smart:1577780/problems/9933307e8f95","belongsTo")="smart:1577780"
    205  ;G("smart:1577780/problems/9933307e8f95","problemName")="node16rk1fgdvx11351"
    206  ;G("smart:1577780/problems/9933307e8f95","rdf:type")="sp:Problem"
    207  ;G("smart:1577780/problems/9933307e8f95","startDate")="2005-08-22"
    208  ;G("snomed:188155002","dcterms:identifier")=188155002
    209  ;G("snomed:188155002","dcterms:title")="Primary malignant neoplasm of lower outer quadrant of female breast"
    210  ;G("snomed:188155002","rdf:type")="sp:Code"
    211  ;G("snomed:188155002","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    212  ;G("snomed:195967001","dcterms:identifier")=195967001
    213  ;G("snomed:195967001","dcterms:title")="Asthma"
    214  ;G("snomed:195967001","rdf:type")="sp:Code"
    215  ;G("snomed:195967001","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    216  ;G("snomed:254837009","dcterms:identifier")=254837009
    217  ;G("snomed:254837009","dcterms:title")="Primary malignant neoplasm of female breast"
    218  ;G("snomed:254837009","rdf:type")="sp:Code"
    219  ;G("snomed:254837009","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    220  ;G("snomed:353295004","dcterms:identifier")=353295004
    221  ;G("snomed:353295004","dcterms:title")="Toxic diffuse goiter"
    222  ;G("snomed:353295004","rdf:type")="sp:Code"
    223  ;G("snomed:353295004","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    224  ;G("snomed:38341003","dcterms:identifier")=38341003
    225  ;G("snomed:38341003","dcterms:title")="Essential hypertension"
    226  ;G("snomed:38341003","rdf:type")="sp:Code"
    227  ;G("snomed:38341003","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    228  ;G("snomed:40930008","dcterms:identifier")=40930008
    229  ;G("snomed:40930008","dcterms:title")="Hypothyroidism"
    230  ;G("snomed:40930008","rdf:type")="sp:Code"
    231  ;G("snomed:40930008","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    232  ;G("snomed:44054006","dcterms:identifier")=44054006
    233  ;G("snomed:44054006","dcterms:title")="Diabetes mellitus type 2"
    234  ;G("snomed:44054006","rdf:type")="sp:Code"
    235  ;G("snomed:44054006","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    236  ;G("snomed:54302000","dcterms:identifier")=54302000
    237  ;G("snomed:54302000","dcterms:title")="Disorder of breast"
    238  ;G("snomed:54302000","rdf:type")="sp:Code"
    239  ;G("snomed:54302000","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    240  ;G("snomed:55822004","dcterms:identifier")=55822004
    241  ;G("snomed:55822004","dcterms:title")="Hyperlipidemia"
    242  ;G("snomed:55822004","rdf:type")="sp:Code"
    243  ;G("snomed:55822004","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    244  ;G("snomed:8517006","dcterms:identifier")=8517006
    245  ;G("snomed:8517006","dcterms:title")="History of tobacco use"
    246  ;G("snomed:8517006","rdf:type")="sp:Code"
    247  ;G("snomed:8517006","system")="http://purl.bioontology.org/ontology/SNOMEDCT/"
    248 
    249  ;
    250 PROB(GRTN,C0SARY) ; GRTN, passed by reference,
    251  ; is the return name of the graph created. "" if none
    252  ; C0SARY is passed in by reference and is the NHIN array of problems
    253  ;
    254  I $O(C0SARY("problem",""))="" D  Q  ;
    255  . I $D(DEBUG) W !,"No Problems"
    256  S GRTN="" ; default to no problems
    257  N C0SGRF
    258  S C0SGRF="vistaSmart:"_ZPATID_"/problems"
    259  I $D(DEBUG) W !,"Processing ",C0SGRF
    260  D DELGRAPH^C0XF2N(C0SGRF) ; delete the old graph
    261  D INITFARY^C0XF2N("C0XFARY") ; which triple store to use
    262  N FARY S FARY="C0XFARY"
    263  D USEFARY^C0XF2N(FARY)
    264  D VOCINIT^C0XUTIL
    265  ;
    266  D STARTADD^C0XF2N ; initialize to create triples
    267  ;
    268  N ZI S ZI=""
    269  F  S ZI=$O(C0SARY("problem",ZI)) Q:ZI=""  D  ;
    270  . N LRN,ZR ; ZR is the local array for building the new triples
    271  . S LRN=$NA(C0SARY("problem",ZI)) ; base for values in this lab result
    272  . ;
    273  . N PROBID ; unique Id for this problem
    274  . S PROBID=C0SGRF_"/"_$$LKY17^C0XF2N ; use a random number
    275  . ;
    276  . ; i don't like this because the same problems gets a
    277  . ; different ID every time it's reported. Can't trace it back to VistA
    278  . ; I'd rather be using id@value ie "id@value")="118"
    279  . ;
    280  . N SNOMED,ICD S ICD=$G(@LRN@("icd@value"))
    281  . S SNOMED=$$SNOMED(ICD) ; look up the snomed code in the map
    282  . N SNOGRF ; graph for SNOMED code
    283  . I SNOMED="" D  ;
    284  . . S SNOMED=ICD ; if not found, return the ICD code
    285  . . S SNOGRF="icd9:"_SNOMED
    286  . E  S SNOGRF="snomed:"_SNOMED
    287  . N SNOTIT S SNOTIT=$G(@LRN@("name@value"))
    288  . I $D(DEBUG) D  ;
    289  . . W !,"Processing Problem List ",PROBID
    290  . . W !,"problem: ",SNOTIT
    291  . . W !,"code: ",SNOMED
    292  . ;
    293  . ; first do the base result graph
    294  . ;
    295  . S ZR("rdf:type")="sp:Problem"
    296  . S ZR("sp:belongsTo")=C0SGRF ; the subject for this patient's problems
    297  . ; ie /vista/smart/99912345/problems
    298  . ;
    299  . N PROBNAME S PROBNAME=$$ANONS^C0XF2N ; new node for problem name
    300  . S ZR("sp:problemName")=PROBNAME
    301  . ;
    302  . N STARTDT S STARTDT=$$SPDATE^C0SUTIL($G(@LRN@("entered@value")))
    303  . S ZR("sp:startDate")=STARTDT
    304  . ;
    305  . D ADDINN^C0XF2N(C0SGRF,PROBID,.ZR) ; addIfNotNull the triples
    306  . K ZR ; clean up
    307  . ;
    308  . ; create the problemName graph
    309  . ;
    310  . S ZR("rdf:type")="sp:CodedValue"
    311  . ;S ZR("sp:code")="snomed:"_SNOMED
    312  . S ZR("sp:code")=SNOGRF
    313  . S ZR("dcterms:title")=$G(@LRN@("name@value"))
    314  . D ADDINN^C0XF2N(C0SGRF,PROBNAME,.ZR)
    315  . K ZR
    316  . ;
    317  . ; create snomed graph
    318  . ;
    319  . S ZR("rdf:type")="sp:Code"
    320  . S ZR("sp:system")="http://purl.bioontology.org/ontology/SNOMEDCT"
    321  . I SNOGRF["icd9" S ZR("sp:system")="http://purl.bioontology.org/ontology/ICD9"
    322  . S ZR("dcterms:identifier")=SNOMED
    323  . S ZR("dcterms:title")=SNOTIT
    324  . D ADDINN^C0XF2N(C0SGRF,SNOGRF,.ZR)
    325  . K ZR
    326  . ;
    327  D BULKLOAD^C0XF2N(.C0XFDA)
    328  S GRTN=C0SGRF
    329  Q
    330  ;
    331 SNOMED(ZICD) ; extrinsic which returns SNOMED code given an ICD9 code
    332  ; requires the mapping table installed in the triplestore
    333  ;
    334  N ZSN,ZARY,ZSUB,ZSUBS
    335  I $E(ZICD,$L(ZICD))="." S ZICD=$P(ZICD,".",1) ; handle trailing dots
    336  D subjects^C0XGET1(.ZSUBS,"cg:ontology#code",ZICD) ; subjects with the ICD9 code
    337  S ZSUB=$O(ZSUBS("")) ; pick the first one
    338  I ZSUB="" Q ""
    339  D objects^C0XGET1(.ZARY,ZSUB,"cg:ontology#toCode")
    340  S ZSN=$O(ZARY(""))
    341  I $D(DEBUG) W !,ZSN," ",$$object^C0XGET1(ZSUB,"rdfs:label")
    342  Q ZSN
    343  ;
     1C0SPROB   ; GPL - Smart Problem Processing ;5/01/12  17:05
     2        ;;1.0;VISTA SMART CONTAINER;;Sep 26, 2012;Build 4
     3        ;Copyright 2012 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        ; sample VistA NHIN problem list
     23        ;
     24        ;^TMP("C0STBL",91,"problem",1,"acuity@value")="C"
     25        ;^TMP("C0STBL",91,"problem",1,"entered@value")=3110531
     26        ;^TMP("C0STBL",91,"problem",1,"facility@code")=100
     27        ;^TMP("C0STBL",91,"problem",1,"facility@name")="VOE OFFICE INSTITUTION"
     28        ;^TMP("C0STBL",91,"problem",1,"icd@value")=414.9
     29        ;^TMP("C0STBL",91,"problem",1,"id@value")=100
     30        ;^TMP("C0STBL",91,"problem",1,"location@value")="DR OFFICE"
     31        ;^TMP("C0STBL",91,"problem",1,"name@value")="Coronary Artery Disease"
     32        ;^TMP("C0STBL",91,"problem",1,"onset@value")=3100201
     33        ;^TMP("C0STBL",91,"problem",1,"provider@code")=63
     34        ;^TMP("C0STBL",91,"problem",1,"provider@name")="KING,MATTHEW MICHAEL"
     35        ;^TMP("C0STBL",91,"problem",1,"removed@value")=0
     36        ;^TMP("C0STBL",91,"problem",1,"sc@value")=0
     37        ;^TMP("C0STBL",91,"problem",1,"status@value")="A"
     38        ;^TMP("C0STBL",91,"problem",1,"unverified@value")=0
     39        ;^TMP("C0STBL",91,"problem",1,"updated@value")=3110531
     40        ;^TMP("C0STBL",91,"problem",2,"acuity@value")="C"
     41        ;^TMP("C0STBL",91,"problem",2,"entered@value")=3110602
     42        ;^TMP("C0STBL",91,"problem",2,"facility@code")=100
     43        ;^TMP("C0STBL",91,"problem",2,"facility@name")="VOE OFFICE INSTITUTION"
     44        ;^TMP("C0STBL",91,"problem",2,"icd@value")=780.2
     45        ;^TMP("C0STBL",91,"problem",2,"id@value")=108
     46        ;^TMP("C0STBL",91,"problem",2,"name@value")="Syncope and collapse"
     47        ;^TMP("C0STBL",91,"problem",2,"onset@value")=3110102
     48        ;^TMP("C0STBL",91,"problem",2,"provider@code")=63
     49        ;^TMP("C0STBL",91,"problem",2,"provider@name")="KING,MATTHEW MICHAEL"
     50        ;^TMP("C0STBL",91,"problem",2,"removed@value")=0
     51        ;^TMP("C0STBL",91,"problem",2,"sc@value")=0
     52        ;^TMP("C0STBL",91,"problem",2,"status@value")="A"
     53        ;^TMP("C0STBL",91,"problem",2,"unverified@value")=0
     54        ;^TMP("C0STBL",91,"problem",2,"updated@value")=3110602
     55        ;^TMP("C0STBL",91,"problem",3,"acuity@value")="C"
     56        ;^TMP("C0STBL",91,"problem",3,"entered@value")=3110602
     57        ;^TMP("C0STBL",91,"problem",3,"facility@code")=100
     58        ;^TMP("C0STBL",91,"problem",3,"facility@name")="VOE OFFICE INSTITUTION"
     59        ;^TMP("C0STBL",91,"problem",3,"icd@value")=433.91
     60        ;^TMP("C0STBL",91,"problem",3,"id@value")=109
     61        ;^TMP("C0STBL",91,"problem",3,"name@value")="Occlusion and Stenosis of Unspecifid Precerebral Artery with Cerebral Infarctio"
     62        ;^TMP("C0STBL",91,"problem",3,"onset@value")=3100101
     63        ;^TMP("C0STBL",91,"problem",3,"provider@code")=63
     64        ;^TMP("C0STBL",91,"problem",3,"provider@name")="KING,MATTHEW MICHAEL"
     65        ;^TMP("C0STBL",91,"problem",3,"removed@value")=0
     66        ;^TMP("C0STBL",91,"problem",3,"sc@value")=0
     67        ;^TMP("C0STBL",91,"problem",3,"status@value")="A"
     68        ;^TMP("C0STBL",91,"problem",3,"unverified@value")=0
     69        ;^TMP("C0STBL",91,"problem",3,"updated@value")=3110602
     70        ;^TMP("C0STBL",91,"problem",4,"entered@value")=3110603
     71        ;^TMP("C0STBL",91,"problem",4,"facility@code")=100
     72        ;^TMP("C0STBL",91,"problem",4,"facility@name")="VOE OFFICE INSTITUTION"
     73        ;^TMP("C0STBL",91,"problem",4,"icd@value")="00.66"
     74        ;^TMP("C0STBL",91,"problem",4,"id@value")=115
     75        ;^TMP("C0STBL",91,"problem",4,"location@value")="DR OFFICE"
     76        ;^TMP("C0STBL",91,"problem",4,"name@value")="00.66"
     77        ;^TMP("C0STBL",91,"problem",4,"provider@code")=63
     78        ;^TMP("C0STBL",91,"problem",4,"provider@name")="KING,MATTHEW MICHAEL"
     79        ;^TMP("C0STBL",91,"problem",4,"removed@value")=0
     80        ;^TMP("C0STBL",91,"problem",4,"status@value")="A"
     81        ;^TMP("C0STBL",91,"problem",4,"unverified@value")=0
     82        ;^TMP("C0STBL",91,"problem",4,"updated@value")=3110603
     83        ;^TMP("C0STBL",91,"problem",5,"entered@value")=3110603
     84        ;^TMP("C0STBL",91,"problem",5,"facility@code")=100
     85        ;^TMP("C0STBL",91,"problem",5,"facility@name")="VOE OFFICE INSTITUTION"
     86        ;^TMP("C0STBL",91,"problem",5,"icd@value")=37.21
     87        ;^TMP("C0STBL",91,"problem",5,"id@value")=116
     88        ;^TMP("C0STBL",91,"problem",5,"location@value")="DR OFFICE"
     89        ;^TMP("C0STBL",91,"problem",5,"name@value")=37.21
     90        ;^TMP("C0STBL",91,"problem",5,"provider@code")=63
     91        ;^TMP("C0STBL",91,"problem",5,"provider@name")="KING,MATTHEW MICHAEL"
     92        ;^TMP("C0STBL",91,"problem",5,"removed@value")=0
     93        ;^TMP("C0STBL",91,"problem",5,"status@value")="A"
     94        ;^TMP("C0STBL",91,"problem",5,"unverified@value")=0
     95        ;^TMP("C0STBL",91,"problem",5,"updated@value")=3110603
     96        ;^TMP("C0STBL",91,"problem",6,"entered@value")=3110603
     97        ;^TMP("C0STBL",91,"problem",6,"facility@code")=100
     98        ;^TMP("C0STBL",91,"problem",6,"facility@name")="VOE OFFICE INSTITUTION"
     99        ;^TMP("C0STBL",91,"problem",6,"icd@value")=81.51
     100        ;^TMP("C0STBL",91,"problem",6,"id@value")=117
     101        ;^TMP("C0STBL",91,"problem",6,"location@value")="DR OFFICE"
     102        ;^TMP("C0STBL",91,"problem",6,"name@value")=81.51
     103        ;^TMP("C0STBL",91,"problem",6,"provider@code")=63
     104        ;^TMP("C0STBL",91,"problem",6,"provider@name")="KING,MATTHEW MICHAEL"
     105        ;^TMP("C0STBL",91,"problem",6,"removed@value")=0
     106        ;^TMP("C0STBL",91,"problem",6,"status@value")="A"
     107        ;^TMP("C0STBL",91,"problem",6,"unverified@value")=0
     108        ;^TMP("C0STBL",91,"problem",6,"updated@value")=3110603
     109        ;^TMP("C0STBL",91,"problem",7,"entered@value")=3110603
     110        ;^TMP("C0STBL",91,"problem",7,"facility@code")=100
     111        ;^TMP("C0STBL",91,"problem",7,"facility@name")="VOE OFFICE INSTITUTION"
     112        ;^TMP("C0STBL",91,"problem",7,"icd@value")=47.09
     113        ;^TMP("C0STBL",91,"problem",7,"id@value")=118
     114        ;^TMP("C0STBL",91,"problem",7,"location@value")="DR OFFICE"
     115        ;^TMP("C0STBL",91,"problem",7,"name@value")=47.09
     116        ;^TMP("C0STBL",91,"problem",7,"provider@code")=63
     117        ;^TMP("C0STBL",91,"problem",7,"provider@name")="KING,MATTHEW MICHAEL"
     118        ;^TMP("C0STBL",91,"problem",7,"removed@value")=0
     119        ;^TMP("C0STBL",91,"problem",7,"status@value")="A"
     120        ;^TMP("C0STBL",91,"problem",7,"unverified@value")=0
     121        ;^TMP("C0STBL",91,"problem",7,"updated@value")=3110603
     122        ;^TMP("C0STBL",91,"problem",8,"entered@value")=3110603
     123        ;^TMP("C0STBL",91,"problem",8,"facility@code")=100
     124        ;^TMP("C0STBL",91,"problem",8,"facility@name")="VOE OFFICE INSTITUTION"
     125        ;^TMP("C0STBL",91,"problem",8,"icd@value")="250.00"
     126        ;^TMP("C0STBL",91,"problem",8,"id@value")=119
     127        ;^TMP("C0STBL",91,"problem",8,"location@value")="DR OFFICE"
     128        ;^TMP("C0STBL",91,"problem",8,"name@value")="Diabetes Mellitus without mentionof Complication, type II or unspecified type,"
     129        ;^TMP("C0STBL",91,"problem",8,"provider@code")=63
     130        ;^TMP("C0STBL",91,"problem",8,"provider@name")="KING,MATTHEW MICHAEL"
     131        ;^TMP("C0STBL",91,"problem",8,"removed@value")=0
     132        ;^TMP("C0STBL",91,"problem",8,"status@value")="A"
     133        ;^TMP("C0STBL",91,"problem",8,"unverified@value")=0
     134        ;^TMP("C0STBL",91,"problem",8,"updated@value")=3110603
     135        ;
     136        ; sample Smart lab result triples
     137        ;
     138        ;G("node16rk1fgdvx10882","code")="snomed:40930008"
     139        ;G("node16rk1fgdvx10882","dcterms:title")="Hypothyroidism"
     140        ;G("node16rk1fgdvx10882","rdf:type")="sp:CodedValue"
     141        ;G("node16rk1fgdvx11051","code")="snomed:188155002"
     142        ;G("node16rk1fgdvx11051","dcterms:title")="Primary malignant neoplasm of lower outer quadrant of female breast"
     143        ;G("node16rk1fgdvx11051","rdf:type")="sp:CodedValue"
     144        ;G("node16rk1fgdvx11073","code")="snomed:353295004"
     145        ;G("node16rk1fgdvx11073","dcterms:title")="Toxic diffuse goiter"
     146        ;G("node16rk1fgdvx11073","rdf:type")="sp:CodedValue"
     147        ;G("node16rk1fgdvx11089","code")="snomed:54302000"
     148        ;G("node16rk1fgdvx11089","dcterms:title")="Disorder of breast"
     149        ;G("node16rk1fgdvx11089","rdf:type")="sp:CodedValue"
     150        ;G("node16rk1fgdvx11351","code")="snomed:38341003"
     151        ;G("node16rk1fgdvx11351","dcterms:title")="Essential hypertension"
     152        ;G("node16rk1fgdvx11351","rdf:type")="sp:CodedValue"
     153        ;G("node16rk1fgdvx11390","code")="snomed:44054006"
     154        ;G("node16rk1fgdvx11390","dcterms:title")="Diabetes mellitus type 2"
     155        ;G("node16rk1fgdvx11390","rdf:type")="sp:CodedValue"
     156        ;G("node16rk1fgdvx11558","code")="snomed:195967001"
     157        ;G("node16rk1fgdvx11558","dcterms:title")="Asthma"
     158        ;G("node16rk1fgdvx11558","rdf:type")="sp:CodedValue"
     159        ;G("node16rk1fgdvx11578","code")="snomed:254837009"
     160        ;G("node16rk1fgdvx11578","dcterms:title")="Primary malignant neoplasm of female breast"
     161        ;G("node16rk1fgdvx11578","rdf:type")="sp:CodedValue"
     162        ;G("node16rk1fgdvx11687","code")="snomed:8517006"
     163        ;G("node16rk1fgdvx11687","dcterms:title")="History of tobacco use"
     164        ;G("node16rk1fgdvx11687","rdf:type")="sp:CodedValue"
     165        ;G("node16rk1fgdvx11716","code")="snomed:55822004"
     166        ;G("node16rk1fgdvx11716","dcterms:title")="Hyperlipidemia"
     167        ;G("node16rk1fgdvx11716","rdf:type")="sp:CodedValue"
     168        ;G("smart:1577780/problems/69560e4721e1","belongsTo")="smart:1577780"
     169        ;G("smart:1577780/problems/69560e4721e1","problemName")="node16rk1fgdvx11089"
     170        ;G("smart:1577780/problems/69560e4721e1","rdf:type")="sp:Problem"
     171        ;G("smart:1577780/problems/69560e4721e1","startDate")="2005-08-02"
     172        ;G("smart:1577780/problems/06ef10c4e92c","belongsTo")="smart:1577780"
     173        ;G("smart:1577780/problems/06ef10c4e92c","problemName")="node16rk1fgdvx11051"
     174        ;G("smart:1577780/problems/06ef10c4e92c","rdf:type")="sp:Problem"
     175        ;G("smart:1577780/problems/06ef10c4e92c","startDate")="2006-02-20"
     176        ;G("smart:1577780/problems/9894ba9dfe5a","belongsTo")="smart:1577780"
     177        ;G("smart:1577780/problems/9894ba9dfe5a","problemName")="node16rk1fgdvx11578"
     178        ;G("smart:1577780/problems/9894ba9dfe5a","rdf:type")="sp:Problem"
     179        ;G("smart:1577780/problems/9894ba9dfe5a","startDate")="2005-08-22"
     180        ;G("smart:1577780/problems/c109aa7a0675","belongsTo")="smart:1577780"
     181        ;G("smart:1577780/problems/c109aa7a0675","problemName")="node16rk1fgdvx11558"
     182        ;G("smart:1577780/problems/c109aa7a0675","rdf:type")="sp:Problem"
     183        ;G("smart:1577780/problems/c109aa7a0675","startDate")="2005-09-22"
     184        ;G("smart:1577780/problems/1c50100614a2","belongsTo")="smart:1577780"
     185        ;G("smart:1577780/problems/1c50100614a2","problemName")="node16rk1fgdvx11073"
     186        ;G("smart:1577780/problems/1c50100614a2","rdf:type")="sp:Problem"
     187        ;G("smart:1577780/problems/1c50100614a2","startDate")="2007-02-21"
     188        ;G("smart:1577780/problems/083dffb2c4a0","belongsTo")="smart:1577780"
     189        ;G("smart:1577780/problems/083dffb2c4a0","problemName")="node16rk1fgdvx11390"
     190        ;G("smart:1577780/problems/083dffb2c4a0","rdf:type")="sp:Problem"
     191        ;G("smart:1577780/problems/083dffb2c4a0","startDate")="2007-01-07"
     192        ;G("smart:1577780/problems/762b5639a2d1","belongsTo")="smart:1577780"
     193        ;G("smart:1577780/problems/762b5639a2d1","problemName")="node16rk1fgdvx11687"
     194        ;G("smart:1577780/problems/762b5639a2d1","rdf:type")="sp:Problem"
     195        ;G("smart:1577780/problems/762b5639a2d1","startDate")="2006-02-20"
     196        ;G("smart:1577780/problems/9dc9053dd6f4","belongsTo")="smart:1577780"
     197        ;G("smart:1577780/problems/9dc9053dd6f4","problemName")="node16rk1fgdvx11716"
     198        ;G("smart:1577780/problems/9dc9053dd6f4","rdf:type")="sp:Problem"
     199        ;G("smart:1577780/problems/9dc9053dd6f4","startDate")="2008-04-08"
     200        ;G("smart:1577780/problems/e3fe9b7ee552","belongsTo")="smart:1577780"
     201        ;G("smart:1577780/problems/e3fe9b7ee552","problemName")="node16rk1fgdvx10882"
     202        ;G("smart:1577780/problems/e3fe9b7ee552","rdf:type")="sp:Problem"
     203        ;G("smart:1577780/problems/e3fe9b7ee552","startDate")="2005-10-27"
     204        ;G("smart:1577780/problems/9933307e8f95","belongsTo")="smart:1577780"
     205        ;G("smart:1577780/problems/9933307e8f95","problemName")="node16rk1fgdvx11351"
     206        ;G("smart:1577780/problems/9933307e8f95","rdf:type")="sp:Problem"
     207        ;G("smart:1577780/problems/9933307e8f95","startDate")="2005-08-22"
     208        ;G("snomed:188155002","dcterms:identifier")=188155002
     209        ;G("snomed:188155002","dcterms:title")="Primary malignant neoplasm of lower outer quadrant of female breast"
     210        ;G("snomed:188155002","rdf:type")="sp:Code"
     211        ;G("snomed:188155002","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     212        ;G("snomed:195967001","dcterms:identifier")=195967001
     213        ;G("snomed:195967001","dcterms:title")="Asthma"
     214        ;G("snomed:195967001","rdf:type")="sp:Code"
     215        ;G("snomed:195967001","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     216        ;G("snomed:254837009","dcterms:identifier")=254837009
     217        ;G("snomed:254837009","dcterms:title")="Primary malignant neoplasm of female breast"
     218        ;G("snomed:254837009","rdf:type")="sp:Code"
     219        ;G("snomed:254837009","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     220        ;G("snomed:353295004","dcterms:identifier")=353295004
     221        ;G("snomed:353295004","dcterms:title")="Toxic diffuse goiter"
     222        ;G("snomed:353295004","rdf:type")="sp:Code"
     223        ;G("snomed:353295004","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     224        ;G("snomed:38341003","dcterms:identifier")=38341003
     225        ;G("snomed:38341003","dcterms:title")="Essential hypertension"
     226        ;G("snomed:38341003","rdf:type")="sp:Code"
     227        ;G("snomed:38341003","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     228        ;G("snomed:40930008","dcterms:identifier")=40930008
     229        ;G("snomed:40930008","dcterms:title")="Hypothyroidism"
     230        ;G("snomed:40930008","rdf:type")="sp:Code"
     231        ;G("snomed:40930008","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     232        ;G("snomed:44054006","dcterms:identifier")=44054006
     233        ;G("snomed:44054006","dcterms:title")="Diabetes mellitus type 2"
     234        ;G("snomed:44054006","rdf:type")="sp:Code"
     235        ;G("snomed:44054006","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     236        ;G("snomed:54302000","dcterms:identifier")=54302000
     237        ;G("snomed:54302000","dcterms:title")="Disorder of breast"
     238        ;G("snomed:54302000","rdf:type")="sp:Code"
     239        ;G("snomed:54302000","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     240        ;G("snomed:55822004","dcterms:identifier")=55822004
     241        ;G("snomed:55822004","dcterms:title")="Hyperlipidemia"
     242        ;G("snomed:55822004","rdf:type")="sp:Code"
     243        ;G("snomed:55822004","system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     244        ;G("snomed:8517006","dcterms:identifier")=8517006
     245        ;G("snomed:8517006","dcterms:title")="History of tobacco use"
     246        ;G("snomed:8517006","rdf:type")="sp:Code"
     247        ;G("snomed:8517006","system")="http://purl.bioontology.org/ontology/SNOMEDCT/"
     248       
     249        ;
     250PROB(GRTN,C0SARY)       ; GRTN, passed by reference,
     251        ; is the return name of the graph created. "" if none
     252        ; C0SARY is passed in by reference and is the NHIN array of problems
     253        ;
     254        I $O(C0SARY("problem",""))="" D  Q  ;
     255        . I $D(DEBUG) W !,"No Problems"
     256        S GRTN="" ; default to no problems
     257        N C0SGRF
     258        S C0SGRF="vistaSmart:"_ZPATID_"/problems"
     259        I $D(DEBUG) W !,"Processing ",C0SGRF
     260        D DELGRAPH^C0XF2N(C0SGRF) ; delete the old graph
     261        D INITFARY^C0XF2N("C0XFARY") ; which triple store to use
     262        N FARY S FARY="C0XFARY"
     263        D USEFARY^C0XF2N(FARY)
     264        D VOCINIT^C0XUTIL
     265        ;
     266        D STARTADD^C0XF2N ; initialize to create triples
     267        ;
     268        N ZI S ZI=""
     269        F  S ZI=$O(C0SARY("problem",ZI)) Q:ZI=""  D  ;
     270        . N LRN,ZR ; ZR is the local array for building the new triples
     271        . S LRN=$NA(C0SARY("problem",ZI)) ; base for values in this lab result
     272        . ;
     273        . N PROBID ; unique Id for this problem
     274        . S PROBID=C0SGRF_"/"_$$LKY17^C0XF2N ; use a random number
     275        . ;
     276        . ; i don't like this because the same problems gets a
     277        . ; different ID every time it's reported. Can't trace it back to VistA
     278        . ; I'd rather be using id@value ie "id@value")="118"
     279        . ;
     280        . N SNOMED,ICD S ICD=$G(@LRN@("icd@value"))
     281        . S SNOMED=$$SNOMED(ICD) ; look up the snomed code in the map
     282        . N SNOGRF ; graph for SNOMED code
     283        . I SNOMED="" D  ;
     284        . . S SNOMED=ICD ; if not found, return the ICD code
     285        . . S SNOGRF="icd9:"_SNOMED
     286        . E  S SNOGRF="snomed:"_SNOMED
     287        . N SNOTIT S SNOTIT=$G(@LRN@("name@value"))
     288        . I $D(DEBUG) D  ;
     289        . . W !,"Processing Problem List ",PROBID
     290        . . W !,"problem: ",SNOTIT
     291        . . W !,"code: ",SNOMED
     292        . ;
     293        . ; first do the base result graph
     294        . ;
     295        . S ZR("rdf:type")="sp:Problem"
     296        . S ZR("sp:belongsTo")=C0SGRF ; the subject for this patient's problems
     297        . ; ie /vista/smart/99912345/problems
     298        . ;
     299        . N PROBNAME S PROBNAME=$$ANONS^C0XF2N ; new node for problem name
     300        . S ZR("sp:problemName")=PROBNAME
     301        . ;
     302        . N STARTDT S STARTDT=$$SPDATE^C0SUTIL($G(@LRN@("entered@value")))
     303        . S ZR("sp:startDate")=STARTDT
     304        . ;
     305        . D ADDINN^C0XF2N(C0SGRF,PROBID,.ZR) ; addIfNotNull the triples
     306        . K ZR ; clean up
     307        . ;
     308        . ; create the problemName graph
     309        . ;
     310        . S ZR("rdf:type")="sp:CodedValue"
     311        . ;S ZR("sp:code")="snomed:"_SNOMED
     312        . S ZR("sp:code")=SNOGRF
     313        . S ZR("dcterms:title")=$G(@LRN@("name@value"))
     314        . D ADDINN^C0XF2N(C0SGRF,PROBNAME,.ZR)
     315        . K ZR
     316        . ;
     317        . ; create snomed graph
     318        . ;
     319        . S ZR("rdf:type")="sp:Code"
     320        . S ZR("sp:system")="http://purl.bioontology.org/ontology/SNOMEDCT"
     321        . I SNOGRF["icd9" S ZR("sp:system")="http://purl.bioontology.org/ontology/ICD9"
     322        . S ZR("dcterms:identifier")=SNOMED
     323        . S ZR("dcterms:title")=SNOTIT
     324        . D ADDINN^C0XF2N(C0SGRF,SNOGRF,.ZR)
     325        . K ZR
     326        . ;
     327        D BULKLOAD^C0XF2N(.C0XFDA)
     328        S GRTN=C0SGRF
     329        Q
     330        ;
     331SNOMED(ZICD)    ; extrinsic which returns SNOMED code given an ICD9 code
     332        ; requires the mapping table installed in the triplestore
     333        ;
     334        N ZSN,ZARY,ZSUB,ZSUBS
     335        I $E(ZICD,$L(ZICD))="." S ZICD=$P(ZICD,".",1) ; handle trailing dots
     336        D subjects^C0XGET1(.ZSUBS,"cg:ontology#code",ZICD) ; subjects with the ICD9 code
     337        S ZSUB=$O(ZSUBS("")) ; pick the first one
     338        I ZSUB="" Q ""
     339        D objects^C0XGET1(.ZARY,ZSUB,"cg:ontology#toCode")
     340        S ZSN=$O(ZARY(""))
     341        I $D(DEBUG) W !,ZSN," ",$$object^C0XGET1(ZSUB,"rdfs:label")
     342        Q ZSN
     343        ;
  • smart/trunk/p/C0STBL.m

    r1569 r1571  
    1 C0STBL   ; GPL - Smart Container CREATE A TABLE OF NHINV VALUES;2/22/12  17:05
    2  ;;0.1;C0S;nopatch;noreleasedate;Build 2
     1C0STBL    ; GPL - Smart Container CREATE A TABLE OF NHINV VALUES;2/22/12  17:05
     2        ;;1.0;VISTA SMART CONTAINER;;Sep 26, 2012;Build 4
    33 ;Copyright 2012 George Lilly.  Licensed under the terms of the GNU
    44 ;General Public License See attached copy of the License.
  • smart/trunk/p/C0SUTIL.m

    r1569 r1571  
    1 C0SUTIL   ; GPL - Smart Processing Utilities ;2/22/12  17:05
    2  ;;0.1;C0S;nopatch;noreleasedate;Build 2
    3  ;Copyright 2012 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 SPDATE(ZDATE) ; extrinsic which returns the Smart date format yyyy-mm-dd
    23  ; ZDATE is a fileman format date
    24  N TMPDT
    25  S TMPDT=$$FMTE^XLFDT(ZDATE,"7D") ; ordered date
    26  S TMPDT=$TR(TMPDT,"/","-") ; change slashes to hyphens
    27  I TMPDT="" S TMPDT="UNKNOWN"
    28  N Z2,Z3
    29  S Z2=$P(TMPDT,"-",2)
    30  S Z3=$P(TMPDT,"-",3)
    31  I $L(Z2)=1 S $P(TMPDT,"-",2)="0"_Z2
    32  I $L(Z3)=1 S $P(TMPDT,"-",3)="0"_Z3
    33  Q TMPDT
    34  ;
     1C0SUTIL   ; GPL - Smart Processing Utilities ;2/22/12  17:05
     2        ;;1.0;VISTA SMART CONTAINER;;Sep 26, 2012;Build 4
     3        ;Copyright 2012 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        ;
     22SPDATE(ZDATE)   ; extrinsic which returns the Smart date format yyyy-mm-dd
     23        ; ZDATE is a fileman format date
     24        N TMPDT
     25        S TMPDT=$$FMTE^XLFDT(ZDATE,"7D") ; ordered date
     26        S TMPDT=$TR(TMPDT,"/","-") ; change slashes to hyphens
     27        I TMPDT="" S TMPDT="UNKNOWN"
     28        N Z2,Z3
     29        S Z2=$P(TMPDT,"-",2)
     30        S Z3=$P(TMPDT,"-",3)
     31        I $L(Z2)=1 S $P(TMPDT,"-",2)="0"_Z2
     32        I $L(Z3)=1 S $P(TMPDT,"-",3)="0"_Z3
     33        Q TMPDT
     34        ;
  • smart/trunk/p/C0SXPATH.m

    r1569 r1571  
    1 C0SXPATH   ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
    2  ;;1.0;C0S;;May 19, 2009;Build 2
    3  ;Copyright 2008-2012 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 an XML XPATH utility library",!
    21  W !
    22  Q
    23  ;
    24 OUTPUT(OUTARY,OUTNAME,OUTDIR)   ; WRITE AN ARRAY TO A FILE
    25  ;
    26  N Y
    27  S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME)
    28  I Y Q 1_U_"WROTE FILE: "_OUTNAME_" TO "_OUTDIR
    29  I 'Y Q 0_U_"ERROR WRITING FILE"_OUTNAME_" TO "_OUTDIR
    30  Q
    31  ;
    32 PUSH(STK,VAL)   ; pushs VAL onto STK and updates STK(0)
    33  ;  VAL IS A STRING AND STK IS PASSED BY NAME
    34  ;
    35  I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE
    36  S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH
    37  S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY
    38  Q
    39  ;
    40 POP(STK,VAL)    ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL
    41  ; VAL AND STK ARE PASSED BY REFERENCE
    42  ;
    43  I @STK@(0)<1 D  ; IF ARRAY IS EMPTY
    44  . S VAL=""
    45  . S @STK@(0)=0
    46  I @STK@(0)>0  D  ;
    47  . S VAL=@STK@(@STK@(0))
    48  . K @STK@(@STK@(0))
    49  . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY
    50  Q
    51  ;
    52 PUSHA(ADEST,ASRC) ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME
    53  ;
    54  N ZGI
    55  F ZGI=1:1:@ASRC@(0) D  ; FOR ALL OF THE SOURCE ARRAY
    56  . D PUSH(ADEST,@ASRC@(ZGI)) ; PUSH ONE ELEMENT
    57  Q
    58  ;
    59 MKMDX(STK,RTN,INREDUX)  ; MAKES A MUMPS INDEX FROM THE ARRAY STK
    60  ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS
    61  ; REDUX IS A STRING TO REMOVE FROM THE RESULT
    62  S RTN=""
    63  N I
    64  ; W "STK= ",STK,!
    65  I @STK@(0)>0  D  ; IF THE ARRAY IS NOT EMPTY
    66  . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON
    67  . I @STK@(0)>1  D  ; SUBSEQUENT ELEMENTS NEED A SEMICOLON
    68  . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I)
    69  I $G(INREDUX)'="" S RTN=$P(RTN,INREDUX,1)_$P(RTN,INREDUX,2)
    70  Q
    71  ;
    72 XNAME(ISTR)     ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG
    73  ;  </NAME> AND <NAME ID=XNAME> WILL RETURN NAME
    74  ; ISTR IS PASSED BY VALUE
    75  N CUR,TMP
    76  I ISTR?.E1"<".E  D  ; STRIP OFF LEFT BRACKET
    77  . S TMP=$P(ISTR,"<",2)
    78  I TMP?1"/".E  D  ; ALSO STRIP OFF SLASH IF PRESENT IE </NAME>
    79  . S TMP=$P(TMP,"/",2)
    80  S CUR=$P(TMP,">",1) ; EXTRACT THE NAME
    81  ; W "CUR= ",CUR,!
    82  I CUR?.1"_"1.A1" ".E  D  ; CONTAINS A BLANK IE NAME ID=TEST>
    83  . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER
    84  ; W "CUR2= ",CUR,!
    85  Q CUR
    86  ;
    87 XVAL(ISTR) ; EXTRACTS THE VALUE FROM A FRAGMENT OF XML
    88  ; <NAME>VALUE</NAME> WILL RETURN VALUE
    89  N G
    90  S G=$P(ISTR,">",2) ;STRIP OFF <NAME>
    91  Q $P(G,"<",1) ; STRIP OFF </NAME> LEAVING VALUE
    92  ;
    93 VDX2VDV(OUTVDV,INVDX) ; CONVERT AN VDX ARRAY TO VDV
    94  ; VDX: @INVDX@(XPATH)=VALUE
    95  ; VDV: @OUTVDV@(X1X2X3X4)=VALUE
    96  ; THE VDV DATANAMES MIGHT BE MORE CONVENIENT FOR USE IN CODE
    97  ; AN INDEX IS PROVIDED TO GO BACK TO VDX FOR CONVERSIONS
    98  ; @VDV@("XPATH",X1X2X3X4)="XPATH"
    99  N ZA,ZI,ZW
    100  S ZI=""
    101  F  S ZI=$O(@INVDX@(ZI)) Q:ZI=""  D  ;
    102  . S ZW=$TR(ZI,"/","") ; ELIMINATE ALL SLASHES - CAMEL CASE VARIABLE NAME
    103  . W ZW,!
    104  . S @OUTVDV@(ZW)=@INVDX@(ZI)
    105  . S @OUTVDV@("XPATH",ZW)=ZI
    106  Q
    107  ;
    108 VDX2XPG(OUTXPG,INVDX) ; CONVERT AN VDX ARRAY TO XPG
    109  ; VDX: @VDX@(XPATH)=VALUE
    110  ; XPG: @(VDX(X1,X2,X3,X4))@=VALUE
    111  ; THIS IS A STEP TOWARD GENERATING XML FROM A VDX
    112  N ZA,ZI,ZW
    113  S ZI=""
    114  F  S ZI=$O(@INVDX@(ZI)) Q:ZI=""  D  ;
    115  . S ZW=$E(ZI,3,$L(ZI)) ; STRIP OFF INITIAL //
    116  . S ZW2=$P(ZW,"/",1)
    117  . F ZK=1:1:$L(ZW,"/") D PUSH("ZA",$P(ZW,"/",ZK))
    118  . ;ZWR ZA
    119  . S ZW2=ZA(1)
    120  . F ZK=2:1:ZA(0) D  ;
    121  . . S ZW2=ZW2_""","""_ZA(ZK)
    122  . K ZA
    123  . S ZW2=""""_ZW2_""""
    124  . W ZW2,!
    125  . S ZN=OUTXPG_"("_ZW2_")"
    126  . S @ZN=@INVDX@(ZI)
    127  Q
    128  ;
    129 XML2XPG(OUTXPG,INXML) ; CONVERT AN XML ARRAY, PASSED BY NAME TO AN XPG ARRAY
    130  ; XPG MEANS XPATH GLOBAL AND HAS THE FORM @OUTXPG@("X1","X2","X3")=VALUE
    131  ;
    132  ;N G1
    133  D INDEX(INXML,"G1",1) ; PRODUCES A VDX ARRAY IN G1, NO INDEX IS PRODUCED
    134  D VDX2XPG(OUTXPG,"G1") ; CONVERTS THE VDX ARRAY TO XPG FORM
    135  Q
    136  ;
    137 DO 
    138  D XPG2XML("^GPL2B","^GPL2A")
    139  Q
    140  ;
    141 T1 ; TEST OUT THESE ROUTINES
    142  D XML2XPG("G2","^GPL")
    143  D XPG2XML("G3","G2")
    144  K ^GPLOUT
    145  M ^GPLOUT=G3
    146  W $$OUTPUT^C0CXPATH("^GPLOUT(1)","GPLTEST.xml","/home/vademo2/EHR/p")
    147  Q
    148  ;
    149 XPG2XML(OUTXML,INXPG) ;
    150  N C0CN,FWD,ZA,G,GA,ZQ
    151  S ZQ=0 ; QUIT FLAG
    152  F  Q:ZQ=1  D  ; LOOP THROUGH EVERYTHING
    153  . I '$D(C0CN) D  ; FIRST TIME THROUGH
    154  . . K @OUTXML ; MAKE SURE OUTPUT ARRAY IS CLEAR
    155  . . S FWD=1 ; START OUT GOING FORWARD THROUGH SUBSCRIPTS
    156  . . S G=$Q(@INXPG) ; THIS ONE
    157  . . S GN=$Q(@G) ; NEXT ONE
    158  . . S C0CN=1 ; SUBSCRIPT COUNT
    159  . . S ZQ=0 ; QUIT FLAG
    160  . . D ZXO("?xml version=""1.0"" encoding=""UTF-8""?") ;MAKE IT REAL XML
    161  . . I $QS(G,1)="ContinuityOfCareRecord" D  ;
    162  . . . D ZXO("?xml-stylesheet type=""text/xsl"" href=""ccr.xsl""?") ; HACK TO MAKE THE CCR STYLESHEET WORK
    163  . I FWD D  ; GOING FORWARDS
    164  . . I C0CN<$QL(G) D  ; NOT A DATA NODE
    165  . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT
    166  . . . D ZXO(ZA) ; AND OPEN AN XML ELEMENT
    167  . . . I @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord>" D  ;
    168  . . . . S @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord xmlns=""urn:astm-org:CCR"">"
    169  . . . S C0CN=C0CN+1 ; MOVE TO THE NEXT ONE
    170  . . E  D  ; AT THE DATA NODE
    171  . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT
    172  . . . D ZXVAL(ZA,@G) ; OUTPUT <X>VAL</X> FOR DATA NODE
    173  . . . S FWD=0 ; GO BACKWARDS
    174  . I 'FWD D  ;GOING BACKWARDS
    175  . . S GN=$Q(@G) ;NEXT XPATH
    176  . . ;W "NEXT!",GN,!
    177  . . S C0CN=C0CN-1 ; PREVIOUS SUBSCRIPT
    178  . . I GN'="" D  ;
    179  . . . I $QS(G,C0CN)'=$QS(GN,C0CN) D  ; NEED TO CLOSE OFF ELEMENT
    180  . . . . D ZXC($QS(G,C0CN)) ;
    181  . . . E  I GN'="" D  ; MORE ELEMENTS AT THIS LEVEL
    182  . . . . S G=$Q(@G) ; ADVANCE TO NEW XPATH
    183  . . . . S C0CN=C0CN+1 ; GET READY TO PROCESS NEXT SUBSCRIPT
    184  . . . . S FWD=1 ; GOING FORWARD NOW
    185  . I (GN="")&(C0CN=1) D  Q  ; WHEN WE ARE ALL DONE
    186  . . D ZXC($QS(G,C0CN)) ; LAST ONE
    187  . . S ZQ=1 ; QUIT NOW
    188  Q
    189  ;
    190 ZXO(WHAT) 
    191  D PUSH("GA",WHAT)
    192  D PUSH(OUTXML,"<"_WHAT_">")
    193  Q
    194  ;
    195 ZXC(WHAT) 
    196  D POP("GA",.TMP)
    197  D PUSH(OUTXML,"</"_WHAT_">")
    198  Q
    199  ;
    200 ZXVAL(WHAT,VAL) 
    201  D PUSH(OUTXML,"<"_WHAT_">"_VAL_"</"_WHAT_">")
    202  Q
    203  ;
    204 INDEX(IZXML,VDX,NOINX,TEMPLATE,REDUX) ; parse XML in IZXML and produce
    205  ; an XPATH index; REDUX is a string to be removed from each xpath
    206  ; GPL 7/14/09 OPTIONALLY GENERATE AN XML TEMPLATE IF PASSED BY NAME
    207  ; TEMPLATE IS IDENTICAL TO THE PARSED XML LINE BY LINE
    208  ; EXCEPT THAT DATA VALUES ARE REPLACED WITH @@XPATH@@ FOR THE XPATH OF THE TAG
    209  ; GPL 5/24/09 AND OPTIONALLY PRODUCE THE VDX ARRAY PASSED BY NAME
    210  ; @VDX@("XPATH")=VALUE
    211  ; ex. @IZXML@("XPATH")=FIRSTLINE^LASTLINE
    212  ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE
    213  ; XML SECTION
    214  ; IZXML IS PASSED BY NAME
    215  ; IF NOINX IS SET TO 1, NO INDEX WILL BE GENERATED, BUT THE VDX WILL BE
    216  N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND,CURVAL,DVDX,LCNT
    217  N C0CSTK ; LEAVE OUT FOR DEBUGGING
    218  I '$D(REDUX) S REDUX=""
    219  I '$D(NOINX) S NOINX=0 ; IF NOT PASSED, GENERATE AN INDEX
    220  N ZXML
    221  I NOINX S ZXML=$NA(^TMP("C0CINDEX",$J)) ; TEMP PLACE FOR INDEX TO DISCARD
    222  E  S ZXML=IZXML ; PLACE FOR INDEX TO KEEP
    223  I '$D(@IZXML@(0)) D  ; IF COUNT NOT IN NODE 0 COUNT THEM
    224  . S I="",LCNT=0
    225  . F  S I=$O(@IZXML@(I)) Q:I=""  S LCNT=LCNT+1
    226  E  S LCNT=@IZXML@(0) ; LINE COUNT PASSED IN ARRAY
    227  I LCNT=0  D  Q  ; NO XML PASSED
    228  . W "ERROR IN XML FILE",!
    229  S DVDX=0 ; DEFAULT DO NOT PRODUCE VDX INDEX
    230  I $D(VDX) S DVDX=1 ; IF NAME PASSED, DO VDX
    231  S C0CSTK(0)=0 ; INITIALIZE STACK
    232  K LKASD ; KILL LOOKASIDE ARRAY
    233  D MKLASD(.LKASD,IZXML) ;MAKE LOOK ASIDE BUFFER FOR MULTIPLES
    234  F I=1:1:LCNT  D  ; PROCESS THE ENTIRE ARRAY
    235  . S LINE=@IZXML@(I)
    236  . I $D(TEMPLATE) D  ;IF TEMPLATE IS REQUESTED
    237  . . S @TEMPLATE@(I)=$$CLEAN(LINE)
    238  . ;W LINE,!
    239  . S FOUND=0  ; INTIALIZED FOUND FLAG
    240  . I LINE?.E1"<!".E S FOUND=1 ; SKIP OVER COMMENTS
    241  . I FOUND'=1  D
    242  . . I (LINE?.E1"<"1.E1"</".E)!(LINE?.E1"<"1.E1"/>".E)  D
    243  . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS
    244  . . . ; ON THE SAME LINE
    245  . . . ; W "FOUND ",LINE,!
    246  . . . S FOUND=1  ; SET FOUND FLAG
    247  . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
    248  . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES
    249  . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK
    250  . . . D MKMDX("C0CSTK",.MDX,REDUX) ; GENERATE THE M INDEX
    251  . . . ; W "MDX=",MDX,!
    252  . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
    253  . . . . ;I '$D(ZDUP(MDX)) S ZDUP(MDX)=2
    254  . . . . ;E  S ZDUP(MDX)=ZDUP(MDX)+1
    255  . . . . ;W "DUP:",MDX,!
    256  . . . . ;I '$D(CURVAL) S CURVAL=""
    257  . . . . ;I DVDX S @VDX@(MDX_"["_ZDUP(MDX)_"]")=CURVAL
    258  . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
    259  . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
    260  . . . . S @ZXML@(MDX)=I_"^"_I  ; ADD INDEX ENTRY-FIRST AND LAST
    261  . . . . S CURVAL=$$XVAL(LINE) ; VALUE
    262  . . . . S $P(@ZXML@(MDX),"^",3)=CURVAL ; THIRD PIECE
    263  . . . . I DVDX S @VDX@(MDX)=CURVAL ; FILL IN VDX ARRAY IF REQUESTED
    264  . . . . I $D(TEMPLATE) D  ; IF TEMPLATE IS REQUESTED
    265  . . . . . S LINE=$$CLEAN(LINE) ; CLEAN OUT CONTROL CHARACTERS
    266  . . . . . S @TEMPLATE@(I)=$P(LINE,">",1)_">@@"_MDX_"@@</"_$P(LINE,"</",2)
    267  . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK
    268  . I FOUND'=1  D  ; THE LINE DOESN'T CONTAIN THE START AND END
    269  . . I LINE?.E1"</"1.E  D  ; LINE CONTAINS END OF A SECTION
    270  . . . ; W "FOUND ",LINE,!
    271  . . . S FOUND=1  ; SET FOUND FLAG
    272  . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
    273  . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX
    274  . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
    275  . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK
    276  . . . S TMP=$P(TMP,"[",1) ; REMOVE [X] FROM MULTIPLE
    277  . . . I TMP'=CUR  D  ; MALFORMED XML, END MUST MATCH START
    278  . . . . W "MALFORMED XML ",CUR,"LINE "_I_LINE,!
    279  . . . . D PARY("C0CSTK") ; PRINT OUT THE STACK FOR DEBUGING
    280  . . . . Q
    281  . I FOUND'=1  D  ; THE LINE MIGHT CONTAIN A SECTION BEGINNING
    282  . . I (LINE?.E1"<"1.E)&(LINE'["?>")  D  ; BEGINNING OF A SECTION
    283  . . . ; W "FOUND ",LINE,!
    284  . . . S FOUND=1  ; SET FOUND FLAG
    285  . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
    286  . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES
    287  . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK
    288  . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX
    289  . . . ; W "MDX=",MDX,!
    290  . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
    291  . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
    292  . . . . ;B
    293  . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
    294  . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX
    295  S @ZXML@("INDEXED")=""
    296  S @ZXML@("//")="1^"_LCNT ; ROOT XPATH
    297  I NOINX K @ZXML ; DELETE UNWANTED INDEX
    298  Q
    299  ;
    300 MKLASD(OUTBUF,INARY) ; CREATE A LOOKASIDE BUFFER FOR MULTILPLES
    301  ;
    302  N ZI,ZN,ZA,ZLINE,ZLINE2,CUR,CUR2
    303  F ZI=1:1:LCNT-1  D  ; PROCESS THE ENTIRE ARRAY
    304  . S ZLINE=@IZXML@(ZI)
    305  . I ZI<LCNT S ZLINE2=@IZXML@(ZI+1)
    306  . I ZLINE?.E1"</"1.E  D  ; NEXT LINE CONTAINS END OF A SECTION
    307  . . S CUR=$$XNAME(ZLINE) ; EXTRACT THE NAME
    308  . . I (ZLINE2?.E1"<"1.E)&(ZLINE'["?>")  D  ; BEGINNING OF A SECTION
    309  . . . S CUR2=$$XNAME(ZLINE2) ; EXTRACT THE NAME
    310  . . . I CUR=CUR2 D  ; IF THIS IS A MULTIPLE
    311  . . . . S OUTBUF(CUR,ZI+1)=""
    312  ;ZWR OUTBUF
    313  S ZI=""
    314  F  S ZI=$O(OUTBUF(ZI)) Q:ZI=""  D  ; FOR EACH KIND OF MULTIPLE
    315  . S ZN=$O(OUTBUF(ZI,"")) ; LINE NUMBER OF SECOND MULTIPLE
    316  . F  S ZN=$O(@IZXML@(ZN),-1) Q:ZN=""  I $E($P(@IZXML@(ZN),"<"_ZI,2),1,1)=">" Q  ;
    317  . S OUTBUF(ZI,ZN)=""
    318  S ZA=1,ZI="",ZN=""
    319  F  S ZI=$O(OUTBUF(ZI)) Q:ZI=""  D  ; ADDING THE COUNT FOR THE MULIPLES [x]
    320  . S ZN="",ZA=1
    321  . F  S ZN=$O(OUTBUF(ZI,ZN)) Q:ZN=""  D  ;
    322  . . S OUTBUF(ZI,ZN)="["_ZA_"]"
    323  . . S ZA=ZA+1
    324  Q
    325  ;
    326 CLEAN(STR,TR) ; extrinsic function; returns string
    327  ;; Removes all non printable characters from a string.
    328  ;; STR by Value
    329  ;; TR IS OPTIONAL TO IMPROVE PERFORMANCE
    330  N TR,I
    331  I '$D(TR) D  ;
    332  . F I=0:1:31 S TR=$G(TR)_$C(I)
    333  . S TR=TR_$C(127)
    334  QUIT $TR(STR,TR)
    335  ;
    336 QUERY(IARY,XPATH,OARY)  ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION
    337  ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD"
    338  ; IARY AND OARY ARE PASSED BY NAME
    339  I '$D(@IARY@("INDEXED"))  D  ; INDEX IS NOT PRESENT IN IARY
    340  . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML
    341  N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN
    342  N TMP,I,J,QXPATH
    343  S FIRST=1
    344  I '$D(@IARY@(0)) D  ; LINE COUNT NOT IN ZERO NODE
    345  . S @IARY@(0)=$O(@IARY@("//"),-1) ; THIS SHOULD USUALLY WORK
    346  S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT
    347  I XPATH'="//" D  ; NOT A ROOT QUERY
    348  . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES
    349  . S FIRST=$P(TMP,"^",1)
    350  . S LAST=$P(TMP,"^",2)
    351  K @OARY
    352  S @OARY@(0)=+LAST-FIRST+1
    353  S J=1
    354  FOR I=FIRST:1:LAST  D
    355  . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY
    356  . S J=J+1
    357  ; ZWR OARY
    358  Q
    359  ;
    360 XF(IDX,XPATH)   ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH
    361  ; INDEX WITH TWO PIECES START^FINISH
    362  ; IDX IS PASSED BY NAME
    363  Q $P(@IDX@(XPATH),"^",1)
    364  ;
    365 XL(IDX,XPATH)   ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH
    366  ; INDEX WITH TWO PIECES START^FINISH
    367  ; IDX IS PASSED BY NAME
    368  Q $P(@IDX@(XPATH),"^",2)
    369  ;
    370 START(ISTR)     ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX
    371  ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
    372  ; COMPANION TO FINISH ; IDX IS PASSED BY NAME
    373  Q $P(ISTR,";",2)
    374  ;
    375 FINISH(ISTR)    ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX
    376  ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
    377  Q $P(ISTR,";",3)
    378  ;
    379 ARRAY(ISTR)     ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX
    380  ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
    381  Q $P(ISTR,";",1)
    382  ;
    383 BUILD(BLIST,BDEST)      ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST
    384  ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST
    385  ; DEST IS CLEARED TO START
    386  ; USES PUSH TO DO THE COPY
    387  N I
    388  K @BDEST
    389  F I=1:1:@BLIST@(0) D  ; FOR EACH INSTRUCTION IN BLIST
    390  . N J,ATMP
    391  . S ATMP=$$ARRAY(@BLIST@(I))
    392  . I $G(DEBUG) W "ATMP=",ATMP,!
    393  . I $G(DEBUG) W @BLIST@(I),!
    394  . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D  ;
    395  . . ; FOR EACH LINE IN THIS INSTR
    396  . . I $G(DEBUG) W "BDEST= ",BDEST,!
    397  . . I $G(DEBUG) W "ATMP= ",@ATMP@(J),!
    398  . . D PUSH(BDEST,@ATMP@(J))
    399  Q
    400  ;
    401 QUEUE(BLST,ARRAY,FIRST,LAST)    ; ADD AN ENTRY TO A BLIST
    402  ;
    403  I $G(DEBUG) W "QUEUEING ",BLST,!
    404  D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST)
    405  Q
    406  ;
    407 CP(CPSRC,CPDEST)        ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME
    408  ; KILLS CPDEST FIRST
    409  N CPINSTR
    410  I $G(DEBUG) W "MADE IT TO COPY",CPSRC,CPDEST,!
    411  I @CPSRC@(0)<1 D  ; BAD LENGTH
    412  . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,!
    413  . Q
    414  ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT
    415  D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY
    416  D BUILD("CPINSTR",CPDEST)
    417  Q
    418  ;
    419 QOPEN(QOBLIST,QOXML,QOXPATH)    ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST
    420  ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD
    421  ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT
    422  ; USED TO INSERT CHILDREN NODES
    423  I @QOXML@(0)<1 D  ; MALFORMED XML
    424  . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,!
    425  . Q
    426  I $G(DEBUG) W "DOING QOPEN",!
    427  N S1,E1,QOT,QOTMP
    428  S S1=1 ; OPEN FROM THE BEGINNING OF THE XML
    429  I $D(QOXPATH) D  ; XPATH PROVIDED
    430  . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX
    431  . S E1=$P(@QOXML@(QOXPATH),"^",2)-1
    432  I '$D(QOXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
    433  . S E1=@QOXML@(0)-1
    434  D QUEUE(QOBLIST,QOXML,S1,E1)
    435  ; S QOTMP=QOXML_"^"_S1_"^"_E1
    436  ; D PUSH(QOBLIST,QOTMP)
    437  Q
    438  ;
    439 QCLOSE(QCBLIST,QCXML,QCXPATH)   ; CLOSE XML AFTER A QOPEN
    440  ; ADDS THE LIST LINE OF QCXML TO QCBLIST
    441  ; USED TO FINISH INSERTING CHILDERN NODES
    442  ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END
    443  ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO
    444  I @QCXML@(0)<1 D  ; MALFORMED XML
    445  . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,!
    446  I $G(DEBUG) W "GOING TO CLOSE",!
    447  N S1,E1,QCT,QCTMP
    448  S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML
    449  I $D(QCXPATH) D  ; XPATH PROVIDED
    450  . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX
    451  . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML
    452  I '$D(QCXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
    453  . S S1=@QCXML@(0)
    454  D QUEUE(QCBLIST,QCXML,S1,E1)
    455  ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1)
    456  Q
    457  ;
    458 INSERT(INSXML,INSNEW,INSXPATH)  ; INSERT INSNEW INTO INSXML AT THE
    459  ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS
    460  ; OMITTED, INSERTION WILL BE AT THE ROOT
    461  ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW
    462  ; XML AT THE END OF THE XPATH POINT
    463  ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE
    464  N INSBLD,INSTMP
    465  I $G(DEBUG) W "DOING INSERT ",INSXML,INSNEW,INSXPATH,!
    466  I $G(DEBUG) F G1=1:1:@INSXML@(0) W @INSXML@(G1),!
    467  I '$D(@INSXML@(1)) D  ; INSERT INTO AN EMPTY ARRAY
    468  . D CP^C0CXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT
    469  I $D(@INSXML@(1)) D  ; IF ORIGINAL ARRAY IS NOT EMPTY
    470  . I '$D(@INSXML@(0)) S @INSXML@(0)=$O(@INSXML@(""),-1) ;SET LENGTH
    471  . I $D(INSXPATH) D  ; XPATH PROVIDED
    472  . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE
    473  . . I $G(DEBUG) D PARY^C0CXPATH("INSBLD")
    474  . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
    475  . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH
    476  . I '$D(@INSNEW@(0)) S @INSNEW@(0)=$O(@INSNEW@(""),-1) ;SIZE OF XML
    477  . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML
    478  . I $D(INSXPATH) D  ; XPATH PROVIDED
    479  . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH
    480  . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
    481  . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH
    482  . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST
    483  . D CP^C0CXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE
    484  Q
    485  ;
    486 INSINNER(INNXML,INNNEW,INNXPATH)        ; INSERT THE INNER XML OF INNNEW
    487  ; INTO INNXML AT THE INNXPATH XPATH POINT
    488  ;
    489  N INNBLD,UXPATH
    490  N INNTBUF
    491  S INNTBUF=$NA(^TMP($J,"INNTBUF"))
    492  I '$D(INNXPATH) D  ; XPATH NOT PASSED
    493  . S UXPATH="//" ; USE ROOT XPATH
    494  I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED
    495  I '$D(@INNXML@(0)) D  ; INNXML IS EMPTY
    496  . D QUEUE^C0CXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER
    497  . D BUILD("INNBLD",INNXML)
    498  I @INNXML@(0)>0  D  ; NOT EMPTY
    499  . D QOPEN("INNBLD",INNXML,UXPATH) ;
    500  . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML
    501  . D QCLOSE("INNBLD",INNXML,UXPATH)
    502  . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER
    503  . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST
    504  Q
    505  ;
    506 INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST
    507  ; BUT XDEST AN XNEW ARE PASSED BY NAME
    508  N XBLD,XTMP
    509  D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT
    510  D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST
    511  D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION
    512  D BUILD("XBLD","XTMP") ; BUILD THE RESULT
    513  D CP("XTMP",XDEST) ; COPY TO THE DESTINATION
    514  I $G(DEBUG) D PARY("XDEST")
    515  Q
    516  ;
    517 REPLACE(REXML,RENEW,REXPATH)    ; REPLACE THE XML AT THE XPATH POINT
    518  ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE
    519  ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE
    520  ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD")
    521  N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
    522  S OLD=$NA(^TMP($J,"REPLACE_OLD"))
    523  D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
    524  S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
    525  S XFIRST=$P(XNODE,"^",1)
    526  S XLAST=$P(XNODE,"^",2)
    527  I RENEW="" D  ; WE ARE DELETING A SECTION, MUST SAVE THE TAG
    528  . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE
    529  . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST
    530  I RENEW'="" D  ; NEW XML IS NOT NULL
    531  . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE
    532  . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW
    533  . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST
    534  I $G(DEBUG) W "REPLACE PREBUILD",!
    535  I $G(DEBUG) D PARY("REBLD")
    536  D BUILD("REBLD","RTMP")
    537  K @REXML ; KILL WHAT WAS THERE
    538  D CP("RTMP",REXML) ; COPY IN THE RESULT
    539  Q
    540  ;
    541 DELETE(REXML,REXPATH)    ; DELETE THE XML AT THE XPATH POINT
    542  ; REXML IS PASSED BY NAME XPATH IS A VALUE
    543  N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
    544  S OLD=$NA(^TMP($J,"REPLACE_OLD"))
    545  D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
    546  S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
    547  S XFIRST=$P(XNODE,"^",1)
    548  S XLAST=$P(XNODE,"^",2)
    549  D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE
    550  D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST
    551  I $G(DEBUG) D PARY("REBLD")
    552  D BUILD("REBLD","RTMP")
    553  K @REXML ; KILL WHAT WAS THERE
    554  D CP("RTMP",REXML) ; COPY IN THE RESULT
    555  Q
    556  ;
    557 MISSING(IXML,OARY)      ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY
    558  ; W "Reporting on the missing",!
    559  ; W OARY
    560  I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q
    561  N I
    562  S @OARY@(0)=0 ; INITIALIZED MISSING COUNT
    563  F I=1:1:@IXML@(0)  D   ; LOOP THROUGH WHOLE ARRAY
    564  . I @IXML@(I)?.E1"@@".E D  ; MISSING VARIABLE HERE
    565  . . D PUSH^C0CXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY
    566  . . Q
    567  Q
    568  ;
    569 MAP(IXML,INARY,OXML) ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY
    570  ; AND PUT THE RESULTS IN OXML
    571  N XCNT
    572  I '$D(DEBUG) S DEBUG=0
    573  I '$D(IXML) W "MALFORMED XML PASSED TO MAP",! Q
    574  I '$D(@IXML@(0)) D  ; INITIALIZE COUNT
    575  . S XCNT=$O(@IXML@(""),-1)
    576  E  S XCNT=@IXML@(0) ;COUNT
    577  I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q
    578  N I,J,TNAM,TVAL,TSTR
    579  S @OXML@(0)=XCNT ; TOTAL LINES IN OUTPUT
    580  F I=1:1:XCNT  D   ; LOOP THROUGH WHOLE ARRAY
    581  . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT
    582  . I @OXML@(I)?.E1"@@".E D  ; IS THERE A VARIABLE HERE?
    583  . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS
    584  . . F J=2:2:10  D  Q:$P(@IXML@(I),"@@",J+2)=""  ; QUIT IF NO MORE VARS
    585  . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,!
    586  . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME
    587  . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED
    588  . . . I $D(@INARY@(TNAM))  D  ; IS THE VARIABLE IN THE MAP?
    589  . . . . I '$D(@INARY@(TNAM,"F")) D  ; NOT A SPECIAL FIELD
    590  . . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE
    591  . . . . E  D DOFLD ; PROCESS A FIELD
    592  . . . S TVAL=$$SYMENC^MXMLUTL(TVAL) ;MAKE SURE THE VALUE IS XML SAFE
    593  . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER
    594  . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES
    595  . . I DEBUG W TSTR
    596  I DEBUG W "MAPPED",!
    597  Q
    598  ;
    599 DOFLD ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE
    600  ;
    601  Q
    602  ;
    603 TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS
    604  ; THEXML IS PASSED BY NAME
    605  N I,J,TMPXML,DEL,FOUND,INTXT
    606  S FOUND=0
    607  S INTXT=0
    608  I $G(DEBUG) W "DELETING EMPTY ELEMENTS",!
    609  F I=1:1:(@THEXML@(0)-1) D  ; LOOP THROUGH ENTIRE ARRAY
    610  . S J=@THEXML@(I)
    611  . I J["<text>" D
    612  . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM
    613  . . I $G(DEBUG) W "IN HTML SECTION",!
    614  . N JM,JP,JPX ; JMINUS AND JPLUS
    615  . S JM=@THEXML@(I-1) ; LINE BEFORE
    616  . I JM["</text>" S INTXT=0 ; LEFT HTML SECTION,START TRIM
    617  . S JP=@THEXML@(I+1) ; LINE AFTER
    618  . I INTXT=0 D  ; IF NOT IN AN HTML SECTION
    619  . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH
    620  . . I J=JPX D  ; AN EMPTY ELEMENT ON TWO LINES
    621  . . . I $G(DEBUG) W I,J,JP,!
    622  . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
    623  . . . S DEL(I)="" ; SET LINE TO DELETE
    624  . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE
    625  . . I J["><" D  ; AN EMPTY ELEMENT ON ONE LINE
    626  . . . I $G(DEBUG) W I,J,!
    627  . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
    628  . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED
    629  . . . I JM=JPX D  ;
    630  . . . . I $G(DEBUG) W I,JM_J_JPX,!
    631  . . . . S DEL(I-1)=""
    632  . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL
    633  ; . I J'["><" D PUSH("TMPXML",J)
    634  I FOUND D  ; NEED TO DELETE THINGS
    635  . F I=1:1:@THEXML@(0) D  ; COPY ARRAY LEAVING OUT DELELTED LINES
    636  . . I '$D(DEL(I)) D  ; IF THE LINE IS NOT DELETED
    637  . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY
    638  . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY
    639  Q FOUND
    640  ;
    641 UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML
    642  ; XSEC IS A SECTION PASSED BY NAME
    643  N XBLD,XTMP
    644  D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML
    645  D BUILD("XBLD","XTMP") ; BUILD THE RESULT
    646  D CP("XTMP",XSEC) ; REPLACE PASSED XML
    647  Q
    648  ;
    649 PARY(GLO,ZN)       ;PRINT AN ARRAY
    650  ; IF ZN=-1 NO LINE NUMBERS
    651  N I
    652  F I=1:1:@GLO@(0) D  ;
    653  . I $G(ZN)=-1 W @GLO@(I),!
    654  . E  W I_" "_@GLO@(I),!
    655  Q
    656  ;
    657 H2ARY(IARYRTN,IHASH,IPRE) ; CONVERT IHASH TO RETURN ARRAY
    658  ; IPRE IS OPTIONAL PREFIX FOR THE ELEMENTS. USED FOR MUPTIPLES 1^"VAR"^VALUE
    659  I '$D(IPRE) S IPRE=""
    660  N H2I S H2I=""
    661  ; W $O(@IHASH@(H2I)),!
    662  F  S H2I=$O(@IHASH@(H2I)) Q:H2I=""  D  ; FOR EACH ELEMENT OF THE HASH
    663  . I $QS(H2I,$QL(H2I))="M" D  Q  ; SPECIAL CASE FOR MULTIPLES
    664  . . ;W H2I_"^"_@IHASH@(H2I),!
    665  . . N IH,IHI
    666  . . S IH=$NA(@IHASH@(H2I)) ;
    667  . . S IH2A=$O(@IH@("")) ; SKIP OVER MULTIPLE DISCRIPTOR
    668  . . S IH2=$NA(@IH@(IH2A)) ; PAST THE "M","DIRETIONS" FOR EXAMPLE
    669  . . S IHI="" ; INDEX INTO "M" MULTIPLES
    670  . . F  S IHI=$O(@IH2@(IHI)) Q:IHI=""  D  ; FOR EACH SUB-MULTIPLE
    671  . . . ; W @IH@(IHI)
    672  . . . S IH3=$NA(@IH2@(IHI))
    673  . . . ; W "HEY",IH3,!
    674  . . . D H2ARY(.IARYRTN,IH3,IPRE_";"_IHI) ; RECURSIVE CALL - INDENTED ELEMENTS
    675  . . ; W IH,!
    676  . . ; W "C0CZZ",!
    677  . . ; W $NA(@IHASH@(H2I)),!
    678  . . Q  ;
    679  . D PUSH(IARYRTN,IPRE_"^"_H2I_"^"_@IHASH@(H2I))
    680  . ; W @IARYRTN@(0),!
    681  Q
    682  ;
    683 XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES
    684  ; DEFINED IN INPUT XML XVIXML BY @@VAR@@
    685  ; XVRTN AND XVIXML ARE PASSED BY NAME
    686  ;
    687  N XVI,XVTMP,XVT
    688  F XVI=1:1:@XVIXML@(0) D  ; FOR ALL LINES OF THE XML
    689  . S XVT=@XVIXML@(XVI)
    690  . I XVT["@@" S XVTMP($P(XVT,"@@",2))=XVI
    691  D H2ARY(XVRTN,"XVTMP")
    692  Q
    693  ;
    694 DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE
    695  ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE
    696  ;
    697  N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED
    698  I DXIN="CCR" D  ; NEED TO GO GET CCR TEMPLATE
    699  . D LOAD^C0CCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP
    700  . S DXUSE="DTMP" ; DXUSE IS NAME
    701  E  I DXIN="CCD" D  ; NEED TO GO GET CCD TEMPLATE
    702  . D LOAD^C0CCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP
    703  . S DXUSE="DTMP" ; DXUSE IS NAME
    704  E  S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE
    705  N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE
    706  D XVARS("DVARS",DXUSE) ; PULL OUT VARS
    707  D PARY^C0CXPATH("DVARS") ;AND DISPLAY THEM
    708  Q
    709  ;
    710 TEST     ; Run all the test cases
    711  D TESTALL^C0CUNIT("C0CXPAT0")
    712  Q
    713  ;
    714 ZTEST(WHICH)    ; RUN ONE SET OF TESTS
    715  N ZTMP
    716  S DEBUG=1
    717  D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
    718  D ZTEST^C0CUNIT(.ZTMP,WHICH)
    719  Q
    720  ;
    721 TLIST   ; LIST THE TESTS
    722  N ZTMP
    723  D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
    724  D TLIST^C0CUNIT(.ZTMP)
    725  Q
    726  ;
     1C0SXPATH          ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 ; 9/26/12 10:45am
     2        ;;1.0;VISTA SMART CONTAINER;;Sep 26, 2012;Build 4
     3        ;Copyright 2008-2012 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 an XML XPATH utility library",!
     21        W !
     22        Q
     23        ;
     24OUTPUT(OUTARY,OUTNAME,OUTDIR)     ; WRITE AN ARRAY TO A FILE
     25        ;
     26        N Y
     27        S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME)
     28        I Y Q 1_U_"WROTE FILE: "_OUTNAME_" TO "_OUTDIR
     29        I 'Y Q 0_U_"ERROR WRITING FILE"_OUTNAME_" TO "_OUTDIR
     30        Q
     31        ;
     32PUSH(STK,VAL)     ; pushs VAL onto STK and updates STK(0)
     33        ;  VAL IS A STRING AND STK IS PASSED BY NAME
     34        ;
     35        I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE
     36        S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH
     37        S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY
     38        Q
     39        ;
     40POP(STK,VAL)       ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL
     41        ; VAL AND STK ARE PASSED BY REFERENCE
     42        ;
     43        I @STK@(0)<1 D  ; IF ARRAY IS EMPTY
     44        . S VAL=""
     45        . S @STK@(0)=0
     46        I @STK@(0)>0  D  ;
     47        . S VAL=@STK@(@STK@(0))
     48        . K @STK@(@STK@(0))
     49        . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY
     50        Q
     51        ;
     52PUSHA(ADEST,ASRC)       ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME
     53        ;
     54        N ZGI
     55        F ZGI=1:1:@ASRC@(0) D  ; FOR ALL OF THE SOURCE ARRAY
     56        . D PUSH(ADEST,@ASRC@(ZGI)) ; PUSH ONE ELEMENT
     57        Q
     58        ;
     59MKMDX(STK,RTN,INREDUX)  ; MAKES A MUMPS INDEX FROM THE ARRAY STK
     60        ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS
     61        ; REDUX IS A STRING TO REMOVE FROM THE RESULT
     62        S RTN=""
     63        N I
     64        ; W "STK= ",STK,!
     65        I @STK@(0)>0  D  ; IF THE ARRAY IS NOT EMPTY
     66        . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON
     67        . I @STK@(0)>1  D  ; SUBSEQUENT ELEMENTS NEED A SEMICOLON
     68        . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I)
     69        I $G(INREDUX)'="" S RTN=$P(RTN,INREDUX,1)_$P(RTN,INREDUX,2)
     70        Q
     71        ;
     72XNAME(ISTR)         ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG
     73        ;  </NAME> AND <NAME ID=XNAME> WILL RETURN NAME
     74        ; ISTR IS PASSED BY VALUE
     75        N CUR,TMP
     76        I ISTR?.E1"<".E  D  ; STRIP OFF LEFT BRACKET
     77        . S TMP=$P(ISTR,"<",2)
     78        I TMP?1"/".E  D  ; ALSO STRIP OFF SLASH IF PRESENT IE </NAME>
     79        . S TMP=$P(TMP,"/",2)
     80        S CUR=$P(TMP,">",1) ; EXTRACT THE NAME
     81        ; W "CUR= ",CUR,!
     82        I CUR?.1"_"1.A1" ".E  D  ; CONTAINS A BLANK IE NAME ID=TEST>
     83        . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER
     84        ; W "CUR2= ",CUR,!
     85        Q CUR
     86        ;
     87XVAL(ISTR)      ; EXTRACTS THE VALUE FROM A FRAGMENT OF XML
     88        ; <NAME>VALUE</NAME> WILL RETURN VALUE
     89        N G
     90        S G=$P(ISTR,">",2) ;STRIP OFF <NAME>
     91        Q $P(G,"<",1) ; STRIP OFF </NAME> LEAVING VALUE
     92        ;
     93VDX2VDV(OUTVDV,INVDX)   ; CONVERT AN VDX ARRAY TO VDV
     94        ; VDX: @INVDX@(XPATH)=VALUE
     95        ; VDV: @OUTVDV@(X1X2X3X4)=VALUE
     96        ; THE VDV DATANAMES MIGHT BE MORE CONVENIENT FOR USE IN CODE
     97        ; AN INDEX IS PROVIDED TO GO BACK TO VDX FOR CONVERSIONS
     98        ; @VDV@("XPATH",X1X2X3X4)="XPATH"
     99        N ZA,ZI,ZW
     100        S ZI=""
     101        F  S ZI=$O(@INVDX@(ZI)) Q:ZI=""  D  ;
     102        . S ZW=$TR(ZI,"/","") ; ELIMINATE ALL SLASHES - CAMEL CASE VARIABLE NAME
     103        . W ZW,!
     104        . S @OUTVDV@(ZW)=@INVDX@(ZI)
     105        . S @OUTVDV@("XPATH",ZW)=ZI
     106        Q
     107        ;
     108VDX2XPG(OUTXPG,INVDX)   ; CONVERT AN VDX ARRAY TO XPG
     109        ; VDX: @VDX@(XPATH)=VALUE
     110        ; XPG: @(VDX(X1,X2,X3,X4))@=VALUE
     111        ; THIS IS A STEP TOWARD GENERATING XML FROM A VDX
     112        N ZA,ZI,ZW
     113        S ZI=""
     114        F  S ZI=$O(@INVDX@(ZI)) Q:ZI=""  D  ;
     115        . S ZW=$E(ZI,3,$L(ZI)) ; STRIP OFF INITIAL //
     116        . S ZW2=$P(ZW,"/",1)
     117        . F ZK=1:1:$L(ZW,"/") D PUSH("ZA",$P(ZW,"/",ZK))
     118        . ;ZWR ZA
     119        . S ZW2=ZA(1)
     120        . F ZK=2:1:ZA(0) D  ;
     121        . . S ZW2=ZW2_""","""_ZA(ZK)
     122        . K ZA
     123        . S ZW2=""""_ZW2_""""
     124        . W ZW2,!
     125        . S ZN=OUTXPG_"("_ZW2_")"
     126        . S @ZN=@INVDX@(ZI)
     127        Q
     128        ;
     129XML2XPG(OUTXPG,INXML)   ; CONVERT AN XML ARRAY, PASSED BY NAME TO AN XPG ARRAY
     130        ; XPG MEANS XPATH GLOBAL AND HAS THE FORM @OUTXPG@("X1","X2","X3")=VALUE
     131        ;
     132        ;N G1
     133        D INDEX(INXML,"G1",1) ; PRODUCES A VDX ARRAY IN G1, NO INDEX IS PRODUCED
     134        D VDX2XPG(OUTXPG,"G1") ; CONVERTS THE VDX ARRAY TO XPG FORM
     135        Q
     136        ;
     137DO     
     138        D XPG2XML("^GPL2B","^GPL2A")
     139        Q
     140        ;
     141T1      ; TEST OUT THESE ROUTINES
     142        D XML2XPG("G2","^GPL")
     143        D XPG2XML("G3","G2")
     144        K ^GPLOUT
     145        M ^GPLOUT=G3
     146        W $$OUTPUT^C0CXPATH("^GPLOUT(1)","GPLTEST.xml","/home/vademo2/EHR/p")
     147        Q
     148        ;
     149XPG2XML(OUTXML,INXPG)   ;
     150        N C0CN,FWD,ZA,G,GA,ZQ
     151        S ZQ=0 ; QUIT FLAG
     152        F  Q:ZQ=1  D  ; LOOP THROUGH EVERYTHING
     153        . I '$D(C0CN) D  ; FIRST TIME THROUGH
     154        . . K @OUTXML ; MAKE SURE OUTPUT ARRAY IS CLEAR
     155        . . S FWD=1 ; START OUT GOING FORWARD THROUGH SUBSCRIPTS
     156        . . S G=$Q(@INXPG) ; THIS ONE
     157        . . S GN=$Q(@G) ; NEXT ONE
     158        . . S C0CN=1 ; SUBSCRIPT COUNT
     159        . . S ZQ=0 ; QUIT FLAG
     160        . . D ZXO("?xml version=""1.0"" encoding=""UTF-8""?") ;MAKE IT REAL XML
     161        . . I $QS(G,1)="ContinuityOfCareRecord" D  ;
     162        . . . D ZXO("?xml-stylesheet type=""text/xsl"" href=""ccr.xsl""?") ; HACK TO MAKE THE CCR STYLESHEET WORK
     163        . I FWD D  ; GOING FORWARDS
     164        . . I C0CN<$QL(G) D  ; NOT A DATA NODE
     165        . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT
     166        . . . D ZXO(ZA) ; AND OPEN AN XML ELEMENT
     167        . . . I @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord>" D  ;
     168        . . . . S @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord xmlns=""urn:astm-org:CCR"">"
     169        . . . S C0CN=C0CN+1 ; MOVE TO THE NEXT ONE
     170        . . E  D  ; AT THE DATA NODE
     171        . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT
     172        . . . D ZXVAL(ZA,@G) ; OUTPUT <X>VAL</X> FOR DATA NODE
     173        . . . S FWD=0 ; GO BACKWARDS
     174        . I 'FWD D  ;GOING BACKWARDS
     175        . . S GN=$Q(@G) ;NEXT XPATH
     176        . . ;W "NEXT!",GN,!
     177        . . S C0CN=C0CN-1 ; PREVIOUS SUBSCRIPT
     178        . . I GN'="" D  ;
     179        . . . I $QS(G,C0CN)'=$QS(GN,C0CN) D  ; NEED TO CLOSE OFF ELEMENT
     180        . . . . D ZXC($QS(G,C0CN)) ;
     181        . . . E  I GN'="" D  ; MORE ELEMENTS AT THIS LEVEL
     182        . . . . S G=$Q(@G) ; ADVANCE TO NEW XPATH
     183        . . . . S C0CN=C0CN+1 ; GET READY TO PROCESS NEXT SUBSCRIPT
     184        . . . . S FWD=1 ; GOING FORWARD NOW
     185        . I (GN="")&(C0CN=1) D  Q  ; WHEN WE ARE ALL DONE
     186        . . D ZXC($QS(G,C0CN)) ; LAST ONE
     187        . . S ZQ=1 ; QUIT NOW
     188        Q
     189        ;
     190ZXO(WHAT)       
     191        D PUSH("GA",WHAT)
     192        D PUSH(OUTXML,"<"_WHAT_">")
     193        Q
     194        ;
     195ZXC(WHAT)       
     196        D POP("GA",.TMP)
     197        D PUSH(OUTXML,"</"_WHAT_">")
     198        Q
     199        ;
     200ZXVAL(WHAT,VAL) 
     201        D PUSH(OUTXML,"<"_WHAT_">"_VAL_"</"_WHAT_">")
     202        Q
     203        ;
     204INDEX(IZXML,VDX,NOINX,TEMPLATE,REDUX)   ; parse XML in IZXML and produce
     205        ; an XPATH index; REDUX is a string to be removed from each xpath
     206        ; GPL 7/14/09 OPTIONALLY GENERATE AN XML TEMPLATE IF PASSED BY NAME
     207        ; TEMPLATE IS IDENTICAL TO THE PARSED XML LINE BY LINE
     208        ; EXCEPT THAT DATA VALUES ARE REPLACED WITH @@XPATH@@ FOR THE XPATH OF THE TAG
     209        ; GPL 5/24/09 AND OPTIONALLY PRODUCE THE VDX ARRAY PASSED BY NAME
     210        ; @VDX@("XPATH")=VALUE
     211        ; ex. @IZXML@("XPATH")=FIRSTLINE^LASTLINE
     212        ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE
     213        ; XML SECTION
     214        ; IZXML IS PASSED BY NAME
     215        ; IF NOINX IS SET TO 1, NO INDEX WILL BE GENERATED, BUT THE VDX WILL BE
     216        N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND,CURVAL,DVDX,LCNT
     217        N C0CSTK ; LEAVE OUT FOR DEBUGGING
     218        I '$D(REDUX) S REDUX=""
     219        I '$D(NOINX) S NOINX=0 ; IF NOT PASSED, GENERATE AN INDEX
     220        N ZXML
     221        I NOINX S ZXML=$NA(^TMP("C0CINDEX",$J)) ; TEMP PLACE FOR INDEX TO DISCARD
     222        E  S ZXML=IZXML ; PLACE FOR INDEX TO KEEP
     223        I '$D(@IZXML@(0)) D  ; IF COUNT NOT IN NODE 0 COUNT THEM
     224        . S I="",LCNT=0
     225        . F  S I=$O(@IZXML@(I)) Q:I=""  S LCNT=LCNT+1
     226        E  S LCNT=@IZXML@(0) ; LINE COUNT PASSED IN ARRAY
     227        I LCNT=0  D  Q  ; NO XML PASSED
     228        . W "ERROR IN XML FILE",!
     229        S DVDX=0 ; DEFAULT DO NOT PRODUCE VDX INDEX
     230        I $D(VDX) S DVDX=1 ; IF NAME PASSED, DO VDX
     231        S C0CSTK(0)=0 ; INITIALIZE STACK
     232        K LKASD ; KILL LOOKASIDE ARRAY
     233        D MKLASD(.LKASD,IZXML) ;MAKE LOOK ASIDE BUFFER FOR MULTIPLES
     234        F I=1:1:LCNT  D  ; PROCESS THE ENTIRE ARRAY
     235        . S LINE=@IZXML@(I)
     236        . I $D(TEMPLATE) D  ;IF TEMPLATE IS REQUESTED
     237        . . S @TEMPLATE@(I)=$$CLEAN(LINE)
     238        . ;W LINE,!
     239        . S FOUND=0  ; INTIALIZED FOUND FLAG
     240        . I LINE?.E1"<!".E S FOUND=1 ; SKIP OVER COMMENTS
     241        . I FOUND'=1  D
     242        . . I (LINE?.E1"<"1.E1"</".E)!(LINE?.E1"<"1.E1"/>".E)  D
     243        . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS
     244        . . . ; ON THE SAME LINE
     245        . . . ; W "FOUND ",LINE,!
     246        . . . S FOUND=1  ; SET FOUND FLAG
     247        . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
     248        . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES
     249        . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK
     250        . . . D MKMDX("C0CSTK",.MDX,REDUX) ; GENERATE THE M INDEX
     251        . . . ; W "MDX=",MDX,!
     252        . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
     253        . . . . ;I '$D(ZDUP(MDX)) S ZDUP(MDX)=2
     254        . . . . ;E  S ZDUP(MDX)=ZDUP(MDX)+1
     255        . . . . ;W "DUP:",MDX,!
     256        . . . . ;I '$D(CURVAL) S CURVAL=""
     257        . . . . ;I DVDX S @VDX@(MDX_"["_ZDUP(MDX)_"]")=CURVAL
     258        . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
     259        . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
     260        . . . . S @ZXML@(MDX)=I_"^"_I  ; ADD INDEX ENTRY-FIRST AND LAST
     261        . . . . S CURVAL=$$XVAL(LINE) ; VALUE
     262        . . . . S $P(@ZXML@(MDX),"^",3)=CURVAL ; THIRD PIECE
     263        . . . . I DVDX S @VDX@(MDX)=CURVAL ; FILL IN VDX ARRAY IF REQUESTED
     264        . . . . I $D(TEMPLATE) D  ; IF TEMPLATE IS REQUESTED
     265        . . . . . S LINE=$$CLEAN(LINE) ; CLEAN OUT CONTROL CHARACTERS
     266        . . . . . S @TEMPLATE@(I)=$P(LINE,">",1)_">@@"_MDX_"@@</"_$P(LINE,"</",2)
     267        . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK
     268        . I FOUND'=1  D  ; THE LINE DOESN'T CONTAIN THE START AND END
     269        . . I LINE?.E1"</"1.E  D  ; LINE CONTAINS END OF A SECTION
     270        . . . ; W "FOUND ",LINE,!
     271        . . . S FOUND=1  ; SET FOUND FLAG
     272        . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
     273        . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX
     274        . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
     275        . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK
     276        . . . S TMP=$P(TMP,"[",1) ; REMOVE [X] FROM MULTIPLE
     277        . . . I TMP'=CUR  D  ; MALFORMED XML, END MUST MATCH START
     278        . . . . W "MALFORMED XML ",CUR,"LINE "_I_LINE,!
     279        . . . . D PARY("C0CSTK") ; PRINT OUT THE STACK FOR DEBUGING
     280        . . . . Q
     281        . I FOUND'=1  D  ; THE LINE MIGHT CONTAIN A SECTION BEGINNING
     282        . . I (LINE?.E1"<"1.E)&(LINE'["?>")  D  ; BEGINNING OF A SECTION
     283        . . . ; W "FOUND ",LINE,!
     284        . . . S FOUND=1  ; SET FOUND FLAG
     285        . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
     286        . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES
     287        . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK
     288        . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX
     289        . . . ; W "MDX=",MDX,!
     290        . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
     291        . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
     292        . . . . ;B
     293        . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
     294        . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX
     295        S @ZXML@("INDEXED")=""
     296        S @ZXML@("//")="1^"_LCNT ; ROOT XPATH
     297        I NOINX K @ZXML ; DELETE UNWANTED INDEX
     298        Q
     299        ;
     300MKLASD(OUTBUF,INARY)    ; CREATE A LOOKASIDE BUFFER FOR MULTILPLES
     301        ;
     302        N ZI,ZN,ZA,ZLINE,ZLINE2,CUR,CUR2
     303        F ZI=1:1:LCNT-1  D  ; PROCESS THE ENTIRE ARRAY
     304        . S ZLINE=@IZXML@(ZI)
     305        . I ZI<LCNT S ZLINE2=@IZXML@(ZI+1)
     306        . I ZLINE?.E1"</"1.E  D  ; NEXT LINE CONTAINS END OF A SECTION
     307        . . S CUR=$$XNAME(ZLINE) ; EXTRACT THE NAME
     308        . . I (ZLINE2?.E1"<"1.E)&(ZLINE'["?>")  D  ; BEGINNING OF A SECTION
     309        . . . S CUR2=$$XNAME(ZLINE2) ; EXTRACT THE NAME
     310        . . . I CUR=CUR2 D  ; IF THIS IS A MULTIPLE
     311        . . . . S OUTBUF(CUR,ZI+1)=""
     312        ;ZWR OUTBUF
     313        S ZI=""
     314        F  S ZI=$O(OUTBUF(ZI)) Q:ZI=""  D  ; FOR EACH KIND OF MULTIPLE
     315        . S ZN=$O(OUTBUF(ZI,"")) ; LINE NUMBER OF SECOND MULTIPLE
     316        . F  S ZN=$O(@IZXML@(ZN),-1) Q:ZN=""  I $E($P(@IZXML@(ZN),"<"_ZI,2),1,1)=">" Q  ;
     317        . S OUTBUF(ZI,ZN)=""
     318        S ZA=1,ZI="",ZN=""
     319        F  S ZI=$O(OUTBUF(ZI)) Q:ZI=""  D  ; ADDING THE COUNT FOR THE MULIPLES [x]
     320        . S ZN="",ZA=1
     321        . F  S ZN=$O(OUTBUF(ZI,ZN)) Q:ZN=""  D  ;
     322        . . S OUTBUF(ZI,ZN)="["_ZA_"]"
     323        . . S ZA=ZA+1
     324        Q
     325        ;
     326CLEAN(STR,TR)   ; extrinsic function; returns string
     327        ;; Removes all non printable characters from a string.
     328        ;; STR by Value
     329        ;; TR IS OPTIONAL TO IMPROVE PERFORMANCE
     330        N TR,I
     331        I '$D(TR) D  ;
     332        . F I=0:1:31 S TR=$G(TR)_$C(I)
     333        . S TR=TR_$C(127)
     334        QUIT $TR(STR,TR)
     335        ;
     336QUERY(IARY,XPATH,OARY)  ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION
     337        ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD"
     338        ; IARY AND OARY ARE PASSED BY NAME
     339        I '$D(@IARY@("INDEXED"))  D  ; INDEX IS NOT PRESENT IN IARY
     340        . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML
     341        N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN
     342        N TMP,I,J,QXPATH
     343        S FIRST=1
     344        I '$D(@IARY@(0)) D  ; LINE COUNT NOT IN ZERO NODE
     345        . S @IARY@(0)=$O(@IARY@("//"),-1) ; THIS SHOULD USUALLY WORK
     346        S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT
     347        I XPATH'="//" D  ; NOT A ROOT QUERY
     348        . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES
     349        . S FIRST=$P(TMP,"^",1)
     350        . S LAST=$P(TMP,"^",2)
     351        K @OARY
     352        S @OARY@(0)=+LAST-FIRST+1
     353        S J=1
     354        FOR I=FIRST:1:LAST  D
     355        . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY
     356        . S J=J+1
     357        ; ZWR OARY
     358        Q
     359        ;
     360XF(IDX,XPATH)     ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH
     361        ; INDEX WITH TWO PIECES START^FINISH
     362        ; IDX IS PASSED BY NAME
     363        Q $P(@IDX@(XPATH),"^",1)
     364        ;
     365XL(IDX,XPATH)     ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH
     366        ; INDEX WITH TWO PIECES START^FINISH
     367        ; IDX IS PASSED BY NAME
     368        Q $P(@IDX@(XPATH),"^",2)
     369        ;
     370START(ISTR)         ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX
     371        ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
     372        ; COMPANION TO FINISH ; IDX IS PASSED BY NAME
     373        Q $P(ISTR,";",2)
     374        ;
     375FINISH(ISTR)       ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX
     376        ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
     377        Q $P(ISTR,";",3)
     378        ;
     379ARRAY(ISTR)         ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX
     380        ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
     381        Q $P(ISTR,";",1)
     382        ;
     383BUILD(BLIST,BDEST)           ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST
     384        ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST
     385        ; DEST IS CLEARED TO START
     386        ; USES PUSH TO DO THE COPY
     387        N I
     388        K @BDEST
     389        F I=1:1:@BLIST@(0) D  ; FOR EACH INSTRUCTION IN BLIST
     390        . N J,ATMP
     391        . S ATMP=$$ARRAY(@BLIST@(I))
     392        . I $G(DEBUG) W "ATMP=",ATMP,!
     393        . I $G(DEBUG) W @BLIST@(I),!
     394        . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D  ;
     395        . . ; FOR EACH LINE IN THIS INSTR
     396        . . I $G(DEBUG) W "BDEST= ",BDEST,!
     397        . . I $G(DEBUG) W "ATMP= ",@ATMP@(J),!
     398        . . D PUSH(BDEST,@ATMP@(J))
     399        Q
     400        ;
     401QUEUE(BLST,ARRAY,FIRST,LAST)       ; ADD AN ENTRY TO A BLIST
     402        ;
     403        I $G(DEBUG) W "QUEUEING ",BLST,!
     404        D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST)
     405        Q
     406        ;
     407CP(CPSRC,CPDEST)               ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME
     408        ; KILLS CPDEST FIRST
     409        N CPINSTR
     410        I $G(DEBUG) W "MADE IT TO COPY",CPSRC,CPDEST,!
     411        I @CPSRC@(0)<1 D  ; BAD LENGTH
     412        . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,!
     413        . Q
     414        ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT
     415        D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY
     416        D BUILD("CPINSTR",CPDEST)
     417        Q
     418        ;
     419QOPEN(QOBLIST,QOXML,QOXPATH)       ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST
     420        ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD
     421        ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT
     422        ; USED TO INSERT CHILDREN NODES
     423        I @QOXML@(0)<1 D  ; MALFORMED XML
     424        . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,!
     425        . Q
     426        I $G(DEBUG) W "DOING QOPEN",!
     427        N S1,E1,QOT,QOTMP
     428        S S1=1 ; OPEN FROM THE BEGINNING OF THE XML
     429        I $D(QOXPATH) D  ; XPATH PROVIDED
     430        . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX
     431        . S E1=$P(@QOXML@(QOXPATH),"^",2)-1
     432        I '$D(QOXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
     433        . S E1=@QOXML@(0)-1
     434        D QUEUE(QOBLIST,QOXML,S1,E1)
     435        ; S QOTMP=QOXML_"^"_S1_"^"_E1
     436        ; D PUSH(QOBLIST,QOTMP)
     437        Q
     438        ;
     439QCLOSE(QCBLIST,QCXML,QCXPATH)     ; CLOSE XML AFTER A QOPEN
     440        ; ADDS THE LIST LINE OF QCXML TO QCBLIST
     441        ; USED TO FINISH INSERTING CHILDERN NODES
     442        ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END
     443        ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO
     444        I @QCXML@(0)<1 D  ; MALFORMED XML
     445        . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,!
     446        I $G(DEBUG) W "GOING TO CLOSE",!
     447        N S1,E1,QCT,QCTMP
     448        S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML
     449        I $D(QCXPATH) D  ; XPATH PROVIDED
     450        . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX
     451        . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML
     452        I '$D(QCXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
     453        . S S1=@QCXML@(0)
     454        D QUEUE(QCBLIST,QCXML,S1,E1)
     455        ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1)
     456        Q
     457        ;
     458INSERT(INSXML,INSNEW,INSXPATH)  ; INSERT INSNEW INTO INSXML AT THE
     459        ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS
     460        ; OMITTED, INSERTION WILL BE AT THE ROOT
     461        ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW
     462        ; XML AT THE END OF THE XPATH POINT
     463        ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE
     464        N INSBLD,INSTMP
     465        I $G(DEBUG) W "DOING INSERT ",INSXML,INSNEW,INSXPATH,!
     466        I $G(DEBUG) F G1=1:1:@INSXML@(0) W @INSXML@(G1),!
     467        I '$D(@INSXML@(1)) D  ; INSERT INTO AN EMPTY ARRAY
     468        . D CP^C0CXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT
     469        I $D(@INSXML@(1)) D  ; IF ORIGINAL ARRAY IS NOT EMPTY
     470        . I '$D(@INSXML@(0)) S @INSXML@(0)=$O(@INSXML@(""),-1) ;SET LENGTH
     471        . I $D(INSXPATH) D  ; XPATH PROVIDED
     472        . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE
     473        . . I $G(DEBUG) D PARY^C0CXPATH("INSBLD")
     474        . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
     475        . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH
     476        . I '$D(@INSNEW@(0)) S @INSNEW@(0)=$O(@INSNEW@(""),-1) ;SIZE OF XML
     477        . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML
     478        . I $D(INSXPATH) D  ; XPATH PROVIDED
     479        . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH
     480        . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
     481        . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH
     482        . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST
     483        . D CP^C0CXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE
     484        Q
     485        ;
     486INSINNER(INNXML,INNNEW,INNXPATH)               ; INSERT THE INNER XML OF INNNEW
     487        ; INTO INNXML AT THE INNXPATH XPATH POINT
     488        ;
     489        N INNBLD,UXPATH
     490        N INNTBUF
     491        S INNTBUF=$NA(^TMP($J,"INNTBUF"))
     492        I '$D(INNXPATH) D  ; XPATH NOT PASSED
     493        . S UXPATH="//" ; USE ROOT XPATH
     494        I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED
     495        I '$D(@INNXML@(0)) D  ; INNXML IS EMPTY
     496        . D QUEUE^C0CXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER
     497        . D BUILD("INNBLD",INNXML)
     498        I @INNXML@(0)>0  D  ; NOT EMPTY
     499        . D QOPEN("INNBLD",INNXML,UXPATH) ;
     500        . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML
     501        . D QCLOSE("INNBLD",INNXML,UXPATH)
     502        . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER
     503        . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST
     504        Q
     505        ;
     506INSB4(XDEST,XNEW)       ; INSERT XNEW AT THE BEGINNING OF XDEST
     507        ; BUT XDEST AN XNEW ARE PASSED BY NAME
     508        N XBLD,XTMP
     509        D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT
     510        D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST
     511        D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION
     512        D BUILD("XBLD","XTMP") ; BUILD THE RESULT
     513        D CP("XTMP",XDEST) ; COPY TO THE DESTINATION
     514        I $G(DEBUG) D PARY("XDEST")
     515        Q
     516        ;
     517REPLACE(REXML,RENEW,REXPATH)       ; REPLACE THE XML AT THE XPATH POINT
     518        ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE
     519        ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE
     520        ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD")
     521        N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
     522        S OLD=$NA(^TMP($J,"REPLACE_OLD"))
     523        D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
     524        S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
     525        S XFIRST=$P(XNODE,"^",1)
     526        S XLAST=$P(XNODE,"^",2)
     527        I RENEW="" D  ; WE ARE DELETING A SECTION, MUST SAVE THE TAG
     528        . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE
     529        . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST
     530        I RENEW'="" D  ; NEW XML IS NOT NULL
     531        . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE
     532        . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW
     533        . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST
     534        I $G(DEBUG) W "REPLACE PREBUILD",!
     535        I $G(DEBUG) D PARY("REBLD")
     536        D BUILD("REBLD","RTMP")
     537        K @REXML ; KILL WHAT WAS THERE
     538        D CP("RTMP",REXML) ; COPY IN THE RESULT
     539        Q
     540        ;
     541DELETE(REXML,REXPATH)      ; DELETE THE XML AT THE XPATH POINT
     542        ; REXML IS PASSED BY NAME XPATH IS A VALUE
     543        N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
     544        S OLD=$NA(^TMP($J,"REPLACE_OLD"))
     545        D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
     546        S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
     547        S XFIRST=$P(XNODE,"^",1)
     548        S XLAST=$P(XNODE,"^",2)
     549        D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE
     550        D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST
     551        I $G(DEBUG) D PARY("REBLD")
     552        D BUILD("REBLD","RTMP")
     553        K @REXML ; KILL WHAT WAS THERE
     554        D CP("RTMP",REXML) ; COPY IN THE RESULT
     555        Q
     556        ;
     557MISSING(IXML,OARY)           ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY
     558        ; W "Reporting on the missing",!
     559        ; W OARY
     560        I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q
     561        N I
     562        S @OARY@(0)=0 ; INITIALIZED MISSING COUNT
     563        F I=1:1:@IXML@(0)  D   ; LOOP THROUGH WHOLE ARRAY
     564        . I @IXML@(I)?.E1"@@".E D  ; MISSING VARIABLE HERE
     565        . . D PUSH^C0CXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY
     566        . . Q
     567        Q
     568        ;
     569MAP(IXML,INARY,OXML)    ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY
     570        ; AND PUT THE RESULTS IN OXML
     571        N XCNT
     572        I '$D(DEBUG) S DEBUG=0
     573        I '$D(IXML) W "MALFORMED XML PASSED TO MAP",! Q
     574        I '$D(@IXML@(0)) D  ; INITIALIZE COUNT
     575        . S XCNT=$O(@IXML@(""),-1)
     576        E  S XCNT=@IXML@(0) ;COUNT
     577        I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q
     578        N I,J,TNAM,TVAL,TSTR
     579        S @OXML@(0)=XCNT ; TOTAL LINES IN OUTPUT
     580        F I=1:1:XCNT  D   ; LOOP THROUGH WHOLE ARRAY
     581        . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT
     582        . I @OXML@(I)?.E1"@@".E D  ; IS THERE A VARIABLE HERE?
     583        . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS
     584        . . F J=2:2:10  D  Q:$P(@IXML@(I),"@@",J+2)=""  ; QUIT IF NO MORE VARS
     585        . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,!
     586        . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME
     587        . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED
     588        . . . I $D(@INARY@(TNAM))  D  ; IS THE VARIABLE IN THE MAP?
     589        . . . . I '$D(@INARY@(TNAM,"F")) D  ; NOT A SPECIAL FIELD
     590        . . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE
     591        . . . . E  D DOFLD ; PROCESS A FIELD
     592        . . . S TVAL=$$SYMENC^MXMLUTL(TVAL) ;MAKE SURE THE VALUE IS XML SAFE
     593        . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER
     594        . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES
     595        . . I DEBUG W TSTR
     596        I DEBUG W "MAPPED",!
     597        Q