Changeset 1428 for ccr/branches/ohum/p


Ignore:
Timestamp:
May 11, 2012, 6:06:25 PM (13 years ago)
Author:
Sam Habiel
Message:

Update of all routines

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

Legend:

Unmodified
Added
Removed

  • ccr/branches/ohum/p/C0CACTOR.m

    r1342 r1428  
    1 C0CACTOR  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ; This program is free software; you can redistribute it and/or modify
    8  ; it under the terms of the GNU General Public License as published by
    9  ; the Free Software Foundation; either version 2 of the License, or
    10  ; (at your option) any later version.
    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  ;  PROCESS THE ACTORS SECTION OF THE CCR
    22  ;
    23  ; ===Revision History===
    24  ; 0.1 Initial Writing of Skeleton--GPL
    25  ; 0.2 Patient Data Extraction--SMH
    26  ; 0.3 Information System Info Extraction--SMH
    27  ; 0.4 Patient data rouine refactored; adjustments here--SMH
    28  ;
    29 EXTRACT(IPXML,ALST,AXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE
    30  ; IPXML is the Input Actor Template into which we  substitute values
    31  ; This is straight XML. Values to be substituted are in @@VAL@@ format.
    32  ; ALST is the actor list global generated by ACTLST^C0CCCR and has format:
    33  ; ^TMP(7542,1,"ACTORS",0)=Count
    34  ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN"
    35  ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM"
    36  ; AXML is the output arrary, to contain XML.
    37  ;
    38  N I,J,AMAP,AOID,ATYP,AIEN
    39  D CP^C0CXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML
    40  D REPLACE^C0CXPATH(AXML,"","//Actors") ; DELETE THE INSIDES
    41  I DEBUG W "PROCESSING ACTORS ",!
    42  F I=1:1:@ALST@(0) D  ; PROCESS ALL ACTORS IN THE LIST
    43  . I @ALST@(I)["@@" Q  ; NOT A VALID ACTOR
    44  . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID
    45  . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE
    46  . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER
    47  . I AIEN="" D  Q  ; IEN CAN'T BE NULL
    48  . . W "WARING NUL ACTOR: ",ATYP,!
    49  . I ATYP="" Q  ; NOT A VALID ACTOR
    50  . ;
    51  . I DEBUG W AOID_" "_ATYP_" "_AIEN,!
    52  . I ATYP="PATIENT" D  ; PATIENT ACTOR TYPE
    53  . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP")
    54  . . D PATIENT("ATMP",AIEN,AOID,"ATMP2")
    55  . ;
    56  . I ATYP="SYSTEM" D  ; SYSTEM ACTOR TYPE
    57  . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP")
    58  . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2")
    59  . ;
    60  . I ATYP="NOK" D  ; NOK ACTOR TYPE
    61  . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP")
    62  . . D NOK("ATMP",AIEN,AOID,"ATMP2")
    63  . ;
    64  . I ATYP="PROVIDER" D  ; PROVIDER ACTOR TYPE
    65  . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP")
    66  . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2")
    67  . ;
    68  . I ATYP="ORGANIZATION" D  ; PROVIDER ACTOR TYPE
    69  . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP")
    70  . . D ORG("ATMP",AIEN,AOID,"ATMP2")
    71  . ;
    72  . W "PROCESSING:",ATYP," ",AIEN,!
    73  . ;I @ATMP2@(0)=0 Q  ; NOTHING RETURNED, SKIP THIS ONE
    74  . D INSINNER^C0CXPATH(AXML,"ATMP2") ; INSERT INTO ROOT
    75  . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE
    76  ;
    77  N ACTTMP
    78  D MISSING^C0CXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS
    79  I ACTTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
    80  . ; STRINGS MARKED AS @@X@@
    81  . W "ACTORS Missing list: ",!
    82  . F I=1:1:ACTTMP(0) W ACTTMP(I),!
    83  Q
    84  ;
    85 PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR
    86  I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,!
    87  ;GPL SEPARATED EXTRACT FROM MAP FOR PROCESSING PATIENTS - TO MAKE
    88  ; CODE REUSABLE FROM ERX
    89  N AMAP
    90  S AMAP=$NA(^TMP($J,"AMAP"))
    91  K @AMAP
    92  D PEXTRACT(AMAP,AIEN,AOID) ;EXTRACT THE PATIENT ACTOR
    93  I $P($$SITE^VASITE(),U,2)="OROVILLE HOSPITAL" S C0CDE=1
    94  I $G(C0CDE)'="" D DEIDENT(AMAP,AIEN) ; DEIDENTIFY THE CCR
    95  D MAP(INXML,AMAP,OUTXML) ;MAP TO XML
    96  K @AMAP ; CLEAN UP BEHIND US
    97  Q
    98  ;
    99 DEIDENT(GPL,ZDFN) ; QUICK WAY TO DEIDENTIFY THE CCR
    100  S @GPL@("ACTORADDRESSCITY")="ALTON"
    101  S @GPL@("ACTORADDRESSLINE1")="1234 Somewhere Lane"
    102  S @GPL@("ACTORADDRESSLINE2")=""
    103  S @GPL@("ACTORADDRESSSOURCEID")="ACTORPATIENT_"_ZDFN
    104  S @GPL@("ACTORADDRESSSTATE")="KANSAS"
    105  S @GPL@("ACTORADDRESSTYPE")="Home"
    106  S @GPL@("ACTORADDRESSZIPCODE")=67623
    107  S @GPL@("ACTORCELLTEL")=""
    108  S @GPL@("ACTORCELLTELTEXT")=""
    109  S @GPL@("ACTORDATEOFBIRTH")="1957-12-25"
    110  S @GPL@("ACTOREMAIL")=""
    111  S @GPL@("ACTORFAMILYNAME")="ZZ PATIENT"_ZDFN
    112  ;S @GPL@("ACTORGENDER")="MALE"
    113  S @GPL@("ACTORGIVENNAME")="TEST"_ZDFN
    114  S @GPL@("ACTORIEN")=2
    115  S @GPL@("ACTORMIDDLENAME")="TWO"
    116  S @GPL@("ACTOROBJECTID")="ACTORPATIENT_"_ZDFN
    117  S @GPL@("ACTORRESTEL")="888-555-1212"
    118  S @GPL@("ACTORRESTELTEXT")="Residential Telephone"
    119  S @GPL@("ACTORSOURCEID")="ACTORSYSTEM_1"
    120  S @GPL@("ACTORSSN")="769122557P"
    121  S @GPL@("ACTORSSNSOURCEID")="ACTORPATIENT_"_ZDFN
    122  S @GPL@("ACTORSSNTEXT")="SSN"
    123  S @GPL@("ACTORSUFFIXNAME")=""
    124  S @GPL@("ACTORWORKTEL")="888-121-1212"
    125  S @GPL@("ACTORWORKTELTEXT")="Work Telephone"
    126  Q
    127  ;
    128 PEXTRACT(AMAP,AIEN,AOID) ; EXTRACT TO RETURN ARRAY RARY PASSED BY NAME
    129  N ZX
    130  S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
    131  S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CDPT(AIEN)
    132  S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CDPT(AIEN)
    133  S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CDPT(AIEN)
    134  S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^C0CDPT(AIEN)
    135  S @AMAP@("ACTORGENDER")=$P($$GENDER^C0CDPT(AIEN),U,2)
    136  S @AMAP@("ACTORGENDERCODE")=$P($$GENDER^C0CDPT(AIEN),U,1)
    137  S @AMAP@("ACTORSSN")=""
    138  S @AMAP@("ACTORSSNTEXT")=""
    139  S @AMAP@("ACTORSSNSOURCEID")=""
    140  S X="MSCDPTID" ; ROUTINE TO TEST FOR MRN ON OPENVISTA
    141  X ^%ZOSF("TEST") ; TEST TO SEE IF THE ROUTINE EXISTS
    142  I $T S MRN=$$^MSCDPTID(DFN) ;TEST FOR MRN ON OPENVISTA ;GPL
    143  I $G(MRN)'="" D  ; IF MRN IS PRESENT
    144  . S @AMAP@("ACTORSSN")=MRN
    145  . S @AMAP@("ACTORSSNTEXT")="MRN"
    146  . S @AMAP@("ACTORSSNSOURCEID")=AOID
    147  E  D  ; NO MRN, USE SSN
    148  . S ZX=$$SSN^C0CDPT(AIEN)
    149  . I ZX'="" D  ; IF THERE IS A SSN IN THE RECORD
    150  . . S @AMAP@("ACTORSSN")=ZX
    151  . . S @AMAP@("ACTORSSNTEXT")="SSN"
    152  . . S @AMAP@("ACTORSSNSOURCEID")=AOID
    153  S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^C0CDPT(AIEN)
    154  S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^C0CDPT(AIEN)
    155  S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^C0CDPT(AIEN)
    156  S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CDPT(AIEN)
    157  S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CDPT(AIEN)
    158  S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^C0CDPT(AIEN)
    159  S @AMAP@("ACTORRESTEL")=""
    160  S @AMAP@("ACTORRESTELTEXT")=""
    161  S ZX=$$RESTEL^C0CDPT(AIEN)
    162  I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
    163  . S @AMAP@("ACTORRESTEL")=ZX
    164  . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone"
    165  S @AMAP@("ACTORWORKTEL")=""
    166  S @AMAP@("ACTORWORKTELTEXT")=""
    167  S ZX=$$WORKTEL^C0CDPT(AIEN)
    168  I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
    169  . S @AMAP@("ACTORWORKTEL")=ZX
    170  . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone"
    171  S @AMAP@("ACTORCELLTEL")=""
    172  S @AMAP@("ACTORCELLTELTEXT")=""
    173  S ZX=$$CELLTEL^C0CDPT(AIEN)
    174  I ZX'="" D  ; IF THERE IS A CELL PHONE IN THE RECORD
    175  . S @AMAP@("ACTORCELLTEL")=ZX
    176  . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone"
    177  S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CDPT(AIEN)
    178  S @AMAP@("ACTORADDRESSSOURCEID")=AOID
    179  S @AMAP@("ACTORIEN")=AIEN
    180  S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX
    181  S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
    182  Q
    183  ;
    184 MAP(INXML,AMAP,OUTXML) ;MAP ANY ACTOR TO XML
    185  D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
    186  Q
    187  ;
    188 SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR
    189      ;
    190      ; N AMAP
    191      S AMAP=$NA(^TMP($J,"AMAP"))
    192      K @AMAP
    193      S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
    194      S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^C0CSYS
    195      S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^C0CSYS
    196      S @AMAP@("ACTORINFOSYSSOURCEID")=AOID
    197      D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
    198      Q
    199      ;
    200 NOK(INXML,AIEN,AOID,OUTXML) ; PROCESS A NEXT OF KIN TYPE ACTOR
    201      ;
    202      ; N AMAP
    203      S AMAP=$NA(^TMP($J,"AMAP"))
    204      K @AMAP
    205      S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
    206      S @AMAP@("ACTORDISPLAYNAME")=""
    207      S @AMAP@("ACTORRELATION")=""
    208      S @AMAP@("ACTORRELATIONSOURCEID")=""
    209      S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
    210      D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
    211      Q
    212      ;
    213 ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR
    214      ;
    215      N AMAP,ZIEN,ZSITE
    216      S AMAP=$NA(^TMP($J,"AMAP"))
    217      K @AMAP
    218      S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
    219      S ZSITE=$$SITE^VASITE ; SITE FORMAT IEN^NAME^DATE
    220      S ZIEN=$P(ZSITE,"^",1)
    221      S @AMAP@("ORGANIZATIONNAME")=$P(ZSITE,U,2)
    222      S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1"
    223      S @AMAP@("ACTORADDRESSTYPE")="Office"
    224      S @AMAP@("ACTORADDRESSLINE1")=$$GET1^DIQ(4,ZIEN_",",1.01)
    225      S @AMAP@("ACTORADDRESSLINE2")=$$GET1^DIQ(4,ZIEN_",",1.02)
    226      S @AMAP@("ACTORADDRESSCITY")=$$GET1^DIQ(4,ZIEN_",",1.03)
    227      S @AMAP@("ACTORADDRESSSTATE")=$$GET1^DIQ(4,ZIEN_",",.02)
    228      S @AMAP@("ACTORPOSTALCODE")=$$GET1^DIQ(4,ZIEN_",",1.04)
    229      S @AMAP@("ACTORTELEPHONE")=""
    230      S @AMAP@("ACTORTELEPHONETYPE")=""
    231      S ZX=$$GET1^DIQ(4.03,"1,"_ZIEN_",",.03)
    232      I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
    233      . S @AMAP@("ACTORTELEPHONE")=ZX
    234      . S @AMAP@("ACTORTELEPHONETYPE")="Office"
    235      D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
    236      K @AMAP
    237      Q
    238      ;
    239 PROVIDER(INXML,AIEN,AOID,OUTXML) ; PROCESS A PROVIDER TYPE ACTOR
    240      ;
    241      ; N AMAP
    242      S AMAP=$NA(^TMP($J,"AMAP"))
    243      K @AMAP
    244      I '$D(^VA(200,AIEN,0)) D  Q  ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN)
    245      . W "WARNING - MISSING PROVIDER: ",AIEN,!
    246      . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT
    247      S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
    248      S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CVA200(AIEN)
    249      S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CVA200(AIEN)
    250      S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CVA200(AIEN)
    251      S @AMAP@("ACTORTITLE")=$$TITLE^C0CVA200(AIEN)
    252      S @AMAP@("IDTYPE")=$P($$NPI^C0CVA200(AIEN),U,1)
    253      S @AMAP@("ID")=$P($$NPI^C0CVA200(AIEN),U,2)
    254      S @AMAP@("IDDESC")=$P($$NPI^C0CVA200(AIEN),U,3)
    255      S @AMAP@("ACTORSPECIALITY")=$$SPEC^C0CVA200(AIEN)
    256      S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^C0CVA200(AIEN)
    257      S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^C0CVA200(AIEN)
    258      S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CVA200(AIEN)
    259      S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CVA200(AIEN)
    260      S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^C0CVA200(AIEN)
    261      S @AMAP@("ACTORTELEPHONE")=""
    262      S @AMAP@("ACTORTELEPHONETYPE")=""
    263      S ZX=$$TEL^C0CVA200(AIEN)
    264      I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
    265      . S @AMAP@("ACTORTELEPHONE")=ZX
    266      . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^C0CVA200(AIEN)
    267      S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CVA200(AIEN)
    268      S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1"
    269      S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
    270      S @AMAP@("ACTORORGLINK")="ACTORORGANIZATION_1"
    271      D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
    272      Q
    273      ;
     1C0CACTOR        ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ; This program is free software; you can redistribute it and/or modify
     8        ; it under the terms of the GNU General Public License as published by
     9        ; the Free Software Foundation; either version 2 of the License, or
     10        ; (at your option) any later version.
     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        ;  PROCESS THE ACTORS SECTION OF THE CCR
     22        ;
     23        ; ===Revision History===
     24        ; 0.1 Initial Writing of Skeleton--GPL
     25        ; 0.2 Patient Data Extraction--SMH
     26        ; 0.3 Information System Info Extraction--SMH
     27        ; 0.4 Patient data rouine refactored; adjustments here--SMH
     28        ;
     29EXTRACT(IPXML,ALST,AXML)        ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE
     30        ; IPXML is the Input Actor Template into which we  substitute values
     31        ; This is straight XML. Values to be substituted are in @@VAL@@ format.
     32        ; ALST is the actor list global generated by ACTLST^C0CCCR and has format:
     33        ; ^TMP(7542,1,"ACTORS",0)=Count
     34        ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN"
     35        ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM"
     36        ; AXML is the output arrary, to contain XML.
     37        ;
     38        N I,J,AMAP,AOID,ATYP,AIEN
     39        D CP^C0CXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML
     40        D REPLACE^C0CXPATH(AXML,"","//Actors") ; DELETE THE INSIDES
     41        I DEBUG W "PROCESSING ACTORS ",!
     42        F I=1:1:@ALST@(0) D  ; PROCESS ALL ACTORS IN THE LIST
     43        . I @ALST@(I)["@@" Q  ; NOT A VALID ACTOR
     44        . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID
     45        . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE
     46        . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER
     47        . I AIEN="" D  Q  ; IEN CAN'T BE NULL
     48        . . W "WARING NUL ACTOR: ",ATYP,!
     49        . I ATYP="" Q  ; NOT A VALID ACTOR
     50        . ;
     51        . I DEBUG W AOID_" "_ATYP_" "_AIEN,!
     52        . I ATYP="PATIENT" D  ; PATIENT ACTOR TYPE
     53        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP")
     54        . . D PATIENT("ATMP",AIEN,AOID,"ATMP2")
     55        . ;
     56        . I ATYP="SYSTEM" D  ; SYSTEM ACTOR TYPE
     57        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP")
     58        . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2")
     59        . ;
     60        . I ATYP="NOK" D  ; NOK ACTOR TYPE
     61        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP")
     62        . . D NOK("ATMP",AIEN,AOID,"ATMP2")
     63        . ;
     64        . I ATYP="PROVIDER" D  ; PROVIDER ACTOR TYPE
     65        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP")
     66        . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2")
     67        . ;
     68        . I ATYP="ORGANIZATION" D  ; PROVIDER ACTOR TYPE
     69        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP")
     70        . . D ORG("ATMP",AIEN,AOID,"ATMP2")
     71        . ;
     72        . W "PROCESSING:",ATYP," ",AIEN,!
     73        . ;I @ATMP2@(0)=0 Q  ; NOTHING RETURNED, SKIP THIS ONE
     74        . D INSINNER^C0CXPATH(AXML,"ATMP2") ; INSERT INTO ROOT
     75        . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE
     76        ;
     77        N ACTTMP
     78        D MISSING^C0CXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS
     79        I ACTTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
     80        . ; STRINGS MARKED AS @@X@@
     81        . W "ACTORS Missing list: ",!
     82        . F I=1:1:ACTTMP(0) W ACTTMP(I),!
     83        Q
     84        ;
     85PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR
     86        I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,!
     87        ;GPL SEPARATED EXTRACT FROM MAP FOR PROCESSING PATIENTS - TO MAKE
     88        ; CODE REUSABLE FROM ERX
     89        N AMAP
     90        S AMAP=$NA(^TMP($J,"AMAP"))
     91        K @AMAP
     92        D PEXTRACT(AMAP,AIEN,AOID) ;EXTRACT THE PATIENT ACTOR
     93        I $P($$SITE^VASITE(),U,2)="OROVILLE HOSPITAL" S C0CDE=1
     94        I $G(C0CDE)'="" D DEIDENT(AMAP,AIEN) ; DEIDENTIFY THE CCR
     95        D MAP(INXML,AMAP,OUTXML) ;MAP TO XML
     96        K @AMAP ; CLEAN UP BEHIND US
     97        Q
     98        ;
     99DEIDENT(GPL,ZDFN)       ; QUICK WAY TO DEIDENTIFY THE CCR
     100        S @GPL@("ACTORADDRESSCITY")="ALTON"
     101        S @GPL@("ACTORADDRESSLINE1")="1234 Somewhere Lane"
     102        S @GPL@("ACTORADDRESSLINE2")=""
     103        S @GPL@("ACTORADDRESSSOURCEID")="ACTORPATIENT_"_ZDFN
     104        S @GPL@("ACTORADDRESSSTATE")="KANSAS"
     105        S @GPL@("ACTORADDRESSTYPE")="Home"
     106        S @GPL@("ACTORADDRESSZIPCODE")=67623
     107        S @GPL@("ACTORCELLTEL")=""
     108        S @GPL@("ACTORCELLTELTEXT")=""
     109        S @GPL@("ACTORDATEOFBIRTH")="1957-12-25"
     110        S @GPL@("ACTOREMAIL")=""
     111        S @GPL@("ACTORFAMILYNAME")="ZZ PATIENT"_ZDFN
     112        ;S @GPL@("ACTORGENDER")="MALE"
     113        S @GPL@("ACTORGIVENNAME")="TEST"_ZDFN
     114        S @GPL@("ACTORIEN")=2
     115        S @GPL@("ACTORMIDDLENAME")="TWO"
     116        S @GPL@("ACTOROBJECTID")="ACTORPATIENT_"_ZDFN
     117        S @GPL@("ACTORRESTEL")="888-555-1212"
     118        S @GPL@("ACTORRESTELTEXT")="Residential Telephone"
     119        S @GPL@("ACTORSOURCEID")="ACTORSYSTEM_1"
     120        S @GPL@("ACTORSSN")="769122557P"
     121        S @GPL@("ACTORSSNSOURCEID")="ACTORPATIENT_"_ZDFN
     122        S @GPL@("ACTORSSNTEXT")="SSN"
     123        S @GPL@("ACTORSUFFIXNAME")=""
     124        S @GPL@("ACTORWORKTEL")="888-121-1212"
     125        S @GPL@("ACTORWORKTELTEXT")="Work Telephone"
     126        Q
     127        ;
     128PEXTRACT(AMAP,AIEN,AOID)        ; EXTRACT TO RETURN ARRAY RARY PASSED BY NAME
     129        N ZX
     130        S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     131        S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CDPT(AIEN)
     132        S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CDPT(AIEN)
     133        S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CDPT(AIEN)
     134        S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^C0CDPT(AIEN)
     135        S @AMAP@("ACTORGENDER")=$P($$GENDER^C0CDPT(AIEN),U,2)
     136        S @AMAP@("ACTORGENDERCODE")=$P($$GENDER^C0CDPT(AIEN),U,1)
     137        S @AMAP@("ACTORSSN")=""
     138        S @AMAP@("ACTORSSNTEXT")=""
     139        S @AMAP@("ACTORSSNSOURCEID")=""
     140        S X="MSCDPTID" ; ROUTINE TO TEST FOR MRN ON OPENVISTA
     141        X ^%ZOSF("TEST") ; TEST TO SEE IF THE ROUTINE EXISTS
     142        I $T S MRN=$$^MSCDPTID(DFN) ;TEST FOR MRN ON OPENVISTA ;GPL
     143        I $G(MRN)'="" D  ; IF MRN IS PRESENT
     144        . S @AMAP@("ACTORSSN")=MRN
     145        . S @AMAP@("ACTORSSNTEXT")="MRN"
     146        . S @AMAP@("ACTORSSNSOURCEID")=AOID
     147        E  D  ; NO MRN, USE SSN
     148        . S ZX=$$SSN^C0CDPT(AIEN)
     149        . I ZX'="" D  ; IF THERE IS A SSN IN THE RECORD
     150        . . S @AMAP@("ACTORSSN")=ZX
     151        . . S @AMAP@("ACTORSSNTEXT")="SSN"
     152        . . S @AMAP@("ACTORSSNSOURCEID")=AOID
     153        S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^C0CDPT(AIEN)
     154        S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^C0CDPT(AIEN)
     155        S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^C0CDPT(AIEN)
     156        S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CDPT(AIEN)
     157        S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CDPT(AIEN)
     158        S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^C0CDPT(AIEN)
     159        S @AMAP@("ACTORRESTEL")=""
     160        S @AMAP@("ACTORRESTELTEXT")=""
     161        S ZX=$$RESTEL^C0CDPT(AIEN)
     162        I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
     163        . S @AMAP@("ACTORRESTEL")=ZX
     164        . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone"
     165        S @AMAP@("ACTORWORKTEL")=""
     166        S @AMAP@("ACTORWORKTELTEXT")=""
     167        S ZX=$$WORKTEL^C0CDPT(AIEN)
     168        I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
     169        . S @AMAP@("ACTORWORKTEL")=ZX
     170        . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone"
     171        S @AMAP@("ACTORCELLTEL")=""
     172        S @AMAP@("ACTORCELLTELTEXT")=""
     173        S ZX=$$CELLTEL^C0CDPT(AIEN)
     174        I ZX'="" D  ; IF THERE IS A CELL PHONE IN THE RECORD
     175        . S @AMAP@("ACTORCELLTEL")=ZX
     176        . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone"
     177        S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CDPT(AIEN)
     178        S @AMAP@("ACTORADDRESSSOURCEID")=AOID
     179        S @AMAP@("ACTORIEN")=AIEN
     180        S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX
     181        S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
     182        Q
     183        ;
     184MAP(INXML,AMAP,OUTXML)  ;MAP ANY ACTOR TO XML
     185        D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     186        Q
     187        ;
     188SYSTEM(INXML,AIEN,AOID,OUTXML)  ; PROCESS A SYSTEM ACTOR
     189            ;
     190            ; N AMAP
     191            S AMAP=$NA(^TMP($J,"AMAP"))
     192            K @AMAP
     193            S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     194            S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^C0CSYS
     195            S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^C0CSYS
     196            S @AMAP@("ACTORINFOSYSSOURCEID")=AOID
     197            D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     198            Q
     199            ;
     200NOK(INXML,AIEN,AOID,OUTXML)     ; PROCESS A NEXT OF KIN TYPE ACTOR
     201            ;
     202            ; N AMAP
     203            S AMAP=$NA(^TMP($J,"AMAP"))
     204            K @AMAP
     205            S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     206            S @AMAP@("ACTORDISPLAYNAME")=""
     207            S @AMAP@("ACTORRELATION")=""
     208            S @AMAP@("ACTORRELATIONSOURCEID")=""
     209            S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
     210            D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     211            Q
     212            ;
     213ORG(INXML,AIEN,AOID,OUTXML)     ; PROCESS AN ORGANIZATION TYPE ACTOR
     214            ;
     215            N AMAP,ZIEN,ZSITE
     216            S AMAP=$NA(^TMP($J,"AMAP"))
     217            K @AMAP
     218            S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     219            S ZSITE=$$SITE^VASITE ; SITE FORMAT IEN^NAME^DATE
     220            S ZIEN=$P(ZSITE,"^",1)
     221            S @AMAP@("ORGANIZATIONNAME")=$P(ZSITE,U,2)
     222            S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1"
     223            S @AMAP@("ACTORADDRESSTYPE")="Office"
     224            S @AMAP@("ACTORADDRESSLINE1")=$$GET1^DIQ(4,ZIEN_",",1.01)
     225            S @AMAP@("ACTORADDRESSLINE2")=$$GET1^DIQ(4,ZIEN_",",1.02)
     226            S @AMAP@("ACTORADDRESSCITY")=$$GET1^DIQ(4,ZIEN_",",1.03)
     227            S @AMAP@("ACTORADDRESSSTATE")=$$GET1^DIQ(4,ZIEN_",",.02)
     228            S @AMAP@("ACTORPOSTALCODE")=$$GET1^DIQ(4,ZIEN_",",1.04)
     229            S @AMAP@("ACTORTELEPHONE")=""
     230            S @AMAP@("ACTORTELEPHONETYPE")=""
     231            S ZX=$$GET1^DIQ(4.03,"1,"_ZIEN_",",.03)
     232            I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
     233            . S @AMAP@("ACTORTELEPHONE")=ZX
     234            . S @AMAP@("ACTORTELEPHONETYPE")="Office"
     235            D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     236            K @AMAP
     237            Q
     238            ;
     239PROVIDER(INXML,AIEN,AOID,OUTXML)        ; PROCESS A PROVIDER TYPE ACTOR
     240            ;
     241            ; N AMAP
     242            S AMAP=$NA(^TMP($J,"AMAP"))
     243            K @AMAP
     244            I '$D(^VA(200,AIEN,0)) D  Q  ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN)
     245            . W "WARNING - MISSING PROVIDER: ",AIEN,!
     246            . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT
     247            S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     248            S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CVA200(AIEN)
     249            S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CVA200(AIEN)
     250            S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CVA200(AIEN)
     251            S @AMAP@("ACTORTITLE")=$$TITLE^C0CVA200(AIEN)
     252            S @AMAP@("IDTYPE")=$P($$NPI^C0CVA200(AIEN),U,1)
     253            S @AMAP@("ID")=$P($$NPI^C0CVA200(AIEN),U,2)
     254            S @AMAP@("IDDESC")=$P($$NPI^C0CVA200(AIEN),U,3)
     255            S @AMAP@("ACTORSPECIALITY")=$$SPEC^C0CVA200(AIEN)
     256            S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^C0CVA200(AIEN)
     257            S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^C0CVA200(AIEN)
     258            S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CVA200(AIEN)
     259            S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CVA200(AIEN)
     260            S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^C0CVA200(AIEN)
     261            S @AMAP@("ACTORTELEPHONE")=""
     262            S @AMAP@("ACTORTELEPHONETYPE")=""
     263            S ZX=$$TEL^C0CVA200(AIEN)
     264            I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
     265            . S @AMAP@("ACTORTELEPHONE")=ZX
     266            . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^C0CVA200(AIEN)
     267            S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CVA200(AIEN)
     268            S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1"
     269            S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
     270            S @AMAP@("ACTORORGLINK")="ACTORORGANIZATION_1"
     271            D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     272            Q
     273            ;

  • ccr/branches/ohum/p/C0CALERT.m

    r1342 r1428  
    1 C0CALERT  ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  W "NO ENTRY FROM TOP",!
    22  Q
    23  ;
    24 EXTRACT(ALTXML,DFN,ALTOUTXML,CALLBK) ; EXTRACT ALERTS INTO  XML TEMPLATE
    25  ; CALLBACK IF PROVIDED IS CALLED FOR EACH ALLERGY BEFORE MAPPING
    26  ; ALTXML AND ALTOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
    27  ;
    28  ; GET ADVERSE REACTIONS AND ALLERGIES
    29  ; N GMRA,GMRAL ; FOR DEBUGGING, DON'T NEW THESE VARIABLES
    30  S GMRA="0^0^111"
    31  D EN1^GMRADPT
    32  I $G(GMRAL)'=1 D  Q ; NO ALLERGIES FOUND THUS *QUIT*
    33  . S @ALTOUTXML@(0)=0
    34  ; DEFINE MAPPING
    35  N ALTTVMAP,ALTVMAP,ALTTARYTMP,ALTARYTMP
    36  S ALTTVMAP=$NA(^TMP("C0CCCR",$J,"ALERTS"))
    37  S ALTTARYTMP=$NA(^TMP("C0CCCR",$J,"ALERTSARYTMP"))
    38  K @ALTTVMAP,@ALTTARYTMP
    39  N ALTTMP,ALTCNT S ALTG=$NA(GMRAL),ALTCNT=1
    40  S ALTTMP="" ;
    41  F  S ALTTMP=$O(@ALTG@(ALTTMP)) Q:ALTTMP=""  D  ; CHANGED TO $O BY GPL
    42  . W "ALTTMP="_ALTTMP,!
    43  . ; I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q
    44  . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT))
    45  . K @ALTVMAP
    46  . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT
    47  . N A1 S A1=@ALTG@(ALTTMP) ; ALL THE PIECES
    48  . I $D(CALLBK) D @CALLBK ;CALLBACK FOR EPRESCRIBING
    49  . N A2 S A2=$$GET1^DIQ(120.8,ALTTMP,"MECHANISM","I") ; MECHANISM
    50  . N A3 S A3=$P(A1,U,5) ; ADVERSE FLAG
    51  . N ADT S ADT="Patient has an " ; X $ZINT H 5
    52  . S ADT=ADT_$S(A2="P":"ADVERSE",A2="A":"ALLERGIC",1:"UNKNOWN")
    53  . S ADT=ADT_" reaction to "_$P(@ALTG@(ALTTMP),U,2)_"."
    54  . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT
    55  . N ADTY S ADTY=$S(A2="P":"Adverse Reaction",A2="A":"Allergy",1:"") ;
    56  . S @ALTVMAP@("ALERTTYPE")=ADTY ; type of allergy
    57  . N ALTCDE ; SNOMED CODE THE THE ALERT
    58  . S ALTCDE=$S(A2="P":"282100009",A2="A":"416098002",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC
    59  . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ;
    60  . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE
    61  . ; AND  282100009 FOR ADVERSE REACTION TO A SUBSTANCE
    62  . I ALTCDE'="" D  ; IF THERE IS A CODE
    63  . . S @ALTVMAP@("ALERTCODESYSTEM")="SNOMED CT"
    64  . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="2008"
    65  . E  D  ; SET TO NULL
    66  . . S @ALTVMAP@("ALERTCODESYSTEM")=""
    67  . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")=""
    68  . S @ALTVMAP@("ALERTSTATUSTEXT")="" ; WHERE DO WE GET THIS?
    69  . N ALTPROV S ALTPROV=$P(^GMR(120.8,ALTTMP,0),U,5) ; SOURCE PROVIDER IEN
    70  . I ALTPROV'="" D  ; PROVIDER PROVIDEED
    71  . . S @ALTVMAP@("ALERTSOURCEID")="ACTORPROVIDER_"_ALTPROV
    72  . E  S @ALTVMAP@("ALERTSOURCEID")="" ; SOURCE NULL - SHOULD NOT HAPPEN
    73  . W "RUNNING ALERTS, PROVIDER: ",@ALTVMAP@("ALERTSOURCEID"),!
    74  . N ACGL1,ACGFI,ACIEN,ACVUID,ACNM,ACTMP
    75  . S ACGL1=$P(@ALTG@(ALTTMP),U,9) ; ADDRESS OF THE REACTANT XX;GLB(YY.Z,
    76  . S ACGFI=$$PRSGLB($P(ACGL1,";",2)) ; FILE NUMBER
    77  . S ACIEN=$P(ACGL1,";",1) ; IEN OF REACTANT
    78  . S ACVUID=$$GET1^DIQ(ACGFI,ACIEN,"VUID") ; VUID OF THE REACTANT
    79  . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="PRODUCT_"_ACIEN ; IE OF REACTANT
    80  . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="" ; WHERE DO WE GET THIS?
    81  . S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT
    82  . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM
    83  . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
    84  . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE
    85  . I ACVUID'="" D  ; IF VUID IS NOT NULL
    86  . . S ZC=$$CODE^C0CUTIL(ACVUID)
    87  . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
    88  . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
    89  . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
    90  . E  D  ; IF REACTANT CODE VALUE IS NULL
    91  . . I $G(DUZ("AG"))="I" D  ; IF WE ARE RUNNING ON RPMS
    92  . . . S ACTMP=$O(^C0CCODES(176.112,"C",ACNM,0)) ;
    93  . . . W "RPMS NAME FOUND",ACNM," ",ACTMP,!
    94  . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=""
    95  . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=""
    96  . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ZCD
    97  . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=ZCDS
    98  . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM_" "_ZCDS_": "_ZCD
    99  . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT_" "_ZCDS_": "_ZCD
    100  . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW
    101  . N ARTMP,ARIEN,ARDES,ARVUID
    102  . S (ARTMP,ARDES,ARVUID)=""
    103  . I $D(@ALTG@(ALTTMP,"S",1)) D  ; IF REACTION EXISTS
    104  . . S ARTMP=@ALTG@(ALTTMP,"S",1)
    105  . . W "REACTION:",ARTMP,!
    106  . . S ARIEN=$P(ARTMP,";",2)
    107  . . S ARDES=$P(ARTMP,";",1)
    108  . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID")
    109  . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES
    110  . I ARVUID'="" D  ; IF REACTION VUID IS NOT NULL
    111  . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID
    112  . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID"
    113  . E  D  ; IF IT IS NULL DON'T SET CODE SYSTEM
    114  . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=""
    115  . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")=""
    116  . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT))
    117  . ; NOW GO TO THE GLOBAL TO GET THE DATE/TIME AND BETTER DESCRIPTION
    118  . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL
    119  . D GETN1^C0CRNF("C0CG1",120.8,ALTTMP,"") ;GET VALUES BY NAME
    120  . S C0CT=$$ZVALUEI^C0CRNF("ORIGINATION DATE/TIME","C0CG1")
    121  . S @ALTVMAP@("ALERTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CT,"DT")
    122  . K @ALTARYTMP
    123  . D MAP^C0CXPATH(ALTXML,ALTVMAP,ALTARYTMP)
    124  . I ALTCNT=1 D CP^C0CXPATH(ALTARYTMP,ALTOUTXML)
    125  . I ALTCNT>1 D INSINNER^C0CXPATH(ALTOUTXML,ALTARYTMP)
    126  . S ALTCNT=ALTCNT+1
    127  S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS
    128  Q
    129 PRSGLB(INGLB) ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER
    130  ; INGLB IS OF THE FORM: PSNDF(50.6,
    131  ; RETURN 50.6
    132  Q $P($P(INGLB,"(",2),",",1)  ;
     1C0CALERT        ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        W "NO ENTRY FROM TOP",!
     22        Q
     23        ;
     24EXTRACT(ALTXML,DFN,ALTOUTXML,CALLBK)    ; EXTRACT ALERTS INTO  XML TEMPLATE
     25        ; CALLBACK IF PROVIDED IS CALLED FOR EACH ALLERGY BEFORE MAPPING
     26        ; ALTXML AND ALTOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
     27        ;
     28        ; GET ADVERSE REACTIONS AND ALLERGIES
     29        ; N GMRA,GMRAL ; FOR DEBUGGING, DON'T NEW THESE VARIABLES
     30        S GMRA="0^0^111"
     31        D EN1^GMRADPT
     32        I $G(GMRAL)'=1 D  Q ; NO ALLERGIES FOUND THUS *QUIT*
     33        . S @ALTOUTXML@(0)=0
     34        ; DEFINE MAPPING
     35        N ALTTVMAP,ALTVMAP,ALTTARYTMP,ALTARYTMP
     36        S ALTTVMAP=$NA(^TMP("C0CCCR",$J,"ALERTS"))
     37        S ALTTARYTMP=$NA(^TMP("C0CCCR",$J,"ALERTSARYTMP"))
     38        K @ALTTVMAP,@ALTTARYTMP
     39        N ALTTMP,ALTCNT S ALTG=$NA(GMRAL),ALTCNT=1
     40        S ALTTMP="" ;
     41        F  S ALTTMP=$O(@ALTG@(ALTTMP)) Q:ALTTMP=""  D  ; CHANGED TO $O BY GPL
     42        . W "ALTTMP="_ALTTMP,!
     43        . ; I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q
     44        . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT))
     45        . K @ALTVMAP
     46        . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT
     47        . N A1 S A1=@ALTG@(ALTTMP) ; ALL THE PIECES
     48        . I $D(CALLBK) D @CALLBK ;CALLBACK FOR EPRESCRIBING
     49        . N A2 S A2=$$GET1^DIQ(120.8,ALTTMP,"MECHANISM","I") ; MECHANISM
     50        . N A3 S A3=$P(A1,U,5) ; ADVERSE FLAG
     51        . N ADT S ADT="Patient has an " ; X $ZINT H 5
     52        . S ADT=ADT_$S(A2="P":"ADVERSE",A2="A":"ALLERGIC",1:"UNKNOWN")
     53        . S ADT=ADT_" reaction to "_$P(@ALTG@(ALTTMP),U,2)_"."
     54        . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT
     55        . N ADTY S ADTY=$S(A2="P":"Adverse Reaction",A2="A":"Allergy",1:"") ;
     56        . S @ALTVMAP@("ALERTTYPE")=ADTY ; type of allergy
     57        . N ALTCDE ; SNOMED CODE THE THE ALERT
     58        . S ALTCDE=$S(A2="P":"282100009",A2="A":"416098002",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC
     59        . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ;
     60        . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE
     61        . ; AND  282100009 FOR ADVERSE REACTION TO A SUBSTANCE
     62        . I ALTCDE'="" D  ; IF THERE IS A CODE
     63        . . S @ALTVMAP@("ALERTCODESYSTEM")="SNOMED CT"
     64        . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="2008"
     65        . E  D  ; SET TO NULL
     66        . . S @ALTVMAP@("ALERTCODESYSTEM")=""
     67        . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")=""
     68        . S @ALTVMAP@("ALERTSTATUSTEXT")="" ; WHERE DO WE GET THIS?
     69        . N ALTPROV S ALTPROV=$P(^GMR(120.8,ALTTMP,0),U,5) ; SOURCE PROVIDER IEN
     70        . I ALTPROV'="" D  ; PROVIDER PROVIDEED
     71        . . S @ALTVMAP@("ALERTSOURCEID")="ACTORPROVIDER_"_ALTPROV
     72        . E  S @ALTVMAP@("ALERTSOURCEID")="" ; SOURCE NULL - SHOULD NOT HAPPEN
     73        . W "RUNNING ALERTS, PROVIDER: ",@ALTVMAP@("ALERTSOURCEID"),!
     74        . N ACGL1,ACGFI,ACIEN,ACVUID,ACNM,ACTMP
     75        . S ACGL1=$P(@ALTG@(ALTTMP),U,9) ; ADDRESS OF THE REACTANT XX;GLB(YY.Z,
     76        . S ACGFI=$$PRSGLB($P(ACGL1,";",2)) ; FILE NUMBER
     77        . S ACIEN=$P(ACGL1,";",1) ; IEN OF REACTANT
     78        . S ACVUID=$$GET1^DIQ(ACGFI,ACIEN,"VUID") ; VUID OF THE REACTANT
     79        . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="PRODUCT_"_ACIEN ; IE OF REACTANT
     80        . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="" ; WHERE DO WE GET THIS?
     81        . S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT
     82        . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM
     83        . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
     84        . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE
     85        . I ACVUID'="" D  ; IF VUID IS NOT NULL
     86        . . S ZC=$$CODE^C0CUTIL(ACVUID)
     87        . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
     88        . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
     89        . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
     90        . E  D  ; IF REACTANT CODE VALUE IS NULL
     91        . . I $G(DUZ("AG"))="I" D  ; IF WE ARE RUNNING ON RPMS
     92        . . . S ACTMP=$O(^C0CCODES(176.112,"C",ACNM,0)) ;
     93        . . . W "RPMS NAME FOUND",ACNM," ",ACTMP,!
     94        . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=""
     95        . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=""
     96        . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ZCD
     97        . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=ZCDS
     98        . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM_" "_ZCDS_": "_ZCD
     99        . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT_" "_ZCDS_": "_ZCD
     100        . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW
     101        . N ARTMP,ARIEN,ARDES,ARVUID
     102        . S (ARTMP,ARDES,ARVUID)=""
     103        . I $D(@ALTG@(ALTTMP,"S",1)) D  ; IF REACTION EXISTS
     104        . . S ARTMP=@ALTG@(ALTTMP,"S",1)
     105        . . W "REACTION:",ARTMP,!
     106        . . S ARIEN=$P(ARTMP,";",2)
     107        . . S ARDES=$P(ARTMP,";",1)
     108        . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID")
     109        . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES
     110        . I ARVUID'="" D  ; IF REACTION VUID IS NOT NULL
     111        . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID
     112        . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID"
     113        . E  D  ; IF IT IS NULL DON'T SET CODE SYSTEM
     114        . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=""
     115        . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")=""
     116        . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT))
     117        . ; NOW GO TO THE GLOBAL TO GET THE DATE/TIME AND BETTER DESCRIPTION
     118        . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL
     119        . D GETN1^C0CRNF("C0CG1",120.8,ALTTMP,"") ;GET VALUES BY NAME
     120        . S C0CT=$$ZVALUEI^C0CRNF("ORIGINATION DATE/TIME","C0CG1")
     121        . S @ALTVMAP@("ALERTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CT,"DT")
     122        . K @ALTARYTMP
     123        . D MAP^C0CXPATH(ALTXML,ALTVMAP,ALTARYTMP)
     124        . I ALTCNT=1 D CP^C0CXPATH(ALTARYTMP,ALTOUTXML)
     125        . I ALTCNT>1 D INSINNER^C0CXPATH(ALTOUTXML,ALTARYTMP)
     126        . S ALTCNT=ALTCNT+1
     127        S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS
     128        Q
     129PRSGLB(INGLB)   ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER
     130        ; INGLB IS OF THE FORM: PSNDF(50.6,
     131        ; RETURN 50.6
     132        Q $P($P(INGLB,"(",2),",",1)  ;

  • ccr/branches/ohum/p/C0CBAT.m

    r1342 r1428  
    1 C0CBAT   ; CCDCCR/GPL - CCR Batch utilities; 4/21/09
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  W "This is the CCR Batch Utility Library ",!
    21  Q
    22  ;
    23 STOP ; STOP A CURRENTLY RUNNING BATCH JOB
    24  I '$D(^TMP("C0CBAT","RUNNING")) Q  ;
    25  W !,!,"HALTING CCR BATCH",!
    26  S ^TMP("C0CBAT","STOP")="" ; SIGNAL JOB TO TERMINATE
    27  H 10 ; WAIT TEN SECONDS FOR SIGNAL TO BE RECEIVED
    28  I '$D(^TMP("C0CBAT","STOP")) D  ; SIGNAL RECEIVED
    29  . W "CCR BATCH JOB TERMINATING",!
    30  E  D  ;
    31  . K ^TMP("C0CBAT","STOP") ; STOP SIGNALING
    32  . W !,"BATCH PROCESSING APPARENTLY NOT RUNNING",!
    33  Q
    34  ;
    35 START ; STARTS A TAKSMAN CCR BATCH JOB - FOR USE IN A MENU OPTION
    36  ;
    37  I $D(^TMP("C0CBAT","RUNNING")) D  Q  ; ONLY ONE ALLOWED AT A TIME
    38  . W !,"CCR BATCH ALREADY RUNNING",!
    39  . W !,"STOP FIRST WITH STOP^C0CBAT",!
    40  N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTIO
    41  S ZTRTN="EN^C0CBAT",ZTDESC="CCR Batch"
    42  S ZTDTH=$H ;
    43  ;S ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10))
    44  S ZTSAVE("C0C")="",ZTSAVE("C0C*")=""
    45  S ZTIO="NULL" ;
    46  W !,!,"CCR BATCH JOB STARTED",!
    47  D ^%ZTLOAD
    48  Q
    49  ;
    50 EN ; BATCH ENTRY POINT
    51  ; PROCESSES THE SUBSCRIPTION FILE, EXTRACTING CCR VARIABLES FOR EACH
    52  ; PATIENT WITH AN ACTIVE SUBSCRIPTION, AND IF CHECKSUMS INDICATE A CHANGE,
    53  ; GENERATES A NEW CCR FOR THE PATIENT
    54  ; UPDATES THE E2 CCR ELEMENTS FILE
    55  ;
    56  S C0CQT=1 ; QUIET MODE
    57  I $D(^TMP("C0CBAT","RUNNING")) Q  ; ONLY ONE AT A TIME
    58  S ^TMP("C0CBAT","RUNNING")="" ; RUNNING SIGNAL
    59  S C0CBDT=$$NOW^XLFDT ; DATE OF THIS RUN
    60  S C0CBF=177.301 ; FILE NUMBER OF C0C BATCH CONTROL FILE
    61  S C0CBFR=177.3013 ; FILE NUMBER OF UPDATE SUBFILE
    62  S C0CBB=$NA(^TMP("C0CBATCH",C0CBDT)) ; BATCH WORK AREA
    63  I $D(@C0CBB@(0)) D  ; ERROR SHOULDN'T EXIST
    64  . W "WORK AREA ERROR",!
    65  . B
    66  S @C0CBB@(0)="V22" ; VERSION USED TO CREATE THIS WORK AREA
    67  S C0CBH=$NA(@C0CBB@("HOTLIST")) ; BASE FOR HOT LIST
    68  S C0CBS=$NA(^C0CS("B")) ; SUBSCRIPTION LIST BASE
    69  ;I $D(^C0CB("B",C0CDT)) D  ; BATCH RECORD EXISTS
    70  ;. H 10 ; HANG 10 SECONDS
    71  ;. S C0CBDT=$$NOW^XLFDT ; NEW DATE FOR THIS RUN
    72  ;. I $D(^C0CB("B",C0CDT)) B ;DIDN'T WORK
    73  D BLDHOT(C0CBH) ; BUILD THE HOT LIST
    74  S C0CHN=$$COUNT(C0CBH) ;COUNT NUMBER IN HOT LIST
    75  S C0CSN=$$COUNT(C0CBS) ;COUNT NUMBER OF PATIENTS WITH SUBSCRIPTIONS
    76  S C0CFDA(C0CBF,"+1,",.01)=C0CBDT ; DATE KEY OF BATCH CONTROL
    77  S C0CFDA(C0CBF,"+1,",.02)=C0CBDT ; BATCH ID IS DATE IN STRING FORM
    78  S C0CFDA(C0CBF,"+1,",1)=C0CSN ; TOTAL SUBSCRIPTIONS
    79  S C0CFDA(C0CBF,"+1,",2)=C0CHN ; TOTAL HOT LIST
    80  D UPDIE ; CREATE THE BATCH RECORD
    81  S C0CIEN=$O(^C0CB("B",C0CBDT,""))
    82  S (C0CN,C0CNH)=0 ; COUNTERS FOR TOTAL AND HOT LIST
    83  S C0CBCUR="" ; CURRENT PATIENT
    84  S C0CSTOP=0 ; STOP FLAG FOR HALTING BATCH SET ^TMP("C0CBAT","STOP")=""
    85  ;F  S C0CBCUR=$O(@C0CBH@(C0CBCUR),-1) Q:C0CBCUR=""  D  ; HOT LIST LATEST FIRST
    86  F  S C0CBCUR=$O(@C0CBH@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="")  D  ; HOT LIST FIRST
    87  . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-900^VITLIMIT:T-900")
    88  . I $G(C0CCHK) D  ;
    89  . . D PUTRIM^C0CFM2(C0CBCUR)
    90  . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR
    91  . . K C0CFDA
    92  . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR
    93  . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y"
    94  . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR))
    95  . . D UPDIE ; CREATE UPDATE SUBFILE
    96  . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL
    97  . S C0CNH=C0CNH+1 ; INCREMENT HOT LIST TOTAL
    98  . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS
    99  . S C0CFDA(C0CBF,C0CIEN_",",2.1)=C0CNH ; UPDATE HOT LIST PROGRESS
    100  . S C0CNOW=$$NOW^XLFDT
    101  . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD
    102  . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS
    103  . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME
    104  . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME
    105  . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME
    106  . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START
    107  . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME
    108  . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; LAST RECORD PROCESSED
    109  . D UPDIE ;
    110  . I $D(^TMP("C0CBAT","STOP")) D  ; IF STOP SIGNAL DETECTED
    111  . . S C0CSTOP=1
    112  . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED
    113  . H 1 ; GIVE OTHERS A CHANCE
    114  F  S C0CBCUR=$O(@C0CBS@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="")  D  ; SUBS LIST
    115  . I $D(@C0CBH@(C0CBCUR)) Q  ; SKIP IF IN HOT LIST - ALREADY DONE
    116  . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-760^VITLIMIT:T-760")
    117  . I $G(C0CCHK) D  ; IF CHECKSUMS HAVE CHANGED
    118  . . D PUTRIM^C0CFM2(C0CBCUR)
    119  . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR
    120  . . K C0CFDA
    121  . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR
    122  . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y"
    123  . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR))
    124  . . D UPDIE ; CREATE UPDATE SUBFILE
    125  . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL
    126  . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS
    127  . S C0CNOW=$$NOW^XLFDT
    128  . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD
    129  . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS
    130  . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME
    131  . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME
    132  . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME
    133  . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START
    134  . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME
    135  . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ;
    136  . D UPDIE ;
    137  . I $D(^TMP("C0CBAT","STOP")) D  ; IF STOP SIGNAL DETECTED
    138  . . S C0CSTOP=1
    139  . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED
    140  . H 1 ; GIVE IT A BREAK
    141  I (C0CSTOP) S C0CDISP="KILLED"
    142  E  S C0CDISP="FINISHED"
    143  S C0CFDA(C0CBF,C0CIEN_",",6)=C0CDISP
    144  D UPDIE ; SET DISPOSITION FIELD
    145  K ^TMP("C0CBAT","RUNNING")
    146  Q
    147  ;
    148 BLDHOT(ZHB) ; BUILD HOT LIST AT GLOBAL ZHB, PASSED BY NAME
    149  ; SEARCHS FOR PATIENTS IN THE "AC" INDEX OF THE ORDER FILE
    150  N ZDFN
    151  S ZDFN=""
    152  F  S ZDFN=$O(^OR(100,"AC",ZDFN)) Q:ZDFN=""  D  ; ALL PATIENTS IN THE AC INDX
    153  . S ZZDFN=$P(ZDFN,";",1) ; FORMAT IS "N;DPT("
    154  . I '$D(@C0CBS@(ZZDFN)) Q  ; SKIP IF NOT IN SUBSCRIPTION LIST
    155  . S @ZHB@(ZZDFN)="" ;ADD PATIENT TO THE HOT LIST
    156  Q
    157  ;
    158 COUNT(ZB) ; EXTRINSIC THAT RETURNS THE NUMBER OF ARRAY ELEMENTS
    159  N ZI,ZN
    160  S ZN=0
    161  S ZI=""
    162  F  S ZI=$O(@ZB@(ZI)) Q:ZI=""  D  ;
    163  . S ZN=ZN+1
    164  Q ZN
    165  ;
    166 UPDIEVARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
    167  ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
    168  ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
    169  ;
    170  N ZCCRD,ZVARN,C0CFDA2
    171  S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
    172  S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    173  I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
    174  . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
    175  . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
    176  . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
    177  . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
    178  . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
    179  . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
    180  . I $D(ZERR) D  ; LAYGO ERROR
    181  . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
    182  . E  D  ;
    183  . . D CLEAN^DILF ; CLEAN UP
    184  . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    185  . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
    186  Q ZVARN
    187  ;
    188 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
    189  K ZERR
    190  D CLEAN^DILF
    191  D UPDATE^DIE("","C0CFDA","","ZERR")
    192  I $D(ZERR) D  ;
    193  . W "ERROR",!
    194  . ZWR ZERR
    195  . B
    196  K C0CFDA
    197  Q
    198  ;
    199 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
    200  ; TO SET TO VALUE C0CSV.
    201  ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
    202  ; C0CSN,C0CSV ARE PASSED BY VALUE
    203  ;
    204  N C0CSI,C0CSJ
    205  S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
    206  S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
    207  S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
    208  Q
    209 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
    210  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
    211  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    212  I '$D(ZTAB) S ZTAB="C0CA"
    213  N ZR
    214  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
    215  E  S ZR=""
    216  Q ZR
    217 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
    218  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
    219  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    220  I '$D(ZTAB) S ZTAB="C0CA"
    221  N ZR
    222  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
    223  E  S ZR=""
    224  Q ZR
    225  ;
    226 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
    227  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
    228  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    229  I '$D(ZTAB) S ZTAB="C0CA"
    230  N ZR
    231  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
    232  E  S ZR=""
    233  Q ZR
    234  ;
     1C0CBAT    ; CCDCCR/GPL - CCR Batch utilities; 4/21/09
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        W "This is the CCR Batch Utility Library ",!
     21        Q
     22        ;
     23STOP    ; STOP A CURRENTLY RUNNING BATCH JOB
     24        I '$D(^TMP("C0CBAT","RUNNING")) Q  ;
     25        W !,!,"HALTING CCR BATCH",!
     26        S ^TMP("C0CBAT","STOP")="" ; SIGNAL JOB TO TERMINATE
     27        H 10 ; WAIT TEN SECONDS FOR SIGNAL TO BE RECEIVED
     28        I '$D(^TMP("C0CBAT","STOP")) D  ; SIGNAL RECEIVED
     29        . W "CCR BATCH JOB TERMINATING",!
     30        E  D  ;
     31        . K ^TMP("C0CBAT","STOP") ; STOP SIGNALING
     32        . W !,"BATCH PROCESSING APPARENTLY NOT RUNNING",!
     33        Q
     34        ;
     35START   ; STARTS A TAKSMAN CCR BATCH JOB - FOR USE IN A MENU OPTION
     36        ;
     37        I $D(^TMP("C0CBAT","RUNNING")) D  Q  ; ONLY ONE ALLOWED AT A TIME
     38        . W !,"CCR BATCH ALREADY RUNNING",!
     39        . W !,"STOP FIRST WITH STOP^C0CBAT",!
     40        N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTIO
     41        S ZTRTN="EN^C0CBAT",ZTDESC="CCR Batch"
     42        S ZTDTH=$H ;
     43        ;S ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10))
     44        S ZTSAVE("C0C")="",ZTSAVE("C0C*")=""
     45        S ZTIO="NULL" ;
     46        W !,!,"CCR BATCH JOB STARTED",!
     47        D ^%ZTLOAD
     48        Q
     49        ;
     50EN      ; BATCH ENTRY POINT
     51        ; PROCESSES THE SUBSCRIPTION FILE, EXTRACTING CCR VARIABLES FOR EACH
     52        ; PATIENT WITH AN ACTIVE SUBSCRIPTION, AND IF CHECKSUMS INDICATE A CHANGE,
     53        ; GENERATES A NEW CCR FOR THE PATIENT
     54        ; UPDATES THE E2 CCR ELEMENTS FILE
     55        ;
     56        S C0CQT=1 ; QUIET MODE
     57        I $D(^TMP("C0CBAT","RUNNING")) Q  ; ONLY ONE AT A TIME
     58        S ^TMP("C0CBAT","RUNNING")="" ; RUNNING SIGNAL
     59        S C0CBDT=$$NOW^XLFDT ; DATE OF THIS RUN
     60        S C0CBF=177.301 ; FILE NUMBER OF C0C BATCH CONTROL FILE
     61        S C0CBFR=177.3013 ; FILE NUMBER OF UPDATE SUBFILE
     62        S C0CBB=$NA(^TMP("C0CBATCH",C0CBDT)) ; BATCH WORK AREA
     63        I $D(@C0CBB@(0)) D  ; ERROR SHOULDN'T EXIST
     64        . W "WORK AREA ERROR",!
     65        . B
     66        S @C0CBB@(0)="V22" ; VERSION USED TO CREATE THIS WORK AREA
     67        S C0CBH=$NA(@C0CBB@("HOTLIST")) ; BASE FOR HOT LIST
     68        S C0CBS=$NA(^C0CS("B")) ; SUBSCRIPTION LIST BASE
     69        ;I $D(^C0CB("B",C0CDT)) D  ; BATCH RECORD EXISTS
     70        ;. H 10 ; HANG 10 SECONDS
     71        ;. S C0CBDT=$$NOW^XLFDT ; NEW DATE FOR THIS RUN
     72        ;. I $D(^C0CB("B",C0CDT)) B ;DIDN'T WORK
     73        D BLDHOT(C0CBH) ; BUILD THE HOT LIST
     74        S C0CHN=$$COUNT(C0CBH) ;COUNT NUMBER IN HOT LIST
     75        S C0CSN=$$COUNT(C0CBS) ;COUNT NUMBER OF PATIENTS WITH SUBSCRIPTIONS
     76        S C0CFDA(C0CBF,"+1,",.01)=C0CBDT ; DATE KEY OF BATCH CONTROL
     77        S C0CFDA(C0CBF,"+1,",.02)=C0CBDT ; BATCH ID IS DATE IN STRING FORM
     78        S C0CFDA(C0CBF,"+1,",1)=C0CSN ; TOTAL SUBSCRIPTIONS
     79        S C0CFDA(C0CBF,"+1,",2)=C0CHN ; TOTAL HOT LIST
     80        D UPDIE ; CREATE THE BATCH RECORD
     81        S C0CIEN=$O(^C0CB("B",C0CBDT,""))
     82        S (C0CN,C0CNH)=0 ; COUNTERS FOR TOTAL AND HOT LIST
     83        S C0CBCUR="" ; CURRENT PATIENT
     84        S C0CSTOP=0 ; STOP FLAG FOR HALTING BATCH SET ^TMP("C0CBAT","STOP")=""
     85        ;F  S C0CBCUR=$O(@C0CBH@(C0CBCUR),-1) Q:C0CBCUR=""  D  ; HOT LIST LATEST FIRST
     86        F  S C0CBCUR=$O(@C0CBH@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="")  D  ; HOT LIST FIRST
     87        . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-900^VITLIMIT:T-900")
     88        . I $G(C0CCHK) D  ;
     89        . . D PUTRIM^C0CFM2(C0CBCUR)
     90        . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR
     91        . . K C0CFDA
     92        . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR
     93        . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y"
     94        . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR))
     95        . . D UPDIE ; CREATE UPDATE SUBFILE
     96        . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL
     97        . S C0CNH=C0CNH+1 ; INCREMENT HOT LIST TOTAL
     98        . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS
     99        . S C0CFDA(C0CBF,C0CIEN_",",2.1)=C0CNH ; UPDATE HOT LIST PROGRESS
     100        . S C0CNOW=$$NOW^XLFDT
     101        . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD
     102        . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS
     103        . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME
     104        . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME
     105        . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME
     106        . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START
     107        . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME
     108        . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; LAST RECORD PROCESSED
     109        . D UPDIE ;
     110        . I $D(^TMP("C0CBAT","STOP")) D  ; IF STOP SIGNAL DETECTED
     111        . . S C0CSTOP=1
     112        . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED
     113        . H 1 ; GIVE OTHERS A CHANCE
     114        F  S C0CBCUR=$O(@C0CBS@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="")  D  ; SUBS LIST
     115        . I $D(@C0CBH@(C0CBCUR)) Q  ; SKIP IF IN HOT LIST - ALREADY DONE
     116        . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-760^VITLIMIT:T-760")
     117        . I $G(C0CCHK) D  ; IF CHECKSUMS HAVE CHANGED
     118        . . D PUTRIM^C0CFM2(C0CBCUR)
     119        . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR
     120        . . K C0CFDA
     121        . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR
     122        . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y"
     123        . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR))
     124        . . D UPDIE ; CREATE UPDATE SUBFILE
     125        . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL
     126        . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS
     127        . S C0CNOW=$$NOW^XLFDT
     128        . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD
     129        . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS
     130        . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME
     131        . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME
     132        . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME
     133        . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START
     134        . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME
     135        . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ;
     136        . D UPDIE ;
     137        . I $D(^TMP("C0CBAT","STOP")) D  ; IF STOP SIGNAL DETECTED
     138        . . S C0CSTOP=1
     139        . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED
     140        . H 1 ; GIVE IT A BREAK
     141        I (C0CSTOP) S C0CDISP="KILLED"
     142        E  S C0CDISP="FINISHED"
     143        S C0CFDA(C0CBF,C0CIEN_",",6)=C0CDISP
     144        D UPDIE ; SET DISPOSITION FIELD
     145        K ^TMP("C0CBAT","RUNNING")
     146        Q
     147        ;
     148BLDHOT(ZHB)     ; BUILD HOT LIST AT GLOBAL ZHB, PASSED BY NAME
     149        ; SEARCHS FOR PATIENTS IN THE "AC" INDEX OF THE ORDER FILE
     150        N ZDFN
     151        S ZDFN=""
     152        F  S ZDFN=$O(^OR(100,"AC",ZDFN)) Q:ZDFN=""  D  ; ALL PATIENTS IN THE AC INDX
     153        . S ZZDFN=$P(ZDFN,";",1) ; FORMAT IS "N;DPT("
     154        . I '$D(@C0CBS@(ZZDFN)) Q  ; SKIP IF NOT IN SUBSCRIPTION LIST
     155        . S @ZHB@(ZZDFN)="" ;ADD PATIENT TO THE HOT LIST
     156        Q
     157        ;
     158COUNT(ZB)       ; EXTRINSIC THAT RETURNS THE NUMBER OF ARRAY ELEMENTS
     159        N ZI,ZN
     160        S ZN=0
     161        S ZI=""
     162        F  S ZI=$O(@ZB@(ZI)) Q:ZI=""  D  ;
     163        . S ZN=ZN+1
     164        Q ZN
     165        ;
     166UPDIEVARPTR(ZVAR,ZTYP)  ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
     167        ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
     168        ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
     169        ;
     170        N ZCCRD,ZVARN,C0CFDA2
     171        S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
     172        S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     173        I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
     174        . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
     175        . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
     176        . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
     177        . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
     178        . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
     179        . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
     180        . I $D(ZERR) D  ; LAYGO ERROR
     181        . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
     182        . E  D  ;
     183        . . D CLEAN^DILF ; CLEAN UP
     184        . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     185        . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
     186        Q ZVARN
     187        ;
     188UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
     189        K ZERR
     190        D CLEAN^DILF
     191        D UPDATE^DIE("","C0CFDA","","ZERR")
     192        I $D(ZERR) D  ;
     193        . W "ERROR",!
     194        . ZWR ZERR
     195        . B
     196        K C0CFDA
     197        Q
     198        ;
     199SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
     200        ; TO SET TO VALUE C0CSV.
     201        ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
     202        ; C0CSN,C0CSV ARE PASSED BY VALUE
     203        ;
     204        N C0CSI,C0CSJ
     205        S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
     206        S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
     207        S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
     208        Q
     209ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
     210        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
     211        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     212        I '$D(ZTAB) S ZTAB="C0CA"
     213        N ZR
     214        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
     215        E  S ZR=""
     216        Q ZR
     217ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
     218        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
     219        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     220        I '$D(ZTAB) S ZTAB="C0CA"
     221        N ZR
     222        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
     223        E  S ZR=""
     224        Q ZR
     225        ;
     226ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
     227        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
     228        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     229        I '$D(ZTAB) S ZTAB="C0CA"
     230        N ZR
     231        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
     232        E  S ZR=""
     233        Q ZR
     234        ;

  • ccr/branches/ohum/p/C0CCCD.m

    r1342 r1428  
    1 C0CCCD   ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  ; EXPORT A CCR
    22  ;
    23 EXPORT   ; EXPORT ENTRY POINT FOR CCR
    24        ; Select a patient.
    25        S DIC=2,DIC(0)="AEMQ" D ^DIC
    26        I Y<1 Q  ; EXIT
    27        S DFN=$P(Y,U,1) ; SET THE PATIENT
    28        D XPAT(DFN,"","") ; EXPORT TO A FILE
    29        Q
    30        ;
    31 XPAT(DFN,DIR,FN) ; EXPORT ONE PATIENT TO A FILE
    32        ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR")
    33        ; FN IS FILE NAME, DEFAULTS IF NULL
    34        ; N CCDGLO
    35        D CCDRPC(.CCDGLO,DFN,"CCD","","","")
    36        S OARY=$NA(^TMP("C0CCCR",$J,DFN,"CCD",1))
    37        S ONAM=FN
    38        I FN="" S ONAM="PAT_"_DFN_"_CCD_V1.xml"
    39        S ODIRGLB=$NA(^TMP("C0CCCR","ODIR"))
    40        I '$D(@ODIRGLB) D  ; IF NOT ODIR HAS BEEN SET
    41        . S @ODIRGLB="/home/glilly/CCROUT"
    42        . ;S @ODIRGLB="/home/cedwards/"
    43        . ;S @ODIRGLB="/opt/wv/p/"
    44        S ODIR=DIR
    45        I DIR="" S ODIR=@ODIRGLB
    46        N ZY
    47        S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR)
    48        W $P(ZY,U,2)
    49        Q
    50        ;
    51 CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY)  ;RPC ENTRY POINT FOR CCR OUTPUT
    52     ; CCRGRTN IS RETURN ARRAY PASSED BY NAME
    53     ; DFN IS PATIENT IEN
    54     ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART
    55     ;   OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC
    56     ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL
    57     ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME
    58     ; - NULL MEANS NOW
    59     ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND
    60     ;    "TO" VARIABLES
    61     ;    IF NULL WILL DEFAULT TO "FROM" ORGANIZATION AND "TO" DFN
    62     I '$D(DEBUG) S DEBUG=0
    63     N CCD S CCD=0 ; FLAG FOR PROCESSING A CCD
    64     I CCRPART="CCD" S CCD=1 ; WE ARE PROCESSING A CCD
    65     S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE
    66     I CCD S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCD")) ; GLOBAL FOR THE CCD
    67     E  S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR
    68     S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS
    69     ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC
    70     S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL
    71     I CCD D LOAD^C0CCCD1(TGLOBAL)  ; LOAD THE CCR TEMPLATE
    72     E  D LOAD^C0CCCR0(TGLOBAL)  ; LOAD THE CCR TEMPLATE
    73     D CP^C0CXPATH(TGLOBAL,CCDGLO) ; COPY THE TEMPLATE TO CCR GLOBAL
    74     N CAPSAVE,CAPSAVE2 ; FOR HOLDING THE CCD ROOT LINES
    75     S CAPSAVE=@TGLOBAL@(3) ; SAVE THE CCD ROOT
    76     S CAPSAVE2=@TGLOBAL@(@TGLOBAL@(0)) ; SAVE LAST LINE OF CCD
    77     S @CCDGLO@(3)="<ContinuityOfCareRecord>" ; CAP WITH CCR ROOT
    78     S @TGLOBAL@(3)=@CCDGLO@(3) ; CAP THE TEMPLATE TOO
    79     S @CCDGLO@(@CCDGLO@(0))="</ContinuityOfCareRecord>" ; FINISH CAP
    80     S @TGLOBAL@(@TGLOBAL@(0))="</ContinuityOfCareRecord>" ; FINISH CAP TEMP
    81     ;
    82     ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL
    83     ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES
    84     D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Body")
    85     D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Actors")
    86     I 'CCD D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Signatures")
    87     I DEBUG F I=1:1:@CCDGLO@(0) W @CCDGLO@(I),!
    88     ;
    89     I 'CCD D HDRMAP(CCDGLO,DFN,HDRARY) ; MAP HEADER VARIABLES
    90     ; MAPPING THE PATIENT PORTION OF THE CDA HEADER
    91     S ZZX="//ContinuityOfCareRecord/recordTarget/patientRole/patient"
    92     D QUERY^C0CXPATH(CCDGLO,ZZX,"ACTT1")
    93     D PATIENT^C0CACTOR("ACTT1",DFN,"ACTORPATIENT_"_DFN,"ACTT2") ; MAP PATIENT
    94     I DEBUG D PARY^C0CXPATH("ACTT2")
    95     D REPLACE^C0CXPATH(CCDGLO,"ACTT2",ZZX)
    96     I DEBUG D PARY^C0CXPATH(CCDGLO)
    97     K ACTT1 K ACCT2
    98     ; MAPPING THE PROVIDER ORGANIZATION,AUTHOR,INFORMANT,CUSTODIAN CDA HEADER
    99     ; FOR NOW, THEY ARE ALL THE SAME AND RESOLVE TO ORGANIZATION
    100     D ORG^C0CACTOR(CCDGLO,DFN,"ACTORPATIENTORGANIZATION","ACTT2") ; MAP ORG
    101     D CP^C0CXPATH("ACTT2",CCDGLO)
    102     ;
    103     K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT
    104     S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS
    105     D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS
    106     N I,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD
    107     F I=1:1:@CCRXTAB@(0)  D  ; PROCESS THE CCR BODY SECTIONS
    108     . S XI=@CCRXTAB@(I) ; CALL COPONENTS TO PARSE
    109     . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL
    110     . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL
    111     . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE
    112     . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS
    113     . S IXML="INXML"
    114     . I CCD D SHAVE(IXML) ; REMOVE ALL BUT REPEATING PARTS OF TEMPLATE SECTION
    115     . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES
    116     . ; W OXML,!
    117     . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL
    118     . W "RUNNING ",CALL,!
    119     . X CALL
    120     . I @OXML@(0)'=0 D  ; THERE IS A RESULT
    121     . . I CCD D QUERY^C0CXPATH(TGLOBAL,XPATH,"ITMP") ; XML TO UNSHAVE WITH
    122     . . I CCD D UNSHAVE("ITMP",OXML)
    123     . . I CCD D UNMARK^C0CXPATH(OXML) ; REMOVE THE CCR MARKUP FROM SECTION
    124     . ; NOW INSERT THE RESULTS IN THE CCR BUFFER
    125     . D INSERT^C0CXPATH(CCDGLO,OXML,"//ContinuityOfCareRecord/Body")
    126     . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),!
    127     ; NEED TO ADD BACK IN ACTOR PROCESSING AFTER WE FIGURE OUT LINKAGE
    128     ; D ACTLST^C0CCCR(CCDGLO,ACTGLO) ; GEN THE ACTOR LIST
    129     ; D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT")
    130     ; D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2")
    131     ; D INSINNER^C0CXPATH(CCDGLO,"ACTT2","//ContinuityOfCareRecord/Actors")
    132     N I,J,DONE S DONE=0
    133     F I=0:0 D  Q:DONE  ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE
    134     . S J=$$TRIM^C0CXPATH(CCDGLO) ; DELETE EMPTY ELEMENTS
    135     . W "TRIMMED",J,!
    136     . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE
    137     I CCD D  ; TURN THE BODY INTO A CCD COMPONENT
    138     . N I
    139     . F I=1:1:@CCDGLO@(0) D  ; SEARCH THROUGH THE ENTIRE ARRAY
    140     . . I @CCDGLO@(I)["<Body>" D  ; REPLACE BODY MARKUP
    141     . . . S @CCDGLO@(I)="<component><structuredBody>" ; WITH CCD EQ
    142     . . I @CCDGLO@(I)["</Body>" D  ; REPLACE BODY MARKUP
    143     . . . S @CCDGLO@(I)="</structuredBody></component>"
    144     S @CCDGLO@(3)=CAPSAVE ; UNCAP - TURN IT BACK INTO A CCD
    145     S @CCDGLO@(@CCDGLO@(0))=CAPSAVE2 ; UNCAP LAST LINE
    146     Q
    147     ;
    148 INITSTPS(TAB)  ; INITIALIZE CCR PROCESSING STEPS
    149     ; TAB IS PASSED BY NAME
    150     W "TAB= ",TAB,!
    151     ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS
    152     D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")")
    153     ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")")
    154     I 'CCD D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")")
    155     Q
    156     ;
    157 SHAVE(SHXML) ; REMOVES THE 2-6 AND N-1 AND N-2 LINES FROM A COMPONENT
    158     ; NEEDED TO EXPOSE THE REPEATING PARTS FOR GENERATION
    159     N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST
    160     W SHXML,!
    161     W @SHXML@(1),!
    162     D QUEUE^C0CXPATH("SHBLD",SHXML,1,1) ; THE FIRST LINE IS NEEDED
    163     D QUEUE^C0CXPATH("SHBLD",SHXML,7,@SHXML@(0)-3) ; REPEATING PART
    164     D QUEUE^C0CXPATH("SHBLD",SHXML,@SHXML@(0),@SHXML@(0)) ; LAST LINE
    165     D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST
    166     D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION
    167     D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY
    168     Q
    169     ;
    170 UNSHAVE(ORIGXML,SHXML) ; REPLACES THE 2-6 AND N-1 AND N-2 LINES FROM TEMPLATE
    171     ; NEEDED TO RESTORM FIXED TOP AND BOTTOM OF THE COMPONENT XML
    172     N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST
    173     W SHXML,!
    174     W @SHXML@(1),!
    175     D QUEUE^C0CXPATH("SHBLD",ORIGXML,1,6) ; FIRST 6 LINES OF TEMPLATE
    176     D QUEUE^C0CXPATH("SHBLD",SHXML,2,@SHXML@(0)-1) ; INS ALL BUT FIRST/LAST
    177     D QUEUE^C0CXPATH("SHBLD",ORIGXML,@ORIGXML@(0)-2,@ORIGXML@(0)) ; FROM TEMP
    178     D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST
    179     D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION
    180     D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY
    181     Q
    182     ;
    183 HDRMAP(CXML,DFN,IHDR)   ; MAP HEADER VARIABLES: FROM, TO ECT
    184     N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER"))
    185     ; K @VMAP
    186     S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT")
    187     I IHDR="" D  ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS
    188     . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN
    189     . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ???
    190     . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM
    191     . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN  ; FOR TEST PURPOSES
    192     . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR"  ; FOR TEST PURPOSES
    193     . S @VMAP@("ACTORTOTEXT")="Patient"  ; FOR TEST PURPOSES
    194     . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT
    195     I IHDR'="" D  ; HEADER VALUES ARE PROVIDED
    196     . D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY
    197     N CTMP
    198     D MAP^C0CXPATH(CXML,VMAP,"CTMP")
    199     D CP^C0CXPATH("CTMP",CXML)
    200     Q
    201     ;
    202 ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML
    203     ; AXML AND ACTRTN ARE PASSED BY NAME
    204     ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2
    205     ; P1= OBJECTID - ACTORPATIENT_2
    206     ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE
    207     ;OR INSTITUTION
    208     ;  OR PERSON(IN PATIENT FILE IE NOK)
    209     ; P3= IEN RECORD NUMBER FOR ACTOR - 2
    210     N I,J,K,L
    211     K @ACTRTN ; CLEAR RETURN ARRAY
    212     F I=1:1:@AXML@(0) D  ; SCAN ALL LINES
    213     . I @AXML@(I)?.E1"<ActorID>".E D  ; THERE IS AN ACTOR THIS LINE
    214     . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1)
    215     . . W "<ActorID>=>",J,!
    216     . . I J'="" S K(J)="" ; HASHING ACTOR
    217     . . ;  TO GET RID OF DUPLICATES
    218     S I="" ; GOING TO $O THROUGH THE HASH
    219     F J=0:0 D  Q:$O(K(I))=""  ;
    220     . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS
    221     . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID
    222     . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE
    223     . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR
    224     . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY
    225     Q
    226     ;
    227 TEST ; RUN ALL THE TEST CASES
    228   D TESTALL^C0CUNIT("C0CCCR")
    229   Q
    230   ;
    231 ZTEST(WHICH)  ; RUN ONE SET OF TESTS
    232   N ZTMP
    233   D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
    234   D ZTEST^C0CUNIT(.ZTMP,WHICH)
    235   Q
    236   ;
    237 TLIST  ; LIST THE TESTS
    238   N ZTMP
    239   D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
    240   D TLIST^C0CUNIT(.ZTMP)
    241   Q
    242   ;
    243  ;;><TEST>
    244  ;;><PROBLEMS>
    245  ;;>>>K C0C S C0C=""
    246  ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","","","")
    247  ;;>>?@C0C@(@C0C@(0))["</Problems>"
    248  ;;><VITALS>
    249  ;;>>>K C0C S C0C=""
    250  ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","","","")
    251  ;;>>?@C0C@(@C0C@(0))["</VitalSigns>"
    252  ;;><CCR>
    253  ;;>>>K C0C S C0C=""
    254  ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","")
    255  ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>"
    256  ;;><ACTLST>
    257  ;;>>>K C0C S C0C=""
    258  ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","")
    259  ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST")
    260  ;;><ACTORS>
    261  ;;>>>D ZTEST^C0CCCR("ACTLST")
    262  ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2")
    263  ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3")
    264  ;;>>?G3(G3(0))["</Actors>"
    265  ;;><TRIM>
    266  ;;>>>D ZTEST^C0CCCR("CCR")
    267  ;;>>>W $$TRIM^C0CXPATH(CCDGLO)
    268  ;;><CCD>
    269  ;;>>>K C0C S C0C=""
    270  ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCD","","","")
    271  ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>"
    272  ;;></TEST>
     1C0CCCD    ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        ; EXPORT A CCR
     22        ;
     23EXPORT    ; EXPORT ENTRY POINT FOR CCR
     24              ; Select a patient.
     25              S DIC=2,DIC(0)="AEMQ" D ^DIC
     26              I Y<1 Q  ; EXIT
     27              S DFN=$P(Y,U,1) ; SET THE PATIENT
     28              D XPAT(DFN,"","") ; EXPORT TO A FILE
     29              Q
     30              ;
     31XPAT(DFN,DIR,FN)        ; EXPORT ONE PATIENT TO A FILE
     32              ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR")
     33              ; FN IS FILE NAME, DEFAULTS IF NULL
     34              ; N CCDGLO
     35              D CCDRPC(.CCDGLO,DFN,"CCD","","","")
     36              S OARY=$NA(^TMP("C0CCCR",$J,DFN,"CCD",1))
     37              S ONAM=FN
     38              I FN="" S ONAM="PAT_"_DFN_"_CCD_V1.xml"
     39              S ODIRGLB=$NA(^TMP("C0CCCR","ODIR"))
     40              I '$D(@ODIRGLB) D  ; IF NOT ODIR HAS BEEN SET
     41              . S @ODIRGLB="/home/glilly/CCROUT"
     42              . ;S @ODIRGLB="/home/cedwards/"
     43              . ;S @ODIRGLB="/opt/wv/p/"
     44              S ODIR=DIR
     45              I DIR="" S ODIR=@ODIRGLB
     46              N ZY
     47              S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR)
     48              W $P(ZY,U,2)
     49              Q
     50              ;
     51CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY)  ;RPC ENTRY POINT FOR CCR OUTPUT
     52           ; CCRGRTN IS RETURN ARRAY PASSED BY NAME
     53           ; DFN IS PATIENT IEN
     54           ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART
     55           ;   OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC
     56           ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL
     57           ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME
     58           ; - NULL MEANS NOW
     59           ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND
     60           ;    "TO" VARIABLES
     61           ;    IF NULL WILL DEFAULT TO "FROM" ORGANIZATION AND "TO" DFN
     62           I '$D(DEBUG) S DEBUG=0
     63           N CCD S CCD=0 ; FLAG FOR PROCESSING A CCD
     64           I CCRPART="CCD" S CCD=1 ; WE ARE PROCESSING A CCD
     65           S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE
     66           I CCD S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCD")) ; GLOBAL FOR THE CCD
     67           E  S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR
     68           S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS
     69           ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC
     70           S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL
     71           I CCD D LOAD^C0CCCD1(TGLOBAL)  ; LOAD THE CCR TEMPLATE
     72           E  D LOAD^C0CCCR0(TGLOBAL)  ; LOAD THE CCR TEMPLATE
     73           D CP^C0CXPATH(TGLOBAL,CCDGLO) ; COPY THE TEMPLATE TO CCR GLOBAL
     74           N CAPSAVE,CAPSAVE2 ; FOR HOLDING THE CCD ROOT LINES
     75           S CAPSAVE=@TGLOBAL@(3) ; SAVE THE CCD ROOT
     76           S CAPSAVE2=@TGLOBAL@(@TGLOBAL@(0)) ; SAVE LAST LINE OF CCD
     77           S @CCDGLO@(3)="<ContinuityOfCareRecord>" ; CAP WITH CCR ROOT
     78           S @TGLOBAL@(3)=@CCDGLO@(3) ; CAP THE TEMPLATE TOO
     79           S @CCDGLO@(@CCDGLO@(0))="</ContinuityOfCareRecord>" ; FINISH CAP
     80           S @TGLOBAL@(@TGLOBAL@(0))="</ContinuityOfCareRecord>" ; FINISH CAP TEMP
     81           ;
     82           ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL
     83           ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES
     84           D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Body")
     85           D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Actors")
     86           I 'CCD D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Signatures")
     87           I DEBUG F I=1:1:@CCDGLO@(0) W @CCDGLO@(I),!
     88           ;
     89           I 'CCD D HDRMAP(CCDGLO,DFN,HDRARY) ; MAP HEADER VARIABLES
     90           ; MAPPING THE PATIENT PORTION OF THE CDA HEADER
     91           S ZZX="//ContinuityOfCareRecord/recordTarget/patientRole/patient"
     92           D QUERY^C0CXPATH(CCDGLO,ZZX,"ACTT1")
     93           D PATIENT^C0CACTOR("ACTT1",DFN,"ACTORPATIENT_"_DFN,"ACTT2") ; MAP PATIENT
     94           I DEBUG D PARY^C0CXPATH("ACTT2")
     95           D REPLACE^C0CXPATH(CCDGLO,"ACTT2",ZZX)
     96           I DEBUG D PARY^C0CXPATH(CCDGLO)
     97           K ACTT1 K ACCT2
     98           ; MAPPING THE PROVIDER ORGANIZATION,AUTHOR,INFORMANT,CUSTODIAN CDA HEADER
     99           ; FOR NOW, THEY ARE ALL THE SAME AND RESOLVE TO ORGANIZATION
     100           D ORG^C0CACTOR(CCDGLO,DFN,"ACTORPATIENTORGANIZATION","ACTT2") ; MAP ORG
     101           D CP^C0CXPATH("ACTT2",CCDGLO)
     102           ;
     103           K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT
     104           S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS
     105           D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS
     106           N I,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD
     107           F I=1:1:@CCRXTAB@(0)  D  ; PROCESS THE CCR BODY SECTIONS
     108           . S XI=@CCRXTAB@(I) ; CALL COPONENTS TO PARSE
     109           . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL
     110           . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL
     111           . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE
     112           . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS
     113           . S IXML="INXML"
     114           . I CCD D SHAVE(IXML) ; REMOVE ALL BUT REPEATING PARTS OF TEMPLATE SECTION
     115           . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES
     116           . ; W OXML,!
     117           . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL
     118           . W "RUNNING ",CALL,!
     119           . X CALL
     120           . I @OXML@(0)'=0 D  ; THERE IS A RESULT
     121           . . I CCD D QUERY^C0CXPATH(TGLOBAL,XPATH,"ITMP") ; XML TO UNSHAVE WITH
     122           . . I CCD D UNSHAVE("ITMP",OXML)
     123           . . I CCD D UNMARK^C0CXPATH(OXML) ; REMOVE THE CCR MARKUP FROM SECTION
     124           . ; NOW INSERT THE RESULTS IN THE CCR BUFFER
     125           . D INSERT^C0CXPATH(CCDGLO,OXML,"//ContinuityOfCareRecord/Body")
     126           . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),!
     127           ; NEED TO ADD BACK IN ACTOR PROCESSING AFTER WE FIGURE OUT LINKAGE
     128           ; D ACTLST^C0CCCR(CCDGLO,ACTGLO) ; GEN THE ACTOR LIST
     129           ; D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT")
     130           ; D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2")
     131           ; D INSINNER^C0CXPATH(CCDGLO,"ACTT2","//ContinuityOfCareRecord/Actors")
     132           N I,J,DONE S DONE=0
     133           F I=0:0 D  Q:DONE  ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE
     134           . S J=$$TRIM^C0CXPATH(CCDGLO) ; DELETE EMPTY ELEMENTS
     135           . W "TRIMMED",J,!
     136           . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE
     137           I CCD D  ; TURN THE BODY INTO A CCD COMPONENT
     138           . N I
     139           . F I=1:1:@CCDGLO@(0) D  ; SEARCH THROUGH THE ENTIRE ARRAY
     140           . . I @CCDGLO@(I)["<Body>" D  ; REPLACE BODY MARKUP
     141           . . . S @CCDGLO@(I)="<component><structuredBody>" ; WITH CCD EQ
     142           . . I @CCDGLO@(I)["</Body>" D  ; REPLACE BODY MARKUP
     143           . . . S @CCDGLO@(I)="</structuredBody></component>"
     144           S @CCDGLO@(3)=CAPSAVE ; UNCAP - TURN IT BACK INTO A CCD
     145           S @CCDGLO@(@CCDGLO@(0))=CAPSAVE2 ; UNCAP LAST LINE
     146           Q
     147           ;
     148INITSTPS(TAB)    ; INITIALIZE CCR PROCESSING STEPS
     149           ; TAB IS PASSED BY NAME
     150           W "TAB= ",TAB,!
     151           ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS
     152           D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")")
     153           ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")")
     154           I 'CCD D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")")
     155           Q
     156           ;
     157SHAVE(SHXML)    ; REMOVES THE 2-6 AND N-1 AND N-2 LINES FROM A COMPONENT
     158           ; NEEDED TO EXPOSE THE REPEATING PARTS FOR GENERATION
     159           N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST
     160           W SHXML,!
     161           W @SHXML@(1),!
     162           D QUEUE^C0CXPATH("SHBLD",SHXML,1,1) ; THE FIRST LINE IS NEEDED
     163           D QUEUE^C0CXPATH("SHBLD",SHXML,7,@SHXML@(0)-3) ; REPEATING PART
     164           D QUEUE^C0CXPATH("SHBLD",SHXML,@SHXML@(0),@SHXML@(0)) ; LAST LINE
     165           D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST
     166           D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION
     167           D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY
     168           Q
     169           ;
     170UNSHAVE(ORIGXML,SHXML)  ; REPLACES THE 2-6 AND N-1 AND N-2 LINES FROM TEMPLATE
     171           ; NEEDED TO RESTORM FIXED TOP AND BOTTOM OF THE COMPONENT XML
     172           N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST
     173           W SHXML,!
     174           W @SHXML@(1),!
     175           D QUEUE^C0CXPATH("SHBLD",ORIGXML,1,6) ; FIRST 6 LINES OF TEMPLATE
     176           D QUEUE^C0CXPATH("SHBLD",SHXML,2,@SHXML@(0)-1) ; INS ALL BUT FIRST/LAST
     177           D QUEUE^C0CXPATH("SHBLD",ORIGXML,@ORIGXML@(0)-2,@ORIGXML@(0)) ; FROM TEMP
     178           D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST
     179           D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION
     180           D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY
     181           Q
     182           ;
     183HDRMAP(CXML,DFN,IHDR)     ; MAP HEADER VARIABLES: FROM, TO ECT
     184           N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER"))
     185           ; K @VMAP
     186           S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT")
     187           I IHDR="" D  ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS
     188           . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN
     189           . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ???
     190           . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM
     191           . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN  ; FOR TEST PURPOSES
     192           . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR"  ; FOR TEST PURPOSES
     193           . S @VMAP@("ACTORTOTEXT")="Patient"  ; FOR TEST PURPOSES
     194           . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT
     195           I IHDR'="" D  ; HEADER VALUES ARE PROVIDED
     196           . D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY
     197           N CTMP
     198           D MAP^C0CXPATH(CXML,VMAP,"CTMP")
     199           D CP^C0CXPATH("CTMP",CXML)
     200           Q
     201           ;
     202ACTLST(AXML,ACTRTN)     ; RETURN THE ACTOR LIST FOR THE XML IN AXML
     203           ; AXML AND ACTRTN ARE PASSED BY NAME
     204           ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2
     205           ; P1= OBJECTID - ACTORPATIENT_2
     206           ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE
     207           ;OR INSTITUTION
     208           ;  OR PERSON(IN PATIENT FILE IE NOK)
     209           ; P3= IEN RECORD NUMBER FOR ACTOR - 2
     210           N I,J,K,L
     211           K @ACTRTN ; CLEAR RETURN ARRAY
     212           F I=1:1:@AXML@(0) D  ; SCAN ALL LINES
     213           . I @AXML@(I)?.E1"<ActorID>".E D  ; THERE IS AN ACTOR THIS LINE
     214           . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1)
     215           . . W "<ActorID>=>",J,!
     216           . . I J'="" S K(J)="" ; HASHING ACTOR
     217           . . ;  TO GET RID OF DUPLICATES
     218           S I="" ; GOING TO $O THROUGH THE HASH
     219           F J=0:0 D  Q:$O(K(I))=""  ;
     220           . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS
     221           . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID
     222           . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE
     223           . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR
     224           . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY
     225           Q
     226           ;
     227TEST    ; RUN ALL THE TEST CASES
     228        D TESTALL^C0CUNIT("C0CCCR")
     229        Q
     230        ;
     231ZTEST(WHICH)    ; RUN ONE SET OF TESTS
     232        N ZTMP
     233        D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
     234        D ZTEST^C0CUNIT(.ZTMP,WHICH)
     235        Q
     236        ;
     237TLIST    ; LIST THE TESTS
     238        N ZTMP
     239        D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
     240        D TLIST^C0CUNIT(.ZTMP)
     241        Q
     242        ;
     243        ;;><TEST>
     244        ;;><PROBLEMS>
     245        ;;>>>K C0C S C0C=""
     246        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","","","")
     247        ;;>>?@C0C@(@C0C@(0))["</Problems>"
     248        ;;><VITALS>
     249        ;;>>>K C0C S C0C=""
     250        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","","","")
     251        ;;>>?@C0C@(@C0C@(0))["</VitalSigns>"
     252        ;;><CCR>
     253        ;;>>>K C0C S C0C=""
     254        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","")
     255        ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>"
     256        ;;><ACTLST>
     257        ;;>>>K C0C S C0C=""
     258        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","")
     259        ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST")
     260        ;;><ACTORS>
     261        ;;>>>D ZTEST^C0CCCR("ACTLST")
     262        ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2")
     263        ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3")
     264        ;;>>?G3(G3(0))["</Actors>"
     265        ;;><TRIM>
     266        ;;>>>D ZTEST^C0CCCR("CCR")
     267        ;;>>>W $$TRIM^C0CXPATH(CCDGLO)
     268        ;;><CCD>
     269        ;;>>>K C0C S C0C=""
     270        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCD","","","")
     271        ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>"
     272        ;;></TEST>

  • ccr/branches/ohum/p/C0CCCD1.m

    r1342 r1428  
    1 C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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           W "This is a CCD TEMPLATE with processing routines",!
    22           W !
    23           Q
    24           ;
    25 ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array
    26           ; ZARY IS PASSED BY NAME
    27           ; BAT is a string identifying the section
    28           ; LINE is a test which will evaluate to true or false
    29           ; I '$G(@ZARY) D  ; IF ZARY DOES NOT EXIST '
    30           ; . S @ZARY@(0)=0 ; initially there are no elements
    31           ; . W "GOT HERE LOADING "_LINE,!
    32           N CNT ; count of array elements
    33           S CNT=@ZARY@(0) ; contains array count
    34           S CNT=CNT+1 ; increment count
    35           S @ZARY@(CNT)=LINE ; put the line in the array
    36           ; S @ZARY@(BAT,CNT)="" ; index the test by battery
    37           S @ZARY@(0)=CNT ; update the array counter
    38           Q
    39           ;
    40 ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference
    41           ; ZARY IS PASSED BY NAME
    42           ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
    43           ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
    44           K @ZARY S @ZARY=""
    45           S @ZARY@(0)=0 ; initialize array count
    46           N LINE,LABEL,BODY
    47           N INTEST S INTEST=0 ; switch for in the TEMPLATE section
    48           N SECTION S SECTION="[anonymous]" ; NO section LABEL
    49           ;
    50           N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
    51           . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section
    52           . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section
    53           . I INTEST  D  ; within the section
    54           . . I LINE?." "1";><".E  D  ; sub-section name found
    55           . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name
    56           . . I LINE?." "1";;".E  D  ; line found
    57           . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array
    58           Q
    59           ;
    60 LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME
    61           D ZLOAD(ARY,"C0CCCD1")
    62           ; ZWR @ARY
    63           Q
    64           ;
    65 TRMCCD    ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD
    66           Q
    67 MARKUP ;<MARKUP>
    68  ;;<Body>
    69  ;;<Problems>
    70  ;;</Problems>
    71  ;;<FamilyHistory>
    72  ;;</FamilyHistory>
    73  ;;<SocialHistory>
    74  ;;</SocialHistory>
    75  ;;<Alerts>
    76  ;;</Alerts>
    77  ;;<Medications>
    78  ;;</Medications>
    79  ;;<VitalSigns>
    80  ;;</VitalSigns>
    81  ;;<Results>
    82  ;;</Results>
    83  ;;</Body>
    84  ;;</ContinuityOfCareRecord>
    85  ;</MARKUP>
    86  ;;<ClinicalDocument xmlns="urn:hl7-org:v3" xmlns:voc="urn:hl7-org:v3/voc" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="urn:hl7-org:v3 CDA.xsd">
    87  ;;</ClinicalDocument>
    88  Q
    89  ;
    90  ;<TEMPLATE>
    91  ;;<?xml version="1.0"?>
    92  ;;<?xml-stylesheet type="text/xsl" href="CCD.xsl"?>
    93  ;;<ClinicalDocument xmlns="urn:hl7-org:v3" xmlns:voc="urn:hl7-org:v3/voc" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="urn:hl7-org:v3 CDA.xsd">
    94  ;;<typeId root="2.16.840.1.113883.1.3" extension="POCD_HD000040"/>
    95  ;;<templateId root="2.16.840.1.113883.10.20.1"/>
    96  ;;<id root="db734647-fc99-424c-a864-7e3cda82e703"/>
    97  ;;<code code="34133-9" codeSystem="2.16.840.1.113883.6.1" displayName="Summarization of episode note"/>
    98  ;;<title>Continuity of Care Document</title>
    99  ;;<effectiveTime value="20000407130000+0500"/>
    100  ;;<confidentialityCode code="N" codeSystem="2.16.840.1.113883.5.25"/>
    101  ;;<languageCode code="en-US"/>
    102  ;;<recordTarget>
    103  ;;<patientRole>
    104  ;;<id extension="@@ACTORIEN@@" root="2.16.840.1.113883.19.5"/>
    105  ;;<patient>
    106  ;;<name>
    107  ;;<given>@@ACTORGIVENNAME@@</given>
    108  ;;<family>@@ACTORFAMILYNAME@@</family>
    109  ;;<suffix>@@ACTORSUFFIXNAME@@</suffix>
    110  ;;</name>
    111  ;;<administrativeGenderCode code="@@ACTORGENDER@@" codeSystem="2.16.840.1.113883.5.1"/>
    112  ;;<birthTime value="@@ACTORDATEOFBIRTH@@"/>
    113  ;;</patient>
    114  ;;<providerOrganization>
    115  ;;<id root="2.16.840.1.113883.19.5"/>
    116  ;;<name>@@ORGANIZATIONNAME@@</name>
    117  ;;</providerOrganization>
    118  ;;</patientRole>
    119  ;;</recordTarget>
    120  ;;<author>
    121  ;;<time value="20000407130000+0500"/>
    122  ;;<assignedAuthor>
    123  ;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/>
    124  ;;<assignedPerson>
    125  ;;<name>
    126  ;;<prefix>@@ACTORNAMEPREFIX@@</prefix>
    127  ;;<given>@@ACTORGIVENNAME@@</given>
    128  ;;<family>@@ACTORFAMILYNAME@@</family>
    129  ;;</name>
    130  ;;</assignedPerson>
    131  ;;<representedOrganization>
    132  ;;<id root="2.16.840.1.113883.19.5"/>
    133  ;;<name>@@ORGANIZATIONNAME@@</name>
    134  ;;</representedOrganization>
    135  ;;</assignedAuthor>
    136  ;;</author>
    137  ;;<informant>
    138  ;;<assignedEntity>
    139  ;;<id nullFlavor="NI"/>
    140  ;;<representedOrganization>
    141  ;;<id root="2.16.840.1.113883.19.5"/>
    142  ;;<name>@@ORGANIZATIONNAME@@</name>
    143  ;;</representedOrganization>
    144  ;;</assignedEntity>
    145  ;;</informant>
    146  ;;<custodian>
    147  ;;<assignedCustodian>
    148  ;;<representedCustodianOrganization>
    149  ;;<id root="2.16.840.1.113883.19.5"/>
    150  ;;<name>@@ORGANIZATIONNAME@@</name>
    151  ;;</representedCustodianOrganization>
    152  ;;</assignedCustodian>
    153  ;;</custodian>
    154  ;;<legalAuthenticator>
    155  ;;<time value="20000407130000+0500"/>
    156  ;;<signatureCode code="S"/>
    157  ;;<assignedEntity>
    158  ;;<id nullFlavor="NI"/>
    159  ;;<representedOrganization>
    160  ;;<id root="2.16.840.1.113883.19.5"/>
    161  ;;<name>@@ORGANIZATIONNAME@@</name>
    162  ;;</representedOrganization>
    163  ;;</assignedEntity>
    164  ;;</legalAuthenticator>
    165  ;;<Actors>
    166  ;;<ACTOR-NOK>
    167  ;;<participant typeCode="IND">
    168  ;;<associatedEntity classCode="NOK">
    169  ;;<id root="4ac71514-6a10-4164-9715-f8d96af48e6d"/>
    170  ;;<code code="65656005" codeSystem="2.16.840.1.113883.6.96" displayName="Biiological mother"/>
    171  ;;<telecom value="tel:(999)555-1212"/>
    172  ;;<associatedPerson>
    173  ;;<name>
    174  ;;<given>Henrietta</given>
    175  ;;<family>Levin</family>
    176  ;;</name>
    177  ;;</associatedPerson>
    178  ;;</associatedEntity>
    179  ;;</participant>
    180  ;;</ACTOR-NOK>
    181  ;;</Actors>
    182  ;;<documentationOf>
    183  ;;<serviceEvent classCode="PCPR">
    184  ;;<effectiveTime>
    185  ;;<high value="@@DATETIME@@"/>
    186  ;;</effectiveTime>
    187  ;;<performer typeCode="PRF">
    188  ;;<functionCode code="PCP" codeSystem="2.16.840.1.113883.5.88"/>
    189  ;;<time>
    190  ;;<low value="1990"/>
    191  ;;<high value='20000407'/>
    192  ;;</time>
    193  ;;<assignedEntity>
    194  ;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/>
    195  ;;<assignedPerson>
    196  ;;<name>
    197  ;;<prefix>@@ACTORPREFIXNAME@@</prefix>
    198  ;;<given>@@ACTORGIVENNAME@@</given>
    199  ;;<family>@@ACTORFAMILYNAME@@</family>
    200  ;;</name>
    201  ;;</assignedPerson>
    202  ;;<representedOrganization>
    203  ;;<id root="2.16.840.1.113883.19.5"/>
    204  ;;<name>@@ORGANIZATIONNAME@@</name>
    205  ;;</representedOrganization>
    206  ;;</assignedEntity>
    207  ;;</performer>
    208  ;;</serviceEvent>
    209  ;;</documentationOf>
    210  ;;<Body>
    211  ;;<PROBLEMS-HTML>
    212  ;;<text><table border="1" width="100%"><thead><tr><th>Condition</th><th>Effective Dates</th><th>Condition Status</th></tr></thead><tbody>
    213  ;;<tr><td>@@PROBLEMDESCRIPTION@@</td>
    214  ;;<td>@@PROBLEMDATEOFONSET@@</td>
    215  ;;<td>Active</td></tr>
    216  ;;</tbody></table></text>
    217  ;;</PROBLEMS-HTML>
    218  ;;<Problems>
    219  ;;<component>
    220  ;;<section>
    221  ;;<templateId root='2.16.840.1.113883.10.20.1.11'/>
    222  ;;<code code="11450-4" codeSystem="2.16.840.1.113883.6.1"/>
    223  ;;<title>Problems</title>
    224  ;;<entry typeCode="DRIV">
    225  ;;<act classCode="ACT" moodCode="EVN">
    226  ;;<templateId root='2.16.840.1.113883.10.20.1.27'/>
    227  ;;<id root="6a2fa88d-4174-4909-aece-db44b60a3abb"/>
    228  ;;<code nullFlavor="NA"/>
    229  ;;<entryRelationship typeCode="SUBJ">
    230  ;;<observation classCode="OBS" moodCode="EVN">
    231  ;;<templateId root='2.16.840.1.113883.10.20.1.28'/>
    232  ;;<id root="d11275e7-67ae-11db-bd13-0800200c9a66"/>
    233  ;;<code code="ASSERTION" codeSystem="2.16.840.1.113883.5.4"/>
    234  ;;<statusCode code="completed"/>
    235  ;;<effectiveTime>
    236  ;;<low value="@@PROBLEMDATEOFONSET@@"/>
    237  ;;</effectiveTime>
    238  ;;<value xsi:type="CD" code="@@PROBLEMCODEVALUE@@" codeSystem="2.16.840.1.113883.6.96" displayName="@@PROBLEMDESCRIPTION@@"/>
    239  ;;<entryRelationship typeCode="REFR">
    240  ;;<observation classCode="OBS" moodCode="EVN">
    241  ;;<templateId root='2.16.840.1.113883.10.20.1.50'/>
    242  ;;<code code="33999-4" codeSystem="2.16.840.1.113883.6.1" displayName="Status"/>
    243  ;;<statusCode code="completed"/>
    244  ;;<value xsi:type="CE" code="55561003" codeSystem="2.16.840.1.113883.6.96" displayName="Active"/>
    245  ;;</observation>
    246  ;;</entryRelationship>
    247  ;;</observation>
    248  ;;</entryRelationship>
    249  ;;</act>
    250  ;;</entry>
    251  ;;</section>
    252  ;;</component>
    253  ;;</Problems>
    254  ;;<FamilyHistory>
    255  ;;</FamilyHistory>
    256  ;;<SocialHistory>
    257  ;;</SocialHistory>
    258  ;;<Alerts>
    259  ;;</Alerts>
    260  ;;<Medications>
    261  ;;</Medications>
    262  ;;<VitalSigns>
    263  ;;</VitalSigns>
    264  ;;<Results>
    265  ;;</Results>
    266  ;;</Body>
    267  ;;</ClinicalDocument>
    268  ;</TEMPLATE>
     1C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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                 W "This is a CCD TEMPLATE with processing routines",!
     22                 W !
     23                 Q
     24                 ;
     25ZT(ZARY,BAT,LINE)       ; private routine to add a line to the ZARY array
     26                 ; ZARY IS PASSED BY NAME
     27                 ; BAT is a string identifying the section
     28                 ; LINE is a test which will evaluate to true or false
     29                 ; I '$G(@ZARY) D  ; IF ZARY DOES NOT EXIST '
     30                 ; . S @ZARY@(0)=0 ; initially there are no elements
     31                 ; . W "GOT HERE LOADING "_LINE,!
     32                 N CNT ; count of array elements
     33                 S CNT=@ZARY@(0) ; contains array count
     34                 S CNT=CNT+1 ; increment count
     35                 S @ZARY@(CNT)=LINE ; put the line in the array
     36                 ; S @ZARY@(BAT,CNT)="" ; index the test by battery
     37                 S @ZARY@(0)=CNT ; update the array counter
     38                 Q
     39                 ;
     40ZLOAD(ZARY,ROUTINE)     ; load tests into ZARY which is passed by reference
     41                 ; ZARY IS PASSED BY NAME
     42                 ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
     43                 ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
     44                 K @ZARY S @ZARY=""
     45                 S @ZARY@(0)=0 ; initialize array count
     46                 N LINE,LABEL,BODY
     47                 N INTEST S INTEST=0 ; switch for in the TEMPLATE section
     48                 N SECTION S SECTION="[anonymous]" ; NO section LABEL
     49                 ;
     50                 N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
     51                 . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section
     52                 . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section
     53                 . I INTEST  D  ; within the section
     54                 . . I LINE?." "1";><".E  D  ; sub-section name found
     55                 . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name
     56                 . . I LINE?." "1";;".E  D  ; line found
     57                 . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array
     58                 Q
     59                 ;
     60LOAD(ARY)       ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME
     61                 D ZLOAD(ARY,"C0CCCD1")
     62                 ; ZWR @ARY
     63                 Q
     64                 ;
     65TRMCCD     ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD
     66                 Q
     67MARKUP  ;<MARKUP>
     68        ;;<Body>
     69        ;;<Problems>
     70        ;;</Problems>
     71        ;;<FamilyHistory>
     72        ;;</FamilyHistory>
     73        ;;<SocialHistory>
     74        ;;</SocialHistory>
     75        ;;<Alerts>
     76        ;;</Alerts>
     77        ;;<Medications>
     78        ;;</Medications>
     79        ;;<VitalSigns>
     80        ;;</VitalSigns>
     81        ;;<Results>
     82        ;;</Results>
     83        ;;</Body>
     84        ;;</ContinuityOfCareRecord>
     85        ;</MARKUP>
     86        ;;<ClinicalDocument xmlns="urn:hl7-org:v3" xmlns:voc="urn:hl7-org:v3/voc" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="urn:hl7-org:v3 CDA.xsd">
     87        ;;</ClinicalDocument>
     88        Q
     89        ;
     90        ;<TEMPLATE>
     91        ;;<?xml version="1.0"?>
     92        ;;<?xml-stylesheet type="text/xsl" href="CCD.xsl"?>
     93        ;;<ClinicalDocument xmlns="urn:hl7-org:v3" xmlns:voc="urn:hl7-org:v3/voc" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="urn:hl7-org:v3 CDA.xsd">
     94        ;;<typeId root="2.16.840.1.113883.1.3" extension="POCD_HD000040"/>
     95        ;;<templateId root="2.16.840.1.113883.10.20.1"/>
     96        ;;<id root="db734647-fc99-424c-a864-7e3cda82e703"/>
     97        ;;<code code="34133-9" codeSystem="2.16.840.1.113883.6.1" displayName="Summarization of episode note"/>
     98        ;;<title>Continuity of Care Document</title>
     99        ;;<effectiveTime value="20000407130000+0500"/>
     100        ;;<confidentialityCode code="N" codeSystem="2.16.840.1.113883.5.25"/>
     101        ;;<languageCode code="en-US"/>
     102        ;;<recordTarget>
     103        ;;<patientRole>
     104        ;;<id extension="@@ACTORIEN@@" root="2.16.840.1.113883.19.5"/>
     105        ;;<patient>
     106        ;;<name>
     107        ;;<given>@@ACTORGIVENNAME@@</given>
     108        ;;<family>@@ACTORFAMILYNAME@@</family>
     109        ;;<suffix>@@ACTORSUFFIXNAME@@</suffix>
     110        ;;</name>
     111        ;;<administrativeGenderCode code="@@ACTORGENDER@@" codeSystem="2.16.840.1.113883.5.1"/>
     112        ;;<birthTime value="@@ACTORDATEOFBIRTH@@"/>
     113        ;;</patient>
     114        ;;<providerOrganization>
     115        ;;<id root="2.16.840.1.113883.19.5"/>
     116        ;;<name>@@ORGANIZATIONNAME@@</name>
     117        ;;</providerOrganization>
     118        ;;</patientRole>
     119        ;;</recordTarget>
     120        ;;<author>
     121        ;;<time value="20000407130000+0500"/>
     122        ;;<assignedAuthor>
     123        ;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/>
     124        ;;<assignedPerson>
     125        ;;<name>
     126        ;;<prefix>@@ACTORNAMEPREFIX@@</prefix>
     127        ;;<given>@@ACTORGIVENNAME@@</given>
     128        ;;<family>@@ACTORFAMILYNAME@@</family>
     129        ;;</name>
     130        ;;</assignedPerson>
     131        ;;<representedOrganization>
     132        ;;<id root="2.16.840.1.113883.19.5"/>
     133        ;;<name>@@ORGANIZATIONNAME@@</name>
     134        ;;</representedOrganization>
     135        ;;</assignedAuthor>
     136        ;;</author>
     137        ;;<informant>
     138        ;;<assignedEntity>
     139        ;;<id nullFlavor="NI"/>
     140        ;;<representedOrganization>
     141        ;;<id root="2.16.840.1.113883.19.5"/>
     142        ;;<name>@@ORGANIZATIONNAME@@</name>
     143        ;;</representedOrganization>
     144        ;;</assignedEntity>
     145        ;;</informant>
     146        ;;<custodian>
     147        ;;<assignedCustodian>
     148        ;;<representedCustodianOrganization>
     149        ;;<id root="2.16.840.1.113883.19.5"/>
     150        ;;<name>@@ORGANIZATIONNAME@@</name>
     151        ;;</representedCustodianOrganization>
     152        ;;</assignedCustodian>
     153        ;;</custodian>
     154        ;;<legalAuthenticator>
     155        ;;<time value="20000407130000+0500"/>
     156        ;;<signatureCode code="S"/>
     157        ;;<assignedEntity>
     158        ;;<id nullFlavor="NI"/>
     159        ;;<representedOrganization>
     160        ;;<id root="2.16.840.1.113883.19.5"/>
     161        ;;<name>@@ORGANIZATIONNAME@@</name>
     162        ;;</representedOrganization>
     163        ;;</assignedEntity>
     164        ;;</legalAuthenticator>
     165        ;;<Actors>
     166        ;;<ACTOR-NOK>
     167        ;;<participant typeCode="IND">
     168        ;;<associatedEntity classCode="NOK">
     169        ;;<id root="4ac71514-6a10-4164-9715-f8d96af48e6d"/>
     170        ;;<code code="65656005" codeSystem="2.16.840.1.113883.6.96" displayName="Biiological mother"/>
     171        ;;<telecom value="tel:(999)555-1212"/>
     172        ;;<associatedPerson>
     173        ;;<name>
     174        ;;<given>Henrietta</given>
     175        ;;<family>Levin</family>
     176        ;;</name>
     177        ;;</associatedPerson>
     178        ;;</associatedEntity>
     179        ;;</participant>
     180        ;;</ACTOR-NOK>
     181        ;;</Actors>
     182        ;;<documentationOf>
     183        ;;<serviceEvent classCode="PCPR">
     184        ;;<effectiveTime>
     185        ;;<high value="@@DATETIME@@"/>
     186        ;;</effectiveTime>
     187        ;;<performer typeCode="PRF">
     188        ;;<functionCode code="PCP" codeSystem="2.16.840.1.113883.5.88"/>
     189        ;;<time>
     190        ;;<low value="1990"/>
     191        ;;<high value='20000407'/>
     192        ;;</time>
     193        ;;<assignedEntity>
     194        ;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/>
     195        ;;<assignedPerson>
     196        ;;<name>
     197        ;;<prefix>@@ACTORPREFIXNAME@@</prefix>
     198        ;;<given>@@ACTORGIVENNAME@@</given>
     199        ;;<family>@@ACTORFAMILYNAME@@</family>
     200        ;;</name>
     201        ;;</assignedPerson>
     202        ;;<representedOrganization>
     203        ;;<id root="2.16.840.1.113883.19.5"/>
     204        ;;<name>@@ORGANIZATIONNAME@@</name>
     205        ;;</representedOrganization>
     206        ;;</assignedEntity>
     207        ;;</performer>
     208        ;;</serviceEvent>
     209        ;;</documentationOf>
     210        ;;<Body>
     211        ;;<PROBLEMS-HTML>
     212        ;;<text><table border="1" width="100%"><thead><tr><th>Condition</th><th>Effective Dates</th><th>Condition Status</th></tr></thead><tbody>
     213        ;;<tr><td>@@PROBLEMDESCRIPTION@@</td>
     214        ;;<td>@@PROBLEMDATEOFONSET@@</td>
     215        ;;<td>Active</td></tr>
     216        ;;</tbody></table></text>
     217        ;;</PROBLEMS-HTML>
     218        ;;<Problems>
     219        ;;<component>
     220        ;;<section>
     221        ;;<templateId root='2.16.840.1.113883.10.20.1.11'/>
     222        ;;<code code="11450-4" codeSystem="2.16.840.1.113883.6.1"/>
     223        ;;<title>Problems</title>
     224        ;;<entry typeCode="DRIV">
     225        ;;<act classCode="ACT" moodCode="EVN">
     226        ;;<templateId root='2.16.840.1.113883.10.20.1.27'/>
     227        ;;<id root="6a2fa88d-4174-4909-aece-db44b60a3abb"/>
     228        ;;<code nullFlavor="NA"/>
     229        ;;<entryRelationship typeCode="SUBJ">
     230        ;;<observation classCode="OBS" moodCode="EVN">
     231        ;;<templateId root='2.16.840.1.113883.10.20.1.28'/>
     232        ;;<id root="d11275e7-67ae-11db-bd13-0800200c9a66"/>
     233        ;;<code code="ASSERTION" codeSystem="2.16.840.1.113883.5.4"/>
     234        ;;<statusCode code="completed"/>
     235        ;;<effectiveTime>
     236        ;;<low value="@@PROBLEMDATEOFONSET@@"/>
     237        ;;</effectiveTime>
     238        ;;<value xsi:type="CD" code="@@PROBLEMCODEVALUE@@" codeSystem="2.16.840.1.113883.6.96" displayName="@@PROBLEMDESCRIPTION@@"/>
     239        ;;<entryRelationship typeCode="REFR">
     240        ;;<observation classCode="OBS" moodCode="EVN">
     241        ;;<templateId root='2.16.840.1.113883.10.20.1.50'/>
     242        ;;<code code="33999-4" codeSystem="2.16.840.1.113883.6.1" displayName="Status"/>
     243        ;;<statusCode code="completed"/>
     244        ;;<value xsi:type="CE" code="55561003" codeSystem="2.16.840.1.113883.6.96" displayName="Active"/>
     245        ;;</observation>
     246        ;;</entryRelationship>
     247        ;;</observation>
     248        ;;</entryRelationship>
     249        ;;</act>
     250        ;;</entry>
     251        ;;</section>
     252        ;;</component>
     253        ;;</Problems>
     254        ;;<FamilyHistory>
     255        ;;</FamilyHistory>
     256        ;;<SocialHistory>
     257        ;;</SocialHistory>
     258        ;;<Alerts>
     259        ;;</Alerts>
     260        ;;<Medications>
     261        ;;</Medications>
     262        ;;<VitalSigns>
     263        ;;</VitalSigns>
     264        ;;<Results>
     265        ;;</Results>
     266        ;;</Body>
     267        ;;</ClinicalDocument>
     268        ;</TEMPLATE>

  • ccr/branches/ohum/p/C0CCCR.m

    r1342 r1428  
    1 C0CCCR   ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  ; EXPORT A CCR
    22  ;
    23 EXPORT   ; EXPORT ENTRY POINT FOR CCR
    24  ; Select a patient.
    25  S DIC=2,DIC(0)="AEMQ" D ^DIC
    26  I Y<1 Q  ; EXIT
    27  S DFN=$P(Y,U,1) ; SET THE PATIENT
    28  ;OHUM/RUT 3120109 commented
    29  ;;OHUM/RUT 3120102 To take inputs from user for date limits and notes
    30  ;D ^C0CVALID
    31  ;;OHUM/RUT
    32  ;OHUM/RUT
    33  D XPAT(DFN) ; EXPORT TO A FILE
    34  Q
    35  ;
    36 XPAT(DFN,XPARMS,DIR,FN) ; EXPORT ONE PATIENT TO A FILE
    37  ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR")
    38  ; FN IS FILE NAME, DEFAULTS IF NULL
    39  N CCRGLO,UDIR,UFN
    40  S C0CNRPC=1 ; FLAG FOR NOT AN RPC CALL - FOR DEBUGGING THE RPC
    41  I '$D(DIR) S UDIR=""
    42  E  S UDIR=DIR
    43  I '$D(FN) S UFN="" ; IF FILENAME IS NOT PASSED
    44  E  S UFN=FN
    45  I '$D(XPARMS) S XPARMS=""
    46  N C0CRTN  ; RETURN ARRAY
    47  D CCRRPC(.C0CRTN,DFN,XPARMS,"CCR")
    48  S OARY=$NA(^TMP("C0CCUR",$J,DFN,"CCR",1))
    49  S ONAM=UFN
    50  I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_0.xml"
    51  S ODIRGLB=$NA(^TMP("C0CCCR","ODIR"))
    52  S ^TMP("C0CCCR","FNAME",DFN)=ONAM ; FILE NAME FOR BATCH USE
    53  I $D(^TMP("GPLCCR","ODIR")) S @ODIRGLB=^TMP("GPLCCR","ODIR")
    54  I '$D(@ODIRGLB) D  ; IF NOT ODIR HAS BEEN SET
    55  . W "Warning.. please set ^TMP(""C0CCCR"",""ODIR"")=""output path""",! Q
    56  . ;S @ODIRGLB="/home/glilly/CCROUT"
    57  . ;S @ODIRGLB="/home/cedwards/"
    58  . S @ODIRGLB="/opt/wv/p/"
    59  S ODIR=UDIR
    60  I UDIR="" S ODIR=@ODIRGLB
    61  N ZY
    62  S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR)
    63  W !,$P(ZY,U,2),!
    64  Q
    65  ;
    66 DCCR(DFN) ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED
    67  ;
    68  N G1
    69  S G1=$NA(^TMP("C0CCUR",$J,DFN,"CCR"))
    70  I $D(@G1@(0)) D  ; CCR EXISTS
    71  . D PARY^C0CXPATH(G1)
    72  E  W "CCR NOT CREATED, RUN D XPAT^C0CCCR(DFN,"""","""") FIRST",!
    73  Q
    74  ;
    75 CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART)  ;RPC ENTRY POINT FOR CCR OUTPUT
    76  ; CCRGRTN IS RETURN ARRAY PASSED BY REFERENCE
    77  ; DFN IS PATIENT IEN
    78  ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART
    79  ;   OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC
    80  ; CCRPARMS ARE PARAMETERS THAT AFFECT THE EXTRACTION
    81  ; IN THE FORM "PARM1:VALUE1^PARM2:VALUE2"
    82  ; EXAMPLE: "LABLIMIT:T-60" TO LIMIT LAB EXTRACTION TO THE LAST 60 DAYS
    83  ; SEE C0CPARMS FOR A COMPLETE LIST OF SUPPORTED PARAMETERS
    84  K ^TMP("C0CCCR",$J) ; CLEAN UP THE GLOBAL BEFORE WE USE IT
    85  M ^TMP("C0CSAV",$J)=^TMP($J) ; SAVING CALLER'S TMP SETTINGS
    86  K ^TMP($J) ; START CLEAN
    87  I '$D(DEBUG) S DEBUG=0
    88  S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD
    89  I '$D(CCRPARMS) S CCRPARMS=""
    90  I '$D(CCRPART) S CCRPART="CCR"
    91  I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"CALL",DFN)=""
    92  D SET^C0CPARMS(CCRPARMS) ;SET PARAMETERS WITH CCRPARMS AS OVERRIDES
    93  I '$D(TESTVIT) S TESTVIT=0 ; FLAG FOR TESTING VITALS
    94  I '$D(TESTLAB) S TESTLAB=0 ; FLAG FOR TESTING RESULTS SECTION
    95  I '$D(TESTALERT) S TESTALERT=1 ; FLAG FOR TESTING ALERTS SECTION
    96  I '$D(TESTMEDS) S TESTMEDS=0 ; FLAG FOR TESTING C0CMED SECTION
    97  S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE
    98  S CCRGLO=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR
    99  S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS
    100  ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC
    101  ;M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART OR ALL
    102  D LOAD^C0CCCR0(TGLOBAL)  ; LOAD THE CCR TEMPLATE
    103  D CP^C0CXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL
    104  ;
    105  ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL
    106  ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES
    107  D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body")
    108  D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors")
    109  D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures")
    110  D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Comments")
    111  I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),!
    112  ;
    113  D HDRMAP(CCRGLO,DFN) ; MAP HEADER VARIABLES
    114  ;
    115  K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT
    116  S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS
    117  D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS
    118  N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD
    119  F PROCI=1:1:@CCRXTAB@(0) D  ; PROCESS THE CCR BODY SECTIONS
    120  . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE
    121  . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL
    122  . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL
    123  . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE
    124  . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS
    125  . S IXML="INXML"
    126  . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES
    127  . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY
    128  . ; W OXML,!
    129  . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL
    130  . W "RUNNING ",CALL,!
    131  . X CALL
    132  . ; NOW INSERT THE RESULTS IN THE CCR BUFFER
    133  . I $G(@OXML@(0))>0 D  ; THERE IS A RESULT
    134  . . D INSERT^C0CXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body")
    135  . . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),!
    136  N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING
    137  D ACTLST^C0CCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST
    138  D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT")
    139  D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2")
    140  D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors")
    141  K ACTT,ACTT2
    142  ;D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT")
    143  ;D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2")
    144  ;D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments")
    145  ; gpl - turned off Comments for Certification
    146  K CMTT,CMTT2
    147  N TRIMI,J,DONE S DONE=0
    148  F TRIMI=0:0 D  Q:DONE  ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE
    149  . S J=$$TRIM^C0CXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS
    150  . I DEBUG W "TRIMMED",J,!
    151  . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE
    152  ;S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLOBAL OF PART OR ALL
    153  I CCRPART="CCR" M CCRGRTN=@CCRGLO ; ENTIRE CCR
    154  E  M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART
    155  I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"RESULT",CCRGRTN(0))=""
    156  K ^TMP("C0CCCR",$J) ; BEGIN TO CLEAN UP
    157  K ^TMP($J) ; REALLY CLEAN UP
    158  M ^TMP($J)=^TMP("C0CSAV",$J) ; RESTORE CALLER'S $J
    159  Q
    160  ;
    161 INITSTPS(TAB)  ; INITIALIZE CCR PROCESSING STEPS
    162  ; TAB IS PASSED BY NAME
    163  I DEBUG W "TAB= ",TAB,!
    164  ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS
    165  D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")")
    166  I TESTALERT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""C0CCCR"",$J,DFN,""ALERTS"")")
    167  D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")")
    168  D PUSH^C0CXPATH(TAB,"MAP;C0CIMMU;//ContinuityOfCareRecord/Body/Immunizations;^TMP(""C0CCCR"",$J,DFN,""IMMUNE"")")
    169  I TESTVIT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVIT2;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")")
    170  E  D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")")
    171  D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")")
    172  D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROC;//ContinuityOfCareRecord/Body/Procedures;^TMP(""C0CCCR"",$J,DFN,""PROCEDURES"")")
    173  ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
    174  ; gpl - turned off Encounters for Certification
    175  ;OHUM/RUT 3120109 Changed the condition
    176  ;;OHUM/RUT 3111228 Condition for Notes ; It should be included or not
    177  ;;I ^TMP("C0CCCR","TIULIMIT")'="" D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
    178  I $P(^C0CPARM(1,2),"^",3)=1 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
    179  ;;OHUM/RUT
    180  ;OHUM/RUT
    181  Q
    182  ;
    183 HDRMAP(CXML,DFN) ; MAP HEADER VARIABLES: FROM, TO ECT
    184  N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER"))
    185  ; K @VMAP
    186  S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT")
    187  ; I IHDR="" D  ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS
    188  D  ; ALWAYS MAP THESE VARIABLES
    189  . S @VMAP@("CCRDOCOBJECTID")=$$UUID^C0CUTIL ; UUID FOR THIS CCR
    190  . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN
    191  . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - FROM PROVIDER
    192  . ;S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ???
    193  . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM
    194  . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES
    195  . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR"  ; FOR TEST PURPOSES
    196  . S @VMAP@("ACTORTOTEXT")="Patient"  ; FOR TEST PURPOSES
    197  . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT
    198  ;I IHDR'="" D  ; HEADER VALUES ARE PROVIDED
    199  ;. D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY
    200  N CTMP
    201  D MAP^C0CXPATH(CXML,VMAP,"CTMP")
    202  D CP^C0CXPATH("CTMP",CXML)
    203  N HRIMVARS ;
    204  S HRIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"HEADER")) ; TO PERSIST VARS
    205  M @HRIMVARS@(1)=@VMAP ; PERSIST THE HEADER VARIABLES IN RIM TABLE
    206  S @HRIMVARS@(0)=1 ; ONLY ONE SET OF HEADERS PER PATIENT
    207  Q
    208  ;
    209 ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML
    210  ; AXML AND ACTRTN ARE PASSED BY NAME
    211  ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2
    212  ; P1= OBJECTID - ACTORPATIENT_2
    213  ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE
    214  ;OR INSTITUTION
    215  ;  OR PERSON(IN PATIENT FILE IE NOK)
    216  ; P3= IEN RECORD NUMBER FOR ACTOR - 2
    217  N I,J,K,L
    218  K @ACTRTN ; CLEAR RETURN ARRAY
    219  F I=1:1:@AXML@(0) D  ; FIRST FIX MISSING LINKS
    220  . I @AXML@(I)?.E1"_<".E D  ;
    221  . . N ZA,ZB
    222  . . S ZA=$P(@AXML@(I),">",1)_">"
    223  . . S ZB="<"_$P(@AXML@(I),"<",3)
    224  . . S @AXML@(I)=ZA_"ACTORORGANIZATION_1"_ZB
    225  F I=1:1:@AXML@(0) D  ; SCAN ALL LINES
    226  . I @AXML@(I)?.E1"<ActorID>".E D  ; THERE IS AN ACTOR THIS LINE
    227  . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1)
    228  . . I $G(LINKDEBUG) W "<ActorID>=>",J,!
    229  . . I J'="" S K(J)="" ; HASHING ACTOR
    230  . I @AXML@(I)?.E1"<LinkID>".E D  ; THERE IS AN ACTOR THIS LINE
    231  . . S J=$P($P(@AXML@(I),"<LinkID>",2),"</LinkID>",1)
    232  . . I $G(LINKDEBUG) W "<LinkID>=>",J,!
    233  . . I J'="" S K(J)="" ; HASHING ACTOR
    234  . . ;  TO GET RID OF DUPLICATES
    235  S I="" ; GOING TO $O THROUGH THE HASH
    236  F J=0:0 D  Q:$O(K(I))=""
    237  . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS
    238  . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID
    239  . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE
    240  . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR
    241  . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY
    242  Q
    243  ;
    244 TEST ; RUN ALL THE TEST CASES
    245  D TESTALL^C0CUNIT("C0CCCR")
    246  Q
    247  ;
    248 ZTEST(WHICH)  ; RUN ONE SET OF TESTS
    249  N ZTMP
    250  D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
    251  D ZTEST^C0CUNIT(.ZTMP,WHICH)
    252  Q
    253  ;
    254 TLIST  ; LIST THE TESTS
    255  N ZTMP
    256  D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
    257  D TLIST^C0CUNIT(.ZTMP)
    258  Q
    259  ;
    260  ;;><TEST>
    261  ;;><PROBLEMS>
    262  ;;>>>K C0C S C0C=""
    263  ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","")
    264  ;;>>?@C0C@(@C0C@(0))["</Problems>"
    265  ;;><VITALS>
    266  ;;>>>K C0C S C0C=""
    267  ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","")
    268  ;;>>?@C0C@(@C0C@(0))["</VitalSigns>"
    269  ;;><CCR>
    270  ;;>>>K C0C S C0C=""
    271  ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","")
    272  ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>"
    273  ;;><ACTLST>
    274  ;;>>>K C0C S C0C=""
    275  ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","")
    276  ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST")
    277  ;;><ACTORS>
    278  ;;>>>D ZTEST^C0CCCR("ACTLST")
    279  ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2")
    280  ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3")
    281  ;;>>?G3(G3(0))["</Actors>"
    282  ;;><TRIM>
    283  ;;>>>D ZTEST^C0CCCR("CCR")
    284  ;;>>>W $$TRIM^C0CXPATH(CCRGLO)
    285  ;;><ALERTS>
    286  ;;>>>S TESTALERT=1
    287  ;;>>>K C0C S C0C=""
    288  ;;>>>D CCRRPC^C0CCCR(.C0C,"2","ALERTS","")
    289  ;;>>?@C0C@(@C0C@(0))["</Alerts>"
    290  
    291  
     1C0CCCR    ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        ; EXPORT A CCR
     22        ;
     23EXPORT    ; EXPORT ENTRY POINT FOR CCR
     24        ; Select a patient.
     25        S DIC=2,DIC(0)="AEMQ" D ^DIC
     26        I Y<1 Q  ; EXIT
     27        S DFN=$P(Y,U,1) ; SET THE PATIENT
     28        ;OHUM/RUT 3120109 commented
     29        ;;OHUM/RUT 3120102 To take inputs from user for date limits and notes
     30        ;D ^C0CVALID
     31        ;;OHUM/RUT
     32        ;OHUM/RUT
     33        D XPAT(DFN) ; EXPORT TO A FILE
     34        Q
     35        ;
     36XPAT(DFN,XPARMS,DIR,FN) ; EXPORT ONE PATIENT TO A FILE
     37        ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR")
     38        ; FN IS FILE NAME, DEFAULTS IF NULL
     39        N CCRGLO,UDIR,UFN
     40        S C0CNRPC=1 ; FLAG FOR NOT AN RPC CALL - FOR DEBUGGING THE RPC
     41        I '$D(DIR) S UDIR=""
     42        E  S UDIR=DIR
     43        I '$D(FN) S UFN="" ; IF FILENAME IS NOT PASSED
     44        E  S UFN=FN
     45        I '$D(XPARMS) S XPARMS=""
     46        N C0CRTN  ; RETURN ARRAY
     47        D CCRRPC(.C0CRTN,DFN,XPARMS,"CCR")
     48        S OARY=$NA(^TMP("C0CCUR",$J,DFN,"CCR",1))
     49        S ONAM=UFN
     50        I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_0.xml"
     51        S ODIRGLB=$NA(^TMP("C0CCCR","ODIR"))
     52        S ^TMP("C0CCCR","FNAME",DFN)=ONAM ; FILE NAME FOR BATCH USE
     53        I $D(^TMP("GPLCCR","ODIR")) S @ODIRGLB=^TMP("GPLCCR","ODIR")
     54        I '$D(@ODIRGLB) D  ; IF NOT ODIR HAS BEEN SET
     55        . W "Warning.. please set ^TMP(""C0CCCR"",""ODIR"")=""output path""",! Q
     56        . ;S @ODIRGLB="/home/glilly/CCROUT"
     57        . ;S @ODIRGLB="/home/cedwards/"
     58        . S @ODIRGLB="/opt/wv/p/"
     59        S ODIR=UDIR
     60        I UDIR="" S ODIR=@ODIRGLB
     61        N ZY
     62        S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR)
     63        W !,$P(ZY,U,2),!
     64        Q
     65        ;
     66DCCR(DFN)       ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED
     67        ;
     68        N G1
     69        S G1=$NA(^TMP("C0CCUR",$J,DFN,"CCR"))
     70        I $D(@G1@(0)) D  ; CCR EXISTS
     71        . D PARY^C0CXPATH(G1)
     72        E  W "CCR NOT CREATED, RUN D XPAT^C0CCCR(DFN,"""","""") FIRST",!
     73        Q
     74        ;
     75CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART)    ;RPC ENTRY POINT FOR CCR OUTPUT
     76        ; CCRGRTN IS RETURN ARRAY PASSED BY REFERENCE
     77        ; DFN IS PATIENT IEN
     78        ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART
     79        ;   OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC
     80        ; CCRPARMS ARE PARAMETERS THAT AFFECT THE EXTRACTION
     81        ; IN THE FORM "PARM1:VALUE1^PARM2:VALUE2"
     82        ; EXAMPLE: "LABLIMIT:T-60" TO LIMIT LAB EXTRACTION TO THE LAST 60 DAYS
     83        ; SEE C0CPARMS FOR A COMPLETE LIST OF SUPPORTED PARAMETERS
     84        K ^TMP("C0CCCR",$J) ; CLEAN UP THE GLOBAL BEFORE WE USE IT
     85        M ^TMP("C0CSAV",$J)=^TMP($J) ; SAVING CALLER'S TMP SETTINGS
     86        K ^TMP($J) ; START CLEAN
     87        I '$D(DEBUG) S DEBUG=0
     88        S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD
     89        I '$D(CCRPARMS) S CCRPARMS=""
     90        I '$D(CCRPART) S CCRPART="CCR"
     91        I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"CALL",DFN)=""
     92        D SET^C0CPARMS(CCRPARMS) ;SET PARAMETERS WITH CCRPARMS AS OVERRIDES
     93        I '$D(TESTVIT) S TESTVIT=0 ; FLAG FOR TESTING VITALS
     94        I '$D(TESTLAB) S TESTLAB=0 ; FLAG FOR TESTING RESULTS SECTION
     95        I '$D(TESTALERT) S TESTALERT=1 ; FLAG FOR TESTING ALERTS SECTION
     96        I '$D(TESTMEDS) S TESTMEDS=0 ; FLAG FOR TESTING C0CMED SECTION
     97        S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE
     98        S CCRGLO=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR
     99        S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS
     100        ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC
     101        ;M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART OR ALL
     102        D LOAD^C0CCCR0(TGLOBAL)  ; LOAD THE CCR TEMPLATE
     103        D CP^C0CXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL
     104        ;
     105        ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL
     106        ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES
     107        D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body")
     108        D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors")
     109        D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures")
     110        D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Comments")
     111        I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),!
     112        ;
     113        D HDRMAP(CCRGLO,DFN) ; MAP HEADER VARIABLES
     114        ;
     115        K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT
     116        S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS
     117        D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS
     118        N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD
     119        F PROCI=1:1:@CCRXTAB@(0) D  ; PROCESS THE CCR BODY SECTIONS
     120        . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE
     121        . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL
     122        . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL
     123        . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE
     124        . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS
     125        . S IXML="INXML"
     126        . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES
     127        . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY
     128        . ; W OXML,!
     129        . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL
     130        . W "RUNNING ",CALL,!
     131        . X CALL
     132        . ; NOW INSERT THE RESULTS IN THE CCR BUFFER
     133        . I $G(@OXML@(0))>0 D  ; THERE IS A RESULT
     134        . . D INSERT^C0CXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body")
     135        . . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),!
     136        N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING
     137        D ACTLST^C0CCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST
     138        D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT")
     139        D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2")
     140        D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors")
     141        K ACTT,ACTT2
     142        ;D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT")
     143        ;D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2")
     144        ;D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments")
     145        ; gpl - turned off Comments for Certification
     146        K CMTT,CMTT2
     147        N TRIMI,J,DONE S DONE=0
     148        F TRIMI=0:0 D  Q:DONE  ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE
     149        . S J=$$TRIM^C0CXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS
     150        . I DEBUG W "TRIMMED",J,!
     151        . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE
     152        ;S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLOBAL OF PART OR ALL
     153        I CCRPART="CCR" M CCRGRTN=@CCRGLO ; ENTIRE CCR
     154        E  M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART
     155        I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"RESULT",CCRGRTN(0))=""
     156        K ^TMP("C0CCCR",$J) ; BEGIN TO CLEAN UP
     157        K ^TMP($J) ; REALLY CLEAN UP
     158        M ^TMP($J)=^TMP("C0CSAV",$J) ; RESTORE CALLER'S $J
     159        Q
     160        ;
     161INITSTPS(TAB)    ; INITIALIZE CCR PROCESSING STEPS
     162        ; TAB IS PASSED BY NAME
     163        I DEBUG W "TAB= ",TAB,!
     164        ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS
     165        D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")")
     166        I TESTALERT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""C0CCCR"",$J,DFN,""ALERTS"")")
     167        D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")")
     168        D PUSH^C0CXPATH(TAB,"MAP;C0CIMMU;//ContinuityOfCareRecord/Body/Immunizations;^TMP(""C0CCCR"",$J,DFN,""IMMUNE"")")
     169        I TESTVIT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVIT2;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")")
     170        E  D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")")
     171        D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")")
     172        D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROC;//ContinuityOfCareRecord/Body/Procedures;^TMP(""C0CCCR"",$J,DFN,""PROCEDURES"")")
     173        ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
     174        ; gpl - turned off Encounters for Certification
     175        ;OHUM/RUT 3120109 Changed the condition
     176        ;;OHUM/RUT 3111228 Condition for Notes ; It should be included or not
     177        ;;I ^TMP("C0CCCR","TIULIMIT")'="" D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
     178        I $P(^C0CPARM(1,2),"^",3)=1 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
     179        ;;OHUM/RUT
     180        ;OHUM/RUT
     181        Q
     182        ;
     183HDRMAP(CXML,DFN)        ; MAP HEADER VARIABLES: FROM, TO ECT
     184        N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER"))
     185        ; K @VMAP
     186        S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT")
     187        ; I IHDR="" D  ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS
     188        D  ; ALWAYS MAP THESE VARIABLES
     189        . S @VMAP@("CCRDOCOBJECTID")=$$UUID^C0CUTIL ; UUID FOR THIS CCR
     190        . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN
     191        . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - FROM PROVIDER
     192        . ;S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ???
     193        . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM
     194        . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES
     195        . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR"  ; FOR TEST PURPOSES
     196        . S @VMAP@("ACTORTOTEXT")="Patient"  ; FOR TEST PURPOSES
     197        . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT
     198        ;I IHDR'="" D  ; HEADER VALUES ARE PROVIDED
     199        ;. D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY
     200        N CTMP
     201        D MAP^C0CXPATH(CXML,VMAP,"CTMP")
     202        D CP^C0CXPATH("CTMP",CXML)
     203        N HRIMVARS ;
     204        S HRIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"HEADER")) ; TO PERSIST VARS
     205        M @HRIMVARS@(1)=@VMAP ; PERSIST THE HEADER VARIABLES IN RIM TABLE
     206        S @HRIMVARS@(0)=1 ; ONLY ONE SET OF HEADERS PER PATIENT
     207        Q
     208        ;
     209ACTLST(AXML,ACTRTN)     ; RETURN THE ACTOR LIST FOR THE XML IN AXML
     210        ; AXML AND ACTRTN ARE PASSED BY NAME
     211        ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2
     212        ; P1= OBJECTID - ACTORPATIENT_2
     213        ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE
     214        ;OR INSTITUTION
     215        ;  OR PERSON(IN PATIENT FILE IE NOK)
     216        ; P3= IEN RECORD NUMBER FOR ACTOR - 2
     217        N I,J,K,L
     218        K @ACTRTN ; CLEAR RETURN ARRAY
     219        F I=1:1:@AXML@(0) D  ; FIRST FIX MISSING LINKS
     220        . I @AXML@(I)?.E1"_<".E D  ;
     221        . . N ZA,ZB
     222        . . S ZA=$P(@AXML@(I),">",1)_">"
     223        . . S ZB="<"_$P(@AXML@(I),"<",3)
     224        . . S @AXML@(I)=ZA_"ACTORORGANIZATION_1"_ZB
     225        F I=1:1:@AXML@(0) D  ; SCAN ALL LINES
     226        . I @AXML@(I)?.E1"<ActorID>".E D  ; THERE IS AN ACTOR THIS LINE
     227        . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1)
     228        . . I $G(LINKDEBUG) W "<ActorID>=>",J,!
     229        . . I J'="" S K(J)="" ; HASHING ACTOR
     230        . I @AXML@(I)?.E1"<LinkID>".E D  ; THERE IS AN ACTOR THIS LINE
     231        . . S J=$P($P(@AXML@(I),"<LinkID>",2),"</LinkID>",1)
     232        . . I $G(LINKDEBUG) W "<LinkID>=>",J,!
     233        . . I J'="" S K(J)="" ; HASHING ACTOR
     234        . . ;  TO GET RID OF DUPLICATES
     235        S I="" ; GOING TO $O THROUGH THE HASH
     236        F J=0:0 D  Q:$O(K(I))=""
     237        . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS
     238        . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID
     239        . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE
     240        . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR
     241        . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY
     242        Q
     243        ;
     244TEST    ; RUN ALL THE TEST CASES
     245        D TESTALL^C0CUNIT("C0CCCR")
     246        Q
     247        ;
     248ZTEST(WHICH)    ; RUN ONE SET OF TESTS
     249        N ZTMP
     250        D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
     251        D ZTEST^C0CUNIT(.ZTMP,WHICH)
     252        Q
     253        ;
     254TLIST    ; LIST THE TESTS
     255        N ZTMP
     256        D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
     257        D TLIST^C0CUNIT(.ZTMP)
     258        Q
     259        ;
     260        ;;><TEST>
     261        ;;><PROBLEMS>
     262        ;;>>>K C0C S C0C=""
     263        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","")
     264        ;;>>?@C0C@(@C0C@(0))["</Problems>"
     265        ;;><VITALS>
     266        ;;>>>K C0C S C0C=""
     267        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","")
     268        ;;>>?@C0C@(@C0C@(0))["</VitalSigns>"
     269        ;;><CCR>
     270        ;;>>>K C0C S C0C=""
     271        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","")
     272        ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>"
     273        ;;><ACTLST>
     274        ;;>>>K C0C S C0C=""
     275        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","")
     276        ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST")
     277        ;;><ACTORS>
     278        ;;>>>D ZTEST^C0CCCR("ACTLST")
     279        ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2")
     280        ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3")
     281        ;;>>?G3(G3(0))["</Actors>"
     282        ;;><TRIM>
     283        ;;>>>D ZTEST^C0CCCR("CCR")
     284        ;;>>>W $$TRIM^C0CXPATH(CCRGLO)
     285        ;;><ALERTS>
     286        ;;>>>S TESTALERT=1
     287        ;;>>>K C0C S C0C=""
     288        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","ALERTS","")
     289        ;;>>?@C0C@(@C0C@(0))["</Alerts>"
     290       
     291       

  • ccr/branches/ohum/p/C0CCCR0.m

    r1342 r1428  
    1 C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  W "This is a CCR TEMPLATE with processing routines",!
    22  W !
    23  Q
    24  ;
    25 ZT(ZARY,BAT,LINE)       ; private routine to add a line to the ZARY array
    26  ; ZARY IS PASSED BY NAME
    27  ; BAT is a string identifying the section
    28  ; LINE is a test which will evaluate to true or false
    29  ; I '$G(@ZARY) D  ;
    30  ; . S @ZARY@(0)=0 ; initially there are no elements
    31  ; . W "GOT HERE LOADING "_LINE,!
    32  N CNT ; count of array elements
    33  S CNT=@ZARY@(0) ; contains array count
    34  S CNT=CNT+1 ; increment count
    35  S @ZARY@(CNT)=LINE ; put the line in the array
    36  ; S @ZARY@(BAT,CNT)="" ; index the test by battery
    37  S @ZARY@(0)=CNT ; update the array counter
    38  Q
    39  ;
    40 ZLOAD(ZARY,ROUTINE)      ; load tests into ZARY which is passed by reference
    41  ; ZARY IS PASSED BY NAME
    42  ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
    43  ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
    44  K @ZARY S @ZARY=""
    45  S @ZARY@(0)=0 ; initialize array count
    46  N LINE,LABEL,BODY
    47  N INTEST S INTEST=0 ; switch for in the TEMPLATE section
    48  N SECTION S SECTION="[anonymous]" ; NO section LABEL
    49  ;
    50  N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
    51  . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section
    52  . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section
    53  . I INTEST  D  ; within the section
    54  . . I LINE?." "1";><".E  D  ; sub-section name found
    55  . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name
    56  . . I LINE?." "1";;".E  D  ; line found
    57  . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array
    58  Q
    59  ;
    60 LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME
    61  D ZLOAD(ARY,"C0CCCR0")
    62  ; ZWR @ARY
    63  Q
    64  ;
    65  ;<TEMPLATE>
    66  ;;<?xml version="1.0" encoding="UTF-8"?>
    67  ;;<?xml-stylesheet type="text/xsl" href="ccr.xsl"?>
    68  ;;<ContinuityOfCareRecord xmlns="urn:astm-org:CCR">
    69  ;;<CCRDocumentObjectID>@@CCRDOCOBJECTID@@</CCRDocumentObjectID>
    70  ;;<Language>
    71  ;;<Text>English</Text>
    72  ;;</Language>
    73  ;;<Version>V1.0</Version>
    74  ;;<DateTime>
    75  ;;<ExactDateTime>@@DATETIME@@</ExactDateTime>
    76  ;;</DateTime>
    77  ;;<Patient>
    78  ;;<ActorID>@@ACTORPATIENT@@</ActorID>
    79  ;;</Patient>
    80  ;;<From>
    81  ;;<ActorLink>
    82  ;;<ActorID>@@ACTORFROM@@</ActorID>
    83  ;;</ActorLink>
    84  ;;<ActorLink>
    85  ;;<ActorID>@@ACTORFROM2@@</ActorID>
    86  ;;</ActorLink>
    87  ;;</From>
    88  ;;<To>
    89  ;;<ActorLink>
    90  ;;<ActorID>@@ACTORTO@@</ActorID>
    91  ;;<ActorRole>
    92  ;;<Text>@@ACTORTOTEXT@@</Text>
    93  ;;</ActorRole>
    94  ;;</ActorLink>
    95  ;;</To>
    96  ;;<Purpose>
    97  ;;<Description>
    98  ;;<Text>@@PURPOSEDESCRIPTION@@</Text>
    99  ;;</Description>
    100  ;;</Purpose>
    101  ;;<Body>
    102  ;;<Problems>
    103  ;;<Problem>
    104  ;;<CCRDataObjectID>@@PROBLEMOBJECTID@@</CCRDataObjectID>
    105  ;;<DateTime>
    106  ;;<ExactDateTime>@@PROBLEMDATEMOD@@</ExactDateTime>
    107  ;;</DateTime>
    108  ;;<Type>
    109  ;;<Text>Problem</Text>
    110  ;;</Type>
    111  ;;<Description>
    112  ;;<Text>@@PROBLEMDESCRIPTION@@</Text>
    113  ;;<Code>
    114  ;;<Value>@@PROBLEMCODEVALUE@@</Value>
    115  ;;<CodingSystem>ICD9CM</CodingSystem>
    116  ;;<Version>@@PROBLEMCODINGVERSION@@</Version>
    117  ;;</Code>
    118  ;;</Description>
    119  ;;<Status>
    120  ;;<Text>@@PROBLEMSTATUS@@</Text>
    121  ;;</Status>
    122  ;;<Source>
    123  ;;<Actor>
    124  ;;<ActorID>@@PROBLEMSOURCEACTORID@@</ActorID>
    125  ;;</Actor>
    126  ;;</Source>
    127  ;;</Problem>
    128  ;;</Problems>
    129  ;;<Immunizations>
    130  ;;<Immunization>
    131  ;;<CCRDataObjectID>@@IMMUNEOBJECTID@@</CCRDataObjectID>
    132  ;;<DateTime>
    133  ;;<Type>
    134  ;;<Text>@@IMMUNEDATETIMETYPETEXT@@</Text>
    135  ;;</Type>
    136  ;;<ExactDateTime>@@IMMUNEDATETIME@@</ExactDateTime>
    137  ;;</DateTime>
    138  ;;<Source>
    139  ;;<Actor>
    140  ;;<ActorID>@@IMMUNESOURCEACTORID@@</ActorID>
    141  ;;</Actor>
    142  ;;</Source>
    143  ;;<Product>
    144  ;;<ProductName>
    145  ;;<Text>@@IMMUNEPRODUCTNAMETEXT@@</Text>
    146  ;;<Code>
    147  ;;<Value>@@IMMUNEPRODUCTCODE@@</Value>
    148  ;;<CodingSystem>@@IMMUNEPRODUCTCODESYSTEM@@</CodingSystem>
    149  ;;</Code>
    150  ;;</ProductName>
    151  ;;</Product>
    152  ;;</Immunization>
    153  ;;</Immunizations>
    154  ;;<FamilyHistory>
    155  ;;<FamilyProblemHistory>
    156  ;;<CCRDataObjectID>@@FAMILYHISTORYOBJECTID@@</CCRDataObjectID>
    157  ;;<Source>
    158  ;;<Actor>
    159  ;;<ActorID>@@FAMILYHISTORYACTORID@@</ActorID>
    160  ;;</Actor>
    161  ;;</Source>
    162  ;;<FamilyMember>
    163  ;;<ActorID>@@FAMILYMEMBERACTORID@@</ActorID>
    164  ;;<ActorRole>
    165  ;;<Text>@@FAMILYMEMBERACTORROLETEXT@@</Text>
    166  ;;</ActorRole>
    167  ;;<Source>
    168  ;;<Actor>
    169  ;;<ActorID>@@FAMILYMEMBERSOURCACTORID@@</ActorID>
    170  ;;</Actor>
    171  ;;</Source>
    172  ;;</FamilyMember>
    173  ;;<Problem>
    174  ;;<Type>
    175  ;;<Text>Problem</Text>
    176  ;;</Type>
    177  ;;<Description>
    178  ;;<Text>@@FAMILYMEMBERPROBLEMDESCRIPTION@@</Text>
    179  ;;<Code>
    180  ;;<Value>@@FAMILYMEMBERPROBLEMCODE@@</Value>
    181  ;;<CodingSystem>@@FAMILYMEMBERCODESYSTEM@@</CodingSystem>
    182  ;;<Version>@@FAMILYMEMBERCODEVERSION@@</Version>
    183  ;;</Code>
    184  ;;</Description>
    185  ;;<Source>
    186  ;;<Actor>
    187  ;;<ActorID>@@FAMILYMEMBERPROBLEMSOURCEID@@</ActorID>
    188  ;;</Actor>
    189  ;;</Source>
    190  ;;</Problem>
    191  ;;</FamilyProblemHistory>
    192  ;;</FamilyHistory>
    193  ;;<SocialHistory>
    194  ;;<SocialHistoryElement>
    195  ;;<CCRDataObjectID>@@SOCIALHISTORYOBJECTID@@</CCRDataObjectID>
    196  ;;<Type>
    197  ;;<Text>@@SOCIALHISTORYTYPETEXT@@</Text>
    198  ;;</Type>
    199  ;;<Description>
    200  ;;<Text>@@SOCIALHISTORYDESCRIPTIONTEXT@@</Text>
    201  ;;</Description>
    202  ;;<Source>
    203  ;;<Actor>
    204  ;;<ActorID>@@SOCIALHISTORYSOURCACTORID@@</ActorID>
    205  ;;</Actor>
    206  ;;</Source>
    207  ;;</SocialHistoryElement>
    208  ;;<SocialHistoryElement>
    209  ;;<CCRDataObjectID>BB0005</CCRDataObjectID>
    210  ;;<Type>
    211  ;;<Text>Ethnic Origin</Text>
    212  ;;</Type>
    213  ;;<Description>
    214  ;;<Text>Not Hispanic or Latino</Text>
    215  ;;</Description>
    216  ;;<Source>
    217  ;;<Actor>
    218  ;;<ActorID>AA0001</ActorID>
    219  ;;</Actor>
    220  ;;</Source>
    221  ;;</SocialHistoryElement>
    222  ;;<SocialHistoryElement>
    223  ;;<CCRDataObjectID>BB0006</CCRDataObjectID>
    224  ;;<Type>
    225  ;;<Text>Race</Text>
    226  ;;</Type>
    227  ;;<Description>
    228  ;;<Text>White</Text>
    229  ;;</Description>
    230  ;;<Source>
    231  ;;<Actor>
    232  ;;<ActorID>AA0001</ActorID>
    233  ;;</Actor>
    234  ;;</Source>
    235  ;;</SocialHistoryElement>
    236  ;;<SocialHistoryElement>
    237  ;;<CCRDataObjectID>BB0007</CCRDataObjectID>
    238  ;;<Type>
    239  ;;<Text>Occupation</Text>
    240  ;;</Type>
    241  ;;<Description>
    242  ;;<Text>Physician</Text>
    243  ;;</Description>
    244  ;;<Source>
    245  ;;<Actor>
    246  ;;<ActorID>AA0001</ActorID>
    247  ;;</Actor>
    248  ;;</Source>
    249  ;;</SocialHistoryElement>
    250  ;;</SocialHistory>
    251  ;;<Alerts>
    252  ;;<Alert>
    253  ;;<CCRDataObjectID>@@ALERTOBJECTID@@</CCRDataObjectID>
    254  ;;<DateTime>
    255  ;;<ExactDateTime>@@ALERTDATETIME@@</ExactDateTime>
    256  ;;</DateTime>
    257  ;;<Type>
    258  ;;<Text>@@ALERTTYPE@@</Text>
    259  ;;</Type>
    260  ;;<Status>
    261  ;;<Text>@@ALERTSTATUSTEXT@@</Text>
    262  ;;</Status>
    263  ;;<Description>
    264  ;;<Text>@@ALERTDESCRIPTIONTEXT@@</Text>
    265  ;;<Code>
    266  ;;<Value>@@ALERTCODEVALUE@@</Value>
    267  ;;<CodingSystem>@@ALERTCODESYSTEM@@</CodingSystem>
    268  ;;</Code>
    269  ;;</Description>
    270  ;;<Source>
    271  ;;<Actor>
    272  ;;<ActorID>@@ALERTSOURCEID@@</ActorID>
    273  ;;</Actor>
    274  ;;</Source>
    275  ;;<Agent>
    276  ;;<Products>
    277  ;;<Product>
    278  ;;<CCRDataObjectID>@@ALERTAGENTPRODUCTOBJECTID@@</CCRDataObjectID>
    279  ;;<Source>
    280  ;;<Actor>
    281  ;;<ActorID>@@ALERTSOURCEID@@</ActorID>
    282  ;;</Actor>
    283  ;;</Source>
    284  ;;<Product>
    285  ;;<ProductName>
    286  ;;<Text>@@ALERTAGENTPRODUCTNAMETEXT@@</Text>
    287  ;;<Code>
    288  ;;<Value>@@ALERTAGENTPRODUCTCODEVALUE@@</Value>
    289  ;;<CodingSystem>@@ALERTAGENTPRODUCTCODESYSTEM@@</CodingSystem>
    290  ;;</Code>
    291  ;;</ProductName>
    292  ;;</Product>
    293  ;;</Product>
    294  ;;</Products>
    295  ;;</Agent>
    296  ;;<Reaction>
    297  ;;<Description>
    298  ;;<Text>@@ALERTREACTIOINDESCRIPTIONTEXT@@</Text>
    299  ;;<Code>
    300  ;;<Value>@@ALERTREACTIONCODEVALUE@@</Value>
    301  ;;<CodingSystem>@@ALERTREACTIONCODESYSTEM@@</CodingSystem>
    302  ;;</Code>
    303  ;;</Description>
    304  ;;</Reaction>
    305  ;;</Alert>
    306  ;;</Alerts>
    307  ;;<Medications>
    308  ;;<Medication>
    309  ;;<CCRDataObjectID>@@MEDOBJECTID@@</CCRDataObjectID>
    310  ;;<DateTime>
    311  ;;<Type>
    312  ;;<Text>@@MEDISSUEDATETXT@@</Text>
    313  ;;</Type>
    314  ;;<ExactDateTime>@@MEDISSUEDATE@@</ExactDateTime>
    315  ;;</DateTime>
    316  ;;<DateTime>
    317  ;;<Type>
    318  ;;<Text>@@MEDLASTFILLDATETXT@@</Text>
    319  ;;</Type>
    320  ;;<ExactDateTime>@@MEDLASTFILLDATE@@</ExactDateTime>
    321  ;;</DateTime>
    322  ;;<IDs>
    323  ;;<Type>
    324  ;;<Text>@@MEDRXNOTXT@@</Text>
    325  ;;</Type>
    326  ;;<ID>@@MEDRXNO@@</ID>
    327  ;;</IDs>
    328  ;;<Type>
    329  ;;<Text>@@MEDTYPETEXT@@</Text>
    330  ;;</Type>
    331  ;;<Description>
    332  ;;<Text>@@MEDDETAILUNADORNED@@</Text>
    333  ;;</Description>
    334  ;;<Status>
    335  ;;<Text>@@MEDSTATUSTEXT@@</Text>
    336  ;;</Status>
    337  ;;<Source>
    338  ;;<Actor>
    339  ;;<ActorID>@@MEDSOURCEACTORID@@</ActorID>
    340  ;;</Actor>
    341  ;;</Source>
    342  ;;<Product>
    343  ;;<ProductName>
    344  ;;<Text>@@MEDPRODUCTNAMETEXT@@</Text>
    345  ;;<Code>
    346  ;;<Value>@@MEDPRODUCTNAMECODEVALUE@@</Value>
    347  ;;<CodingSystem>@@MEDPRODUCTNAMECODINGINGSYSTEM@@</CodingSystem>
    348  ;;<Version>@@MEDPRODUCTNAMECODEVERSION@@</Version>
    349  ;;</Code>
    350  ;;</ProductName>
    351  ;;<BrandName>
    352  ;;<Text>@@MEDBRANDNAMETEXT@@</Text>
    353  ;;</BrandName>
    354  ;;<Strength>
    355  ;;<Value>@@MEDSTRENGTHVALUE@@</Value>
    356  ;;<Units>
    357  ;;<Unit>@@MEDSTRENGTHUNIT@@</Unit>
    358  ;;</Units>
    359  ;;</Strength>
    360  ;;<Form>
    361  ;;<Text>@@MEDFORMTEXT@@</Text>
    362  ;;</Form>
    363  ;;<Concentration>
    364  ;;<Value>@@MEDCONCVALUE@@</Value>
    365  ;;<Units>
    366  ;;<Unit>@@MEDCONCUNIT@@</Unit>
    367  ;;</Units>
    368  ;;</Concentration>
    369  ;;</Product>
    370  ;;<Quantity>
    371  ;;<Value>@@MEDQUANTITYVALUE@@</Value>
    372  ;;<Units>
    373  ;;<Unit>@@MEDQUANTITYUNIT@@</Unit>
    374  ;;</Units>
    375  ;;</Quantity>
    376  ;;<Directions>
    377  ;;<Direction>
    378  ;;<Description>
    379  ;;<Text>@@MEDDIRECTIONDESCRIPTIONTEXT@@</Text>
    380  ;;</Description>
    381  ;;<DoseIndicator>
    382  ;;<Text>@@MEDDOSEINDICATOR@@</Text>
    383  ;;</DoseIndicator>
    384  ;;<DeliveryMethod>
    385  ;;<Text>@@MEDDELIVERYMETHOD@@</Text>
    386  ;;</DeliveryMethod>
    387  ;;<Dose>
    388  ;;<Value>@@MEDDOSEVALUE@@</Value>
    389  ;;<Units>
    390  ;;<Unit>@@MEDDOSEUNIT@@</Unit>
    391  ;;</Units>
    392  ;;<Rate>
    393  ;;<Value>@@MEDRATEVALUE@@</Value>
    394  ;;<Units>
    395  ;;<Unit>@@MEDRATEUNIT@@</Unit>
    396  ;;</Units>
    397  ;;</Rate>
    398  ;;</Dose>
    399  ;;<Vehicle>
    400  ;;<Text>@@MEDVEHICLETEXT@@</Text>
    401  ;;</Vehicle>
    402  ;;<Route>
    403  ;;<Text>@@MEDDIRECTIONROUTETEXT@@</Text>
    404  ;;</Route>
    405  ;;<Frequency>
    406  ;;<Value>@@MEDFREQUENCYVALUE@@</Value>
    407  ;;</Frequency>
    408  ;;<Interval>
    409  ;;<Value>@@MEDINTERVALVALUE@@</Value>
    410  ;;<Units>
    411  ;;<Unit>@@MEDINTERVALUNIT@@</Unit>
    412  ;;</Units>
    413  ;;</Interval>
    414  ;;<Duration>
    415  ;;<Value>@@MEDDURATIONVALUE@@</Value>
    416  ;;<Units>
    417  ;;<Unit>@@MEDDURATIONUNIT@@</Unit>
    418  ;;</Units>
    419  ;;</Duration>
    420  ;;<Indication>
    421  ;;<PRNFlag>
    422  ;;<Text>@@MEDPRNFLAG@@</Text>
    423  ;;</PRNFlag>
    424  ;;<Problem>
    425  ;;<CCRDataObjectID>@@MEDPROBLEMOBJECTID@@</CCRDataObjectID>
    426  ;;<Type>
    427  ;;<Text>@@MEDPROBLEMTYPETXT@@</Text>
    428  ;;</Type>
    429  ;;<Description>
    430  ;;<Text>@@MEDPROBLEMDESCRIPTION@@</Text>
    431  ;;<Code>
    432  ;;<Value>@@MEDPROBLEMCODEVALUE@@</Value>
    433  ;;<CodingSystem>@@MEDPROBLEMCODINGSYSTEM@@</CodingSystem>
    434  ;;<Version>@@MEDPROBLEMCODINGVERSION@@</Version>
    435  ;;</Code>
    436  ;;</Description>
    437  ;;<Source>
    438  ;;<Actor>
    439  ;;<ActorID>@@MEDPROBLEMSOURCEACTORID@@</ActorID>
    440  ;;</Actor>
    441  ;;</Source>
    442  ;;</Problem>
    443  ;;</Indication>
    444  ;;<StopIndicator>
    445  ;;<Text>@@MEDSTOPINDICATOR@@</Text>
    446  ;;</StopIndicator>
    447  ;;<DirectionSequenceModifier>@@MEDDIRSEQ@@</DirectionSequenceModifier>
    448  ;;<MultipleDirectionModifier>
    449  ;;<Text>@@MEDMULDIRMOD@@</Text>
    450  ;;</MultipleDirectionModifier>
    451  ;;</Direction>
    452  ;;</Directions>
    453  ;;<PatientInstructions>
    454  ;;<Instruction>
    455  ;;<Text>@@MEDPTINSTRUCTIONS@@</Text>
    456  ;;</Instruction>
    457  ;;</PatientInstructions>
    458  ;;<FullfillmentInstructions>
    459  ;;<Text>@@MEDFULLFILLMENTINSTRUCTIONS@@</Text>
    460  ;;</FullfillmentInstructions>
    461  ;;<Refills>
    462  ;;<Refill>
    463  ;;<Number>@@MEDRFNO@@</Number>
    464  ;;</Refill>
    465  ;;</Refills>
    466  ;;</Medication>
    467  ;;</Medications>
    468  ;;<VitalSigns>
    469  ;;<Result>
    470  ;;<CCRDataObjectID>@@VITALSIGNSDATAOBJECTID@@</CCRDataObjectID>
    471  ;;<DateTime>
    472  ;;<Type>
    473  ;;<Text>@@VITALSIGNSDATETIMETYPETEXT@@</Text>
    474  ;;</Type>
    475  ;;<ExactDateTime>@@VITALSIGNSEXACTDATETIME@@</ExactDateTime>
    476  ;;</DateTime>
    477  ;;<Description>
    478  ;;<Text>@@VITALSIGNSDESCRIPTIONTEXT@@</Text>
    479  ;;</Description>
    480  ;;<Source>
    481  ;;<Actor>
    482  ;;<ActorID>@@VITALSIGNSSOURCEACTORID@@</ActorID>
    483  ;;</Actor>
    484  ;;</Source>
    485  ;;<Test>
    486  ;;<CCRDataObjectID>@@VITALSIGNSTESTOBJECTID@@</CCRDataObjectID>
    487  ;;<Type>
    488  ;;<Text>@@VITALSIGNSTESTTYPETEXT@@</Text>
    489  ;;</Type>
    490  ;;<Description>
    491  ;;<Text>@@VITALSIGNSDESCRIPTIONTEXT@@</Text>
    492  ;;<Code>
    493  ;;<Value>@@VITALSIGNSDESCCODEVALUE@@</Value>
    494  ;;<CodingSystem>@@VITALSIGNSDESCCODINGSYSTEM@@</CodingSystem>
    495  ;;<Version>@@VITALSIGNSCODEVERSION@@</Version>
    496  ;;</Code>
    497  ;;</Description>
    498  ;;<Source>
    499  ;;<Actor>
    500  ;;<ActorID>@@VITALSIGNSTESTSOURCEACTORID@@</ActorID>
    501  ;;</Actor>
    502  ;;</Source>
    503  ;;<TestResult>
    504  ;;<Value>@@VITALSIGNSTESTRESULTVALUE@@</Value>
    505  ;;<Units>
    506  ;;<Unit>@@VITALSIGNSTESTRESULTUNIT@@</Unit>
    507  ;;</Units>
    508  ;;</TestResult>
    509  ;;</Test>
    510  ;;</Result>
    511  ;;</VitalSigns>
    512  ;;<Results>
    513  ;;<Result>
    514  ;;<CCRDataObjectID>@@RESULTOBJECTID@@</CCRDataObjectID>
    515  ;;<DateTime>
    516  ;;<Type>
    517  ;;<Text>Assessment Time</Text>
    518  ;;</Type>
    519  ;;<ExactDateTime>@@RESULTASSESSMENTDATETIME@@</ExactDateTime>
    520  ;;</DateTime>
    521  ;;<Description>
    522  ;;<Text>@@RESULTDESCRIPTIONTEXT@@</Text>
    523  ;;<Code>
    524  ;;<Value>@@RESULTCODE@@</Value>
    525  ;;<CodingSystem>@@RESULTCODINGSYSTEM@@</CodingSystem>
    526  ;;</Code>
    527  ;;</Description>
    528  ;;<Status>
    529  ;;<Text>@@RESULTSTATUS@@</Text>
    530  ;;</Status>
    531  ;;<Source>
    532  ;;<Actor>
    533  ;;<ActorID>@@RESULTSOURCEACTORID@@</ActorID>
    534  ;;</Actor>
    535  ;;</Source>
    536  ;;<Test>
    537  ;;<CCRDataObjectID>@@RESULTTESTOBJECTID@@</CCRDataObjectID>
    538  ;;<DateTime>
    539  ;;<Type>
    540  ;;<Text>Assessment Time</Text>
    541  ;;</Type>
    542  ;;<ExactDateTime>@@RESULTTESTDATETIME@@</ExactDateTime>
    543  ;;</DateTime>
    544  ;;<Description>
    545  ;;<Text>@@RESULTTESTDESCRIPTIONTEXT@@</Text>
    546  ;;<Code>
    547  ;;<Value>@@RESULTTESTCODEVALUE@@</Value>
    548  ;;<CodingSystem>@@RESULTTESTCODINGSYSTEM@@</CodingSystem>
    549  ;;</Code>
    550  ;;</Description>
    551  ;;<Status>
    552  ;;<Text>@@RESULTTESTSTATUSTEXT@@</Text>
    553  ;;</Status>
    554  ;;<Source>
    555  ;;<Actor>
    556  ;;<ActorID>@@RESULTTESTSOURCEACTORID@@</ActorID>
    557  ;;</Actor>
    558  ;;</Source>
    559  ;;<TestResult>
    560  ;;<Value>@@RESULTTESTVALUE@@</Value>
    561  ;;<Units>
    562  ;;<Unit>@@RESULTTESTUNITS@@</Unit>
    563  ;;</Units>
    564  ;;</TestResult>
    565  ;;<NormalResult>
    566  ;;<Normal>
    567  ;;<Description>
    568  ;;<Text>@@RESULTTESTNORMALDESCTEXT@@</Text>
    569  ;;</Description>
    570  ;;<Source>
    571  ;;<Actor>
    572  ;;<ActorID>@@RESULTTESTNORMALSOURCEACTORID@@</ActorID>
    573  ;;</Actor>
    574  ;;</Source>
    575  ;;</Normal>
    576  ;;</NormalResult>
    577  ;;<Flag>
    578  ;;<Text>@@RESULTTESTFLAG@@</Text>
    579  ;;</Flag>
    580  ;;</Test>
    581  ;;</Result>
    582  ;;</Results>
    583  ;;<Procedures>
    584  ;;<Procedure>
    585  ;;<CCRDataObjectID>@@PROCOBJECTID@@</CCRDataObjectID>
    586  ;;<DateTime>
    587  ;;<Type>
    588  ;;<Text>@@PROCDATETEXT@@</Text>
    589  ;;</Type>
    590  ;;<ExactDateTime>@@PROCDATETIME@@</ExactDateTime>
    591  ;;</DateTime>
    592  ;;<Description>
    593  ;;<Text>@@PROCDESCTEXT@@</Text>
    594  ;;<ObjectAttribute>
    595  ;;<Attribute>@@PROCDESCOBJATTR@@</Attribute>
    596  ;;<AttributeValue>
    597  ;;<Value>@@PROCDESCOBJATTRVAL@@</Value>
    598  ;;<Code>
    599  ;;<Value>@@PROCDESCOBJATTRCODE@@</Value>
    600  ;;<CodingSystem>@@PROCDESCOBJATTRCODESYS@@</CodingSystem>
    601  ;;</Code>
    602  ;;</AttributeValue>
    603  ;;</ObjectAttribute>
    604  ;;<Code>
    605  ;;<Value>@@PROCCODE@@</Value>
    606  ;;<CodingSystem>@@PROCCODESYS@@</CodingSystem>
    607  ;;</Code>
    608  ;;</Description>
    609  ;;<Status>
    610  ;;<Text>@@PROCSTATUS@@</Text>
    611  ;;</Status>
    612  ;;<Source>
    613  ;;<Actor>
    614  ;;<ActorID>@@PROCACTOROBJID@@</ActorID>
    615  ;;</Actor>
    616  ;;</Source>
    617  ;;<InternalCCRLink>
    618  ;;<LinkID>@@PROCLINKID@@</LinkID>
    619  ;;<LinkRelationship>@@PROCLINKREL@@</LinkRelationship>
    620  ;;</InternalCCRLink>
    621  ;;</Procedure>
    622  ;;</Procedures>
    623  ;;<Encounters>
    624  ;;<Encounter>
    625  ;;<CCRDataObjectID>@@ENCOBJECTID@@</CCRDataObjectID>
    626  ;;<DateTime>
    627  ;;<ExactDateTime>@@ENCDATETIME@@</ExactDateTime>
    628  ;;</DateTime>
    629  ;;<Type>
    630  ;;<Text>@@ENCTYPETXT@@</Text>
    631  ;;<Code>
    632  ;;<Value>@@ENCTYPECODE@@</Value>
    633  ;;<CodingSystem>@@ENCTYPECODESYS@@</CodingSystem>
    634  ;;</Code>
    635  ;;</Type>
    636  ;;<Description>
    637  ;;<Text>@@ENCDESCTXT@@</Text>
    638  ;;<Code>
    639  ;;<Value>@@ENCDESCCODE@@</Value>
    640  ;;<CodingSystem>@@ENCDESCCODESYS@@</CodingSystem>
    641  ;;</Code>
    642  ;;</Description>
    643  ;;<Location>
    644  ;;<Actor>
    645  ;;<ActorID>@@ENCLOCACTORID@@</ActorID>
    646  ;;</Actor>
    647  ;;</Location>
    648  ;;<Practioner>
    649  ;;<Actor>
    650  ;;<ActorID>@@ENCPRVACTORID@@</ActorID>
    651  ;;</Actor>
    652  ;;</Practioner>
    653  ;;<Indication>
    654  ;;<Text>@@ENCINDTXT@@</Text>
    655  ;;<Code>
    656  ;;<Value>@@ENCINDCODE@@</Value>
    657  ;;<CodingSystem>@@ENCINDCODESYS@@</CodingSystem>
    658  ;;</Code>
    659  ;;</Indication>
    660  ;;<Source>
    661  ;;<Actor>
    662  ;;<ActorID>@@ENCACTORID@@</ActorID>
    663  ;;</Actor>
    664  ;;</Source>
    665  ;;<CommentID>@@ENCCOMMENTID@@</CommentID>
    666  ;;</Encounter>
    667  ;;</Encounters>
    668  ;;<HealthCareProviders>
    669  ;;<Provider>
    670  ;;<ActorID>AA0005</ActorID>
    671  ;;<ActorRole>
    672  ;;<Text>Primary Provider</Text>
    673  ;;</ActorRole>
    674  ;;</Provider>
    675  ;;</HealthCareProviders>
    676  ;;</Body>
    677  ;;<Actors>
    678  ;;<ACTOR-PATIENT>
    679  ;;<Actor>
    680  ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
    681  ;;<Person>
    682  ;;<Name>
    683  ;;<CurrentName>
    684  ;;<Given>@@ACTORGIVENNAME@@</Given>
    685  ;;<Middle>@@ACTORMIDDLENAME@@</Middle>
    686  ;;<Family>@@ACTORFAMILYNAME@@</Family>
    687  ;;</CurrentName>
    688  ;;</Name>
    689  ;;<DateOfBirth>
    690  ;;<ExactDateTime>@@ACTORDATEOFBIRTH@@</ExactDateTime>
    691  ;;</DateOfBirth>
    692  ;;<Gender>
    693  ;;<Text>@@ACTORGENDER@@</Text>
    694  ;;<Code>
    695  ;;<Value>@@ACTORGENDERCODE@@</Value>
    696  ;;<CodingSystem>HL7 AdministrativeGender</CodingSystem>
    697  ;;</Code>
    698  ;;</Gender>
    699  ;;</Person>
    700  ;;<IDs>
    701  ;;<Type>
    702  ;;<Text>@@ACTORSSNTEXT@@</Text>
    703  ;;</Type>
    704  ;;<ID>@@ACTORSSN@@</ID>
    705  ;;<Source>
    706  ;;<Actor>
    707  ;;<ActorID>@@ACTORSSNSOURCEID@@</ActorID>
    708  ;;</Actor>
    709  ;;</Source>
    710  ;;</IDs>
    711  ;;<Address>
    712  ;;<Type>
    713  ;;<Text>@@ACTORADDRESSTYPE@@</Text>
    714  ;;</Type>
    715  ;;<Line1>@@ACTORADDRESSLINE1@@</Line1>
    716  ;;<Line2>@@ACTORADDRESSLINE2@@</Line2>
    717  ;;<City>@@ACTORADDRESSCITY@@</City>
    718  ;;<State>@@ACTORADDRESSSTATE@@</State>
    719  ;;<PostalCode>@@ACTORADDRESSZIPCODE@@</PostalCode>
    720  ;;</Address>
    721  ;;<Telephone>
    722  ;;<Value>@@ACTORRESTEL@@</Value>
    723  ;;<Type>
    724  ;;<Text>@@ACTORRESTELTEXT@@</Text>
    725  ;;</Type>
    726  ;;</Telephone>
    727  ;;<Telephone>
    728  ;;<Value>@@ACTORWORKTEL@@</Value>
    729  ;;<Type>
    730  ;;<Text>@@ACTORWORKTELTEXT@@</Text>
    731  ;;</Type>
    732  ;;</Telephone>
    733  ;;<Telephone>
    734  ;;<Value>@@ACTORCELLTEL@@</Value>
    735  ;;<Type>
    736  ;;<Text>@@ACTORCELLTELTEXT@@</Text>
    737  ;;</Type>
    738  ;;</Telephone>
    739  ;;<EMail>
    740  ;;<Value>@@ACTOREMAIL@@</Value>
    741  ;;</EMail>
    742  ;;<Source>
    743  ;;<Actor>
    744  ;;<ActorID>@@ACTORADDRESSSOURCEID@@</ActorID>
    745  ;;</Actor>
    746  ;;</Source>
    747  ;;</Actor>
    748  ;;</ACTOR-PATIENT>
    749  ;;<ACTOR-SYSTEM>
    750  ;;<Actor>
    751  ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
    752  ;;<InformationSystem>
    753  ;;<Name>@@ACTORINFOSYSNAME@@</Name>
    754  ;;<Version>@@ACTORINFOSYSVER@@</Version>
    755  ;;</InformationSystem>
    756  ;;<Source>
    757  ;;<Actor>
    758  ;;<ActorID>@@ACTORINFOSYSSOURCEID@@</ActorID>
    759  ;;</Actor>
    760  ;;</Source>
    761  ;;</Actor>
    762  ;;</ACTOR-SYSTEM>
    763  ;;<ACTOR-NOK>
    764  ;;<Actor>
    765  ;;<ActorObjectID>AA0003</ActorObjectID>
    766  ;;<Person>
    767  ;;<Name>
    768  ;;<DisplayName>@@ACTORDISPLAYNAME@@</DisplayName>
    769  ;;</Name>
    770  ;;</Person>
    771  ;;<Relation>
    772  ;;<Text>@@ACTORRELATION@@</Text>
    773  ;;</Relation>
    774  ;;<Source>
    775  ;;<Actor>
    776  ;;<ActorID>@@ACTORRELATIONSOURCEID@@</ActorID>
    777  ;;</Actor>
    778  ;;</Source>
    779  ;;</Actor>
    780  ;;</ACTOR-NOK>
    781  ;;<ACTOR-PROVIDER>
    782  ;;<Actor>
    783  ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
    784  ;;<Person>
    785  ;;<Name>
    786  ;;<CurrentName>
    787  ;;<Given>@@ACTORGIVENNAME@@</Given>
    788  ;;<Middle>@@ACTORMIDDLENAME@@</Middle>
    789  ;;<Family>@@ACTORFAMILYNAME@@</Family>
    790  ;;<Title>@@ACTORTITLE@@</Title>
    791  ;;</CurrentName>
    792  ;;</Name>
    793  ;;</Person>
    794  ;;<Specialty>
    795  ;;<Text>@@ACTORSPECIALITY@@</Text>
    796  ;;</Specialty>
    797  ;;<Address>
    798  ;;<Type>
    799  ;;<Text>@@ACTORADDRESSTYPE@@</Text>
    800  ;;</Type>
    801  ;;<Line1>@@ACTORADDRESSLINE1@@</Line1>
    802  ;;<City>@@ACTORADDRESSCITY@@</City>
    803  ;;<State>@@ACTORADDRESSSTATE@@</State>
    804  ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode>
    805  ;;</Address>
    806  ;;<Telephone>
    807  ;;<Value>@@ACTORTELEPHONE@@</Value>
    808  ;;<Type>
    809  ;;<Text>@@ACTORTELEPHONETYPE@@</Text>
    810  ;;</Type>
    811  ;;</Telephone>
    812  ;;<Email>
    813  ;;<Value>@@ACTOREMAIL@@</Value>
    814  ;;</Email>
    815  ;;<Source>
    816  ;;<Actor>
    817  ;;<ActorID>@@ACTORSOURCEID@@</ActorID>
    818  ;;</Actor>
    819  ;;</Source>
    820  ;;<InternalCCRLink>
    821  ;;<LinkID>@@ACTORORGLINK@@</LinkID>
    822  ;;<LinkRelationship>representedOrganization</LinkRelationship>
    823  ;;</InternalCCRLink>
    824  ;;</Actor>
    825  ;;</ACTOR-PROVIDER>
    826  ;;<ACTOR-ORG>
    827  ;;<Actor>
    828  ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
    829  ;;<Organization>
    830  ;;<Name>@@ORGANIZATIONNAME@@</Name>
    831  ;;</Organization>
    832  ;;<Address>
    833  ;;<Type>
    834  ;;<Text>@@ACTORADDRESSTYPE@@</Text>
    835  ;;</Type>
    836  ;;<Line1>@@ACTORADDRESSLINE1@@</Line1>
    837  ;;<City>@@ACTORADDRESSCITY@@</City>
    838  ;;<State>@@ACTORADDRESSSTATE@@</State>
    839  ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode>
    840  ;;</Address>
    841  ;;<Telephone>
    842  ;;<Value>@@ACTORTELEPHONE@@</Value>
    843  ;;<Type>
    844  ;;<Text>@@ACTORTELEPHONETYPE@@</Text>
    845  ;;</Type>
    846  ;;</Telephone>
    847  ;;<Source>
    848  ;;<Actor>
    849  ;;<ActorID>@@ACTORSOURCEID@@</ActorID>
    850  ;;</Actor>
    851  ;;</Source>
    852  ;;</Actor>
    853  ;;</ACTOR-ORG>
    854  ;;</Actors>
    855  ;;<Signatures>
    856  ;;<CCRSignature>
    857  ;;<SignatureObjectID>S0001</SignatureObjectID>
    858  ;;<ExactDateTime>2008-03-18T23:10:58Z</ExactDateTime>
    859  ;;<Source>
    860  ;;<ActorID>AA0001</ActorID>
    861  ;;</Source>
    862  ;;<Signature>
    863  ;;<Signature xmlns="http://www.w3.org/2000/09/xmldsig#">
    864  ;;<SignedInfo>
    865  ;;<CanonicalizationMethod Algorithm="http://www.w3.org/TR/2001/REC-xml-c14n-20010315"/>
    866  ;;<SignatureMethod Algorithm="http://www.w3.org/2000/09/xmldsig#rsa-sha1"/>
    867  ;;<Reference URI="">
    868  ;;<Transforms>
    869  ;;<Transform Algorithm="http://www.w3.org/2000/09/xmldsig#enveloped-signature"/>
    870  ;;</Transforms>
    871  ;;<DigestMethod Algorithm="http://www.w3.org/2000/09/xmldsig#sha1"/>
    872  ;;<DigestValue>YFveLLyo+75P7rSciv0/m1O6Ot4=</DigestValue>
    873  ;;</Reference>
    874  ;;</SignedInfo>
    875  ;;<SignatureValue>Bj6sACXl74hrlbUYnu8HqnRab5VGy69BOYjOH7dETxgppXMEd7AoVYaePZvgJft78JR4oQY76hbFyGcIslYauPpJxx2hCd5d56xFeaQg01R6AQOvGnhjlq63TbpFdUq0B4tYsmiibJPbQJhTQe+TcWTBvWaQt8Fkk5blO571YvI=</SignatureValue>
    876  ;;<KeyInfo>
    877  ;;<KeyValue>
    878  ;;<RSAKeyValue>
    879  ;;<Modulus>meH817QYol+/uUEg6j8Mg89s7GTlaN9B+/CGlzrtnQH+swMigZRnEPxHVO8PhEymP/W9nlhAjTScV/CUzA9yJ9WiaOn17c+KReKhfBqL24DX9BpbJ+kLYVz7mBO5Qydk5AzUT2hFwW93irD8iRKP+/t+2Mi2CjNfj8VTjJpHpm0=</Modulus>
    880  ;;<Exponent>AQAB</Exponent>
    881  ;;</RSAKeyValue>
    882  ;;</KeyValue>
    883  ;;</KeyInfo>
    884  ;;</Signature>
    885  ;;</Signature>
    886  ;;</CCRSignature>
    887  ;;</Signatures>
    888  ;;<Comments>
    889  ;;<Comment>
    890  ;;<CommentObjectID>@@COMMENTOBJECTID@@</CommentObjectID>
    891  ;;<DateTime>
    892  ;;<ExactDateTime>@@CMTDATETIME@@</ExactDateTime>
    893  ;;</DateTime>
    894  ;;<Description>
    895  ;;<Text>
    896  ;;</Text>
    897  ;;</Description>
    898  ;;<Source>
    899  ;;<Actor>
    900  ;;<ActorID>@@ACTORSOURCEID@@</ActorID>
    901  ;;</Actor>
    902  ;;</Source>
    903  ;;</Comment>
    904  ;;</Comments>
    905  ;;</ContinuityOfCareRecord>
    906  ;</TEMPLATE>
     1C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        W "This is a CCR TEMPLATE with processing routines",!
     22        W !
     23        Q
     24        ;
     25ZT(ZARY,BAT,LINE)             ; private routine to add a line to the ZARY array
     26        ; ZARY IS PASSED BY NAME
     27        ; BAT is a string identifying the section
     28        ; LINE is a test which will evaluate to true or false
     29        ; I '$G(@ZARY) D  ;
     30        ; . S @ZARY@(0)=0 ; initially there are no elements
     31        ; . W "GOT HERE LOADING "_LINE,!
     32        N CNT ; count of array elements
     33        S CNT=@ZARY@(0) ; contains array count
     34        S CNT=CNT+1 ; increment count
     35        S @ZARY@(CNT)=LINE ; put the line in the array
     36        ; S @ZARY@(BAT,CNT)="" ; index the test by battery
     37        S @ZARY@(0)=CNT ; update the array counter
     38        Q
     39        ;
     40ZLOAD(ZARY,ROUTINE)          ; load tests into ZARY which is passed by reference
     41        ; ZARY IS PASSED BY NAME
     42        ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
     43        ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
     44        K @ZARY S @ZARY=""
     45        S @ZARY@(0)=0 ; initialize array count
     46        N LINE,LABEL,BODY
     47        N INTEST S INTEST=0 ; switch for in the TEMPLATE section
     48        N SECTION S SECTION="[anonymous]" ; NO section LABEL
     49        ;
     50        N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
     51        . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section
     52        . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section
     53        . I INTEST  D  ; within the section
     54        . . I LINE?." "1";><".E  D  ; sub-section name found
     55        . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name
     56        . . I LINE?." "1";;".E  D  ; line found
     57        . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array
     58        Q
     59        ;
     60LOAD(ARY)       ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME
     61        D ZLOAD(ARY,"C0CCCR0")
     62        ; ZWR @ARY
     63        Q
     64        ;
     65        ;<TEMPLATE>
     66        ;;<?xml version="1.0" encoding="UTF-8"?>
     67        ;;<?xml-stylesheet type="text/xsl" href="ccr.xsl"?>
     68        ;;<ContinuityOfCareRecord xmlns="urn:astm-org:CCR">
     69        ;;<CCRDocumentObjectID>@@CCRDOCOBJECTID@@</CCRDocumentObjectID>
     70        ;;<Language>
     71        ;;<Text>English</Text>
     72        ;;</Language>
     73        ;;<Version>V1.0</Version>
     74        ;;<DateTime>
     75        ;;<ExactDateTime>@@DATETIME@@</ExactDateTime>
     76        ;;</DateTime>
     77        ;;<Patient>
     78        ;;<ActorID>@@ACTORPATIENT@@</ActorID>
     79        ;;</Patient>
     80        ;;<From>
     81        ;;<ActorLink>
     82        ;;<ActorID>@@ACTORFROM@@</ActorID>
     83        ;;</ActorLink>
     84        ;;<ActorLink>
     85        ;;<ActorID>@@ACTORFROM2@@</ActorID>
     86        ;;</ActorLink>
     87        ;;</From>
     88        ;;<To>
     89        ;;<ActorLink>
     90        ;;<ActorID>@@ACTORTO@@</ActorID>
     91        ;;<ActorRole>
     92        ;;<Text>@@ACTORTOTEXT@@</Text>
     93        ;;</ActorRole>
     94        ;;</ActorLink>
     95        ;;</To>
     96        ;;<Purpose>
     97        ;;<Description>
     98        ;;<Text>@@PURPOSEDESCRIPTION@@</Text>
     99        ;;</Description>
     100        ;;</Purpose>
     101        ;;<Body>
     102        ;;<Problems>
     103        ;;<Problem>
     104        ;;<CCRDataObjectID>@@PROBLEMOBJECTID@@</CCRDataObjectID>
     105        ;;<DateTime>
     106        ;;<ExactDateTime>@@PROBLEMDATEMOD@@</ExactDateTime>
     107        ;;</DateTime>
     108        ;;<Type>
     109        ;;<Text>Problem</Text>
     110        ;;</Type>
     111        ;;<Description>
     112        ;;<Text>@@PROBLEMDESCRIPTION@@</Text>
     113        ;;<Code>
     114        ;;<Value>@@PROBLEMCODEVALUE@@</Value>
     115        ;;<CodingSystem>ICD9CM</CodingSystem>
     116        ;;<Version>@@PROBLEMCODINGVERSION@@</Version>
     117        ;;</Code>
     118        ;;</Description>
     119        ;;<Status>
     120        ;;<Text>@@PROBLEMSTATUS@@</Text>
     121        ;;</Status>
     122        ;;<Source>
     123        ;;<Actor>
     124        ;;<ActorID>@@PROBLEMSOURCEACTORID@@</ActorID>
     125        ;;</Actor>
     126        ;;</Source>
     127        ;;</Problem>
     128        ;;</Problems>
     129        ;;<Immunizations>
     130        ;;<Immunization>
     131        ;;<CCRDataObjectID>@@IMMUNEOBJECTID@@</CCRDataObjectID>
     132        ;;<DateTime>
     133        ;;<Type>
     134        ;;<Text>@@IMMUNEDATETIMETYPETEXT@@</Text>
     135        ;;</Type>
     136        ;;<ExactDateTime>@@IMMUNEDATETIME@@</ExactDateTime>
     137        ;;</DateTime>
     138        ;;<Source>
     139        ;;<Actor>
     140        ;;<ActorID>@@IMMUNESOURCEACTORID@@</ActorID>
     141        ;;</Actor>
     142        ;;</Source>
     143        ;;<Product>
     144        ;;<ProductName>
     145        ;;<Text>@@IMMUNEPRODUCTNAMETEXT@@</Text>
     146        ;;<Code>
     147        ;;<Value>@@IMMUNEPRODUCTCODE@@</Value>
     148        ;;<CodingSystem>@@IMMUNEPRODUCTCODESYSTEM@@</CodingSystem>
     149        ;;</Code>
     150        ;;</ProductName>
     151        ;;</Product>
     152        ;;</Immunization>
     153        ;;</Immunizations>
     154        ;;<FamilyHistory>
     155        ;;<FamilyProblemHistory>
     156        ;;<CCRDataObjectID>@@FAMILYHISTORYOBJECTID@@</CCRDataObjectID>
     157        ;;<Source>
     158        ;;<Actor>
     159        ;;<ActorID>@@FAMILYHISTORYACTORID@@</ActorID>
     160        ;;</Actor>
     161        ;;</Source>
     162        ;;<FamilyMember>
     163        ;;<ActorID>@@FAMILYMEMBERACTORID@@</ActorID>
     164        ;;<ActorRole>
     165        ;;<Text>@@FAMILYMEMBERACTORROLETEXT@@</Text>
     166        ;;</ActorRole>
     167        ;;<Source>
     168        ;;<Actor>
     169        ;;<ActorID>@@FAMILYMEMBERSOURCACTORID@@</ActorID>
     170        ;;</Actor>
     171        ;;</Source>
     172        ;;</FamilyMember>
     173        ;;<Problem>
     174        ;;<Type>
     175        ;;<Text>Problem</Text>
     176        ;;</Type>
     177        ;;<Description>
     178        ;;<Text>@@FAMILYMEMBERPROBLEMDESCRIPTION@@</Text>
     179        ;;<Code>
     180        ;;<Value>@@FAMILYMEMBERPROBLEMCODE@@</Value>
     181        ;;<CodingSystem>@@FAMILYMEMBERCODESYSTEM@@</CodingSystem>
     182        ;;<Version>@@FAMILYMEMBERCODEVERSION@@</Version>
     183        ;;</Code>
     184        ;;</Description>
     185        ;;<Source>
     186        ;;<Actor>
     187        ;;<ActorID>@@FAMILYMEMBERPROBLEMSOURCEID@@</ActorID>
     188        ;;</Actor>
     189        ;;</Source>
     190        ;;</Problem>
     191        ;;</FamilyProblemHistory>
     192        ;;</FamilyHistory>
     193        ;;<SocialHistory>
     194        ;;<SocialHistoryElement>
     195        ;;<CCRDataObjectID>@@SOCIALHISTORYOBJECTID@@</CCRDataObjectID>
     196        ;;<Type>
     197        ;;<Text>@@SOCIALHISTORYTYPETEXT@@</Text>
     198        ;;</Type>
     199        ;;<Description>
     200        ;;<Text>@@SOCIALHISTORYDESCRIPTIONTEXT@@</Text>
     201        ;;</Description>
     202        ;;<Source>
     203        ;;<Actor>
     204        ;;<ActorID>@@SOCIALHISTORYSOURCACTORID@@</ActorID>
     205        ;;</Actor>
     206        ;;</Source>
     207        ;;</SocialHistoryElement>
     208        ;;<SocialHistoryElement>
     209        ;;<CCRDataObjectID>BB0005</CCRDataObjectID>
     210        ;;<Type>
     211        ;;<Text>Ethnic Origin</Text>
     212        ;;</Type>
     213        ;;<Description>
     214        ;;<Text>Not Hispanic or Latino</Text>
     215        ;;</Description>
     216        ;;<Source>
     217        ;;<Actor>
     218        ;;<ActorID>AA0001</ActorID>
     219        ;;</Actor>
     220        ;;</Source>
     221        ;;</SocialHistoryElement>
     222        ;;<SocialHistoryElement>
     223        ;;<CCRDataObjectID>BB0006</CCRDataObjectID>
     224        ;;<Type>
     225        ;;<Text>Race</Text>
     226        ;;</Type>
     227        ;;<Description>
     228        ;;<Text>White</Text>
     229        ;;</Description>
     230        ;;<Source>
     231        ;;<Actor>
     232        ;;<ActorID>AA0001</ActorID>
     233        ;;</Actor>
     234        ;;</Source>
     235        ;;</SocialHistoryElement>
     236        ;;<SocialHistoryElement>
     237        ;;<CCRDataObjectID>BB0007</CCRDataObjectID>
     238        ;;<Type>
     239        ;;<Text>Occupation</Text>
     240        ;;</Type>
     241        ;;<Description>
     242        ;;<Text>Physician</Text>
     243        ;;</Description>
     244        ;;<Source>
     245        ;;<Actor>
     246        ;;<ActorID>AA0001</ActorID>
     247        ;;</Actor>
     248        ;;</Source>
     249        ;;</SocialHistoryElement>
     250        ;;</SocialHistory>
     251        ;;<Alerts>
     252        ;;<Alert>
     253        ;;<CCRDataObjectID>@@ALERTOBJECTID@@</CCRDataObjectID>
     254        ;;<DateTime>
     255        ;;<ExactDateTime>@@ALERTDATETIME@@</ExactDateTime>
     256        ;;</DateTime>
     257        ;;<Type>
     258        ;;<Text>@@ALERTTYPE@@</Text>
     259        ;;</Type>
     260        ;;<Status>
     261        ;;<Text>@@ALERTSTATUSTEXT@@</Text>
     262        ;;</Status>
     263        ;;<Description>
     264        ;;<Text>@@ALERTDESCRIPTIONTEXT@@</Text>
     265        ;;<Code>
     266        ;;<Value>@@ALERTCODEVALUE@@</Value>
     267        ;;<CodingSystem>@@ALERTCODESYSTEM@@</CodingSystem>
     268        ;;</Code>
     269        ;;</Description>
     270        ;;<Source>
     271        ;;<Actor>
     272        ;;<ActorID>@@ALERTSOURCEID@@</ActorID>
     273        ;;</Actor>
     274        ;;</Source>
     275        ;;<Agent>
     276        ;;<Products>
     277        ;;<Product>
     278        ;;<CCRDataObjectID>@@ALERTAGENTPRODUCTOBJECTID@@</CCRDataObjectID>
     279        ;;<Source>
     280        ;;<Actor>
     281        ;;<ActorID>@@ALERTSOURCEID@@</ActorID>
     282        ;;</Actor>
     283        ;;</Source>
     284        ;;<Product>
     285        ;;<ProductName>
     286        ;;<Text>@@ALERTAGENTPRODUCTNAMETEXT@@</Text>
     287        ;;<Code>
     288        ;;<Value>@@ALERTAGENTPRODUCTCODEVALUE@@</Value>
     289        ;;<CodingSystem>@@ALERTAGENTPRODUCTCODESYSTEM@@</CodingSystem>
     290        ;;</Code>
     291        ;;</ProductName>
     292        ;;</Product>
     293        ;;</Product>
     294        ;;</Products>
     295        ;;</Agent>
     296        ;;<Reaction>
     297        ;;<Description>
     298        ;;<Text>@@ALERTREACTIOINDESCRIPTIONTEXT@@</Text>
     299        ;;<Code>
     300        ;;<Value>@@ALERTREACTIONCODEVALUE@@</Value>
     301        ;;<CodingSystem>@@ALERTREACTIONCODESYSTEM@@</CodingSystem>
     302        ;;</Code>
     303        ;;</Description>
     304        ;;</Reaction>
     305        ;;</Alert>
     306        ;;</Alerts>
     307        ;;<Medications>
     308        ;;<Medication>
     309        ;;<CCRDataObjectID>@@MEDOBJECTID@@</CCRDataObjectID>
     310        ;;<DateTime>
     311        ;;<Type>
     312        ;;<Text>@@MEDISSUEDATETXT@@</Text>
     313        ;;</Type>
     314        ;;<ExactDateTime>@@MEDISSUEDATE@@</ExactDateTime>
     315        ;;</DateTime>
     316        ;;<DateTime>
     317        ;;<Type>
     318        ;;<Text>@@MEDLASTFILLDATETXT@@</Text>
     319        ;;</Type>
     320        ;;<ExactDateTime>@@MEDLASTFILLDATE@@</ExactDateTime>
     321        ;;</DateTime>
     322        ;;<IDs>
     323        ;;<Type>
     324        ;;<Text>@@MEDRXNOTXT@@</Text>
     325        ;;</Type>
     326        ;;<ID>@@MEDRXNO@@</ID>
     327        ;;</IDs>
     328        ;;<Type>
     329        ;;<Text>@@MEDTYPETEXT@@</Text>
     330        ;;</Type>
     331        ;;<Description>
     332        ;;<Text>@@MEDDETAILUNADORNED@@</Text>
     333        ;;</Description>
     334        ;;<Status>
     335        ;;<Text>@@MEDSTATUSTEXT@@</Text>
     336        ;;</Status>
     337        ;;<Source>
     338        ;;<Actor>
     339        ;;<ActorID>@@MEDSOURCEACTORID@@</ActorID>
     340        ;;</Actor>
     341        ;;</Source>
     342        ;;<Product>
     343        ;;<ProductName>
     344        ;;<Text>@@MEDPRODUCTNAMETEXT@@</Text>
     345        ;;<Code>
     346        ;;<Value>@@MEDPRODUCTNAMECODEVALUE@@</Value>
     347        ;;<CodingSystem>@@MEDPRODUCTNAMECODINGINGSYSTEM@@</CodingSystem>
     348        ;;<Version>@@MEDPRODUCTNAMECODEVERSION@@</Version>
     349        ;;</Code>
     350        ;;</ProductName>
     351        ;;<BrandName>
     352        ;;<Text>@@MEDBRANDNAMETEXT@@</Text>
     353        ;;</BrandName>
     354        ;;<Strength>
     355        ;;<Value>@@MEDSTRENGTHVALUE@@</Value>
     356        ;;<Units>
     357        ;;<Unit>@@MEDSTRENGTHUNIT@@</Unit>
     358        ;;</Units>
     359        ;;</Strength>
     360        ;;<Form>
     361        ;;<Text>@@MEDFORMTEXT@@</Text>
     362        ;;</Form>
     363        ;;<Concentration>
     364        ;;<Value>@@MEDCONCVALUE@@</Value>
     365        ;;<Units>
     366        ;;<Unit>@@MEDCONCUNIT@@</Unit>
     367        ;;</Units>
     368        ;;</Concentration>
     369        ;;</Product>
     370        ;;<Quantity>
     371        ;;<Value>@@MEDQUANTITYVALUE@@</Value>
     372        ;;<Units>
     373        ;;<Unit>@@MEDQUANTITYUNIT@@</Unit>
     374        ;;</Units>
     375        ;;</Quantity>
     376        ;;<Directions>
     377        ;;<Direction>
     378        ;;<Description>
     379        ;;<Text>@@MEDDIRECTIONDESCRIPTIONTEXT@@</Text>
     380        ;;</Description>
     381        ;;<DoseIndicator>
     382        ;;<Text>@@MEDDOSEINDICATOR@@</Text>
     383        ;;</DoseIndicator>
     384        ;;<DeliveryMethod>
     385        ;;<Text>@@MEDDELIVERYMETHOD@@</Text>
     386        ;;</DeliveryMethod>
     387        ;;<Dose>
     388        ;;<Value>@@MEDDOSEVALUE@@</Value>
     389        ;;<Units>
     390        ;;<Unit>@@MEDDOSEUNIT@@</Unit>
     391        ;;</Units>
     392        ;;<Rate>
     393        ;;<Value>@@MEDRATEVALUE@@</Value>
     394        ;;<Units>
     395        ;;<Unit>@@MEDRATEUNIT@@</Unit>
     396        ;;</Units>
     397        ;;</Rate>
     398        ;;</Dose>
     399        ;;<Vehicle>
     400        ;;<Text>@@MEDVEHICLETEXT@@</Text>
     401        ;;</Vehicle>
     402        ;;<Route>
     403        ;;<Text>@@MEDDIRECTIONROUTETEXT@@</Text>
     404        ;;</Route>
     405        ;;<Frequency>
     406        ;;<Value>@@MEDFREQUENCYVALUE@@</Value>
     407        ;;</Frequency>
     408        ;;<Interval>
     409        ;;<Value>@@MEDINTERVALVALUE@@</Value>
     410        ;;<Units>
     411        ;;<Unit>@@MEDINTERVALUNIT@@</Unit>
     412        ;;</Units>
     413        ;;</Interval>
     414        ;;<Duration>
     415        ;;<Value>@@MEDDURATIONVALUE@@</Value>
     416        ;;<Units>
     417        ;;<Unit>@@MEDDURATIONUNIT@@</Unit>
     418        ;;</Units>
     419        ;;</Duration>
     420        ;;<Indication>
     421        ;;<PRNFlag>
     422        ;;<Text>@@MEDPRNFLAG@@</Text>
     423        ;;</PRNFlag>
     424        ;;<Problem>
     425        ;;<CCRDataObjectID>@@MEDPROBLEMOBJECTID@@</CCRDataObjectID>
     426        ;;<Type>
     427        ;;<Text>@@MEDPROBLEMTYPETXT@@</Text>
     428        ;;</Type>
     429        ;;<Description>
     430        ;;<Text>@@MEDPROBLEMDESCRIPTION@@</Text>
     431        ;;<Code>
     432        ;;<Value>@@MEDPROBLEMCODEVALUE@@</Value>
     433        ;;<CodingSystem>@@MEDPROBLEMCODINGSYSTEM@@</CodingSystem>
     434        ;;<Version>@@MEDPROBLEMCODINGVERSION@@</Version>
     435        ;;</Code>
     436        ;;</Description>
     437        ;;<Source>
     438        ;;<Actor>
     439        ;;<ActorID>@@MEDPROBLEMSOURCEACTORID@@</ActorID>
     440        ;;</Actor>
     441        ;;</Source>
     442        ;;</Problem>
     443        ;;</Indication>
     444        ;;<StopIndicator>
     445        ;;<Text>@@MEDSTOPINDICATOR@@</Text>
     446        ;;</StopIndicator>
     447        ;;<DirectionSequenceModifier>@@MEDDIRSEQ@@</DirectionSequenceModifier>
     448        ;;<MultipleDirectionModifier>
     449        ;;<Text>@@MEDMULDIRMOD@@</Text>
     450        ;;</MultipleDirectionModifier>
     451        ;;</Direction>
     452        ;;</Directions>
     453        ;;<PatientInstructions>
     454        ;;<Instruction>
     455        ;;<Text>@@MEDPTINSTRUCTIONS@@</Text>
     456        ;;</Instruction>
     457        ;;</PatientInstructions>
     458        ;;<FullfillmentInstructions>
     459        ;;<Text>@@MEDFULLFILLMENTINSTRUCTIONS@@</Text>
     460        ;;</FullfillmentInstructions>
     461        ;;<Refills>
     462        ;;<Refill>
     463        ;;<Number>@@MEDRFNO@@</Number>
     464        ;;</Refill>
     465        ;;</Refills>
     466        ;;</Medication>
     467        ;;</Medications>
     468        ;;<VitalSigns>
     469        ;;<Result>
     470        ;;<CCRDataObjectID>@@VITALSIGNSDATAOBJECTID@@</CCRDataObjectID>
     471        ;;<DateTime>
     472        ;;<Type>
     473        ;;<Text>@@VITALSIGNSDATETIMETYPETEXT@@</Text>
     474        ;;</Type>
     475        ;;<ExactDateTime>@@VITALSIGNSEXACTDATETIME@@</ExactDateTime>
     476        ;;</DateTime>
     477        ;;<Description>
     478        ;;<Text>@@VITALSIGNSDESCRIPTIONTEXT@@</Text>
     479        ;;</Description>
     480        ;;<Source>
     481        ;;<Actor>
     482        ;;<ActorID>@@VITALSIGNSSOURCEACTORID@@</ActorID>
     483        ;;</Actor>
     484        ;;</Source>
     485        ;;<Test>
     486        ;;<CCRDataObjectID>@@VITALSIGNSTESTOBJECTID@@</CCRDataObjectID>
     487        ;;<Type>
     488        ;;<Text>@@VITALSIGNSTESTTYPETEXT@@</Text>
     489        ;;</Type>
     490        ;;<Description>
     491        ;;<Text>@@VITALSIGNSDESCRIPTIONTEXT@@</Text>
     492        ;;<Code>
     493        ;;<Value>@@VITALSIGNSDESCCODEVALUE@@</Value>
     494        ;;<CodingSystem>@@VITALSIGNSDESCCODINGSYSTEM@@</CodingSystem>
     495        ;;<Version>@@VITALSIGNSCODEVERSION@@</Version>
     496        ;;</Code>
     497        ;;</Description>
     498        ;;<Source>
     499        ;;<Actor>
     500        ;;<ActorID>@@VITALSIGNSTESTSOURCEACTORID@@</ActorID>
     501        ;;</Actor>
     502        ;;</Source>
     503        ;;<TestResult>
     504        ;;<Value>@@VITALSIGNSTESTRESULTVALUE@@</Value>
     505        ;;<Units>
     506        ;;<Unit>@@VITALSIGNSTESTRESULTUNIT@@</Unit>
     507        ;;</Units>
     508        ;;</TestResult>
     509        ;;</Test>
     510        ;;</Result>
     511        ;;</VitalSigns>
     512        ;;<Results>
     513        ;;<Result>
     514        ;;<CCRDataObjectID>@@RESULTOBJECTID@@</CCRDataObjectID>
     515        ;;<DateTime>
     516        ;;<Type>
     517        ;;<Text>Assessment Time</Text>
     518        ;;</Type>
     519        ;;<ExactDateTime>@@RESULTASSESSMENTDATETIME@@</ExactDateTime>
     520        ;;</DateTime>
     521        ;;<Description>
     522        ;;<Text>@@RESULTDESCRIPTIONTEXT@@</Text>
     523        ;;<Code>
     524        ;;<Value>@@RESULTCODE@@</Value>
     525        ;;<CodingSystem>@@RESULTCODINGSYSTEM@@</CodingSystem>
     526        ;;</Code>
     527        ;;</Description>
     528        ;;<Status>
     529        ;;<Text>@@RESULTSTATUS@@</Text>
     530        ;;</Status>
     531        ;;<Source>
     532        ;;<Actor>
     533        ;;<ActorID>@@RESULTSOURCEACTORID@@</ActorID>
     534        ;;</Actor>
     535        ;;</Source>
     536        ;;<Test>
     537        ;;<CCRDataObjectID>@@RESULTTESTOBJECTID@@</CCRDataObjectID>
     538        ;;<DateTime>
     539        ;;<Type>
     540        ;;<Text>Assessment Time</Text>
     541        ;;</Type>
     542        ;;<ExactDateTime>@@RESULTTESTDATETIME@@</ExactDateTime>
     543        ;;</DateTime>
     544        ;;<Description>
     545        ;;<Text>@@RESULTTESTDESCRIPTIONTEXT@@</Text>
     546        ;;<Code>
     547        ;;<Value>@@RESULTTESTCODEVALUE@@</Value>
     548        ;;<CodingSystem>@@RESULTTESTCODINGSYSTEM@@</CodingSystem>
     549        ;;</Code>
     550        ;;</Description>
     551        ;;<Status>
     552        ;;<Text>@@RESULTTESTSTATUSTEXT@@</Text>
     553        ;;</Status>
     554        ;;<Source>
     555        ;;<Actor>
     556        ;;<ActorID>@@RESULTTESTSOURCEACTORID@@</ActorID>
     557        ;;</Actor>
     558        ;;</Source>
     559        ;;<TestResult>
     560        ;;<Value>@@RESULTTESTVALUE@@</Value>
     561        ;;<Units>
     562        ;;<Unit>@@RESULTTESTUNITS@@</Unit>
     563        ;;</Units>
     564        ;;</TestResult>
     565        ;;<NormalResult>
     566        ;;<Normal>
     567        ;;<Description>
     568        ;;<Text>@@RESULTTESTNORMALDESCTEXT@@</Text>
     569        ;;</Description>
     570        ;;<Source>
     571        ;;<Actor>
     572        ;;<ActorID>@@RESULTTESTNORMALSOURCEACTORID@@</ActorID>
     573        ;;</Actor>
     574        ;;</Source>
     575        ;;</Normal>
     576        ;;</NormalResult>
     577        ;;<Flag>
     578        ;;<Text>@@RESULTTESTFLAG@@</Text>
     579        ;;</Flag>
     580        ;;</Test>
     581        ;;</Result>
     582        ;;</Results>
     583        ;;<Procedures>
     584        ;;<Procedure>
     585        ;;<CCRDataObjectID>@@PROCOBJECTID@@</CCRDataObjectID>
     586        ;;<DateTime>
     587        ;;<Type>
     588        ;;<Text>@@PROCDATETEXT@@</Text>
     589        ;;</Type>
     590        ;;<ExactDateTime>@@PROCDATETIME@@</ExactDateTime>
     591        ;;</DateTime>
     592        ;;<Description>
     593        ;;<Text>@@PROCDESCTEXT@@</Text>
     594        ;;<ObjectAttribute>
     595        ;;<Attribute>@@PROCDESCOBJATTR@@</Attribute>
     596        ;;<AttributeValue>
     597        ;;<Value>@@PROCDESCOBJATTRVAL@@</Value>
     598        ;;<Code>
     599        ;;<Value>@@PROCDESCOBJATTRCODE@@</Value>
     600        ;;<CodingSystem>@@PROCDESCOBJATTRCODESYS@@</CodingSystem>
     601        ;;</Code>
     602        ;;</AttributeValue>
     603        ;;</ObjectAttribute>
     604        ;;<Code>
     605        ;;<Value>@@PROCCODE@@</Value>
     606        ;;<CodingSystem>@@PROCCODESYS@@</CodingSystem>
     607        ;;</Code>
     608        ;;</Description>
     609        ;;<Status>
     610        ;;<Text>@@PROCSTATUS@@</Text>
     611        ;;</Status>
     612        ;;<Source>
     613        ;;<Actor>
     614        ;;<ActorID>@@PROCACTOROBJID@@</ActorID>
     615        ;;</Actor>
     616        ;;</Source>
     617        ;;<InternalCCRLink>
     618        ;;<LinkID>@@PROCLINKID@@</LinkID>
     619        ;;<LinkRelationship>@@PROCLINKREL@@</LinkRelationship>
     620        ;;</InternalCCRLink>
     621        ;;</Procedure>
     622        ;;</Procedures>
     623        ;;<Encounters>
     624        ;;<Encounter>
     625        ;;<CCRDataObjectID>@@ENCOBJECTID@@</CCRDataObjectID>
     626        ;;<DateTime>
     627        ;;<ExactDateTime>@@ENCDATETIME@@</ExactDateTime>
     628        ;;</DateTime>
     629        ;;<Type>
     630        ;;<Text>@@ENCTYPETXT@@</Text>
     631        ;;<Code>
     632        ;;<Value>@@ENCTYPECODE@@</Value>
     633        ;;<CodingSystem>@@ENCTYPECODESYS@@</CodingSystem>
     634        ;;</Code>
     635        ;;</Type>
     636        ;;<Description>
     637        ;;<Text>@@ENCDESCTXT@@</Text>
     638        ;;<Code>
     639        ;;<Value>@@ENCDESCCODE@@</Value>
     640        ;;<CodingSystem>@@ENCDESCCODESYS@@</CodingSystem>
     641        ;;</Code>
     642        ;;</Description>
     643        ;;<Location>
     644        ;;<Actor>
     645        ;;<ActorID>@@ENCLOCACTORID@@</ActorID>
     646        ;;</Actor>
     647        ;;</Location>
     648        ;;<Practioner>
     649        ;;<Actor>
     650        ;;<ActorID>@@ENCPRVACTORID@@</ActorID>
     651        ;;</Actor>
     652        ;;</Practioner>
     653        ;;<Indication>
     654        ;;<Text>@@ENCINDTXT@@</Text>
     655        ;;<Code>
     656        ;;<Value>@@ENCINDCODE@@</Value>
     657        ;;<CodingSystem>@@ENCINDCODESYS@@</CodingSystem>
     658        ;;</Code>
     659        ;;</Indication>
     660        ;;<Source>
     661        ;;<Actor>
     662        ;;<ActorID>@@ENCACTORID@@</ActorID>
     663        ;;</Actor>
     664        ;;</Source>
     665        ;;<CommentID>@@ENCCOMMENTID@@</CommentID>
     666        ;;</Encounter>
     667        ;;</Encounters>
     668        ;;<HealthCareProviders>
     669        ;;<Provider>
     670        ;;<ActorID>AA0005</ActorID>
     671        ;;<ActorRole>
     672        ;;<Text>Primary Provider</Text>
     673        ;;</ActorRole>
     674        ;;</Provider>
     675        ;;</HealthCareProviders>
     676        ;;</Body>
     677        ;;<Actors>
     678        ;;<ACTOR-PATIENT>
     679        ;;<Actor>
     680        ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
     681        ;;<Person>
     682        ;;<Name>
     683        ;;<CurrentName>
     684        ;;<Given>@@ACTORGIVENNAME@@</Given>
     685        ;;<Middle>@@ACTORMIDDLENAME@@</Middle>
     686        ;;<Family>@@ACTORFAMILYNAME@@</Family>
     687        ;;</CurrentName>
     688        ;;</Name>
     689        ;;<DateOfBirth>
     690        ;;<ExactDateTime>@@ACTORDATEOFBIRTH@@</ExactDateTime>
     691        ;;</DateOfBirth>
     692        ;;<Gender>
     693        ;;<Text>@@ACTORGENDER@@</Text>
     694        ;;<Code>
     695        ;;<Value>@@ACTORGENDERCODE@@</Value>
     696        ;;<CodingSystem>HL7 AdministrativeGender</CodingSystem>
     697        ;;</Code>
     698        ;;</Gender>
     699        ;;</Person>
     700        ;;<IDs>
     701        ;;<Type>
     702        ;;<Text>@@ACTORSSNTEXT@@</Text>
     703        ;;</Type>
     704        ;;<ID>@@ACTORSSN@@</ID>
     705        ;;<Source>
     706        ;;<Actor>
     707        ;;<ActorID>@@ACTORSSNSOURCEID@@</ActorID>
     708        ;;</Actor>
     709        ;;</Source>
     710        ;;</IDs>
     711        ;;<Address>
     712        ;;<Type>
     713        ;;<Text>@@ACTORADDRESSTYPE@@</Text>
     714        ;;</Type>
     715        ;;<Line1>@@ACTORADDRESSLINE1@@</Line1>
     716        ;;<Line2>@@ACTORADDRESSLINE2@@</Line2>
     717        ;;<City>@@ACTORADDRESSCITY@@</City>
     718        ;;<State>@@ACTORADDRESSSTATE@@</State>
     719        ;;<PostalCode>@@ACTORADDRESSZIPCODE@@</PostalCode>
     720        ;;</Address>
     721        ;;<Telephone>
     722        ;;<Value>@@ACTORRESTEL@@</Value>
     723        ;;<Type>
     724        ;;<Text>@@ACTORRESTELTEXT@@</Text>
     725        ;;</Type>
     726        ;;</Telephone>
     727        ;;<Telephone>
     728        ;;<Value>@@ACTORWORKTEL@@</Value>
     729        ;;<Type>
     730        ;;<Text>@@ACTORWORKTELTEXT@@</Text>
     731        ;;</Type>
     732        ;;</Telephone>
     733        ;;<Telephone>
     734        ;;<Value>@@ACTORCELLTEL@@</Value>
     735        ;;<Type>
     736        ;;<Text>@@ACTORCELLTELTEXT@@</Text>
     737        ;;</Type>
     738        ;;</Telephone>
     739        ;;<EMail>
     740        ;;<Value>@@ACTOREMAIL@@</Value>
     741        ;;</EMail>
     742        ;;<Source>
     743        ;;<Actor>
     744        ;;<ActorID>@@ACTORADDRESSSOURCEID@@</ActorID>
     745        ;;</Actor>
     746        ;;</Source>
     747        ;;</Actor>
     748        ;;</ACTOR-PATIENT>
     749        ;;<ACTOR-SYSTEM>
     750        ;;<Actor>
     751        ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
     752        ;;<InformationSystem>
     753        ;;<Name>@@ACTORINFOSYSNAME@@</Name>
     754        ;;<Version>@@ACTORINFOSYSVER@@</Version>
     755        ;;</InformationSystem>
     756        ;;<Source>
     757        ;;<Actor>
     758        ;;<ActorID>@@ACTORINFOSYSSOURCEID@@</ActorID>
     759        ;;</Actor>
     760        ;;</Source>
     761        ;;</Actor>
     762        ;;</ACTOR-SYSTEM>
     763        ;;<ACTOR-NOK>
     764        ;;<Actor>
     765        ;;<ActorObjectID>AA0003</ActorObjectID>
     766        ;;<Person>
     767        ;;<Name>
     768        ;;<DisplayName>@@ACTORDISPLAYNAME@@</DisplayName>
     769        ;;</Name>
     770        ;;</Person>
     771        ;;<Relation>
     772        ;;<Text>@@ACTORRELATION@@</Text>
     773        ;;</Relation>
     774        ;;<Source>
     775        ;;<Actor>
     776        ;;<ActorID>@@ACTORRELATIONSOURCEID@@</ActorID>
     777        ;;</Actor>
     778        ;;</Source>
     779        ;;</Actor>
     780        ;;</ACTOR-NOK>
     781        ;;<ACTOR-PROVIDER>
     782        ;;<Actor>
     783        ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
     784        ;;<Person>
     785        ;;<Name>
     786        ;;<CurrentName>
     787        ;;<Given>@@ACTORGIVENNAME@@</Given>
     788        ;;<Middle>@@ACTORMIDDLENAME@@</Middle>
     789        ;;<Family>@@ACTORFAMILYNAME@@</Family>
     790        ;;<Title>@@ACTORTITLE@@</Title>
     791        ;;</CurrentName>
     792        ;;</Name>
     793        ;;</Person>
     794        ;;<Specialty>
     795        ;;<Text>@@ACTORSPECIALITY@@</Text>
     796        ;;</Specialty>
     797        ;;<Address>
     798        ;;<Type>
     799        ;;<Text>@@ACTORADDRESSTYPE@@</Text>
     800        ;;</Type>
     801        ;;<Line1>@@ACTORADDRESSLINE1@@</Line1>
     802        ;;<City>@@ACTORADDRESSCITY@@</City>
     803        ;;<State>@@ACTORADDRESSSTATE@@</State>
     804        ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode>
     805        ;;</Address>
     806        ;;<Telephone>
     807        ;;<Value>@@ACTORTELEPHONE@@</Value>
     808        ;;<Type>
     809        ;;<Text>@@ACTORTELEPHONETYPE@@</Text>
     810        ;;</Type>
     811        ;;</Telephone>
     812        ;;<Email>
     813        ;;<Value>@@ACTOREMAIL@@</Value>
     814        ;;</Email>
     815        ;;<Source>
     816        ;;<Actor>
     817        ;;<ActorID>@@ACTORSOURCEID@@</ActorID>
     818        ;;</Actor>
     819        ;;</Source>
     820        ;;<InternalCCRLink>
     821        ;;<LinkID>@@ACTORORGLINK@@</LinkID>
     822        ;;<LinkRelationship>representedOrganization</LinkRelationship>
     823        ;;</InternalCCRLink>
     824        ;;</Actor>
     825        ;;</ACTOR-PROVIDER>
     826        ;;<ACTOR-ORG>
     827        ;;<Actor>
     828        ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
     829        ;;<Organization>
     830        ;;<Name>@@ORGANIZATIONNAME@@</Name>
     831        ;;</Organization>
     832        ;;<Address>
     833        ;;<Type>
     834        ;;<Text>@@ACTORADDRESSTYPE@@</Text>
     835        ;;</Type>
     836        ;;<Line1>@@ACTORADDRESSLINE1@@</Line1>
     837        ;;<City>@@ACTORADDRESSCITY@@</City>
     838        ;;<State>@@ACTORADDRESSSTATE@@</State>
     839        ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode>
     840        ;;</Address>
     841        ;;<Telephone>
     842        ;;<Value>@@ACTORTELEPHONE@@</Value>
     843        ;;<Type>
     844        ;;<Text>@@ACTORTELEPHONETYPE@@</Text>
     845        ;;</Type>
     846        ;;</Telephone>
     847        ;;<Source>
     848        ;;<Actor>
     849        ;;<ActorID>@@ACTORSOURCEID@@</ActorID>
     850        ;;</Actor>
     851        ;;</Source>
     852        ;;</Actor>
     853        ;;</ACTOR-ORG>
     854        ;;</Actors>
     855        ;;<Signatures>
     856        ;;<CCRSignature>
     857        ;;<SignatureObjectID>S0001</SignatureObjectID>
     858        ;;<ExactDateTime>2008-03-18T23:10:58Z</ExactDateTime>
     859        ;;<Source>
     860        ;;<ActorID>AA0001</ActorID>
     861        ;;</Source>
     862        ;;<Signature>
     863        ;;<Signature xmlns="http://www.w3.org/2000/09/xmldsig#">
     864        ;;<SignedInfo>
     865        ;;<CanonicalizationMethod Algorithm="http://www.w3.org/TR/2001/REC-xml-c14n-20010315"/>
     866        ;;<SignatureMethod Algorithm="http://www.w3.org/2000/09/xmldsig#rsa-sha1"/>
     867        ;;<Reference URI="">
     868        ;;<Transforms>
     869        ;;<Transform Algorithm="http://www.w3.org/2000/09/xmldsig#enveloped-signature"/>
     870        ;;</Transforms>
     871        ;;<DigestMethod Algorithm="http://www.w3.org/2000/09/xmldsig#sha1"/>
     872        ;;<DigestValue>YFveLLyo+75P7rSciv0/m1O6Ot4=</DigestValue>
     873        ;;</Reference>
     874        ;;</SignedInfo>
     875        ;;<SignatureValue>Bj6sACXl74hrlbUYnu8HqnRab5VGy69BOYjOH7dETxgppXMEd7AoVYaePZvgJft78JR4oQY76hbFyGcIslYauPpJxx2hCd5d56xFeaQg01R6AQOvGnhjlq63TbpFdUq0B4tYsmiibJPbQJhTQe+TcWTBvWaQt8Fkk5blO571YvI=</SignatureValue>
     876        ;;<KeyInfo>
     877        ;;<KeyValue>
     878        ;;<RSAKeyValue>
     879        ;;<Modulus>meH817QYol+/uUEg6j8Mg89s7GTlaN9B+/CGlzrtnQH+swMigZRnEPxHVO8PhEymP/W9nlhAjTScV/CUzA9yJ9WiaOn17c+KReKhfBqL24DX9BpbJ+kLYVz7mBO5Qydk5AzUT2hFwW93irD8iRKP+/t+2Mi2CjNfj8VTjJpHpm0=</Modulus>
     880        ;;<Exponent>AQAB</Exponent>
     881        ;;</RSAKeyValue>
     882        ;;</KeyValue>
     883        ;;</KeyInfo>
     884        ;;</Signature>
     885        ;;</Signature>
     886        ;;</CCRSignature>
     887        ;;</Signatures>
     888        ;;<Comments>
     889        ;;<Comment>
     890        ;;<CommentObjectID>@@COMMENTOBJECTID@@</CommentObjectID>
     891        ;;<DateTime>
     892        ;;<ExactDateTime>@@CMTDATETIME@@</ExactDateTime>
     893        ;;</DateTime>
     894        ;;<Description>
     895        ;;<Text>
     896        ;;</Text>
     897        ;;</Description>
     898        ;;<Source>
     899        ;;<Actor>
     900        ;;<ActorID>@@ACTORSOURCEID@@</ActorID>
     901        ;;</Actor>
     902        ;;</Source>
     903        ;;</Comment>
     904        ;;</Comments>
     905        ;;</ContinuityOfCareRecord>
     906        ;</TEMPLATE>

  • ccr/branches/ohum/p/C0CCMT.m

    r1342 r1428  
    1 C0CCMT  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10
    2  ;;1.0;C0C;;May 21, 2010;Build 2
    3  ;Copyright 2010 George Lilly, University of Minnesota and others.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  W "NO ENTRY FROM TOP",!
    22  Q
    23  ;
    24 EXTRACT(NOTEXML,DFN,NOTEOUT) ; EXTRACT NOTES INTO  XML TEMPLATE
    25  ; NOTEXML AND NOTEOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
    26  ;
    27  D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES
    28  ;I '$D(@C0CNTE) Q  ; NO NOTES AVAILABLE
    29  D MAP(NOTEXML,C0CNTE,NOTEOUT) ;MAP RESULTS FOR NOTES
    30  Q
    31  ;
    32 MAP(NOTEXML,C0CNTE,NOTEOUT) ; MAP PROCEDURES XML
    33  ;
    34  N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"NOTETEMP")) ;WORK AREA FOR TEMPLATE
    35  K @ZTEMP
    36  N ZBLD
    37  S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"NOTEBLD")) ; BUILD LIST AREA
    38  D QUEUE^C0CXPATH(ZBLD,NOTEXML,1,1) ; FIRST LINE
    39  N ZINNER
    40  D QUERY^C0CXPATH(NOTEXML,"//Comments/Comment","ZINNER") ;ONE NOTE
    41  N ZTMP,ZVAR,ZI
    42  S ZI=""
    43  F  S ZI=$O(@C0CNTE@(ZI)) Q:ZI=""  D  ;FOR EACH NOTE
    44  . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS NOTE XML
    45  . S ZVAR=$NA(@C0CNTE@(ZI)) ;THIS NOTE VARIABLES
    46  . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE
    47  . N ZNOTE,ZN
    48  . D CLEAN($NA(@C0CNTE@(ZI,"TEXT"))) ;REMOVE CONTROL CHARS AND XML RESERVED
    49  . M ZNOTE=@C0CNTE@(ZI,"TEXT") ;THE NOTE TO ADD TO THE BUILD
    50  . S ZNOTE(0)=$O(ZNOTE(""),-1) ;LENGTH OF THE NOTE
    51  . D INSERT^C0CXPATH(ZTMP,"ZNOTE","//Comment/Description/Text")
    52  . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD
    53  D QUEUE^C0CXPATH(ZBLD,NOTEXML,@NOTEXML@(0),@NOTEXML@(0))
    54  N ZZTMP
    55  D BUILD^C0CXPATH(ZBLD,NOTEOUT) ;BUILD FINAL XML
    56  K @ZTEMP,@ZBLD,@C0CNTE
    57  Q
    58  ; 
    59 CLEAN(INARY) ; INARY IS PASSED BY NAME
    60  ; REMOVE CONTROL CHARACTERS AND XML RESERVED SYMBOLS FROM THE ARRAY
    61  N ZI,ZJ S ZI=""
    62  F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ;
    63  . S @INARY@(ZI)=$$CLEAN^C0CXPATH(@INARY@(ZI)) ; CONTROL CHARS
    64  . S @INARY@(ZI)=$$SYMENC^MXMLUTL(@INARY@(ZI)) ; XML RESERVED SYMBOLS
    65  Q
    66  ;
     1C0CCMT  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2010 George Lilly, University of Minnesota and others.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        W "NO ENTRY FROM TOP",!
     22        Q
     23        ;
     24EXTRACT(NOTEXML,DFN,NOTEOUT)    ; EXTRACT NOTES INTO  XML TEMPLATE
     25        ; NOTEXML AND NOTEOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
     26        ;
     27        D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES
     28        ;I '$D(@C0CNTE) Q  ; NO NOTES AVAILABLE
     29        D MAP(NOTEXML,C0CNTE,NOTEOUT) ;MAP RESULTS FOR NOTES
     30        Q
     31        ;
     32MAP(NOTEXML,C0CNTE,NOTEOUT)     ; MAP PROCEDURES XML
     33        ;
     34        N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"NOTETEMP")) ;WORK AREA FOR TEMPLATE
     35        K @ZTEMP
     36        N ZBLD
     37        S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"NOTEBLD")) ; BUILD LIST AREA
     38        D QUEUE^C0CXPATH(ZBLD,NOTEXML,1,1) ; FIRST LINE
     39        N ZINNER
     40        D QUERY^C0CXPATH(NOTEXML,"//Comments/Comment","ZINNER") ;ONE NOTE
     41        N ZTMP,ZVAR,ZI
     42        S ZI=""
     43        F  S ZI=$O(@C0CNTE@(ZI)) Q:ZI=""  D  ;FOR EACH NOTE
     44        . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS NOTE XML
     45        . S ZVAR=$NA(@C0CNTE@(ZI)) ;THIS NOTE VARIABLES
     46        . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE
     47        . N ZNOTE,ZN
     48        . D CLEAN($NA(@C0CNTE@(ZI,"TEXT"))) ;REMOVE CONTROL CHARS AND XML RESERVED
     49        . M ZNOTE=@C0CNTE@(ZI,"TEXT") ;THE NOTE TO ADD TO THE BUILD
     50        . S ZNOTE(0)=$O(ZNOTE(""),-1) ;LENGTH OF THE NOTE
     51        . D INSERT^C0CXPATH(ZTMP,"ZNOTE","//Comment/Description/Text")
     52        . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD
     53        D QUEUE^C0CXPATH(ZBLD,NOTEXML,@NOTEXML@(0),@NOTEXML@(0))
     54        N ZZTMP
     55        D BUILD^C0CXPATH(ZBLD,NOTEOUT) ;BUILD FINAL XML
     56        K @ZTEMP,@ZBLD,@C0CNTE
     57        Q
     58        ; 
     59CLEAN(INARY)    ; INARY IS PASSED BY NAME
     60        ; REMOVE CONTROL CHARACTERS AND XML RESERVED SYMBOLS FROM THE ARRAY
     61        N ZI,ZJ S ZI=""
     62        F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ;
     63        . S @INARY@(ZI)=$$CLEAN^C0CXPATH(@INARY@(ZI)) ; CONTROL CHARS
     64        . S @INARY@(ZI)=$$SYMENC^MXMLUTL(@INARY@(ZI)) ; XML RESERVED SYMBOLS
     65        Q
     66        ;

  • ccr/branches/ohum/p/C0CCPT.m

    r1342 r1428  
    1 C0CCPT ;;BSL;RETURN CPT DATA;
    2  ;Sequence Managers Software GPL;;;;;Build 2
    3  ;Copied into C0C namespace from SQMCPT with permission from
    4  ;Brian Lord - and with our thanks. gpl 01/20/2010
    5 ENTRY(DFN,STDT,ENDDT,TXT) ;BUILD TOTAL ARRAY OF ALL IEN'S FOR TIU NOTES
    6  ;DFN=PATIENT IEN
    7  ;STDT=START DATE IN 3100101 FORMAT (VA YEAR YYYMMDD)
    8  ;ENDDT=END DATE IN 3100101 FORMAT
    9  ;TXT=INCLUDE TEXT FROM ENCOUNTER NOTE
    10  ;THAT FALL INSIDE DATA RANGE. IF NO STDT OR ENDDT ASSUME
    11         ;ALL INCLUSIVE IN THAT DIRECTION
    12         ;LIST OF TIU DOCS IN ^TIU(8925,"ACLPT",3,DFN)
    13         ;BUILD INTO NOTE(Y)=""
    14         S U="^",X=""
    15         F  S X=$O(^TIU(8925,"ACLPT",3,DFN,X)) Q:X=""  D
    16         . S Y=""
    17         . F  S Y=$O(^TIU(8925,"ACLPT",3,DFN,X,Y)) Q:Y=""  D
    18         .. S NOTE(Y)=""
    19         ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE
    20         ;GET DATE OF NOTE
    21  ;RUT 3120109 Changing DATE in FILMAN's FORMAT
    22  ;;OHUM/RUT 3111228 Date Range for Notes
    23         ;S STDT=^TMP("C0CCCR","TIULIMIT") D NOW^%DTC S ENDDT=X
    24  N FLAGS1,FLAGS2
    25  S FLAGS1=$P(^C0CPARM(1,2),"^",1) S STDT=$$HTOF^C0CVALID(FLAGS1)
    26  S FLAGS2=$P(^C0CPARM(1,2),"^",2) S ENDDT=$$HTOF^C0CVALID(FLAGS2)
    27  ;S STDT=^TMP("C0CCCR","TIULIMIT"),ENDDT=^TMP("C0CCCR","TIUSTART")
    28         ;;OHUM/RUT
    29  ;RUT
    30         S Z=""
    31         F  S Z=$O(NOTE(Z)) Q:Z=""  D
    32         . S DT=$P(^TIU(8925,Z,0),U,7)
    33         . I $G(STDT)]"" D
    34         .. I STDT>DT S NOTE(Z)="D"  ;SET NOTE TO BE DELETED
    35         . I $G(ENDDT)]"" D
    36         .. I ENDDT<DT S NOTE(Z)="D"
    37         . I NOTE(Z)="D" K NOTE(Z)
    38  D VISIT
    39         Q
    40 VISIT   ;GET VISIT INFO FOR A GIVEN NOTE. BUILD INTO RETURN ARRAY .VISIT
    41  S ILST=1,X0="",X12="",VISIT="",LST="",X811=""
    42  S IEN=""  F  S IEN=$O(NOTE(IEN)) Q:IEN=""  D
    43  . S X0=^TIU(8925,IEN,0),X12=$G(^(12))
    44  . S VISIT=$P(X12,U,7)
    45  . I 'VISIT S VISIT=$P(X0,U,3)
    46  . K ^TMP("PXKENC",$J)
    47  . Q:VISIT=""!(VISIT'>0)
    48  . D ENCEVENT^PXKENC(VISIT,1)
    49  . I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q
    50  . S IPRV=0 F  S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV  D
    51  .. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0)
    52  .. ;Q:$P(X0,U,4)'="P"
    53  .. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U)
    54  .. S PRIM=($P(X0,U,4)="P")
    55  .. S ILST=ILST+1
    56  .. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM
    57  .. S VISIT(IEN,"PRV",ILST)=CODE_"^^^"_NARR_"^"_PRIM
    58  . S IPOV=0 F  S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV  D
    59  .. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811))
    60  .. S CODE=$P(X0,U)
    61  .. S:CODE CODE=$P(^ICD9(CODE,0),U)
    62  .. S CAT=$P(X802,U)
    63  .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
    64  .. S NARR=$P(X0,U,4)
    65  .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
    66  .. S PRIM=($P(X0,U,12)="P")
    67  .. S PRV=$P(X12,U,4)
    68  .. S ILST=ILST+1
    69  .. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV
    70  .. S VISIT(IEN,"POV",ILST)=CODE_U_CAT_U_NARR_U_PRIM_U_PRV
    71  . S ICPT=0 F  S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT  D
    72  .. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811))
    73  .. ;S CODE=$P(X0,U)
    74  .. S CODE=$O(^ICPT("B",$P(X0,U),0))
    75  .. S:CODE CODE=$P(^ICPT(CODE,0),U)
    76  .. S CAT=$P(X802,U)
    77  .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
    78  .. S NARR=$P(X0,U,4)
    79  .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
    80  .. S QTY=$P(X0,U,16)
    81  .. S PRV=$P(X12,U,4)
    82  .. S MCNT=0,MIDX=0,MODS=""
    83  .. F  S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX  D
    84  ... S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0))
    85  ... I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN
    86  .. I +MCNT S MODS=MCNT_MODS
    87  .. S ILST=ILST+1
    88  .. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
    89  .. S VISIT(IEN,"CPT",ILST)=CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
    90  . S VISIT(IEN,"DATE",0)=$P($P(^TIU(8925,IEN,0),U,7),".")
    91  . S VISIT(IEN,"CLASS")=$$GET1^DIQ(8925,IEN_",",.04) ;GPL 5/21/10
    92  . I $G(TXT)=1 D GETNOTE(IEN)
    93  Q
    94 GETNOTE(IEN) ;GET THE TEXT THAT GOES WITH VISIT
    95  ;EXTRACT NOTE TEXT FROM ^TIU(8925,IEN,"TEXT"
    96  Q:'$D(VISIT(IEN,"CPT"))
    97  S TXTCNT=0
    98  F  S TXTCNT=TXTCNT+1 Q:'$D(^TIU(8925,IEN,"TEXT",TXTCNT,0))  D
    99  . S VISIT(IEN,"TEXT",TXTCNT)=^TIU(8925,IEN,"TEXT",TXTCNT,0)
    100  Q
     1C0CCPT  ;;BSL;RETURN CPT DATA;
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Sequence Managers Software GPL;;;;;Build 2
     4        ;Copied into C0C namespace from SQMCPT with permission from
     5        ;Brian Lord - and with our thanks. gpl 01/20/2010
     6ENTRY(DFN,STDT,ENDDT,TXT)       ;BUILD TOTAL ARRAY OF ALL IEN'S FOR TIU NOTES
     7        ;DFN=PATIENT IEN
     8        ;STDT=START DATE IN 3100101 FORMAT (VA YEAR YYYMMDD)
     9        ;ENDDT=END DATE IN 3100101 FORMAT
     10        ;TXT=INCLUDE TEXT FROM ENCOUNTER NOTE
     11        ;THAT FALL INSIDE DATA RANGE. IF NO STDT OR ENDDT ASSUME
     12               ;ALL INCLUSIVE IN THAT DIRECTION
     13               ;LIST OF TIU DOCS IN ^TIU(8925,"ACLPT",3,DFN)
     14               ;BUILD INTO NOTE(Y)=""
     15               S U="^",X=""
     16               F  S X=$O(^TIU(8925,"ACLPT",3,DFN,X)) Q:X=""  D
     17               . S Y=""
     18               . F  S Y=$O(^TIU(8925,"ACLPT",3,DFN,X,Y)) Q:Y=""  D
     19               .. S NOTE(Y)=""
     20               ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE
     21               ;GET DATE OF NOTE
     22        ;RUT 3120109 Changing DATE in FILMAN's FORMAT
     23        ;;OHUM/RUT 3111228 Date Range for Notes
     24               ;S STDT=^TMP("C0CCCR","TIULIMIT") D NOW^%DTC S ENDDT=X
     25        N FLAGS1,FLAGS2
     26        S FLAGS1=$P(^C0CPARM(1,2),"^",1) S STDT=$$HTOF^C0CVALID(FLAGS1)
     27        S FLAGS2=$P(^C0CPARM(1,2),"^",2) S ENDDT=$$HTOF^C0CVALID(FLAGS2)
     28        ;S STDT=^TMP("C0CCCR","TIULIMIT"),ENDDT=^TMP("C0CCCR","TIUSTART")
     29               ;;OHUM/RUT
     30        ;RUT
     31               S Z=""
     32               F  S Z=$O(NOTE(Z)) Q:Z=""  D
     33               . S DT=$P(^TIU(8925,Z,0),U,7)
     34               . I $G(STDT)]"" D
     35               .. I STDT>DT S NOTE(Z)="D"  ;SET NOTE TO BE DELETED
     36               . I $G(ENDDT)]"" D
     37               .. I ENDDT<DT S NOTE(Z)="D"
     38               . I NOTE(Z)="D" K NOTE(Z)
     39        D VISIT
     40               Q
     41VISIT     ;GET VISIT INFO FOR A GIVEN NOTE. BUILD INTO RETURN ARRAY .VISIT
     42        S ILST=1,X0="",X12="",VISIT="",LST="",X811=""
     43        S IEN=""  F  S IEN=$O(NOTE(IEN)) Q:IEN=""  D
     44        . S X0=^TIU(8925,IEN,0),X12=$G(^(12))
     45        . S VISIT=$P(X12,U,7)
     46        . I 'VISIT S VISIT=$P(X0,U,3)
     47        . K ^TMP("PXKENC",$J)
     48        . Q:VISIT=""!(VISIT'>0)
     49        . D ENCEVENT^PXKENC(VISIT,1)
     50        . I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q
     51        . S IPRV=0 F  S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV  D
     52        .. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0)
     53        .. ;Q:$P(X0,U,4)'="P"
     54        .. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U)
     55        .. S PRIM=($P(X0,U,4)="P")
     56        .. S ILST=ILST+1
     57        .. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM
     58        .. S VISIT(IEN,"PRV",ILST)=CODE_"^^^"_NARR_"^"_PRIM
     59        . S IPOV=0 F  S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV  D
     60        .. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811))
     61        .. S CODE=$P(X0,U)
     62        .. S:CODE CODE=$P(^ICD9(CODE,0),U)
     63        .. S CAT=$P(X802,U)
     64        .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
     65        .. S NARR=$P(X0,U,4)
     66        .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
     67        .. S PRIM=($P(X0,U,12)="P")
     68        .. S PRV=$P(X12,U,4)
     69        .. S ILST=ILST+1
     70        .. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV
     71        .. S VISIT(IEN,"POV",ILST)=CODE_U_CAT_U_NARR_U_PRIM_U_PRV
     72        . S ICPT=0 F  S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT  D
     73        .. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811))
     74        .. ;S CODE=$P(X0,U)
     75        .. S CODE=$O(^ICPT("B",$P(X0,U),0))
     76        .. S:CODE CODE=$P(^ICPT(CODE,0),U)
     77        .. S CAT=$P(X802,U)
     78        .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
     79        .. S NARR=$P(X0,U,4)
     80        .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
     81        .. S QTY=$P(X0,U,16)
     82        .. S PRV=$P(X12,U,4)
     83        .. S MCNT=0,MIDX=0,MODS=""
     84        .. F  S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX  D
     85        ... S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0))
     86        ... I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN
     87        .. I +MCNT S MODS=MCNT_MODS
     88        .. S ILST=ILST+1
     89        .. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
     90        .. S VISIT(IEN,"CPT",ILST)=CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
     91        . S VISIT(IEN,"DATE",0)=$P($P(^TIU(8925,IEN,0),U,7),".")
     92        . S VISIT(IEN,"CLASS")=$$GET1^DIQ(8925,IEN_",",.04) ;GPL 5/21/10
     93        . I $G(TXT)=1 D GETNOTE(IEN)
     94        Q
     95GETNOTE(IEN)    ;GET THE TEXT THAT GOES WITH VISIT
     96        ;EXTRACT NOTE TEXT FROM ^TIU(8925,IEN,"TEXT"
     97        Q:'$D(VISIT(IEN,"CPT"))
     98        S TXTCNT=0
     99        F  S TXTCNT=TXTCNT+1 Q:'$D(^TIU(8925,IEN,"TEXT",TXTCNT,0))  D
     100        . S VISIT(IEN,"TEXT",TXTCNT)=^TIU(8925,IEN,"TEXT",TXTCNT,0)
     101        Q

  • ccr/branches/ohum/p/C0CDIC.m

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

  • ccr/branches/ohum/p/C0CDOM.m

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

  • ccr/branches/ohum/p/C0CDPT.m

    r1342 r1428  
    1 C0CDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;
    4  ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    5  ; General Public License.
    6  ;
    7  ; This program is distributed in the hope that it will be useful,
    8  ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    9  ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    10  ; GNU General Public License for more details.
    11  ;
    12  ; You should have received a copy of the GNU General Public License along
    13  ; with this program; if not, write to the Free Software Foundation, Inc.,
    14  ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    15  ;
    16  ; FAMILY       Family Name
    17  ; GIVEN        Given Name
    18  ; MIDDLE       Middle Name
    19  ; SUFFIX       Suffix Name
    20  ; DISPNAME     Display Name
    21  ; DOB          Date of Birth
    22  ; GENDER       Get Gender
    23  ; SSN          Get SSN for ID
    24  ; ADDRTYPE     Get Home Address
    25  ; ADDR1        Get Home Address line 1
    26  ; ADDR2        Get Home Address line 2
    27  ; CITY         Get City for Home Address
    28  ; STATE        Get State for Home Address
    29  ; ZIP          Get Zip code for Home Address
    30  ; COUNTY       Get County for our Address
    31  ; COUNTRY      Get Country for our Address
    32  ; RESTEL       Residential Telephone
    33  ; WORKTEL      Work Telephone
    34  ; EMAIL        Email Adddress
    35  ; CELLTEL      Cell Phone
    36  ; NOK1FAM      Next of Kin 1 (NOK1) Family Name
    37  ; NOK1GIV      NOK1 Given Name
    38  ; NOK1MID      NOK1 Middle Name
    39  ; NOK1SUF      NOK1 Suffi Name
    40  ; NOK1DISP     NOK1 Display Name
    41  ; NOK1REL      NOK1 Relationship to the patient
    42  ; NOK1ADD1     NOK1 Address 1
    43  ; NOK1ADD2     NOK1 Address 2
    44  ; NOK1CITY     NOK1 City
    45  ; NOK1STAT     NOK1 State
    46  ; NOK1ZIP      NOK1 Zip Code
    47  ; NOK1HTEL     NOK1 Home Telephone
    48  ; NOK1WTEL     NOK1 Work Telephone
    49  ; NOK1SAME     Is NOK1's Address the same the patient?
    50  ; NOK2FAM      NOK2 Family Name
    51  ; NOK2GIV      NOK2 Given Name
    52  ; NOK2MID      NOK2 Middle Name
    53  ; NOK2SUF      NOK2 Suffi Name
    54  ; NOK2DISP     NOK2 Display Name
    55  ; NOK2REL      NOK2 Relationship to the patient
    56  ; NOK2ADD1     NOK2 Address 1
    57  ; NOK2ADD2     NOK2 Address 2
    58  ; NOK2CITY     NOK2 City
    59  ; NOK2STAT     NOK2 State
    60  ; NOK2ZIP      NOK2 Zip Code
    61  ; NOK2HTEL     NOK2 Home Telephone
    62  ; NOK2WTEL     NOK2 Work Telephone
    63  ; NOK2SAME     Is NOK2's Address the same the patient?
    64  ; EMERFAM      Emergency Contact (EMER) Family Name
    65  ; EMERGIV      EMER Given Name
    66  ; EMERMID      EMER Middle Name
    67  ; EMERSUF      EMER Suffi Name
    68  ; EMERDISP     EMER Display Name
    69  ; EMERREL      EMER Relationship to the patient
    70  ; EMERADD1     EMER Address 1
    71  ; EMERADD2     EMER Address 2
    72  ; EMERCITY     EMER City
    73  ; EMERSTAT     EMER State
    74  ; EMERZIP      EMER Zip Code
    75  ; EMERHTEL     EMER Home Telephone
    76  ; EMERWTEL     EMER Work Telephone
    77  ; EMERSAME     Is EMER's Address the same the NOK?
    78  ;
    79  W "No Entry at top!" Q
    80  ;
    81  ;**Revision History**
    82  ; - June 15, 08: v0.1 using merged global
    83  ; - Oct 3, 08: v0.2 using fileman calls, many formatting changes.
    84  ;
    85  ; All methods are Public and Extrinsic
    86  ; All calls use Fileman file 2 (Patient).
    87  ; You can obtain field numbers using the data dictionary
    88  ;
    89 FAMILY(DFN) ; Family Name
    90  N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
    91  D NAMECOMP^XLFNAME(.NAME)
    92  Q NAME("FAMILY")
    93 GIVEN(DFN) ; Given Name
    94  N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
    95  D NAMECOMP^XLFNAME(.NAME)
    96  Q NAME("GIVEN")
    97 MIDDLE(DFN) ; Middle Name
    98  N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
    99  D NAMECOMP^XLFNAME(.NAME)
    100  Q NAME("MIDDLE")
    101 SUFFIX(DFN) ; Suffi Name
    102  N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
    103  D NAMECOMP^XLFNAME(.NAME)
    104  Q NAME("SUFFIX")
    105 DISPNAME(DFN) ; Display Name
    106  N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
    107  ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    108  Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    109 DOB(DFN) ; Date of Birth
    110  N DOB S DOB=$$GET1^DIQ(2,DFN,.03,"I")
    111  ; Date in FM Date Format. Convert to UTC/ISO 8601.
    112  Q $$FMDTOUTC^C0CUTIL(DOB,"D")
    113 GENDER(DFN) ; Gender/Sex
    114  Q $$GET1^DIQ(2,DFN,.02,"I")_"^"_$$GET1^DIQ(2,DFN,.02,"E") ;
    115 SSN(DFN) ; SSN
    116  Q $$GET1^DIQ(2,DFN,.09)
    117 ADDRTYPE(DFN) ; Address Type
    118  ; Vista only stores a home address for the patient.
    119  Q "Home"
    120 ADDR1(DFN) ; Get Home Address line 1
    121  Q $$GET1^DIQ(2,DFN,.111)
    122 ADDR2(DFN) ; Get Home Address line 2
    123  ; Vista has Lines 2,3; CCR has only line 1,2; so compromise
    124  N ADDLN2,ADDLN3
    125  S ADDLN2=$$GET1^DIQ(2,DFN,.112),ADDLN3=$$GET1^DIQ(2,DFN,.113)
    126  Q:ADDLN3="" ADDLN2
    127  Q ADDLN2_", "_ADDLN3
    128 CITY(DFN) ; Get City for Home Address
    129  Q $$GET1^DIQ(2,DFN,.114)
    130 STATE(DFN) ; Get State for Home Address
    131  Q $$GET1^DIQ(2,DFN,.115)
    132 ZIP(DFN) ; Get Zip code for Home Address
    133  Q $$GET1^DIQ(2,DFN,.116)
    134 COUNTY(DFN) ; Get County for our Address
    135  Q $$GET1^DIQ(2,DFN,.117)
    136 COUNTRY(DFN) ; Get Country for our Address
    137  ; Unfortunately, it's not stored anywhere in Vista, so the inevitable...
    138  Q "USA"
    139 RESTEL(DFN) ; Residential Telephone
    140  Q $$GET1^DIQ(2,DFN,.131)
    141 WORKTEL(DFN) ; Work Telephone
    142  Q $$GET1^DIQ(2,DFN,.132)
    143 EMAIL(DFN) ; Email Adddress
    144  Q $$GET1^DIQ(2,DFN,.133)
    145 CELLTEL(DFN) ; Cell Phone
    146  Q $$GET1^DIQ(2,DFN,.134)
    147 NOK1FAM(DFN) ; Next of Kin 1 (NOK1) Family Name
    148  N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
    149  D NAMECOMP^XLFNAME(.NAME)
    150  Q NAME("FAMILY")
    151 NOK1GIV(DFN) ; NOK1 Given Name
    152  N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
    153  D NAMECOMP^XLFNAME(.NAME)
    154  Q NAME("GIVEN")
    155 NOK1MID(DFN) ; NOK1 Middle Name
    156  N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
    157  D NAMECOMP^XLFNAME(.NAME)
    158  Q NAME("MIDDLE")
    159 NOK1SUF(DFN) ; NOK1 Suffi Name
    160  N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
    161  D NAMECOMP^XLFNAME(.NAME)
    162  Q NAME("SUFFIX")
    163 NOK1DISP(DFN) ; NOK1 Display Name
    164  N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
    165  ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    166  Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    167 NOK1REL(DFN) ; NOK1 Relationship to the patient
    168  Q $$GET1^DIQ(2,DFN,.212)
    169 NOK1ADD1(DFN) ; NOK1 Address 1
    170  Q $$GET1^DIQ(2,DFN,.213)
    171 NOK1ADD2(DFN) ; NOK1 Address 2
    172  N ADDLN2,ADDLN3
    173  S ADDLN2=$$GET1^DIQ(2,DFN,.214),ADDLN3=$$GET1^DIQ(2,DFN,.215)
    174  Q:ADDLN3="" ADDLN2
    175  Q ADDLN2_", "_ADDLN3
    176 NOK1CITY(DFN) ; NOK1 City
    177  Q $$GET1^DIQ(2,DFN,.216)
    178 NOK1STAT(DFN) ; NOK1 State
    179  Q $$GET1^DIQ(2,DFN,.217)
    180 NOK1ZIP(DFN) ; NOK1 Zip Code
    181  Q $$GET1^DIQ(2,DFN,.218)
    182 NOK1HTEL(DFN) ; NOK1 Home Telephone
    183  Q $$GET1^DIQ(2,DFN,.219)
    184 NOK1WTEL(DFN) ; NOK1 Work Telephone
    185  Q $$GET1^DIQ(2,DFN,.21011)
    186 NOK1SAME(DFN) ; Is NOK1's Address the same the patient?
    187  Q $$GET1^DIQ(2,DFN,.2125)
    188 NOK2FAM(DFN) ; NOK2 Family Name
    189  N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
    190  D NAMECOMP^XLFNAME(.NAME)
    191  Q NAME("FAMILY")
    192 NOK2GIV(DFN) ; NOK2 Given Name
    193  N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
    194  D NAMECOMP^XLFNAME(.NAME)
    195  Q NAME("GIVEN")
    196 NOK2MID(DFN) ; NOK2 Middle Name
    197  N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
    198  D NAMECOMP^XLFNAME(.NAME)
    199  Q NAME("MIDDLE")
    200 NOK2SUF(DFN) ; NOK2 Suffi Name
    201  N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
    202  D NAMECOMP^XLFNAME(.NAME)
    203  Q NAME("SUFFIX")
    204 NOK2DISP(DFN) ; NOK2 Display Name
    205  N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
    206  ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    207  Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    208 NOK2REL(DFN) ; NOK2 Relationship to the patient
    209  Q $$GET1^DIQ(2,DFN,.2192)
    210 NOK2ADD1(DFN) ; NOK2 Address 1
    211  Q $$GET1^DIQ(2,DFN,.2193)
    212 NOK2ADD2(DFN) ; NOK2 Address 2
    213  N ADDLN2,ADDLN3
    214  S ADDLN2=$$GET1^DIQ(2,DFN,.2194),ADDLN3=$$GET1^DIQ(2,DFN,.2195)
    215  Q:ADDLN3="" ADDLN2
    216  Q ADDLN2_", "_ADDLN3
    217 NOK2CITY(DFN) ; NOK2 City
    218  Q $$GET1^DIQ(2,DFN,.2196)
    219 NOK2STAT(DFN) ; NOK2 State
    220  Q $$GET1^DIQ(2,DFN,.2197)
    221 NOK2ZIP(DFN) ; NOK2 Zip Code
    222  Q $$GET1^DIQ(2,DFN,.2198)
    223 NOK2HTEL(DFN) ; NOK2 Home Telephone
    224  Q $$GET1^DIQ(2,DFN,.2199)
    225 NOK2WTEL(DFN) ; NOK2 Work Telephone
    226  Q $$GET1^DIQ(2,DFN,.211011)
    227 NOK2SAME(DFN) ; Is NOK2's Address the same the patient?
    228  Q $$GET1^DIQ(2,DFN,.21925)
    229 EMERFAM(DFN) ; Emergency Contact (EMER) Family Name
    230  N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
    231  D NAMECOMP^XLFNAME(.NAME)
    232  Q NAME("FAMILY")
    233 EMERGIV(DFN) ; EMER Given Name
    234  N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
    235  D NAMECOMP^XLFNAME(.NAME)
    236  Q NAME("GIVEN")
    237 EMERMID(DFN) ; EMER Middle Name
    238  N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
    239  D NAMECOMP^XLFNAME(.NAME)
    240  Q NAME("MIDDLE")
    241 EMERSUF(DFN) ; EMER Suffi Name
    242  N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
    243  D NAMECOMP^XLFNAME(.NAME)
    244  Q NAME("SUFFIX")
    245 EMERDISP(DFN) ; EMER Display Name
    246  N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
    247  ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    248  Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    249 EMERREL(DFN) ; EMER Relationship to the patient
    250  Q $$GET1^DIQ(2,DFN,.331)
    251 EMERADD1(DFN) ; EMER Address 1
    252  Q $$GET1^DIQ(2,DFN,.333)
    253 EMERADD2(DFN) ; EMER Address 2
    254  N ADDLN2,ADDLN3
    255  S ADDLN2=$$GET1^DIQ(2,DFN,.334),ADDLN3=$$GET1^DIQ(2,DFN,.335)
    256  Q:ADDLN3="" ADDLN2
    257  Q ADDLN2_", "_ADDLN3
    258 EMERCITY(DFN) ; EMER City
    259  Q $$GET1^DIQ(2,DFN,.336)
    260 EMERSTAT(DFN) ; EMER State
    261  Q $$GET1^DIQ(2,DFN,.337)
    262 EMERZIP(DFN) ; EMER Zip Code
    263  Q $$GET1^DIQ(2,DFN,.338)
    264 EMERHTEL(DFN) ; EMER Home Telephone
    265  Q $$GET1^DIQ(2,DFN,.339)
    266 EMERWTEL(DFN) ; EMER Work Telephone
    267  Q $$GET1^DIQ(2,DFN,.33011)
    268 EMERSAME(DFN) ; Is EMER's Address the same the NOK?
    269  Q $$GET1^DIQ(2,DFN,.3305)
     1C0CDPT  ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;
     4        ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     5        ; General Public License.
     6        ;
     7        ; This program is distributed in the hope that it will be useful,
     8        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     9        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     10        ; GNU General Public License for more details.
     11        ;
     12        ; You should have received a copy of the GNU General Public License along
     13        ; with this program; if not, write to the Free Software Foundation, Inc.,
     14        ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     15        ;
     16        ; FAMILY       Family Name
     17        ; GIVEN        Given Name
     18        ; MIDDLE       Middle Name
     19        ; SUFFIX       Suffix Name
     20        ; DISPNAME     Display Name
     21        ; DOB          Date of Birth
     22        ; GENDER       Get Gender
     23        ; SSN          Get SSN for ID
     24        ; ADDRTYPE     Get Home Address
     25        ; ADDR1        Get Home Address line 1
     26        ; ADDR2        Get Home Address line 2
     27        ; CITY         Get City for Home Address
     28        ; STATE        Get State for Home Address
     29        ; ZIP          Get Zip code for Home Address
     30        ; COUNTY       Get County for our Address
     31        ; COUNTRY      Get Country for our Address
     32        ; RESTEL       Residential Telephone
     33        ; WORKTEL      Work Telephone
     34        ; EMAIL        Email Adddress
     35        ; CELLTEL      Cell Phone
     36        ; NOK1FAM      Next of Kin 1 (NOK1) Family Name
     37        ; NOK1GIV      NOK1 Given Name
     38        ; NOK1MID      NOK1 Middle Name
     39        ; NOK1SUF      NOK1 Suffi Name
     40        ; NOK1DISP     NOK1 Display Name
     41        ; NOK1REL      NOK1 Relationship to the patient
     42        ; NOK1ADD1     NOK1 Address 1
     43        ; NOK1ADD2     NOK1 Address 2
     44        ; NOK1CITY     NOK1 City
     45        ; NOK1STAT     NOK1 State
     46        ; NOK1ZIP      NOK1 Zip Code
     47        ; NOK1HTEL     NOK1 Home Telephone
     48        ; NOK1WTEL     NOK1 Work Telephone
     49        ; NOK1SAME     Is NOK1's Address the same the patient?
     50        ; NOK2FAM      NOK2 Family Name
     51        ; NOK2GIV      NOK2 Given Name
     52        ; NOK2MID      NOK2 Middle Name
     53        ; NOK2SUF      NOK2 Suffi Name
     54        ; NOK2DISP     NOK2 Display Name
     55        ; NOK2REL      NOK2 Relationship to the patient
     56        ; NOK2ADD1     NOK2 Address 1
     57        ; NOK2ADD2     NOK2 Address 2
     58        ; NOK2CITY     NOK2 City
     59        ; NOK2STAT     NOK2 State
     60        ; NOK2ZIP      NOK2 Zip Code
     61        ; NOK2HTEL     NOK2 Home Telephone
     62        ; NOK2WTEL     NOK2 Work Telephone
     63        ; NOK2SAME     Is NOK2's Address the same the patient?
     64        ; EMERFAM      Emergency Contact (EMER) Family Name
     65        ; EMERGIV      EMER Given Name
     66        ; EMERMID      EMER Middle Name
     67        ; EMERSUF      EMER Suffi Name
     68        ; EMERDISP     EMER Display Name
     69        ; EMERREL      EMER Relationship to the patient
     70        ; EMERADD1     EMER Address 1
     71        ; EMERADD2     EMER Address 2
     72        ; EMERCITY     EMER City
     73        ; EMERSTAT     EMER State
     74        ; EMERZIP      EMER Zip Code
     75        ; EMERHTEL     EMER Home Telephone
     76        ; EMERWTEL     EMER Work Telephone
     77        ; EMERSAME     Is EMER's Address the same the NOK?
     78        ;
     79        W "No Entry at top!" Q
     80        ;
     81        ;**Revision History**
     82        ; - June 15, 08: v0.1 using merged global
     83        ; - Oct 3, 08: v0.2 using fileman calls, many formatting changes.
     84        ;
     85        ; All methods are Public and Extrinsic
     86        ; All calls use Fileman file 2 (Patient).
     87        ; You can obtain field numbers using the data dictionary
     88        ;
     89FAMILY(DFN)     ; Family Name
     90        N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
     91        D NAMECOMP^XLFNAME(.NAME)
     92        Q NAME("FAMILY")
     93GIVEN(DFN)      ; Given Name
     94        N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
     95        D NAMECOMP^XLFNAME(.NAME)
     96        Q NAME("GIVEN")
     97MIDDLE(DFN)     ; Middle Name
     98        N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
     99        D NAMECOMP^XLFNAME(.NAME)
     100        Q NAME("MIDDLE")
     101SUFFIX(DFN)     ; Suffi Name
     102        N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
     103        D NAMECOMP^XLFNAME(.NAME)
     104        Q NAME("SUFFIX")
     105DISPNAME(DFN)   ; Display Name
     106        N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
     107        ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
     108        Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
     109DOB(DFN)        ; Date of Birth
     110        N DOB S DOB=$$GET1^DIQ(2,DFN,.03,"I")
     111        ; Date in FM Date Format. Convert to UTC/ISO 8601.
     112        Q $$FMDTOUTC^C0CUTIL(DOB,"D")
     113GENDER(DFN)     ; Gender/Sex
     114        Q $$GET1^DIQ(2,DFN,.02,"I")_"^"_$$GET1^DIQ(2,DFN,.02,"E") ;
     115SSN(DFN)        ; SSN
     116        Q $$GET1^DIQ(2,DFN,.09)
     117ADDRTYPE(DFN)   ; Address Type
     118        ; Vista only stores a home address for the patient.
     119        Q "Home"
     120ADDR1(DFN)      ; Get Home Address line 1
     121        Q $$GET1^DIQ(2,DFN,.111)
     122ADDR2(DFN)      ; Get Home Address line 2
     123        ; Vista has Lines 2,3; CCR has only line 1,2; so compromise
     124        N ADDLN2,ADDLN3
     125        S ADDLN2=$$GET1^DIQ(2,DFN,.112),ADDLN3=$$GET1^DIQ(2,DFN,.113)
     126        Q:ADDLN3="" ADDLN2
     127        Q ADDLN2_", "_ADDLN3
     128CITY(DFN)       ; Get City for Home Address
     129        Q $$GET1^DIQ(2,DFN,.114)
     130STATE(DFN)      ; Get State for Home Address
     131        Q $$GET1^DIQ(2,DFN,.115)
     132ZIP(DFN)        ; Get Zip code for Home Address
     133        Q $$GET1^DIQ(2,DFN,.116)
     134COUNTY(DFN)     ; Get County for our Address
     135        Q $$GET1^DIQ(2,DFN,.117)
     136COUNTRY(DFN)    ; Get Country for our Address
     137        ; Unfortunately, it's not stored anywhere in Vista, so the inevitable...
     138        Q "USA"
     139RESTEL(DFN)     ; Residential Telephone
     140        Q $$GET1^DIQ(2,DFN,.131)
     141WORKTEL(DFN)    ; Work Telephone
     142        Q $$GET1^DIQ(2,DFN,.132)
     143EMAIL(DFN)      ; Email Adddress
     144        Q $$GET1^DIQ(2,DFN,.133)
     145CELLTEL(DFN)    ; Cell Phone
     146        Q $$GET1^DIQ(2,DFN,.134)
     147NOK1FAM(DFN)    ; Next of Kin 1 (NOK1) Family Name
     148        N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
     149        D NAMECOMP^XLFNAME(.NAME)
     150        Q NAME("FAMILY")
     151NOK1GIV(DFN)    ; NOK1 Given Name
     152        N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
     153        D NAMECOMP^XLFNAME(.NAME)
     154        Q NAME("GIVEN")
     155NOK1MID(DFN)    ; NOK1 Middle Name
     156        N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
     157        D NAMECOMP^XLFNAME(.NAME)
     158        Q NAME("MIDDLE")
     159NOK1SUF(DFN)    ; NOK1 Suffi Name
     160        N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
     161        D NAMECOMP^XLFNAME(.NAME)
     162        Q NAME("SUFFIX")
     163NOK1DISP(DFN)   ; NOK1 Display Name
     164        N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
     165        ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
     166        Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
     167NOK1REL(DFN)    ; NOK1 Relationship to the patient
     168        Q $$GET1^DIQ(2,DFN,.212)
     169NOK1ADD1(DFN)   ; NOK1 Address 1
     170        Q $$GET1^DIQ(2,DFN,.213)
     171NOK1ADD2(DFN)   ; NOK1 Address 2
     172        N ADDLN2,ADDLN3
     173        S ADDLN2=$$GET1^DIQ(2,DFN,.214),ADDLN3=$$GET1^DIQ(2,DFN,.215)
     174        Q:ADDLN3="" ADDLN2
     175        Q ADDLN2_", "_ADDLN3
     176NOK1CITY(DFN)   ; NOK1 City
     177        Q $$GET1^DIQ(2,DFN,.216)
     178NOK1STAT(DFN)   ; NOK1 State
     179        Q $$GET1^DIQ(2,DFN,.217)
     180NOK1ZIP(DFN)    ; NOK1 Zip Code
     181        Q $$GET1^DIQ(2,DFN,.218)
     182NOK1HTEL(DFN)   ; NOK1 Home Telephone
     183        Q $$GET1^DIQ(2,DFN,.219)
     184NOK1WTEL(DFN)   ; NOK1 Work Telephone
     185        Q $$GET1^DIQ(2,DFN,.21011)
     186NOK1SAME(DFN)   ; Is NOK1's Address the same the patient?
     187        Q $$GET1^DIQ(2,DFN,.2125)
     188NOK2FAM(DFN)    ; NOK2 Family Name
     189        N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
     190        D NAMECOMP^XLFNAME(.NAME)
     191        Q NAME("FAMILY")
     192NOK2GIV(DFN)    ; NOK2 Given Name
     193        N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
     194        D NAMECOMP^XLFNAME(.NAME)
     195        Q NAME("GIVEN")
     196NOK2MID(DFN)    ; NOK2 Middle Name
     197        N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
     198        D NAMECOMP^XLFNAME(.NAME)
     199        Q NAME("MIDDLE")
     200NOK2SUF(DFN)    ; NOK2 Suffi Name
     201        N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
     202        D NAMECOMP^XLFNAME(.NAME)
     203        Q NAME("SUFFIX")
     204NOK2DISP(DFN)   ; NOK2 Display Name
     205        N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
     206        ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
     207        Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
     208NOK2REL(DFN)    ; NOK2 Relationship to the patient
     209        Q $$GET1^DIQ(2,DFN,.2192)
     210NOK2ADD1(DFN)   ; NOK2 Address 1
     211        Q $$GET1^DIQ(2,DFN,.2193)
     212NOK2ADD2(DFN)   ; NOK2 Address 2
     213        N ADDLN2,ADDLN3
     214        S ADDLN2=$$GET1^DIQ(2,DFN,.2194),ADDLN3=$$GET1^DIQ(2,DFN,.2195)
     215        Q:ADDLN3="" ADDLN2
     216        Q ADDLN2_", "_ADDLN3
     217NOK2CITY(DFN)   ; NOK2 City
     218        Q $$GET1^DIQ(2,DFN,.2196)
     219NOK2STAT(DFN)   ; NOK2 State
     220        Q $$GET1^DIQ(2,DFN,.2197)
     221NOK2ZIP(DFN)    ; NOK2 Zip Code
     222        Q $$GET1^DIQ(2,DFN,.2198)
     223NOK2HTEL(DFN)   ; NOK2 Home Telephone
     224        Q $$GET1^DIQ(2,DFN,.2199)
     225NOK2WTEL(DFN)   ; NOK2 Work Telephone
     226        Q $$GET1^DIQ(2,DFN,.211011)
     227NOK2SAME(DFN)   ; Is NOK2's Address the same the patient?
     228        Q $$GET1^DIQ(2,DFN,.21925)
     229EMERFAM(DFN)    ; Emergency Contact (EMER) Family Name
     230        N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
     231        D NAMECOMP^XLFNAME(.NAME)
     232        Q NAME("FAMILY")
     233EMERGIV(DFN)    ; EMER Given Name
     234        N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
     235        D NAMECOMP^XLFNAME(.NAME)
     236        Q NAME("GIVEN")
     237EMERMID(DFN)    ; EMER Middle Name
     238        N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
     239        D NAMECOMP^XLFNAME(.NAME)
     240        Q NAME("MIDDLE")
     241EMERSUF(DFN)    ; EMER Suffi Name
     242        N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
     243        D NAMECOMP^XLFNAME(.NAME)
     244        Q NAME("SUFFIX")
     245EMERDISP(DFN)   ; EMER Display Name
     246        N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
     247        ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
     248        Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
     249EMERREL(DFN)    ; EMER Relationship to the patient
     250        Q $$GET1^DIQ(2,DFN,.331)
     251EMERADD1(DFN)   ; EMER Address 1
     252        Q $$GET1^DIQ(2,DFN,.333)
     253EMERADD2(DFN)   ; EMER Address 2
     254        N ADDLN2,ADDLN3
     255        S ADDLN2=$$GET1^DIQ(2,DFN,.334),ADDLN3=$$GET1^DIQ(2,DFN,.335)
     256        Q:ADDLN3="" ADDLN2
     257        Q ADDLN2_", "_ADDLN3
     258EMERCITY(DFN)   ; EMER City
     259        Q $$GET1^DIQ(2,DFN,.336)
     260EMERSTAT(DFN)   ; EMER State
     261        Q $$GET1^DIQ(2,DFN,.337)
     262EMERZIP(DFN)    ; EMER Zip Code
     263        Q $$GET1^DIQ(2,DFN,.338)
     264EMERHTEL(DFN)   ; EMER Home Telephone
     265        Q $$GET1^DIQ(2,DFN,.339)
     266EMERWTEL(DFN)   ; EMER Work Telephone
     267        Q $$GET1^DIQ(2,DFN,.33011)
     268EMERSAME(DFN)   ; Is EMER's Address the same the NOK?
     269        Q $$GET1^DIQ(2,DFN,.3305)

  • ccr/branches/ohum/p/C0CENC.m

    r1342 r1428  
    1 C0CENC  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10
    2  ;;1.0;C0C;;May 21, 2010;Build 2
    3  ;Copyright 2010 George Lilly, University of Minnesota and others.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  W "NO ENTRY FROM TOP",!
    22  Q
    23  ;
    24 EXTRACT(ENCXML,DFN,ENCOUT) ; EXTRACT ENCOUNTERS INTO  XML TEMPLATE
    25  ; ENCXML AND ENCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
    26  ;
    27  D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES
    28  ;I '$D(@C0CENC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE
    29  K @C0CENC
    30  D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET ENCOUNTERS
    31  D MAP(ENCXML,C0CENC,ENCOUT) ;MAP RESULTS FOR ENCOUNTERS
    32  Q
    33  ;
    34 TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES,
    35  ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
    36  ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES
    37  ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT
    38  ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY
    39  ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM
    40  ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS
    41  ;
    42  ;K VISIT,LST,NOTE
    43  I '$D(C0CPRC) D SETVARS^C0CPROC ; INITIALIZE WORK AREAS IF NOT ALREADY THERE
    44  I '$D(VISIT) D ENTRY^C0CCPT(DFN,,,1) ; RETURNS VISIT LOCAL VARIABLE
    45  ; NEED TO ADD START AND END DATES FROM PARAMETERS
    46  N ZI S ZI=""
    47  N PREVCPT,PREVDT S (PREVCPT,PREVDT)=""
    48  F  S ZI=$O(VISIT(ZI),-1) Q:ZI=""  D  ; REVERSE TIME ORDER - MOST RECENT FIRST
    49  . N ZDATE
    50  . S ZDATE=$$DATE(VISIT(ZI,"DATE",0))
    51  . S ZPRVARY=$NA(VISIT(ZI,"PRV"))
    52  . N ZPRV
    53  . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM
    54  . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON
    55  . ; ENCOBJECTID - ENCOUNTER OBJECT ID
    56  . ; ENCDATETIME - ENCOUNTER DATE TIME
    57  . ; ENCTYPETXT - ENCOUNTER TYPE (PLANNING TO USE ADMINISTRATIVE CPT IF AVAIL)
    58  . ; ENCTYPECODE - CODE OF TYPE - PLANNING CPT CODE
    59  . ; ENCTYPECODESYS - CODING SYSTEM OF TYPE - CPT-4
    60  . ; ENCDESCTXT - ENCOUNTER DESCRIPTION TEXT
    61  . ; ENCDESCCODE - ENCOUNTER DESCRIPTION CODE
    62  . ; ENCDESCCODESYS - ENCOUNTER DESCRIPTION CODE SYSTEM
    63  . ; ENCLOCACTORID - ENCOUNTER LOCATION ACTOR ID
    64  . ; ENCPRVACTORID - ENCOUNTER PRACTIONER ACTOR ID
    65  . ; ENCINDTXT - ENCOUNTER INDICATION TEXT
    66  . ; ENCINDCODE - ENCOUNTER INDICATION CODE
    67  . ; ENCINDCODESYS - ENCOUNTER INDICATION CODE SYSTEM
    68  . ; ENCACTORID - ENCOUNTER SOURCE ACTOR ID
    69  . ; ENCCOMMENTID - ENCOUNTER COMMENT ID - POINTER TO NOTE IN COMMENT SECTION
    70  . S ZRNF("ENCOBJECTID")="ENCOUNTER_"_ZI
    71  . S ZRNF("ENCDATETIME")=ZDATE ; ENCOUNTER DATE TIME
    72  . S ZRNF("ENCTYPETXT")=""
    73  . S ZRNF("ENCTYPECODE")=""
    74  . S ZRNF("ENCTYPECODESYS")=""
    75  . S ZRNF("ENCDESCTXT")=""
    76  . S ZRNF("ENCDESCCODE")=""
    77  . S ZRNF("ENCDESCCODESYS")=""
    78  . N TYPTXT,TYPCDE,TYPSYS  ; WILL BE UPDATED BY GETTYPE CALL
    79  . I $$GETTYPE("VISIT(ZI)",.TYPTXT,.TYPCDE,.TYPSYS) D  ; RETURNS FALSE IF NO TYPE
    80  . . S ZRNF("ENCTYPETXT")=TYPTXT
    81  . . S ZRNF("ENCTYPECODE")=TYPCDE
    82  . . S ZRNF("ENCTYPECODESYS")=TYPSYS
    83  . . S ZRNF("ENCDESCTXT")=TYPTXT ; FOR NOW, DESCRIPTION IS SAME AS TYPE
    84  . . S ZRNF("ENCDESCCODE")=TYPCDE ; DESCRIPTION IS REQUIRED (TYPE IS NOT)
    85  . . S ZRNF("ENCDESCCODESYS")=TYPSYS ; NEED TO CLARIFY FOR VISTA
    86  . S ZRNF("ENCLOCACTORID")="ACTORORGANIZATION_1"
    87  . S ZRNF("ENCPRVACTORID")=ZPRV ; PRIMARY PROVIDER LISTED FOR THE ENCOUNTER
    88  . S ZRNF("ENCINDTXT")="" ; WE WILL PUT POINTERS TO PROBLEMS HERE
    89  . S ZRNF("ENCINDCODE")=""
    90  . S ZRNF("ENCINDCODESYS")=""
    91  . S ZRNF("ENCACTORID")=ZPRV ; SOURCE WILL BE PRIMARY PROVIDER
    92  . S ZRNF("ENCCOMMENTID")=""
    93  . I $G(VISIT(ZI,"TEXT",1))'="" D  ; THERE IS A NOTE
    94  . . M @C0CNTE@(ZI,"TEXT")=VISIT(ZI,"TEXT") ; COPY THE TEXT OF THE NOTE
    95  . . S @C0CNTE@(ZI,"COMMENTOBJECTID")="NOTE_"_ZI
    96  . . S @C0CNTE@(ZI,"CMTDATETIME")=ZDATE ; DATE OF THE NOTE
    97  . . S @C0CNTE@(ZI,"ACTORSOURCEID")=ZPRV ; SOURCE OF THE NOTE
    98  . . S ZRNF("ENCCOMMENTID")="NOTE_"_ZI ; POINT TO THE NOTE FROM THE ENCOUNTER
    99  . D RNF1TO2^C0CRNF(C0CENC,"ZRNF") ; ADD THIS ROW TO THE ARRAY
    100  . ;S PREVCPT=ZCPT
    101  . ;S PREVDT=ZDATE
    102  N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"ENCOUNTERS"))
    103  M @ZRIM=@C0CENC@("V")
    104  K VISIT,LST,NOTE
    105  Q
    106  ;
    107 GETTYPE(ZARY,ZTXT,ZCDE,ZSYS) ; EXTRINSIC WHICH RETURNS FALSE IF NO ENCOUNTER TYPE
    108  ; UPDATES ZTXT WITH ENCOUNTER TYPE TEXT, ZCDE WITH ENCOUNTER TYPE CODE
    109  ; AND ZSYS WITH ENCOUNTER TYPE CODING SYSTEM
    110  ; THIS ROUTINE SHOULD BE UPDATED TO SEARCH FOR AN ADMINISTRATIVE CPT CODE
    111  ; INSTEAD OF JUST THE FIRST ONE IN THE LIST - GPL 1/23/10
    112  N ZS,ZC
    113  S ZC="" S ZS=""
    114  S (ZTXT,ZCDE,ZSYS)=""
    115  F  S ZC=$O(@ZARY@("CPT",ZC)) Q:ZC=""  D  ; TRY AND FIND A "99" CPT CODE
    116  . N ZT
    117  . S ZT=$$CPT^C0CPROC(@ZARY@("CPT",ZC)) ; VALUES IN A CPT MULTIPLE
    118  . I $E($P(ZT,U,1),1,2)="99" S ZS=ZT ; IS IT AN ADMIN CPT CODE?
    119  I ZS'="" D  ; CODED ENCOUNTER TYPE FOUND
    120  . S ZTXT=$P(ZS,U,2)_" "_$P(ZS,U,3) ; USE BOTH PIECES FOR THE TYPE
    121  . S ZCDE=$P($$CPT^C0CPROC(ZS),U,1) ; CPT CODE FOR ENCOUTER
    122  . S ZSYS=""
    123  . I ZCDE'="" S ZSYS="CPT-4" ; ONLY HAVE A CODING SYSTEM IF THERE IS A CODE
    124  I ZS="" S ZTXT=$$ANYTXT(ZARY) ; TRY AND GET FREE FORM TEXT FROM CPT MULTIPLES
    125  I ZTXT="" Q 0 ; FAILED
    126  W !,ZTXT
    127  Q 1 ; SUCCESS
    128  ;
    129 ANYTXT(ZVST) ; EXTRINSIC WHICH RETURNS TEXT FROM THE CPT MULTIPLE
    130  ; OF A VISIT ARRAY WITHOUT CHECKING THE CPT CODE (THAT HAVING FAILED)
    131  ; ZVST IS THE VISIT ARRAY AND IS PASSED BY NAME
    132  ; RETURNS TEXT TO USE AS ENCOUNTER TYPE IF ANY
    133  N ZK,ZL
    134  S ZK="" S ZL=""
    135  F  S ZK=$O(@ZVST@("CPT",ZK)) Q:ZK=""  D  ; LOOK FOR SOME TEXT TO USE
    136  . N ZT
    137  . S ZT=$G(@ZVST@("CPT",ZK)) ; LOOK AT THIS CPT MULTIPLE
    138  . I $P(ZT,U,2)_" "_$P(ZT,U,3)'=" " S ZL=$P(ZT,U,2)_" "_$P(ZT,U,3)
    139  . ; CONCATENATE PIECE 2 AND 3 OF THE CPT MULTIPLE FOR A TYPE
    140  I ZL="" S ZL=$G(@ZVST@("CLASS")) ; USE THE NOTE DOCUMENT CLASS FOR ENCOUTNER TYPE
    141  Q ZL
    142  ;
    143 PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME
    144  N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN=""
    145  F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH PRV SEG
    146  . I ZR'="" Q  ;ONLY WANT THE FIRST PRIMARY PROVIDER
    147  . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1)
    148  I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR
    149  Q ZRTN
    150  ;
    151 DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT
    152  Q $$FMDTOUTC^C0CUTIL(ISTR,"DT")
    153  ;
    154 CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS
    155  ; CPT^CATEGORY^TEXT
    156  N Z1,Z2,Z3,ZRTN
    157  S Z1=$P(ISTR,U,1)
    158  I Z1="" D  ;
    159  . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1)
    160  I Z1'="" D  ; IF THERE IS A CPT CODE IN THERE
    161  . ;S Z1=$P(ISTR,U,1)
    162  . S Z2=$P(ISTR,U,2)
    163  . S Z3=$P(ISTR,U,3)
    164  . S ZRTN=Z1_U_Z2_U_Z3
    165  E  S ZRTN=""
    166  Q ZRTN
    167  ;
    168 MAP(ENCXML,C0CENC,ENCOUT) ; MAP PROCEDURES XML
    169  ;
    170  N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"ENCTEMP")) ;WORK AREA FOR TEMPLATE
    171  K @ZTEMP
    172  N ZBLD
    173  S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"ENCBLD")) ; BUILD LIST AREA
    174  D QUEUE^C0CXPATH(ZBLD,ENCXML,1,1) ; FIRST LINE
    175  N ZINNER
    176  D QUERY^C0CXPATH(ENCXML,"//Encounters/Encounter","ZINNER") ;ONE ENCOUNTER
    177  N ZTMP,ZVAR,ZI
    178  S ZI=""
    179  F  S ZI=$O(@C0CENC@("V",ZI)) Q:ZI=""  D  ;FOR EACH ENCOUNTER
    180  . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS ENCOUNTER XML
    181  . S ZVAR=$NA(@C0CENC@("V",ZI)) ;THIS ENCOUNTER VARIABLES
    182  . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE
    183  . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD
    184  D QUEUE^C0CXPATH(ZBLD,ENCXML,@ENCXML@(0),@ENCXML@(0))
    185  N ZZTMP
    186  D BUILD^C0CXPATH(ZBLD,ENCOUT) ;BUILD FINAL XML
    187  K @ZTEMP,@ZBLD,@C0CENC
    188  Q
    189  ; 
     1C0CENC  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2010 George Lilly, University of Minnesota and others.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        W "NO ENTRY FROM TOP",!
     22        Q
     23        ;
     24EXTRACT(ENCXML,DFN,ENCOUT)      ; EXTRACT ENCOUNTERS INTO  XML TEMPLATE
     25        ; ENCXML AND ENCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
     26        ;
     27        D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES
     28        ;I '$D(@C0CENC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE
     29        K @C0CENC
     30        D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET ENCOUNTERS
     31        D MAP(ENCXML,C0CENC,ENCOUT) ;MAP RESULTS FOR ENCOUNTERS
     32        Q
     33        ;
     34TIUGET(DFN,C0CENC,C0CPRC,C0CNTE)        ; CALLS ENTRY^C0CCPT TO GET PROCEDURES,
     35        ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
     36        ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES
     37        ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT
     38        ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY
     39        ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM
     40        ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS
     41        ;
     42        ;K VISIT,LST,NOTE
     43        I '$D(C0CPRC) D SETVARS^C0CPROC ; INITIALIZE WORK AREAS IF NOT ALREADY THERE
     44        I '$D(VISIT) D ENTRY^C0CCPT(DFN,,,1) ; RETURNS VISIT LOCAL VARIABLE
     45        ; NEED TO ADD START AND END DATES FROM PARAMETERS
     46        N ZI S ZI=""
     47        N PREVCPT,PREVDT S (PREVCPT,PREVDT)=""
     48        F  S ZI=$O(VISIT(ZI),-1) Q:ZI=""  D  ; REVERSE TIME ORDER - MOST RECENT FIRST
     49        . N ZDATE
     50        . S ZDATE=$$DATE(VISIT(ZI,"DATE",0))
     51        . S ZPRVARY=$NA(VISIT(ZI,"PRV"))
     52        . N ZPRV
     53        . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM
     54        . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON
     55        . ; ENCOBJECTID - ENCOUNTER OBJECT ID
     56        . ; ENCDATETIME - ENCOUNTER DATE TIME
     57        . ; ENCTYPETXT - ENCOUNTER TYPE (PLANNING TO USE ADMINISTRATIVE CPT IF AVAIL)
     58        . ; ENCTYPECODE - CODE OF TYPE - PLANNING CPT CODE
     59        . ; ENCTYPECODESYS - CODING SYSTEM OF TYPE - CPT-4
     60        . ; ENCDESCTXT - ENCOUNTER DESCRIPTION TEXT
     61        . ; ENCDESCCODE - ENCOUNTER DESCRIPTION CODE
     62        . ; ENCDESCCODESYS - ENCOUNTER DESCRIPTION CODE SYSTEM
     63        . ; ENCLOCACTORID - ENCOUNTER LOCATION ACTOR ID
     64        . ; ENCPRVACTORID - ENCOUNTER PRACTIONER ACTOR ID
     65        . ; ENCINDTXT - ENCOUNTER INDICATION TEXT
     66        . ; ENCINDCODE - ENCOUNTER INDICATION CODE
     67        . ; ENCINDCODESYS - ENCOUNTER INDICATION CODE SYSTEM
     68        . ; ENCACTORID - ENCOUNTER SOURCE ACTOR ID
     69        . ; ENCCOMMENTID - ENCOUNTER COMMENT ID - POINTER TO NOTE IN COMMENT SECTION
     70        . S ZRNF("ENCOBJECTID")="ENCOUNTER_"_ZI
     71        . S ZRNF("ENCDATETIME")=ZDATE ; ENCOUNTER DATE TIME
     72        . S ZRNF("ENCTYPETXT")=""
     73        . S ZRNF("ENCTYPECODE")=""
     74        . S ZRNF("ENCTYPECODESYS")=""
     75        . S ZRNF("ENCDESCTXT")=""
     76        . S ZRNF("ENCDESCCODE")=""
     77        . S ZRNF("ENCDESCCODESYS")=""
     78        . N TYPTXT,TYPCDE,TYPSYS  ; WILL BE UPDATED BY GETTYPE CALL
     79        . I $$GETTYPE("VISIT(ZI)",.TYPTXT,.TYPCDE,.TYPSYS) D  ; RETURNS FALSE IF NO TYPE
     80        . . S ZRNF("ENCTYPETXT")=TYPTXT
     81        . . S ZRNF("ENCTYPECODE")=TYPCDE
     82        . . S ZRNF("ENCTYPECODESYS")=TYPSYS
     83        . . S ZRNF("ENCDESCTXT")=TYPTXT ; FOR NOW, DESCRIPTION IS SAME AS TYPE
     84        . . S ZRNF("ENCDESCCODE")=TYPCDE ; DESCRIPTION IS REQUIRED (TYPE IS NOT)
     85        . . S ZRNF("ENCDESCCODESYS")=TYPSYS ; NEED TO CLARIFY FOR VISTA
     86        . S ZRNF("ENCLOCACTORID")="ACTORORGANIZATION_1"
     87        . S ZRNF("ENCPRVACTORID")=ZPRV ; PRIMARY PROVIDER LISTED FOR THE ENCOUNTER
     88        . S ZRNF("ENCINDTXT")="" ; WE WILL PUT POINTERS TO PROBLEMS HERE
     89        . S ZRNF("ENCINDCODE")=""
     90        . S ZRNF("ENCINDCODESYS")=""
     91        . S ZRNF("ENCACTORID")=ZPRV ; SOURCE WILL BE PRIMARY PROVIDER
     92        . S ZRNF("ENCCOMMENTID")=""
     93        . I $G(VISIT(ZI,"TEXT",1))'="" D  ; THERE IS A NOTE
     94        . . M @C0CNTE@(ZI,"TEXT")=VISIT(ZI,"TEXT") ; COPY THE TEXT OF THE NOTE
     95        . . S @C0CNTE@(ZI,"COMMENTOBJECTID")="NOTE_"_ZI
     96        . . S @C0CNTE@(ZI,"CMTDATETIME")=ZDATE ; DATE OF THE NOTE
     97        . . S @C0CNTE@(ZI,"ACTORSOURCEID")=ZPRV ; SOURCE OF THE NOTE
     98        . . S ZRNF("ENCCOMMENTID")="NOTE_"_ZI ; POINT TO THE NOTE FROM THE ENCOUNTER
     99        . D RNF1TO2^C0CRNF(C0CENC,"ZRNF") ; ADD THIS ROW TO THE ARRAY
     100        . ;S PREVCPT=ZCPT
     101        . ;S PREVDT=ZDATE
     102        N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"ENCOUNTERS"))
     103        M @ZRIM=@C0CENC@("V")
     104        K VISIT,LST,NOTE
     105        Q
     106        ;
     107GETTYPE(ZARY,ZTXT,ZCDE,ZSYS)    ; EXTRINSIC WHICH RETURNS FALSE IF NO ENCOUNTER TYPE
     108        ; UPDATES ZTXT WITH ENCOUNTER TYPE TEXT, ZCDE WITH ENCOUNTER TYPE CODE
     109        ; AND ZSYS WITH ENCOUNTER TYPE CODING SYSTEM
     110        ; THIS ROUTINE SHOULD BE UPDATED TO SEARCH FOR AN ADMINISTRATIVE CPT CODE
     111        ; INSTEAD OF JUST THE FIRST ONE IN THE LIST - GPL 1/23/10
     112        N ZS,ZC
     113        S ZC="" S ZS=""
     114        S (ZTXT,ZCDE,ZSYS)=""
     115        F  S ZC=$O(@ZARY@("CPT",ZC)) Q:ZC=""  D  ; TRY AND FIND A "99" CPT CODE
     116        . N ZT
     117        . S ZT=$$CPT^C0CPROC(@ZARY@("CPT",ZC)) ; VALUES IN A CPT MULTIPLE
     118        . I $E($P(ZT,U,1),1,2)="99" S ZS=ZT ; IS IT AN ADMIN CPT CODE?
     119        I ZS'="" D  ; CODED ENCOUNTER TYPE FOUND
     120        . S ZTXT=$P(ZS,U,2)_" "_$P(ZS,U,3) ; USE BOTH PIECES FOR THE TYPE
     121        . S ZCDE=$P($$CPT^C0CPROC(ZS),U,1) ; CPT CODE FOR ENCOUTER
     122        . S ZSYS=""
     123        . I ZCDE'="" S ZSYS="CPT-4" ; ONLY HAVE A CODING SYSTEM IF THERE IS A CODE
     124        I ZS="" S ZTXT=$$ANYTXT(ZARY) ; TRY AND GET FREE FORM TEXT FROM CPT MULTIPLES
     125        I ZTXT="" Q 0 ; FAILED
     126        W !,ZTXT
     127        Q 1 ; SUCCESS
     128        ;
     129ANYTXT(ZVST)    ; EXTRINSIC WHICH RETURNS TEXT FROM THE CPT MULTIPLE
     130        ; OF A VISIT ARRAY WITHOUT CHECKING THE CPT CODE (THAT HAVING FAILED)
     131        ; ZVST IS THE VISIT ARRAY AND IS PASSED BY NAME
     132        ; RETURNS TEXT TO USE AS ENCOUNTER TYPE IF ANY
     133        N ZK,ZL
     134        S ZK="" S ZL=""
     135        F  S ZK=$O(@ZVST@("CPT",ZK)) Q:ZK=""  D  ; LOOK FOR SOME TEXT TO USE
     136        . N ZT
     137        . S ZT=$G(@ZVST@("CPT",ZK)) ; LOOK AT THIS CPT MULTIPLE
     138        . I $P(ZT,U,2)_" "_$P(ZT,U,3)'=" " S ZL=$P(ZT,U,2)_" "_$P(ZT,U,3)
     139        . ; CONCATENATE PIECE 2 AND 3 OF THE CPT MULTIPLE FOR A TYPE
     140        I ZL="" S ZL=$G(@ZVST@("CLASS")) ; USE THE NOTE DOCUMENT CLASS FOR ENCOUTNER TYPE
     141        Q ZL
     142        ;
     143PRV(IARY)       ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME
     144        N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN=""
     145        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH PRV SEG
     146        . I ZR'="" Q  ;ONLY WANT THE FIRST PRIMARY PROVIDER
     147        . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1)
     148        I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR
     149        Q ZRTN
     150        ;
     151DATE(ISTR)      ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT
     152        Q $$FMDTOUTC^C0CUTIL(ISTR,"DT")
     153        ;
     154CPT(ISTR)       ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS
     155        ; CPT^CATEGORY^TEXT
     156        N Z1,Z2,Z3,ZRTN
     157        S Z1=$P(ISTR,U,1)
     158        I Z1="" D  ;
     159        . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1)
     160        I Z1'="" D  ; IF THERE IS A CPT CODE IN THERE
     161        . ;S Z1=$P(ISTR,U,1)
     162        . S Z2=$P(ISTR,U,2)
     163        . S Z3=$P(ISTR,U,3)
     164        . S ZRTN=Z1_U_Z2_U_Z3
     165        E  S ZRTN=""
     166        Q ZRTN
     167        ;
     168MAP(ENCXML,C0CENC,ENCOUT)       ; MAP PROCEDURES XML
     169        ;
     170        N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"ENCTEMP")) ;WORK AREA FOR TEMPLATE
     171        K @ZTEMP
     172        N ZBLD
     173        S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"ENCBLD")) ; BUILD LIST AREA
     174        D QUEUE^C0CXPATH(ZBLD,ENCXML,1,1) ; FIRST LINE
     175        N ZINNER
     176        D QUERY^C0CXPATH(ENCXML,"//Encounters/Encounter","ZINNER") ;ONE ENCOUNTER
     177        N ZTMP,ZVAR,ZI
     178        S ZI=""
     179        F  S ZI=$O(@C0CENC@("V",ZI)) Q:ZI=""  D  ;FOR EACH ENCOUNTER
     180        . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS ENCOUNTER XML
     181        . S ZVAR=$NA(@C0CENC@("V",ZI)) ;THIS ENCOUNTER VARIABLES
     182        . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE
     183        . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD
     184        D QUEUE^C0CXPATH(ZBLD,ENCXML,@ENCXML@(0),@ENCXML@(0))
     185        N ZZTMP
     186        D BUILD^C0CXPATH(ZBLD,ENCOUT) ;BUILD FINAL XML
     187        K @ZTEMP,@ZBLD,@C0CENC
     188        Q
     189        ; 

  • ccr/branches/ohum/p/C0CENV.m

    r1342 r1428  
    1 C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;
    4  ;
    5 ENV ; Does not prevent loading of the transport global.
    6  ; Environment check is done only during the install.
    7  ;
    8  N XQA,XQAMSG
    9  ;
    10  ;
    11  ; Make sure the patch name exist
    12  ;
    13  I '$D(XPDNM) D  Q
    14  . D BMES("No valid patch name exist")
    15  . S XPDQUIT=2
    16  . D EXIT
    17  ;
    18  D CHECK
    19  D EXIT
    20  Q
    21  ;
    22  ;
    23 CHECK ; Perform environment check
    24  ;
    25  I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D
    26  . D BMES("Terminal Device is not defined")
    27  . S XPDQUIT=2
    28  ;
    29  I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D
    30  . D BMES("Please log in to set local DUZ... variables")
    31  . S XPDQUIT=2
    32  ;
    33  I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D
    34  . D BMES("You are not a valid user on this system")
    35  . S XPDQUIT=2
    36  Q
    37  ;
    38  ;
    39 EXIT ;
    40  ;
    41  ;
    42  I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q
    43  D BMES("--- Environment Check is Ok ---")
    44  ;
    45  Q
    46  ;
    47  ;
    48 PRE ;Pre-install entry point
    49  ;
    50  ; No action needed in pre-install
    51  D BMES("No action need for pre-install")
    52  ;
    53  Q
    54  ;
    55  ;
    56 POST ;Post install
    57  ;
    58  ; Check for RPMS system with V LAB file.
    59  ;
    60  I $$VFILE^DILFD(9000010.09)'=1 Q
    61  ;
    62  S %=$$NEWCP^XPDUTL("RPMS1","POST1^C0CENV")
    63  S %=$$NEWCP^XPDUTL("RPMS2","POST2^C0CENV")
    64  S %=$$NEWCP^XPDUTL("RPMS3","POST3^C0CENV")
    65  S %=$$NEWCP^XPDUTL("RPMS4","POST4^C0CENV")
    66  S %=$$NEWCP^XPDUTL("RPMS5","POST5^C0CENV")
    67  S %=$$NEWCP^XPDUTL("RPMS6","POST6^C0CENV")
    68  S %=$$NEWCP^XPDUTL("RPMS7","POST7^C0CENV")
    69  ;
    70  Q
    71  ;
    72  ;
    73 POST1 ; Checkpoint call back entry point.
    74  ; Add new style ALR1 cross-reference to V LAB file.
    75  ;
    76  N MSG
    77  S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    78  D BMES(MSG)
    79  D ALR1^C0CLA7DD
    80  S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    81  D BMES(MSG)
    82  Q
    83  ;
    84  ;
    85 POST2 ; Checkpoint call back entry point.
    86  ; Add new style ALR2 cross-reference to V LAB file.
    87  ;
    88  N MSG
    89  S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    90  D BMES(MSG)
    91  D ALR2^C0CLA7DD
    92  S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    93  D BMES(MSG)
    94  Q
    95  ;
    96  ;
    97 POST3 ; Checkpoint call back entry point.
    98  ; Add new style ALR3 cross-reference to V LAB file.
    99  ;
    100  N MSG
    101  S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    102  D BMES(MSG)
    103  D ALR3^C0CLA7DD
    104  S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    105  D BMES(MSG)
    106  Q
    107  ;
    108  ;
    109 POST4 ; Checkpoint call back entry point.
    110  ; Add new style ALR4 cross-reference to V LAB file.
    111  ;
    112  N MSG
    113  S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    114  D BMES(MSG)
    115  D ALR4^C0CLA7DD
    116  S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    117  D BMES(MSG)
    118  Q
    119  ;
    120  ;
    121 POST5 ; Checkpoint call back entry point.
    122  ; Add new style ALR5 cross-reference to V LAB file.
    123  ;
    124  N MSG
    125  S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
    126  D BMES(MSG)
    127  D ALR5^C0CLA7DD
    128  S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
    129  D BMES(MSG)
    130  Q
    131  ;
    132  ;
    133 POST6 ; Checkpoint call back entry point.
    134  ; Check for RPMS system and determine LAB patch level
    135  ;  and need to load in C0C version of LA7 routines.
    136  ;
    137  N MSG
    138  ;
    139  ; Load and rename C0CQRY2 to LA7QRY2 if LA*5.2*69 not installed
    140  I '$$PATCH^XPDUTL("LA*5.2*69") D
    141  . S MSG="This system missing LAB patch LA*5.2*69"
    142  . D BMES(MSG)
    143  . S MSG="Renaming routine C0CQRY2 to LA7QRY2"
    144  . D BMES(MSG)
    145  . D LOAD("C0CQRY2")
    146  . D SAVE("C0CQRY2","LA7QRY2")
    147  ;
    148  ; Load and rename C0CVOBX1 to LA7VOBX1 if LA*5.2*64 not installed.
    149  I '$$PATCH^XPDUTL("LA*5.2*64") D
    150  . S MSG="This system missing LAB patch LA*5.2*64"
    151  . D BMES(MSG)
    152  . S MSG="Renaming routine C0CVOBX1 to LA7VOBX1"
    153  . D BMES(MSG)
    154  . D LOAD("C0CVOBX1")
    155  . D SAVE("C0CVOBX1","LA7VOBX1")
    156  ;
    157  ; Load and rename C0CQRY1 to LA7QRY1 if LA*5.2*68 not installed.
    158  I '$$PATCH^XPDUTL("LA*5.2*68") D
    159  . S MSG="This system missing LAB patch LA*5.2*68"
    160  . D BMES(MSG)
    161  . S MSG="Renaming routine C0CQRY1 to LA7QRY1"
    162  . D BMES(MSG)
    163  . D LOAD("C0CQRY1")
    164  . D SAVE("C0CQRY1","LA7QRY1")
    165  ;
    166  Q
    167  ;
    168  ;
    169 POST7 ; Checkpoint call back entry point.
    170  ;
    171  D REINDEX^C0CLA7DD
    172  ;
    173  Q
    174  ;
    175  ;
    176 BMES(STR) ; Write BMES^XPDUTL statements
    177  ;
    178  D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
    179  ;
    180  Q
    181  ;
    182  ;
    183 LOAD(X) ; load routine X
    184  N %N,DIF,XCNP
    185  K ^TMP($J,X)
    186  S DIF="^TMP($J,X,",XCNP=0
    187  X ^%ZOSF("LOAD")
    188  Q
    189  ;
    190  ;
    191 SAVE(OLD,NEW) ; restore routine X
    192  N %,DIE,X,XCM,XCN,XCS
    193  S DIE="^TMP($J,"""_OLD_""",",XCN=0,X=NEW
    194  X ^%ZOSF("SAVE")
    195  Q
     1C0CENV  ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;
     4        ;
     5ENV     ; Does not prevent loading of the transport global.
     6        ; Environment check is done only during the install.
     7        ;
     8        N XQA,XQAMSG
     9        ;
     10        ;
     11        ; Make sure the patch name exist
     12        ;
     13        I '$D(XPDNM) D  Q
     14        . D BMES("No valid patch name exist")
     15        . S XPDQUIT=2
     16        . D EXIT
     17        ;
     18        D CHECK
     19        D EXIT
     20        Q
     21        ;
     22        ;
     23CHECK   ; Perform environment check
     24        ;
     25        I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D
     26        . D BMES("Terminal Device is not defined")
     27        . S XPDQUIT=2
     28        ;
     29        I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D
     30        . D BMES("Please log in to set local DUZ... variables")
     31        . S XPDQUIT=2
     32        ;
     33        I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D
     34        . D BMES("You are not a valid user on this system")
     35        . S XPDQUIT=2
     36        Q
     37        ;
     38        ;
     39EXIT    ;
     40        ;
     41        ;
     42        I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q
     43        D BMES("--- Environment Check is Ok ---")
     44        ;
     45        Q
     46        ;
     47        ;
     48PRE     ;Pre-install entry point
     49        ;
     50        ; No action needed in pre-install
     51        D BMES("No action need for pre-install")
     52        ;
     53        Q
     54        ;
     55        ;
     56POST    ;Post install
     57        ;
     58        ; Check for RPMS system with V LAB file.
     59        ;
     60        I $$VFILE^DILFD(9000010.09)'=1 Q
     61        ;
     62        S %=$$NEWCP^XPDUTL("RPMS1","POST1^C0CENV")
     63        S %=$$NEWCP^XPDUTL("RPMS2","POST2^C0CENV")
     64        S %=$$NEWCP^XPDUTL("RPMS3","POST3^C0CENV")
     65        S %=$$NEWCP^XPDUTL("RPMS4","POST4^C0CENV")
     66        S %=$$NEWCP^XPDUTL("RPMS5","POST5^C0CENV")
     67        S %=$$NEWCP^XPDUTL("RPMS6","POST6^C0CENV")
     68        S %=$$NEWCP^XPDUTL("RPMS7","POST7^C0CENV")
     69        ;
     70        Q
     71        ;
     72        ;
     73POST1   ; Checkpoint call back entry point.
     74        ; Add new style ALR1 cross-reference to V LAB file.
     75        ;
     76        N MSG
     77        S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     78        D BMES(MSG)
     79        D ALR1^C0CLA7DD
     80        S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     81        D BMES(MSG)
     82        Q
     83        ;
     84        ;
     85POST2   ; Checkpoint call back entry point.
     86        ; Add new style ALR2 cross-reference to V LAB file.
     87        ;
     88        N MSG
     89        S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     90        D BMES(MSG)
     91        D ALR2^C0CLA7DD
     92        S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     93        D BMES(MSG)
     94        Q
     95        ;
     96        ;
     97POST3   ; Checkpoint call back entry point.
     98        ; Add new style ALR3 cross-reference to V LAB file.
     99        ;
     100        N MSG
     101        S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     102        D BMES(MSG)
     103        D ALR3^C0CLA7DD
     104        S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     105        D BMES(MSG)
     106        Q
     107        ;
     108        ;
     109POST4   ; Checkpoint call back entry point.
     110        ; Add new style ALR4 cross-reference to V LAB file.
     111        ;
     112        N MSG
     113        S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     114        D BMES(MSG)
     115        D ALR4^C0CLA7DD
     116        S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     117        D BMES(MSG)
     118        Q
     119        ;
     120        ;
     121POST5   ; Checkpoint call back entry point.
     122        ; Add new style ALR5 cross-reference to V LAB file.
     123        ;
     124        N MSG
     125        S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
     126        D BMES(MSG)
     127        D ALR5^C0CLA7DD
     128        S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
     129        D BMES(MSG)
     130        Q
     131        ;
     132        ;
     133POST6   ; Checkpoint call back entry point.
     134        ; Check for RPMS system and determine LAB patch level
     135        ;  and need to load in C0C version of LA7 routines.
     136        ;
     137        N MSG
     138        ;
     139        ; Load and rename C0CQRY2 to LA7QRY2 if LA*5.2*69 not installed
     140        I '$$PATCH^XPDUTL("LA*5.2*69") D
     141        . S MSG="This system missing LAB patch LA*5.2*69"
     142        . D BMES(MSG)
     143        . S MSG="Renaming routine C0CQRY2 to LA7QRY2"
     144        . D BMES(MSG)
     145        . D LOAD("C0CQRY2")
     146        . D SAVE("C0CQRY2","LA7QRY2")
     147        ;
     148        ; Load and rename C0CVOBX1 to LA7VOBX1 if LA*5.2*64 not installed.
     149        I '$$PATCH^XPDUTL("LA*5.2*64") D
     150        . S MSG="This system missing LAB patch LA*5.2*64"
     151        . D BMES(MSG)
     152        . S MSG="Renaming routine C0CVOBX1 to LA7VOBX1"
     153        . D BMES(MSG)
     154        . D LOAD("C0CVOBX1")
     155        . D SAVE("C0CVOBX1","LA7VOBX1")
     156        ;
     157        ; Load and rename C0CQRY1 to LA7QRY1 if LA*5.2*68 not installed.
     158        I '$$PATCH^XPDUTL("LA*5.2*68") D
     159        . S MSG="This system missing LAB patch LA*5.2*68"
     160        . D BMES(MSG)
     161        . S MSG="Renaming routine C0CQRY1 to LA7QRY1"
     162        . D BMES(MSG)
     163        . D LOAD("C0CQRY1")
     164        . D SAVE("C0CQRY1","LA7QRY1")
     165        ;
     166        Q
     167        ;
     168        ;
     169POST7   ; Checkpoint call back entry point.
     170        ;
     171        D REINDEX^C0CLA7DD
     172        ;
     173        Q
     174        ;
     175        ;
     176BMES(STR)       ; Write BMES^XPDUTL statements
     177        ;
     178        D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
     179        ;
     180        Q
     181        ;
     182        ;
     183LOAD(X) ; load routine X
     184        N %N,DIF,XCNP
     185        K ^TMP($J,X)
     186        S DIF="^TMP($J,X,",XCNP=0
     187        X ^%ZOSF("LOAD")
     188        Q
     189        ;
     190        ;
     191SAVE(OLD,NEW)   ; restore routine X
     192        N %,DIE,X,XCM,XCN,XCS
     193        S DIE="^TMP($J,"""_OLD_""",",XCN=0,X=NEW
     194        X ^%ZOSF("SAVE")
     195        Q

  • ccr/branches/ohum/p/C0CEVC.m

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

  • ccr/branches/ohum/p/C0CEWD.m

    r1342 r1428  
    1 C0CEWD   ; CCDCCR/GPL - CCR EWD utilities; 1/6/11
    2  ;;0.1;CCDCCR;nopatch;noreleasedate;Build 2
    3  ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  Q
    21  ;
    22 TOKEN() ; EXTRINSIC WHICH RETURNS A NEW RANDOM TOKEN
    23  Q $$UUID^C0CUTIL ; USE THE UUID FUNCTION IN THE CCR PACKAGE
    24  ;
    25 STORE(ZARY) ; STORE AN ARRAY OF VALUES INDEXED BY A NEW TOKEN
    26  ; IN ^TMP("C0E","TOKEN") FOR LATER RETRIEVAL FROM INSIDE AN EWD SESSION
    27  ; RETURNS THE TOKEN. ZARY IS PASSED BY NAME
    28  N ZT
    29  S ZT=$$TOKEN ; GET A NEW TOKEN
    30  M ^TMP("C0E","TOKEN",ZT)=@ZARY ;
    31  Q ZT
    32  ;
    33 GET(C0ERTN,C0ETOKEN,NOKILL) ; RETRIEVE A STORED ARRAY INDEXED BY ZTOKEN
    34  ; KILL THE ARRAY AFTER RETRIEVAL UNLESS NOKILL=1
    35  ; C0ERTN IS PASSED BY NAME
    36  I '$D(^TMP("C0E","TOKEN",C0ETOKEN)) D  Q  ; DOESN'T EXIST
    37  . S @C0ERTN="" ; PASS BACK NULL
    38  M @C0ERTN=^TMP("C0E","TOKEN",C0ETOKEN) ; RETRIEVE
    39  I $G(NOKILL)'=1 K ^TMP("C0E","TOKEN",C0ETOKEN) ; DELETE
    40  Q
    41  ;
    42 URLTOKEN(sessid) ; EXTRINSIC WHICH RETRIEVES THE TOKEN PASSED ON THE URL
    43  ; IN EWD EXAMPLE: https://example.com/ewd/myApp/index.ewd?token="12345"
    44  N token
    45  S token=""
    46  s token=$$getRequestValue^%zewdAPI("token",sessid)
    47  s token=$tr(token,"""") ; strip out quotes
    48  Q token
    49  ;
    50 cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options) 
    51  ;
    52  n maxNo,noFound
    53  ;
    54  s maxNo=50
    55  s noFound=0
    56  f  s seedValue=$o(^DPT("B",seedValue)) q:seedValue=""  q:noFound=maxNo  d
    57  . s lastSeedValue=seedValue
    58  . i prefix'="",$e(seedValue,1,$l(prefix))'=prefix q
    59  . s optionNo=optionNo+1
    60  . s noFound=noFound+1
    61  . s options(optionNo)=seedValue
    62  QUIT
    63  ;
    64 set1 ;
    65  s ^zewd("comboPlus","methodMap","test")="cbTestMethod^C0PEREW"
    66  q
    67  ;
    68 test1(sessid) ;
    69  d setSessionValue^%zewdAPI("testing","ZZ",sessid)
    70  q 0
    71  ;
     1C0CEWD    ; CCDCCR/GPL - CCR EWD utilities; 1/6/11
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        Q
     21        ;
     22TOKEN() ; EXTRINSIC WHICH RETURNS A NEW RANDOM TOKEN
     23        Q $$UUID^C0CUTIL ; USE THE UUID FUNCTION IN THE CCR PACKAGE
     24        ;
     25STORE(ZARY)     ; STORE AN ARRAY OF VALUES INDEXED BY A NEW TOKEN
     26        ; IN ^TMP("C0E","TOKEN") FOR LATER RETRIEVAL FROM INSIDE AN EWD SESSION
     27        ; RETURNS THE TOKEN. ZARY IS PASSED BY NAME
     28        N ZT
     29        S ZT=$$TOKEN ; GET A NEW TOKEN
     30        M ^TMP("C0E","TOKEN",ZT)=@ZARY ;
     31        Q ZT
     32        ;
     33GET(C0ERTN,C0ETOKEN,NOKILL)     ; RETRIEVE A STORED ARRAY INDEXED BY ZTOKEN
     34        ; KILL THE ARRAY AFTER RETRIEVAL UNLESS NOKILL=1
     35        ; C0ERTN IS PASSED BY NAME
     36        I '$D(^TMP("C0E","TOKEN",C0ETOKEN)) D  Q  ; DOESN'T EXIST
     37        . S @C0ERTN="" ; PASS BACK NULL
     38        M @C0ERTN=^TMP("C0E","TOKEN",C0ETOKEN) ; RETRIEVE
     39        I $G(NOKILL)'=1 K ^TMP("C0E","TOKEN",C0ETOKEN) ; DELETE
     40        Q
     41        ;
     42URLTOKEN(sessid)        ; EXTRINSIC WHICH RETRIEVES THE TOKEN PASSED ON THE URL
     43        ; IN EWD EXAMPLE: https://example.com/ewd/myApp/index.ewd?token="12345"
     44        N token
     45        S token=""
     46        s token=$$getRequestValue^%zewdAPI("token",sessid)
     47        s token=$tr(token,"""") ; strip out quotes
     48        Q token
     49        ;
     50cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options)   
     51        ;
     52        n maxNo,noFound
     53        ;
     54        s maxNo=50
     55        s noFound=0
     56        f  s seedValue=$o(^DPT("B",seedValue)) q:seedValue=""  q:noFound=maxNo  d
     57        . s lastSeedValue=seedValue
     58        . i prefix'="",$e(seedValue,1,$l(prefix))'=prefix q
     59        . s optionNo=optionNo+1
     60        . s noFound=noFound+1
     61        . s options(optionNo)=seedValue
     62        QUIT
     63        ;
     64set1    ;
     65        s ^zewd("comboPlus","methodMap","test")="cbTestMethod^C0PEREW"
     66        q
     67        ;
     68test1(sessid)   ;
     69        d setSessionValue^%zewdAPI("testing","ZZ",sessid)
     70        q 0
     71        ;

  • ccr/branches/ohum/p/C0CEWD1.m

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

  • ccr/branches/ohum/p/C0CFM1.m

    r1342 r1428  
    1 C0CFM1   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  W "This is the CCR FILEMAN Utility Library ",!
    21  W !
    22  Q
    23  ;
    24 PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE
    25  ;
    26  S C0CGLB=$NA(^TMP("GPLRIM","VARS",DFN))
    27  I '$D(ZWHICH) S ZWHICH="ALL"
    28  I ZWHICH'="ALL" D  ; SINGLE SECTION REQUESTED
    29  . S C0CVARS=$NA(@C0CGLB@(ZWHICH))
    30  . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION
    31  E  D  ; MULTIPLE SECTIONS
    32  . S C0CVARS=$NA(@C0CGLB)
    33  . S C0CI=""
    34  . F  S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI=""  D  ;FOR EACH SECTION
    35  . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION
    36  . . D PUTRIM1(DFN,C0CI,C0CVARSN)
    37  Q
    38  ;
    39 PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS
    40  ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1"
    41  S C0CX=0
    42  F  S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX=""  D  ; FOR EACH OCCURANCE
    43  . W "ZOCC=",C0CX,!
    44  . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE
    45  . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE
    46  Q
    47  ;
    48 PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
    49  ; ^C0C(171.201,   DFN IS THE PATIENT IEN PASSED BY VALUE
    50  ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
    51  ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
    52  ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
    53  ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
    54  ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
    55  ;
    56  S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
    57  ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
    58  N ZF,ZFV S ZF=171.201 S ZFV=171.2012
    59  S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS
    60  N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER
    61  N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
    62  W "ZTYPE: ",ZTYPE," ",ZTYPN,!
    63  N ZVARN ; IEN OF VARIABLE BEING PROCESSED
    64  ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
    65  S C0CFDA(ZF,"?+1,",.01)=DFN
    66  S C0CFDA(ZF,"?+1,",.02)=ZSRC
    67  S C0CFDA(ZF,"?+1,",.03)=ZTYPN
    68  S C0CFDA(ZF,"?+1,",.04)=ZOCC ;CREATE OCCURANCE
    69  K ZERR
    70  D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER
    71  I $D(ZERR) B  ;OOPS
    72  K C0CFDA
    73  S ZD0=$O(^C0C(ZF,"C",DFN,ZSRC,ZTYPN,ZOCC,""))
    74  W "RECORD NUMBER: ",ZD0,!
    75  ;B
    76  S ZCNT=0
    77  S ZC0CI="" ;
    78  F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
    79  . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
    80  . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
    81  . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
    82  . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
    83  . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN
    84  . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI)
    85  . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN
    86  . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI)
    87  ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT"
    88  ;S GT1(170,"?+1,",12)="DIR"
    89  ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT"
    90  ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT"
    91  D CLEAN^DILF
    92  D UPDATE^DIE("","C0CFDA","","ZERR")
    93  Q
    94  ;
    95 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
    96  ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
    97  ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
    98  ;
    99  N ZCCRD,ZVARN,C0CFDA2
    100  S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
    101  S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    102  I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
    103  . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
    104  . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
    105  . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
    106  . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
    107  . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
    108  . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
    109  . I $D(ZERR) D  ; LAYGO ERROR
    110  . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
    111  . E  D  ;
    112  . . D CLEAN^DILF ; CLEAN UP
    113  . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    114  . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
    115  Q ZVARN
    116  ;
    117 BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,)
    118  ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED
    119  ;
    120  N C0CDIC,C0CNODE ;
    121  S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY
    122  S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE
    123  Q
    124  ;
    125 FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED
    126  ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET
    127  ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS
    128  ; CONVERSION
    129  ;N C0CC,C0CI,C0CJ,C0CN,C0CZX
    130  D FIELDS^C0CRNF("C0CC",170)
    131  S C0CI=""
    132  F  S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI=""  D  ; EACH SECTION
    133  . S C0CZX=""
    134  . F  S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX=""  D  ; EACH VARIABLE
    135  . . W "SECTION ",C0CI," VAR ",C0CZX
    136  . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,""))
    137  . . W " TYPE: ",C0CV,!
    138  . . D SETFDA("SECTION",C0CV)
    139  . . ;ZWR C0CFDA
    140  Q
    141  ;
    142 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
    143  ; TO SET TO VALUE C0CSV.
    144  ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
    145  ; C0CSN,C0CSV ARE PASSED BY VALUE
    146  ;
    147  N C0CSI,C0CSJ
    148  S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
    149  S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
    150  S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
    151  Q
    152 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
    153  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
    154  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    155  I '$D(ZTAB) S ZTAB="C0CA"
    156  N ZR
    157  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
    158  E  S ZR=""
    159  Q ZR
    160 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
    161  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
    162  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    163  I '$D(ZTAB) S ZTAB="C0CA"
    164  N ZR
    165  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
    166  E  S ZR=""
    167  Q ZR
    168  ;
    169 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
    170  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
    171  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    172  I '$D(ZTAB) S ZTAB="C0CA"
    173  N ZR
    174  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
    175  E  S ZR=""
    176  Q ZR
    177  ;
     1C0CFM1    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        W "This is the CCR FILEMAN Utility Library ",!
     21        W !
     22        Q
     23        ;
     24PUTRIM(DFN,ZWHICH)      ;DFN IS PATIENT , WHICH IS ELEMENT TYPE
     25        ;
     26        S C0CGLB=$NA(^TMP("GPLRIM","VARS",DFN))
     27        I '$D(ZWHICH) S ZWHICH="ALL"
     28        I ZWHICH'="ALL" D  ; SINGLE SECTION REQUESTED
     29        . S C0CVARS=$NA(@C0CGLB@(ZWHICH))
     30        . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION
     31        E  D  ; MULTIPLE SECTIONS
     32        . S C0CVARS=$NA(@C0CGLB)
     33        . S C0CI=""
     34        . F  S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI=""  D  ;FOR EACH SECTION
     35        . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION
     36        . . D PUTRIM1(DFN,C0CI,C0CVARSN)
     37        Q
     38        ;
     39PUTRIM1(DFN,ZZTYP,ZVARS)        ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS
     40        ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1"
     41        S C0CX=0
     42        F  S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX=""  D  ; FOR EACH OCCURANCE
     43        . W "ZOCC=",C0CX,!
     44        . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE
     45        . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE
     46        Q
     47        ;
     48PUTELS(DFN,ZTYPE,ZOCC,ZVALS)    ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
     49        ; ^C0C(171.201,   DFN IS THE PATIENT IEN PASSED BY VALUE
     50        ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
     51        ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
     52        ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
     53        ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
     54        ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
     55        ;
     56        S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
     57        ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
     58        N ZF,ZFV S ZF=171.201 S ZFV=171.2012
     59        S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS
     60        N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER
     61        N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
     62        W "ZTYPE: ",ZTYPE," ",ZTYPN,!
     63        N ZVARN ; IEN OF VARIABLE BEING PROCESSED
     64        ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
     65        S C0CFDA(ZF,"?+1,",.01)=DFN
     66        S C0CFDA(ZF,"?+1,",.02)=ZSRC
     67        S C0CFDA(ZF,"?+1,",.03)=ZTYPN
     68        S C0CFDA(ZF,"?+1,",.04)=ZOCC ;CREATE OCCURANCE
     69        K ZERR
     70        D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER
     71        I $D(ZERR) B  ;OOPS
     72        K C0CFDA
     73        S ZD0=$O(^C0C(ZF,"C",DFN,ZSRC,ZTYPN,ZOCC,""))
     74        W "RECORD NUMBER: ",ZD0,!
     75        ;B
     76        S ZCNT=0
     77        S ZC0CI="" ;
     78        F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
     79        . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
     80        . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
     81        . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
     82        . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
     83        . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN
     84        . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI)
     85        . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN
     86        . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI)
     87        ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT"
     88        ;S GT1(170,"?+1,",12)="DIR"
     89        ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT"
     90        ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT"
     91        D CLEAN^DILF
     92        D UPDATE^DIE("","C0CFDA","","ZERR")
     93        Q
     94        ;
     95VARPTR(ZVAR,ZTYP)       ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
     96        ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
     97        ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
     98        ;
     99        N ZCCRD,ZVARN,C0CFDA2
     100        S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
     101        S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     102        I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
     103        . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
     104        . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
     105        . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
     106        . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
     107        . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
     108        . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
     109        . I $D(ZERR) D  ; LAYGO ERROR
     110        . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
     111        . E  D  ;
     112        . . D CLEAN^DILF ; CLEAN UP
     113        . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     114        . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
     115        Q ZVARN
     116        ;
     117BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,)
     118        ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED
     119        ;
     120        N C0CDIC,C0CNODE ;
     121        S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY
     122        S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE
     123        Q
     124        ;
     125FIXSEC  ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED
     126        ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET
     127        ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS
     128        ; CONVERSION
     129        ;N C0CC,C0CI,C0CJ,C0CN,C0CZX
     130        D FIELDS^C0CRNF("C0CC",170)
     131        S C0CI=""
     132        F  S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI=""  D  ; EACH SECTION
     133        . S C0CZX=""
     134        . F  S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX=""  D  ; EACH VARIABLE
     135        . . W "SECTION ",C0CI," VAR ",C0CZX
     136        . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,""))
     137        . . W " TYPE: ",C0CV,!
     138        . . D SETFDA("SECTION",C0CV)
     139        . . ;ZWR C0CFDA
     140        Q
     141        ;
     142SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
     143        ; TO SET TO VALUE C0CSV.
     144        ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
     145        ; C0CSN,C0CSV ARE PASSED BY VALUE
     146        ;
     147        N C0CSI,C0CSJ
     148        S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
     149        S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
     150        S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
     151        Q
     152ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
     153        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
     154        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     155        I '$D(ZTAB) S ZTAB="C0CA"
     156        N ZR
     157        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
     158        E  S ZR=""
     159        Q ZR
     160ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
     161        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
     162        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     163        I '$D(ZTAB) S ZTAB="C0CA"
     164        N ZR
     165        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
     166        E  S ZR=""
     167        Q ZR
     168        ;
     169ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
     170        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
     171        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     172        I '$D(ZTAB) S ZTAB="C0CA"
     173        N ZR
     174        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
     175        E  S ZR=""
     176        Q ZR
     177        ;

  • ccr/branches/ohum/p/C0CFM2.m

    r1342 r1428  
    1 C0CFM2   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  W "This is the CCR FILEMAN Utility Library ",!
    21  ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF
    22  ; CCR ELEMENTS (^C0C(179.201,
    23  ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE
    24  ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT
    25  ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS
    26  ; ALL SUB-VARIABLES HAVE BEEN REMOVED
    27  W !
    28  Q
    29  ;
    30 RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE
    31  ;
    32  I '$D(RIMBASE) D ASETUP^C0CRIMA ; FOR COMMAND LINE CALLS
    33  N ZI,ZJ,ZC,ZPATBASE
    34  S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH))
    35  S ZI=""
    36  F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
    37  . S ZI=$O(@ZPATBASE@(ZI))
    38  . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE
    39  Q
    40  ;
    41 PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE
    42  ;
    43  S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN))
    44  I '$D(ZWHICH) S ZWHICH="ALL"
    45  I ZWHICH'="ALL" D  ; SINGLE SECTION REQUESTED
    46  . S C0CVARS=$NA(@C0CGLB@(ZWHICH))
    47  . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION
    48  E  D  ; MULTIPLE SECTIONS
    49  . S C0CVARS=$NA(@C0CGLB)
    50  . S C0CI=""
    51  . F  S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI=""  D  ;FOR EACH SECTION
    52  . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION
    53  . . D PUTRIM1(DFN,C0CI,C0CVARSN)
    54  Q
    55  ;
    56 PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS
    57  ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1"
    58  S C0CX=0
    59  F  S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX=""  D  ; FOR EACH OCCURANCE
    60  . W "ZOCC=",C0CX,!
    61  . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME
    62  . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE
    63  . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE
    64  . I $D(C0CMDO) D  ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :()
    65  . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
    66  . . S ZZCNT=0
    67  . . S ZZC0CI=0
    68  . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE
    69  . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
    70  . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
    71  . . W "MULTIPLE:",ZZVALS,!
    72  . . ;B
    73  . . F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
    74  . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
    75  . . . W "COUNT:",ZZCNT,!
    76  . . . S ZV=$NA(@ZZVALS@(ZZC0CI))
    77  . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV)
    78  Q
    79  ;
    80 PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
    81  ; 171.101, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
    82  ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
    83  ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
    84  ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
    85  ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
    86  ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
    87  ;
    88  N PATN,ZTYPN,XD0,ZTYP
    89  I '$D(ZSRC) S ZSRC=1 ; CCR SOURCE IS ASSUMED, 1 IF NOT SET
    90  ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
    91  N C0CFPAT S C0CFPAT=171.101 ; FILE AT PATIENT LEVEL
    92  N C0CFSRC S C0CFSRC=171.111 ; FILE AT CCR SOURCE LVL
    93  N C0CFTYP S C0CFTYP=171.121 ; FILE AT ELEMENT TYPE LVL
    94  N C0CFOCC S C0CFOCC=171.131 ; FILE AT OCCURANCE LVL
    95  N C0CFVAR S C0CFVAR=171.1311 ; FILE AT VARIABLE LVL
    96  ;FILE IS ^C0CE(PAT,1,SCR,1,TYP,1,OCC,1,VAR,1, ...
    97  ; AND WE HAVE TO ADD THEM LEVEL AT A TIME I THINK
    98  N C0CFDA
    99  S C0CFDA(C0CFPAT,"?+1,",.01)=DFN
    100  D UPDIE ; ADD THE PATIENT
    101  S PATN=$O(^C0CE("B",DFN,"")) ; IEN FOR THE PATIENT
    102  S C0CFDA(C0CFSRC,"?+1,"_PATN_",",.01)=ZSRC
    103  D UPDIE ; ADD THE CCR SOURCE
    104  N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) ; FIND THE ELE TYPE
    105  S C0CFDA(C0CFTYP,"?+1,"_ZSRC_","_PATN_",",.01)=ZTYPN
    106  D UPDIE ; ADD THE ELEMENT TYPE
    107  S ZTYP=$O(^C0CE(PATN,1,ZSRC,1,"B",ZTYPN,"")) ; IEN OF ELEMENT TYPE
    108  S C0CFDA(C0CFOCC,"?+1,"_ZTYP_","_ZSRC_","_PATN_",",.01)=ZOCC ; STRING OCC
    109  ; OCC IS PRECEDED BY " " TO FORCE STRING STORAGE AND PRESERVE
    110  ; STRING COLLATION ON THE INDEX
    111  D UPDIE ; ADD THE OCCURANCE
    112  S ZD0=$O(^C0CE(PATN,1,ZSRC,1,ZTYP,1,"B",ZOCC,""))
    113  W "RECORD NUMBER: ",ZD0,!
    114  ;I ZD0=32 B
    115  ;I ZD0=31 B
    116  N ZCNT,ZC0CI,ZVARN,C0CZ1
    117  S ZCNT=0
    118  S ZC0CI="" ;
    119  F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
    120  . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
    121  . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
    122  . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
    123  . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
    124  . . S C0CZ1=ZTYP_","_ZSRC_","_PATN_","
    125  . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,.01)=ZVARN
    126  . . S ZZVAL=$TR(@ZVALS@(ZC0CI),"^","|")
    127  . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,1)=ZZVAL
    128  . E  D  ; THIS IS A SUBELEMENT
    129  . . ;PUT THE FOLLOWING BACK TO USE RECURSION
    130  . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
    131  . . ;S ZZCNT=0
    132  . . ;S ZZC0CI=0
    133  . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE
    134  . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
    135  . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
    136  . . ;W "MULTIPLE:",ZZVALS,!
    137  . . ;B
    138  . . ;F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
    139  . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
    140  . . ;. W "COUNT:",ZZCNT,!
    141  . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI))
    142  . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION
    143  . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION)
    144  D UPDIE ; UPDATE
    145  Q
    146  ;
    147 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
    148  K ZERR
    149  D CLEAN^DILF
    150  D UPDATE^DIE("","C0CFDA","","ZERR")
    151  I $D(ZERR) D  ;
    152  . W "ERROR",!
    153  . ZWR ZERR
    154  . B
    155  K C0CFDA
    156  Q
    157  ;
    158 CHECK ; CHECKSUM EXPERIMENTS
    159  ;
    160  ;B
    161  S ZG=$NA(^C0CE(DA(2),1,DA(1),1,DA))
    162  ;S G2=$NA(^C0CE(8,1,1,1,2,1,6))
    163  S X=$$CHKSUM^XUSESIG1(ZG)
    164  W G1,!
    165  Q
    166  ;
    167 CHKELS(DFN) ; CHECKSUM ALL ELEMENTS FOR  A PATIENT
    168  ;
    169  S ZGLB=$NA(^TMP("C0CCHK"))
    170  S ZPAT=$O(^C0CE("B",DFN,""))
    171  K @ZGLB@(ZPAT) ; CLEAR PREVIOUS CHECKSUMS
    172  S ZSRC=""
    173  F  S ZSRC=$O(^C0CE(ZPAT,1,"B",ZSRC)) Q:ZSRC=""  D  ;
    174  . W "PAT:",ZPAT," SRC:",ZSRC,!
    175  . S ZEL=""
    176  . F  S ZEL=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL)) Q:ZEL=""  D  ;ELEMENTS
    177  . . W "ELEMENT:",ZEL," "
    178  . . S ZELE=$$GET1^DIQ(170.101,ZEL,.01,"E") ;ELEMENT NAME
    179  . . W ZELE," "
    180  . . S ZELI=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL,""))
    181  . . S ZG=$NA(^C0CE(ZPAT,1,ZSRC,1,ZELI))
    182  . . S ZCHK=$$CHKSUM^XUSESIG1(ZG) ; CHECKSUM FOR THE ELEMENT
    183  . . W ZCHK,!
    184  . . S @ZGLB@(ZPAT,ZELE,ZSRC)=ZCHK
    185  ZWR ^TMP("C0CCHK",ZPAT,*)
    186  Q
    187  ;
    188 DOIT(DFN) ; EXPERIMENT FOR TIMING CALLS USING mumps -dir DOIT^C0CFM2(DFN)
    189  D SETXUP
    190  D CHKELS(DFN)
    191  Q
    192  ;
    193 SETXUP ; SET UP ENVIRONMENT
    194  S DISYS=19
    195  S DT=3090325
    196  S DTIME=300
    197  S DUZ=1
    198  S DUZ(0)="@"
    199  S DUZ(1)=""
    200  S DUZ(2)=7247
    201  S DUZ("AG")="I"
    202  S DUZ("BUF")=1
    203  S DUZ("LANG")=""
    204  S IO="/dev/pts/20"
    205  S IO(0)="/dev/pts/20"
    206  S IO(1,"/dev/pts/20")=""
    207  S IO("ERROR")=""
    208  S IO("HOME")="344^/dev/pts/20"
    209  S IO("ZIO")="/dev/pts/20"
    210  S IOBS="$C(8)"
    211  S IOF="#,$C(27,91,50,74,27,91,72)"
    212  S IOM=80
    213  S ION="TELNET"
    214  S IOS=344
    215  S IOSL=24
    216  S IOST="C-VT100"
    217  S IOST(0)=9
    218  S IOT="VTRM"
    219  S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)"
    220  S U="^"
    221  S X="216;DIC(4.2,"
    222  S XPARSYS="216;DIC(4.2,"
    223  S XQXFLG="^^XUP"
    224  Q
    225  ;
    226 PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
    227  ; 171.101, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
    228  ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
    229  ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
    230  ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
    231  ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
    232  ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
    233  ;
    234  S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
    235  ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
    236  N ZF,ZFV S ZF=171.101 S ZFV=171.1011
    237  ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS
    238  ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER
    239  N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
    240  W "ZTYPE: ",ZTYPE," ",ZTYPN,!
    241  N ZVARN ; IEN OF VARIABLE BEING PROCESSED
    242  ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
    243  K C0CFDA
    244  S C0CFDA(ZF,"?+1,",.01)=DFN
    245  S C0CFDA(ZF,"?+1,",.02)=ZSRC
    246  S C0CFDA(ZF,"?+1,",.03)=ZTYPN
    247  S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE
    248  K ZERR
    249  ;B
    250  D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER
    251  I $D(ZERR) B  ;OOPS
    252  K C0CFDA
    253  S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,""))
    254  W "RECORD NUMBER: ",ZD0,!
    255  ;B
    256  S ZCNT=0
    257  S ZC0CI="" ;
    258  F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
    259  . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
    260  . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
    261  . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
    262  . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
    263  . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN
    264  . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI)
    265  . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN
    266  . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI)
    267  ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT"
    268  ;S GT1(170,"?+1,",12)="DIR"
    269  ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT"
    270  ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT"
    271  D CLEAN^DILF
    272  D UPDATE^DIE("","C0CFDA","","ZERR")
    273  I $D(ZERR) D  ;
    274  . W "ERROR",!
    275  . ZWR ZERR
    276  . B
    277  K C0CFDA
    278  Q
    279  ;
    280 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
    281  ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
    282  ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
    283  ;
    284  N ZCCRD,ZVARN,C0CFDA2
    285  S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
    286  S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    287  I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
    288  . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
    289  . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
    290  . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
    291  . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
    292  . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
    293  . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
    294  . I $D(ZERR) D  ; LAYGO ERROR
    295  . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
    296  . E  D  ;
    297  . . D CLEAN^DILF ; CLEAN UP
    298  . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    299  . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
    300  Q ZVARN
    301  ;
    302 BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,)
    303  ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED
    304  ;
    305  N C0CDIC,C0CNODE ;
    306  S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY
    307  S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE
    308  Q
    309  ;
    310 FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED
    311  ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET
    312  ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS
    313  ; CONVERSION
    314  ;N C0CC,C0CI,C0CJ,C0CN,C0CZX
    315  D FIELDS^C0CRNF("C0CC",170)
    316  S C0CI=""
    317  F  S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI=""  D  ; EACH SECTION
    318  . S C0CZX=""
    319  . F  S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX=""  D  ; EACH VARIABLE
    320  . . W "SECTION ",C0CI," VAR ",C0CZX
    321  . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,""))
    322  . . W " TYPE: ",C0CV,!
    323  . . D SETFDA("SECTION",C0CV)
    324  . . ;ZWR C0CFDA
    325  Q
    326  ;
    327 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
    328  ; TO SET TO VALUE C0CSV.
    329  ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
    330  ; C0CSN,C0CSV ARE PASSED BY VALUE
    331  ;
    332  N C0CSI,C0CSJ
    333  S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
    334  S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
    335  S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
    336  Q
    337 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
    338  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
    339  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    340  I '$D(ZTAB) S ZTAB="C0CA"
    341  N ZR
    342  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
    343  E  S ZR=""
    344  Q ZR
    345 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
    346  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
    347  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    348  I '$D(ZTAB) S ZTAB="C0CA"
    349  N ZR
    350  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
    351  E  S ZR=""
    352  Q ZR
    353  ;
    354 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
    355  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
    356  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    357  I '$D(ZTAB) S ZTAB="C0CA"
    358  N ZR
    359  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
    360  E  S ZR=""
    361  Q ZR
    362  ;
     1C0CFM2    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        W "This is the CCR FILEMAN Utility Library ",!
     21        ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF
     22        ; CCR ELEMENTS (^C0C(179.201,
     23        ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE
     24        ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT
     25        ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS
     26        ; ALL SUB-VARIABLES HAVE BEEN REMOVED
     27        W !
     28        Q
     29        ;
     30RIMTBL(ZWHICH)  ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE
     31        ;
     32        I '$D(RIMBASE) D ASETUP^C0CRIMA ; FOR COMMAND LINE CALLS
     33        N ZI,ZJ,ZC,ZPATBASE
     34        S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH))
     35        S ZI=""
     36        F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
     37        . S ZI=$O(@ZPATBASE@(ZI))
     38        . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE
     39        Q
     40        ;
     41PUTRIM(DFN,ZWHICH)      ;DFN IS PATIENT , WHICH IS ELEMENT TYPE
     42        ;
     43        S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN))
     44        I '$D(ZWHICH) S ZWHICH="ALL"
     45        I ZWHICH'="ALL" D  ; SINGLE SECTION REQUESTED
     46        . S C0CVARS=$NA(@C0CGLB@(ZWHICH))
     47        . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION
     48        E  D  ; MULTIPLE SECTIONS
     49        . S C0CVARS=$NA(@C0CGLB)
     50        . S C0CI=""
     51        . F  S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI=""  D  ;FOR EACH SECTION
     52        . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION
     53        . . D PUTRIM1(DFN,C0CI,C0CVARSN)
     54        Q
     55        ;
     56PUTRIM1(DFN,ZZTYP,ZVARS)        ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS
     57        ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1"
     58        S C0CX=0
     59        F  S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX=""  D  ; FOR EACH OCCURANCE
     60        . W "ZOCC=",C0CX,!
     61        . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME
     62        . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE
     63        . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE
     64        . I $D(C0CMDO) D  ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :()
     65        . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
     66        . . S ZZCNT=0
     67        . . S ZZC0CI=0
     68        . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE
     69        . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
     70        . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
     71        . . W "MULTIPLE:",ZZVALS,!
     72        . . ;B
     73        . . F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
     74        . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
     75        . . . W "COUNT:",ZZCNT,!
     76        . . . S ZV=$NA(@ZZVALS@(ZZC0CI))
     77        . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV)
     78        Q
     79        ;
     80PUTELS(DFN,ZTYPE,ZOCC,ZVALS)    ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
     81        ; 171.101, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
     82        ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
     83        ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
     84        ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
     85        ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
     86        ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
     87        ;
     88        N PATN,ZTYPN,XD0,ZTYP
     89        I '$D(ZSRC) S ZSRC=1 ; CCR SOURCE IS ASSUMED, 1 IF NOT SET
     90        ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
     91        N C0CFPAT S C0CFPAT=171.101 ; FILE AT PATIENT LEVEL
     92        N C0CFSRC S C0CFSRC=171.111 ; FILE AT CCR SOURCE LVL
     93        N C0CFTYP S C0CFTYP=171.121 ; FILE AT ELEMENT TYPE LVL
     94        N C0CFOCC S C0CFOCC=171.131 ; FILE AT OCCURANCE LVL
     95        N C0CFVAR S C0CFVAR=171.1311 ; FILE AT VARIABLE LVL
     96        ;FILE IS ^C0CE(PAT,1,SCR,1,TYP,1,OCC,1,VAR,1, ...
     97        ; AND WE HAVE TO ADD THEM LEVEL AT A TIME I THINK
     98        N C0CFDA
     99        S C0CFDA(C0CFPAT,"?+1,",.01)=DFN
     100        D UPDIE ; ADD THE PATIENT
     101        S PATN=$O(^C0CE("B",DFN,"")) ; IEN FOR THE PATIENT
     102        S C0CFDA(C0CFSRC,"?+1,"_PATN_",",.01)=ZSRC
     103        D UPDIE ; ADD THE CCR SOURCE
     104        N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) ; FIND THE ELE TYPE
     105        S C0CFDA(C0CFTYP,"?+1,"_ZSRC_","_PATN_",",.01)=ZTYPN
     106        D UPDIE ; ADD THE ELEMENT TYPE
     107        S ZTYP=$O(^C0CE(PATN,1,ZSRC,1,"B",ZTYPN,"")) ; IEN OF ELEMENT TYPE
     108        S C0CFDA(C0CFOCC,"?+1,"_ZTYP_","_ZSRC_","_PATN_",",.01)=ZOCC ; STRING OCC
     109        ; OCC IS PRECEDED BY " " TO FORCE STRING STORAGE AND PRESERVE
     110        ; STRING COLLATION ON THE INDEX
     111        D UPDIE ; ADD THE OCCURANCE
     112        S ZD0=$O(^C0CE(PATN,1,ZSRC,1,ZTYP,1,"B",ZOCC,""))
     113        W "RECORD NUMBER: ",ZD0,!
     114        ;I ZD0=32 B
     115        ;I ZD0=31 B
     116        N ZCNT,ZC0CI,ZVARN,C0CZ1
     117        S ZCNT=0
     118        S ZC0CI="" ;
     119        F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
     120        . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
     121        . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
     122        . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
     123        . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
     124        . . S C0CZ1=ZTYP_","_ZSRC_","_PATN_","
     125        . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,.01)=ZVARN
     126        . . S ZZVAL=$TR(@ZVALS@(ZC0CI),"^","|")
     127        . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,1)=ZZVAL
     128        . E  D  ; THIS IS A SUBELEMENT
     129        . . ;PUT THE FOLLOWING BACK TO USE RECURSION
     130        . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
     131        . . ;S ZZCNT=0
     132        . . ;S ZZC0CI=0
     133        . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE
     134        . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
     135        . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
     136        . . ;W "MULTIPLE:",ZZVALS,!
     137        . . ;B
     138        . . ;F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
     139        . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
     140        . . ;. W "COUNT:",ZZCNT,!
     141        . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI))
     142        . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION
     143        . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION)
     144        D UPDIE ; UPDATE
     145        Q
     146        ;
     147UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
     148        K ZERR
     149        D CLEAN^DILF
     150        D UPDATE^DIE("","C0CFDA","","ZERR")
     151        I $D(ZERR) D  ;
     152        . W "ERROR",!
     153        . ZWR ZERR
     154        . B
     155        K C0CFDA
     156        Q
     157        ;
     158CHECK   ; CHECKSUM EXPERIMENTS
     159        ;
     160        ;B
     161        S ZG=$NA(^C0CE(DA(2),1,DA(1),1,DA))
     162        ;S G2=$NA(^C0CE(8,1,1,1,2,1,6))
     163        S X=$$CHKSUM^XUSESIG1(ZG)
     164        W G1,!
     165        Q
     166        ;
     167CHKELS(DFN)     ; CHECKSUM ALL ELEMENTS FOR  A PATIENT
     168        ;
     169        S ZGLB=$NA(^TMP("C0CCHK"))
     170        S ZPAT=$O(^C0CE("B",DFN,""))
     171        K @ZGLB@(ZPAT) ; CLEAR PREVIOUS CHECKSUMS
     172        S ZSRC=""
     173        F  S ZSRC=$O(^C0CE(ZPAT,1,"B",ZSRC)) Q:ZSRC=""  D  ;
     174        . W "PAT:",ZPAT," SRC:",ZSRC,!
     175        . S ZEL=""
     176        . F  S ZEL=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL)) Q:ZEL=""  D  ;ELEMENTS
     177        . . W "ELEMENT:",ZEL," "
     178        . . S ZELE=$$GET1^DIQ(170.101,ZEL,.01,"E") ;ELEMENT NAME
     179        . . W ZELE," "
     180        . . S ZELI=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL,""))
     181        . . S ZG=$NA(^C0CE(ZPAT,1,ZSRC,1,ZELI))
     182        . . S ZCHK=$$CHKSUM^XUSESIG1(ZG) ; CHECKSUM FOR THE ELEMENT
     183        . . W ZCHK,!
     184        . . S @ZGLB@(ZPAT,ZELE,ZSRC)=ZCHK
     185        ZWR ^TMP("C0CCHK",ZPAT,*)
     186        Q
     187        ;
     188DOIT(DFN)       ; EXPERIMENT FOR TIMING CALLS USING mumps -dir DOIT^C0CFM2(DFN)
     189        D SETXUP
     190        D CHKELS(DFN)
     191        Q
     192        ;
     193SETXUP  ; SET UP ENVIRONMENT
     194        S DISYS=19
     195        S DT=3090325
     196        S DTIME=300
     197        S DUZ=1
     198        S DUZ(0)="@"
     199        S DUZ(1)=""
     200        S DUZ(2)=7247
     201        S DUZ("AG")="I"
     202        S DUZ("BUF")=1
     203        S DUZ("LANG")=""
     204        S IO="/dev/pts/20"
     205        S IO(0)="/dev/pts/20"
     206        S IO(1,"/dev/pts/20")=""
     207        S IO("ERROR")=""
     208        S IO("HOME")="344^/dev/pts/20"
     209        S IO("ZIO")="/dev/pts/20"
     210        S IOBS="$C(8)"
     211        S IOF="#,$C(27,91,50,74,27,91,72)"
     212        S IOM=80
     213        S ION="TELNET"
     214        S IOS=344
     215        S IOSL=24
     216        S IOST="C-VT100"
     217        S IOST(0)=9
     218        S IOT="VTRM"
     219        S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)"
     220        S U="^"
     221        S X="216;DIC(4.2,"
     222        S XPARSYS="216;DIC(4.2,"
     223        S XQXFLG="^^XUP"
     224        Q
     225        ;
     226PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
     227        ; 171.101, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
     228        ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
     229        ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
     230        ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
     231        ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
     232        ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
     233        ;
     234        S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
     235        ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
     236        N ZF,ZFV S ZF=171.101 S ZFV=171.1011
     237        ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS
     238        ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER
     239        N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
     240        W "ZTYPE: ",ZTYPE," ",ZTYPN,!
     241        N ZVARN ; IEN OF VARIABLE BEING PROCESSED
     242        ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
     243        K C0CFDA
     244        S C0CFDA(ZF,"?+1,",.01)=DFN
     245        S C0CFDA(ZF,"?+1,",.02)=ZSRC
     246        S C0CFDA(ZF,"?+1,",.03)=ZTYPN
     247        S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE
     248        K ZERR
     249        ;B
     250        D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER
     251        I $D(ZERR) B  ;OOPS
     252        K C0CFDA
     253        S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,""))
     254        W "RECORD NUMBER: ",ZD0,!
     255        ;B
     256        S ZCNT=0
     257        S ZC0CI="" ;
     258        F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
     259        . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
     260        . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
     261        . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
     262        . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
     263        . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN
     264        . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI)
     265        . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN
     266        . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI)
     267        ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT"
     268        ;S GT1(170,"?+1,",12)="DIR"
     269        ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT"
     270        ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT"
     271        D CLEAN^DILF
     272        D UPDATE^DIE("","C0CFDA","","ZERR")
     273        I $D(ZERR) D  ;
     274        . W "ERROR",!
     275        . ZWR ZERR
     276        . B
     277        K C0CFDA
     278        Q
     279        ;
     280VARPTR(ZVAR,ZTYP)       ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
     281        ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
     282        ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
     283        ;
     284        N ZCCRD,ZVARN,C0CFDA2
     285        S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
     286        S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     287        I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
     288        . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
     289        . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
     290        . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
     291        . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
     292        . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
     293        . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
     294        . I $D(ZERR) D  ; LAYGO ERROR
     295        . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
     296        . E  D  ;
     297        . . D CLEAN^DILF ; CLEAN UP
     298        . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     299        . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
     300        Q ZVARN
     301        ;
     302BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,)
     303        ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED
     304        ;
     305        N C0CDIC,C0CNODE ;
     306        S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY
     307        S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE
     308        Q
     309        ;
     310FIXSEC  ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED
     311        ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET
     312        ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS
     313        ; CONVERSION
     314        ;N C0CC,C0CI,C0CJ,C0CN,C0CZX
     315        D FIELDS^C0CRNF("C0CC",170)
     316        S C0CI=""
     317        F  S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI=""  D  ; EACH SECTION
     318        . S C0CZX=""
     319        . F  S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX=""  D  ; EACH VARIABLE
     320        . . W "SECTION ",C0CI," VAR ",C0CZX
     321        . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,""))
     322        . . W " TYPE: ",C0CV,!
     323        . . D SETFDA("SECTION",C0CV)
     324        . . ;ZWR C0CFDA
     325        Q
     326        ;
     327SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
     328        ; TO SET TO VALUE C0CSV.
     329        ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
     330        ; C0CSN,C0CSV ARE PASSED BY VALUE
     331        ;
     332        N C0CSI,C0CSJ
     333        S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
     334        S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
     335        S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
     336        Q
     337ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
     338        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
     339        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     340        I '$D(ZTAB) S ZTAB="C0CA"
     341        N ZR
     342        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
     343        E  S ZR=""
     344        Q ZR
     345ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
     346        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
     347        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     348        I '$D(ZTAB) S ZTAB="C0CA"
     349        N ZR
     350        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
     351        E  S ZR=""
     352        Q ZR
     353        ;
     354ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
     355        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
     356        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     357        I '$D(ZTAB) S ZTAB="C0CA"
     358        N ZR
     359        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
     360        E  S ZR=""
     361        Q ZR
     362        ;

  • ccr/branches/ohum/p/C0CFM3.m

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

  • ccr/branches/ohum/p/C0CIM2.m

    r1342 r1428  
    1 C0CIM2  ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10
    2  ;;1.0;C0C;;Feb 16, 2010;Build 2
    3  ;Copyright 2010 George Lilly, University of Minnesota and others.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  W "NO ENTRY FROM TOP",!
    22  Q
    23  ;
    24 EXTRACT(IMMXML,DFN,IMMOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE
    25  ; IMMXML AND IMMOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
    26  ;
    27  ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS
    28  ; THAT GET PASSED TO *GET ROUTINES
    29  ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME))
    30  N C0CIMM
    31  S C0CIMM=$NA(^TMP("C0CCCR",$J,DFN,"C0CIMM"))
    32  ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS
    33  ; THAT GET INSERTED INTO THE XML TEMPLATE
    34  ; I '$D(@C0CIMM) D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS IF NOT THERE
    35  D GETRPMS(DFN,C0CIMM) ; GET VARS IF NOT THERE
    36  ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE
    37  ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES
    38  D MAP(IMMXML,C0CIMM,IMMOUT) ;MAP RESULTS FOR PROCEDURES
    39  Q
    40  ;
    41 GETRPMS(DFN,C0CIMM) ; CALLS GET^BGOVIMM TO GET IMMUNIZATIONS.
    42  ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
    43  ; C0CIMM: IMMUNIZATIONS
    44  ; READY TO BE MAPPED TO XML BY MAP^C0CIMM
    45  ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY
    46  ; EXIST.
    47  ;
    48  ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J))
    49  ;
    50  ; SETUP RPC/API CALL HERE
    51  ; USE START AND END DATES FROM PARAMETERS IF REQUIRED
    52  N IMMA
    53  D GET^BGOVIMM(.IMMA,DFN) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
    54  ; PREFORM SORT HERE IF NEEDED
    55  ;
    56  ; NO SORT REQUIRED FOR IMMUNIZATIONS
    57  ;
    58  ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY
    59  ; RNF1 ARRAY FORMAT:
    60  ; VAR("NAME_OF_RIM_VARIABLE")=VALUE
    61  ;
    62  ; IMMUNIZATIONS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF IMMUNIZATION RESULTS
    63  ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD
    64  ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS
    65  N C0CIM,C0CC,ZRNF
    66  S C0CIM="" ; INITIALIZE FOR $O
    67  F C0CC=1:1 S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM=""  D  ; FOR EACH IMMUNE TYPE IN THE LIST
    68  . I DEBUG W @IMMA@(C0CIM),!
    69  . ; FIGURE OUT WHICH TYPE OF IMMUNIZATION IT IS (IMMUNIZATION, FORECAST, CONTRAINDICATIONS, REFUSALS)
    70  . D:$P(@IMMA@(C0CIM),U,1)="I" IMMUN
    71  . D:$P(@IMMA@(C0CIM),U,1)="F" FORECAST
    72  . D:$P(@IMMA@(C0CIM),U,1)="C" CONTRA
    73  . D:$P(@IMMA@(C0CIM),U,1)="R" REFUSE
    74  . D RNF1TO2^C0CRNF(C0CIMM,"ZRNF") ;ADD THIS ROW TO THE ARRAY
    75  . K ZRNF
    76  ; SAVE RIM VARIABLES SEE C0CRIMA
    77  N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE"))
    78  M @ZRIM=@C0CIMM@("V")
    79  Q
    80  ;
    81 IMMUN ; PARSES IMMUNIZATION TYPE ROWS FOR RPMS
    82  ; RPC FORMAT
    83  ;    I ^ Imm Name [2] ^ Visit Date [3] ^ V File IEN [4] ^ Other Location [5] ^ Group [6] ^ Imm IEN [7] ^ Lot [8] ^
    84  ;     Reaction [9] ^ VIS Date [10] ^ Age [11] ^ Visit Date [12] ^ Provider IEN~Name [13] ^ Inj Site [14] ^
    85  ;     Volume [15] ^ Visit IEN [16] ^ Visit Category [17] ^ Full Name [18] ^ Location IEN~Name [19] ^ Visit Locked [20]
    86  ; RETRIEVE IMMUNIZATION RECORD FROM IMMUNIZATION FILE (9999999.14) FOR THIS IMMUNIZATION
    87  D GETN^C0CRNF("C0CZIM",9999999.14,$P(@IMMA@(C0CIM),U,7)) ; GET IMMUNIZATION RECORD
    88  ; RETIREVE IMMUNIZATION RECORD FROM V IMMUNIZATION FILE (9000010.11) FOR THIS IMMUNIZATION
    89  D GETN^C0CRNF("C0CZVI",9000010.11,$P(@IMMA@(C0CIM),U,4)) ; GET V IMMUNIZATION RECORD
    90  S ZRNF("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID
    91  S ZRNF("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME
    92  S ZRNF("IMMUNEDATETIME")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("EVENT DATE AND TIME","C0CZVI"),"DT")
    93  S ZRNF("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_$P($P(@IMMA@(C0CIM),U,13),"~",1)
    94  S ZRNF("IMMUNEPRODUCTNAMETEXT")=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD
    95  S ZRNF("IMMUNEPRODUCTCODE")=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE
    96  I $$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM")'="" S ZRNF("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code"
    97  E  S ZRNF("IMMUNEPRODUCTCODESYSTEM")="" ;NULL
    98  ;CLEANUP FROM C0CRNF CALLS
    99  K C0CZIM,C0CZVI
    100  Q
    101 FORECAST ; PARSES FORECAST TYPE ROWS FOR RPMS
    102  ; CURRENTLY DISABLED
    103  Q
    104 CONTRA ; PARSES FORECAST TYPE ROWS FOR RPMS
    105  ; CURRENTLY DISABLED
    106  Q
    107 REFUSE ; PARSES FORECAST TYPE ROWS FOR RPMS
    108  ; CURRENTLY DISABLED
    109  Q
    110  ;
    111 MAP(IMMXML,C0CIMM,IMMOUT) ; MAP IMMUNIZATION XML
    112  ;
    113  N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"IMMTEMP")) ;WORK AREA FOR TEMPLATE
    114  K @ZTEMP
    115  N ZBLD
    116  S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"IMMBLD")) ; BUILD LIST AREA
    117  D QUEUE^C0CXPATH(ZBLD,IMMXML,1,1) ; FIRST LINE
    118  N ZINNER
    119  ; XPATH NEEDS TO MATCH YOUR SECTION
    120  D QUERY^C0CXPATH(IMMXML,"//Immunizations/Immunization","ZINNER") ;ONE PROC
    121  N ZTMP,ZVAR,ZI
    122  S ZI=""
    123  F  S ZI=$O(@C0CIMM@("V",ZI)) Q:ZI=""  D  ;FOR EACH IMMUNIZATION
    124  . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS IMMUNIZATION XML
    125  . S ZVAR=$NA(@C0CIMM@("V",ZI)) ;THIS IMMUNIZATION VARIABLES
    126  . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE IMMUNIZATION
    127  . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD
    128  D QUEUE^C0CXPATH(ZBLD,IMMXML,@IMMXML@(0),@IMMXML@(0))
    129  N ZZTMP ; IS THIS NEEDED?
    130  D BUILD^C0CXPATH(ZBLD,IMMOUT) ;BUILD FINAL XML
    131  K @ZTEMP,@ZBLD
    132  Q
    133  ; 
     1C0CIM2  ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2010 George Lilly, University of Minnesota and others.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        W "NO ENTRY FROM TOP",!
     22        Q
     23        ;
     24EXTRACT(IMMXML,DFN,IMMOUT)      ; EXTRACT PROCEDURES INTO XML TEMPLATE
     25        ; IMMXML AND IMMOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
     26        ;
     27        ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS
     28        ; THAT GET PASSED TO *GET ROUTINES
     29        ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME))
     30        N C0CIMM
     31        S C0CIMM=$NA(^TMP("C0CCCR",$J,DFN,"C0CIMM"))
     32        ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS
     33        ; THAT GET INSERTED INTO THE XML TEMPLATE
     34        ; I '$D(@C0CIMM) D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS IF NOT THERE
     35        D GETRPMS(DFN,C0CIMM) ; GET VARS IF NOT THERE
     36        ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE
     37        ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES
     38        D MAP(IMMXML,C0CIMM,IMMOUT) ;MAP RESULTS FOR PROCEDURES
     39        Q
     40        ;
     41GETRPMS(DFN,C0CIMM)     ; CALLS GET^BGOVIMM TO GET IMMUNIZATIONS.
     42        ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
     43        ; C0CIMM: IMMUNIZATIONS
     44        ; READY TO BE MAPPED TO XML BY MAP^C0CIMM
     45        ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY
     46        ; EXIST.
     47        ;
     48        ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J))
     49        ;
     50        ; SETUP RPC/API CALL HERE
     51        ; USE START AND END DATES FROM PARAMETERS IF REQUIRED
     52        N IMMA
     53        D GET^BGOVIMM(.IMMA,DFN) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
     54        ; PREFORM SORT HERE IF NEEDED
     55        ;
     56        ; NO SORT REQUIRED FOR IMMUNIZATIONS
     57        ;
     58        ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY
     59        ; RNF1 ARRAY FORMAT:
     60        ; VAR("NAME_OF_RIM_VARIABLE")=VALUE
     61        ;
     62        ; IMMUNIZATIONS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF IMMUNIZATION RESULTS
     63        ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD
     64        ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS
     65        N C0CIM,C0CC,ZRNF
     66        S C0CIM="" ; INITIALIZE FOR $O
     67        F C0CC=1:1 S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM=""  D  ; FOR EACH IMMUNE TYPE IN THE LIST
     68        . I DEBUG W @IMMA@(C0CIM),!
     69        . ; FIGURE OUT WHICH TYPE OF IMMUNIZATION IT IS (IMMUNIZATION, FORECAST, CONTRAINDICATIONS, REFUSALS)
     70        . D:$P(@IMMA@(C0CIM),U,1)="I" IMMUN
     71        . D:$P(@IMMA@(C0CIM),U,1)="F" FORECAST
     72        . D:$P(@IMMA@(C0CIM),U,1)="C" CONTRA
     73        . D:$P(@IMMA@(C0CIM),U,1)="R" REFUSE
     74        . D RNF1TO2^C0CRNF(C0CIMM,"ZRNF") ;ADD THIS ROW TO THE ARRAY
     75        . K ZRNF
     76        ; SAVE RIM VARIABLES SEE C0CRIMA
     77        N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE"))
     78        M @ZRIM=@C0CIMM@("V")
     79        Q
     80        ;
     81IMMUN   ; PARSES IMMUNIZATION TYPE ROWS FOR RPMS
     82        ; RPC FORMAT
     83        ;    I ^ Imm Name [2] ^ Visit Date [3] ^ V File IEN [4] ^ Other Location [5] ^ Group [6] ^ Imm IEN [7] ^ Lot [8] ^
     84        ;     Reaction [9] ^ VIS Date [10] ^ Age [11] ^ Visit Date [12] ^ Provider IEN~Name [13] ^ Inj Site [14] ^
     85        ;     Volume [15] ^ Visit IEN [16] ^ Visit Category [17] ^ Full Name [18] ^ Location IEN~Name [19] ^ Visit Locked [20]
     86        ; RETRIEVE IMMUNIZATION RECORD FROM IMMUNIZATION FILE (9999999.14) FOR THIS IMMUNIZATION
     87        D GETN^C0CRNF("C0CZIM",9999999.14,$P(@IMMA@(C0CIM),U,7)) ; GET IMMUNIZATION RECORD
     88        ; RETIREVE IMMUNIZATION RECORD FROM V IMMUNIZATION FILE (9000010.11) FOR THIS IMMUNIZATION
     89        D GETN^C0CRNF("C0CZVI",9000010.11,$P(@IMMA@(C0CIM),U,4)) ; GET V IMMUNIZATION RECORD
     90        S ZRNF("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID
     91        S ZRNF("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME
     92        S ZRNF("IMMUNEDATETIME")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("EVENT DATE AND TIME","C0CZVI"),"DT")
     93        S ZRNF("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_$P($P(@IMMA@(C0CIM),U,13),"~",1)
     94        S ZRNF("IMMUNEPRODUCTNAMETEXT")=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD
     95        S ZRNF("IMMUNEPRODUCTCODE")=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE
     96        I $$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM")'="" S ZRNF("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code"
     97        E  S ZRNF("IMMUNEPRODUCTCODESYSTEM")="" ;NULL
     98        ;CLEANUP FROM C0CRNF CALLS
     99        K C0CZIM,C0CZVI
     100        Q
     101FORECAST        ; PARSES FORECAST TYPE ROWS FOR RPMS
     102        ; CURRENTLY DISABLED
     103        Q
     104CONTRA  ; PARSES FORECAST TYPE ROWS FOR RPMS
     105        ; CURRENTLY DISABLED
     106        Q
     107REFUSE  ; PARSES FORECAST TYPE ROWS FOR RPMS
     108        ; CURRENTLY DISABLED
     109        Q
     110        ;
     111MAP(IMMXML,C0CIMM,IMMOUT)       ; MAP IMMUNIZATION XML
     112        ;
     113        N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"IMMTEMP")) ;WORK AREA FOR TEMPLATE
     114        K @ZTEMP
     115        N ZBLD
     116        S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"IMMBLD")) ; BUILD LIST AREA
     117        D QUEUE^C0CXPATH(ZBLD,IMMXML,1,1) ; FIRST LINE
     118        N ZINNER
     119        ; XPATH NEEDS TO MATCH YOUR SECTION
     120        D QUERY^C0CXPATH(IMMXML,"//Immunizations/Immunization","ZINNER") ;ONE PROC
     121        N ZTMP,ZVAR,ZI
     122        S ZI=""
     123        F  S ZI=$O(@C0CIMM@("V",ZI)) Q:ZI=""  D  ;FOR EACH IMMUNIZATION
     124        . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS IMMUNIZATION XML
     125        . S ZVAR=$NA(@C0CIMM@("V",ZI)) ;THIS IMMUNIZATION VARIABLES
     126        . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE IMMUNIZATION
     127        . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD
     128        D QUEUE^C0CXPATH(ZBLD,IMMXML,@IMMXML@(0),@IMMXML@(0))
     129        N ZZTMP ; IS THIS NEEDED?
     130        D BUILD^C0CXPATH(ZBLD,IMMOUT) ;BUILD FINAL XML
     131        K @ZTEMP,@ZBLD
     132        Q
     133        ; 

  • ccr/branches/ohum/p/C0CIMMU.m

    r1342 r1428  
    1 C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  ;
    22  ; PROCESS THE IMMUNIZATIONS SECTION OF THE CCR
    23  ;
    24 MAP(IPXML,DFN,OUTXML) ; MAP IMMUNIZATIONS
    25  ;
    26  N C0CZV,C0CZVI ; TO STORE MAPPED VARIABLES
    27  N C0CZT ; TMP ARRAY OF MAPPED XML
    28  S C0CZV=$NA(^TMP("C0CCCR",$J,"IMMUNE")) ; TEMP STORAGE FOR VARIABLES
    29  D EXTRACT(IPXML,DFN,OUTXML) ;EXTRACT THE VARIABLES
    30  N C0CZI,C0CZIC ; COUNT OF IMMUNIZATIONS
    31  S C0CZIC=$G(@C0CZV@(0)) ; TOTAL FROM VARIABLE ARRAY
    32  I C0CZIC>0 D  ;IMMUNIZATIONS FOUND
    33  . F C0CZI=1:1:C0CZIC D  ;FOR EACH IMMUNIZATION
    34  . . S C0CZVI=$NA(@C0CZV@(C0CZI)) ;THIS IMMUNIZATION
    35  . . D MAP^C0CXPATH(IPXML,C0CZVI,"C0CZT") ;MAP THE VARIABLES TO XML
    36  . . I C0CZI=1 D  ; FIRST ONE
    37  . . . D CP^C0CXPATH("C0CZT",OUTXML) ;JUST COPY RESULTS
    38  . . E  D  ;NOT THE FIRST
    39  . . . D INSINNER^C0CXPATH(OUTXML,"C0CZT")
    40  E  S @OUTXML@(0)=0 ; SIGNAL NO IMMUNIZATIONS
    41  N IMMUTMP,I
    42  D MISSING^C0CXPATH(OUTXML,"IMMUTMP") ; SEARCH XML FOR MISSING VARS
    43  I IMMUTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
    44  . ; STRINGS MARKED AS @@X@@
    45  . W !,"IMMUNE Missing list: ",!
    46  . F I=1:1:IMMUTMP(0) W IMMUTMP(I),!
    47  Q
    48  ;
    49 EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT IMMUNIZATIONS INTO VARIABLES
    50  ;
    51  ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
    52  ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE
    53  ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE
    54  ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS
    55  ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT
    56  ;
    57  N RPCRSLT,J,K,PTMP,X,VMAP,TBU
    58  S TVMAP=$NA(^TMP("C0CCCR",$J,"IMMUNE"))
    59  S TARYTMP=$NA(^TMP("C0CCCR",$J,"IMMUARYTMP"))
    60  S IMMA=$NA(^TMP("PXI",$J)) ;
    61  K @IMMA ; CLEAR OUT PREVIOUS RESULTS
    62  K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES
    63  D IMMUN^PXRHS03(DFN) ;
    64  I $O(@IMMA@(""))="" D  Q  ; RPC RETURNS NULL
    65  . W "NULL RESULT FROM IMMUN^PXRHS03 ",!
    66  . S @TVMAP@(0)=0
    67  N C0CIM,C0CC,C0CIMD,C0CIEN,C0CT ;
    68  S C0CIM=""
    69  S C0CC=0 ; COUNT
    70  F  S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM=""  D  ; FOR EACH IMMUNE TYPE IN THE LIST
    71  . S C0CC=C0CC+1 ;INCREMENT COUNT
    72  . S @TVMAP@(0)=C0CC ; SAVE NEW COUNT TO ARRAY
    73  . S VMAP=$NA(@TVMAP@(C0CC)) ; THIS IMMUNE ELEMENT
    74  . K @VMAP ; MAKE SURE IT IS CLEARED OUT
    75  . W C0CIM,!
    76  . S C0CIMD="" ; IMMUNE DATE
    77  . F  S C0CIMD=$O(@IMMA@(C0CIM,C0CIMD)) Q:C0CIMD=""  D  ; FOR EACH DATE
    78  . . S C0CIEN=$O(@IMMA@(C0CIM,C0CIMD,"")) ;IEN OF IMMUNE RECORD
    79  . . D GETN^C0CRNF("C0CI",9000010.11,C0CIEN) ; GET THE FILEMAN RECORD FOR IENS
    80  . . W C0CIEN,"_",C0CIMD
    81  . . S C0CT=$$FMDTOUTC^C0CUTIL(9999999-C0CIMD,"DT") ; FORMAT DATE/TIME
    82  . . W C0CT,!
    83  . . S @VMAP@("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID
    84  . . S @VMAP@("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME
    85  . . S @VMAP@("IMMUNEDATETIME")=C0CT ;FORMATTED DATE/TIME
    86  . . S C0CIP=$$ZVALUEI^C0CRNF("ENCOUNTER PROVIDER","C0CI") ;IEN OF PROVIDER
    87  . . S @VMAP@("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_C0CIP
    88  . . S C0CIIEN=$$ZVALUEI^C0CRNF("IMMUNIZATION","C0CI") ;IEN OF IMMUNIZATION
    89  . . I $G(DUZ("AG"))="I" D  ; RUNNING IN RPMS
    90  . . . D GETN^C0CRNF("C0CZIM",9999999.14,C0CIIEN) ;GET IMMUNE RECORD
    91  . . . S C0CIN=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD
    92  . . . ; FOR LOOKING UP THE CODE
    93  . . . ; GET IT FROM THE CODE FILE
    94  . . . S C0CICD=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE
    95  . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME
    96  . . . S @VMAP@("IMMUNEPRODUCTCODE")=C0CICD ; CVX CODE
    97  . . . I C0CICD'="" S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code" ;
    98  . . . E  S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NULL
    99  . . E  D  ; NOT IN RPMS
    100  . . . S C0CIN=$$ZVALUE^C0CRNF("IMMUNIZATION","C0CI") ;NAME OF IMMUNIZATION
    101  . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME
    102  . . . S @VMAP@("IMMUNEPRODUCTCODE")="" ; CVX CODE
    103  . . . S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NO CODE
    104  N C0CIRIM S C0CIRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE"))
    105  M @C0CIRIM=@TVMAP ; PERSIST RIM VARIABLES
    106  Q
    107  ;
     1C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        ;
     22        ; PROCESS THE IMMUNIZATIONS SECTION OF THE CCR
     23        ;
     24MAP(IPXML,DFN,OUTXML)   ; MAP IMMUNIZATIONS
     25        ;
     26        N C0CZV,C0CZVI ; TO STORE MAPPED VARIABLES
     27        N C0CZT ; TMP ARRAY OF MAPPED XML
     28        S C0CZV=$NA(^TMP("C0CCCR",$J,"IMMUNE")) ; TEMP STORAGE FOR VARIABLES
     29        D EXTRACT(IPXML,DFN,OUTXML) ;EXTRACT THE VARIABLES
     30        N C0CZI,C0CZIC ; COUNT OF IMMUNIZATIONS
     31        S C0CZIC=$G(@C0CZV@(0)) ; TOTAL FROM VARIABLE ARRAY
     32        I C0CZIC>0 D  ;IMMUNIZATIONS FOUND
     33        . F C0CZI=1:1:C0CZIC D  ;FOR EACH IMMUNIZATION
     34        . . S C0CZVI=$NA(@C0CZV@(C0CZI)) ;THIS IMMUNIZATION
     35        . . D MAP^C0CXPATH(IPXML,C0CZVI,"C0CZT") ;MAP THE VARIABLES TO XML
     36        . . I C0CZI=1 D  ; FIRST ONE
     37        . . . D CP^C0CXPATH("C0CZT",OUTXML) ;JUST COPY RESULTS
     38        . . E  D  ;NOT THE FIRST
     39        . . . D INSINNER^C0CXPATH(OUTXML,"C0CZT")
     40        E  S @OUTXML@(0)=0 ; SIGNAL NO IMMUNIZATIONS
     41        N IMMUTMP,I
     42        D MISSING^C0CXPATH(OUTXML,"IMMUTMP") ; SEARCH XML FOR MISSING VARS
     43        I IMMUTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
     44        . ; STRINGS MARKED AS @@X@@
     45        . W !,"IMMUNE Missing list: ",!
     46        . F I=1:1:IMMUTMP(0) W IMMUTMP(I),!
     47        Q
     48        ;
     49EXTRACT(IPXML,DFN,OUTXML)       ; EXTRACT IMMUNIZATIONS INTO VARIABLES
     50        ;
     51        ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
     52        ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE
     53        ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE
     54        ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS
     55        ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT
     56        ;
     57        N RPCRSLT,J,K,PTMP,X,VMAP,TBU
     58        S TVMAP=$NA(^TMP("C0CCCR",$J,"IMMUNE"))
     59        S TARYTMP=$NA(^TMP("C0CCCR",$J,"IMMUARYTMP"))
     60        S IMMA=$NA(^TMP("PXI",$J)) ;
     61        K @IMMA ; CLEAR OUT PREVIOUS RESULTS
     62        K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES
     63        D IMMUN^PXRHS03(DFN) ;
     64        I $O(@IMMA@(""))="" D  Q  ; RPC RETURNS NULL
     65        . W "NULL RESULT FROM IMMUN^PXRHS03 ",!
     66        . S @TVMAP@(0)=0
     67        N C0CIM,C0CC,C0CIMD,C0CIEN,C0CT ;
     68        S C0CIM=""
     69        S C0CC=0 ; COUNT
     70        F  S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM=""  D  ; FOR EACH IMMUNE TYPE IN THE LIST
     71        . S C0CC=C0CC+1 ;INCREMENT COUNT
     72        . S @TVMAP@(0)=C0CC ; SAVE NEW COUNT TO ARRAY
     73        . S VMAP=$NA(@TVMAP@(C0CC)) ; THIS IMMUNE ELEMENT
     74        . K @VMAP ; MAKE SURE IT IS CLEARED OUT
     75        . W C0CIM,!
     76        . S C0CIMD="" ; IMMUNE DATE
     77        . F  S C0CIMD=$O(@IMMA@(C0CIM,C0CIMD)) Q:C0CIMD=""  D  ; FOR EACH DATE
     78        . . S C0CIEN=$O(@IMMA@(C0CIM,C0CIMD,"")) ;IEN OF IMMUNE RECORD
     79        . . D GETN^C0CRNF("C0CI",9000010.11,C0CIEN) ; GET THE FILEMAN RECORD FOR IENS
     80        . . W C0CIEN,"_",C0CIMD
     81        . . S C0CT=$$FMDTOUTC^C0CUTIL(9999999-C0CIMD,"DT") ; FORMAT DATE/TIME
     82        . . W C0CT,!
     83        . . S @VMAP@("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID
     84        . . S @VMAP@("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME
     85        . . S @VMAP@("IMMUNEDATETIME")=C0CT ;FORMATTED DATE/TIME
     86        . . S C0CIP=$$ZVALUEI^C0CRNF("ENCOUNTER PROVIDER","C0CI") ;IEN OF PROVIDER
     87        . . S @VMAP@("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_C0CIP
     88        . . S C0CIIEN=$$ZVALUEI^C0CRNF("IMMUNIZATION","C0CI") ;IEN OF IMMUNIZATION
     89        . . I $G(DUZ("AG"))="I" D  ; RUNNING IN RPMS
     90        . . . D GETN^C0CRNF("C0CZIM",9999999.14,C0CIIEN) ;GET IMMUNE RECORD
     91        . . . S C0CIN=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD
     92        . . . ; FOR LOOKING UP THE CODE
     93        . . . ; GET IT FROM THE CODE FILE
     94        . . . S C0CICD=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE
     95        . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME
     96        . . . S @VMAP@("IMMUNEPRODUCTCODE")=C0CICD ; CVX CODE
     97        . . . I C0CICD'="" S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code" ;
     98        . . . E  S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NULL
     99        . . E  D  ; NOT IN RPMS
     100        . . . S C0CIN=$$ZVALUE^C0CRNF("IMMUNIZATION","C0CI") ;NAME OF IMMUNIZATION
     101        . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME
     102        . . . S @VMAP@("IMMUNEPRODUCTCODE")="" ; CVX CODE
     103        . . . S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NO CODE
     104        N C0CIRIM S C0CIRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE"))
     105        M @C0CIRIM=@TVMAP ; PERSIST RIM VARIABLES
     106        Q
     107        ;

  • ccr/branches/ohum/p/C0CIN.m

    r1342 r1428  
    1 C0CIN   ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08
    2  ;;1.0;C0C;;Sep 20, 2009;Build 2
    3  ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  W "This is the CCR Import Utility Library ",!
    21  Q
    22  ;
    23 TEST ; TESTS BOTH ROUTINES AT ONCE
    24  N ZI,ZJ
    25  S ZI="/home/vademo2/CCR" ;directory purposely leaving off the trailing /
    26  S ZJ="PAT_358_CCR_V1_0_21.xml" ; random test patient
    27  D RPCFIN(.GPL,358,135,"GPLTEST","CCR",ZJ,ZI)
    28  Q
    29  ;
    30 RPCAIN(RTN,DFN,DUZ,SOURCE,TYPE,ARY) ; ARRAY IN RPC - ACCEPT AN XML DOCUMENT
    31  ; AND STORE IT IN THE INCOMING XML FILE
    32  ; RETURNS THE IEN OF THE RECORD OR TEXT IF THERE IS AN ERROR
    33  I $G(DFN)="" S RTN="DFN NOT DEFINED" Q  ;
    34  N C0CXF S C0CXF=175 ; FILE NUMBER FOR INCOMING XML FILE
    35  N C0CFDA,ZX
    36  S C0CFDA(C0CXF,"+1,",.01)=DFN ; PATIENT
    37  S C0CFDA(C0CXF,"+1,",.02)=DUZ ; PROVIDER CREATING THE RECORD
    38  S C0CFDA(C0CXF,"+1,",1)=$$NOW^XLFDT ;DATE
    39  S C0CFDA(C0CXF,"+1,",2)=TYPE  ;TYPE
    40  S C0CFDA(C0CXF,"+1,",3)=$$ADDSRC(SOURCE) ;SOURCE
    41  S C0CFDA(C0CXF,"+1,",7)="NEW" ; STATUS OF NEW FOR NOT PROCESSED
    42  D UPDIE ; CREATE THE RECORD
    43  S ZX=C0CIEN(1) ; CAPTURE THE RECORD NUMBER
    44  D WP^DIE(C0CXF,ZX_",",4,,ARY,"ZERR")
    45  ;W "RECORD:",ZX,!
    46  S RTN=ZX ; RETURN IEN OF THE XML FILE
    47  Q
    48  ;
    49 ADDSRC(ZSRC) ;EXTRISIC TO ADD A SOURCE TO THE CCR SOURCE FILE
    50  ; RETURNS RECORD NUMBER. IF SOURCE EXISTS, JUST RETURNS IT'S RECORD NUMBER
    51  ;
    52  N ZX,ZF,C0CFDA
    53  S ZF=171.401 ; FILE NUMBER FOR CCR SOURCE FILE
    54  S C0CFDA(ZF,"?+1,",.01)=ZSRC
    55  D UPDIE
    56  Q $O(^C0C(171.401,"B",ZSRC,""))
    57  ;
    58 RPCFIN(RTN,DFN,DUZ,SOURCE,TYPE,FN,FP) ; FILE IN RPC - READ AN XML DOCUMENT
    59  ; FROM A HOST FILE AND STORE IT IN THE INCOMING XML FILE
    60  N ZX,ZTMP
    61  I $E($RE(FP))'="/" S ZX=FP_"/"
    62  E  S ZX=FP
    63  S ZX=ZX_FN
    64  D LOAD("ZTMP",ZX)
    65  I '$D(ZTMP) D  Q  ; NO LUCK
    66  . W "FILE NOT LOADED",!
    67  D RPCAIN(.RTN,DFN,DUZ,SOURCE,TYPE,"ZTMP")
    68  N C0CFDA
    69  S C0CFDA(175,RTN_",",5)=FN ; FILE NAME
    70  S C0CFDA(175,RTN_",",6)=FP ; FILE PATH
    71  D UPDIE ; UPDATE WITH FILE NAME AND PATH
    72  Q
    73  ;
    74 RPCLIST(RTN,DFN) ; CCR LIST - LIST XML DOCUMENTS FOR PATIENT DFN
    75  ; THAT ARE STORED IN THE INCOMING XML FILE
    76  ; RETURNS AN ARRAY OF THE FORM
    77  ; RTN(x)="IEN^DATE^TYPE^SOURCE^STATUS^CREATEDBY" WHERE
    78  ; IEN IS THE RECORD NUMBER OF THE XML DOCUMENT
    79  ; DATE IS THE DATE THE DOCUMENT WAS STORED IN THE FILE
    80  ; TYPE IS "CCD" OR "CCR" OR "OTHER"
    81  ; SOURCE IS THE NAME OF THE DOCUMENT SOURCE FROM THE CCR SOURCE FILE
    82  ; STATUS IS THE STATUS OF THE DOCUMENT (VALUES TO BE DEFINED)
    83  ; CREATEDBY IS THE NAME OF THE PROVIDER WHO UPLOADED THE XML
    84  N ZF S ZF=175 ; FILE NUMBER OF INCOMING XML FILE
    85  N ZI S ZI=""
    86  N ZN S ZN=0
    87  F  S ZI=$O(^C0CIN("B",DFN,ZI),-1) Q:ZI=""  D  ; FOR EACH RECORD FOR THIS PATIENT
    88  . S ZN=ZN+1 ;INCREMENT COUNT OF RETURN ARRAY
    89  . S $P(RTN(ZN),"^",1)=ZI ; IEN OF RECORD
    90  . S $P(RTN(ZN),"^",2)=$$GET1^DIQ(ZF,ZI_",",1,"E") ;DATE
    91  . S $P(RTN(ZN),"^",3)=$$GET1^DIQ(ZF,ZI_",",2,"E") ;TYPE
    92  . S $P(RTN(ZN),"^",4)=$$GET1^DIQ(ZF,ZI_",",3,"E") ;SOURCE
    93  . S $P(RTN(ZN),"^",5)=$$GET1^DIQ(ZF,ZI_",",7,"I") ; STATUS
    94  . S $P(RTN(ZN),"^",6)=$$GET1^DIQ(ZF,ZI_",",.02,"E") ; CREATED BY
    95  Q
    96  ;
    97 RPCDOC(RTN,IEN) ; RETRIEVE DOCUMENT NUMBER IEN FROM THE INCOMING XML FILE
    98  ; RETURNED IN ARRAY RTN
    99  N ZI
    100  S ZI=$$GET1^DIQ(175,IEN_",",4,,"RTN")
    101  Q
    102  ;
    103 EN(INXML,SOURCE,C0CDFN) ; IMPORT A CCR, PASSED BY NAME INXML
    104  ; FILE UNDER SOURCE, WHICH IS A POINTER TO THE CCR SOURCE FILE
    105  ; FOR PATIENT C0CDFN
    106  ;N C0CXP
    107  S C0CINB=$NA(^TMP("C0CIN",$J,"VARS",C0CDFN))
    108  S C0CDOCID=$$PARSE^C0CMXML(INXML) ;W !,"DocID: ",C0CDOCID
    109  ;S REDUX="//ContinuityOfCareRecord/Body"
    110  S REDUX=""
    111  D XPATH^C0CMXML(1,"/","C0CIDX","C0CXP",,REDUX)
    112  ;D INDEX^C0CXPATH(INXML,"C0CXP",-1) ; GENERATE XPATHS FROM THE CCR
    113  ;N ZI,ZJ,ZK
    114  S ZI=""
    115  F  S ZI=$O(C0CXP(ZI)) Q:ZI=""  D  ; FOR EACH XPATH
    116  . D DEMUX^C0CMXP("ZJ",ZI) ;
    117  . W ZJ,!
    118  . S ZK=$P(ZJ,"^",3) ; PULL OUT THE XPATH
    119  . S ZM=$P(ZJ,"^",1) ; PULL OUT THE MULTIPLE
    120  . S ZS=$P(ZJ,"^",2) ; PULL OUT THE SUBMULTIPLE
    121  . S C0CDICN=$O(^C0CDIC(170,"XPATH",ZK,""))
    122  . I C0CDICN="" D  Q  ;
    123  . . W "MISSING XPATH:",!,ZK,! ; OOPS, XPATH NOT IN C0CDIC
    124  . . S MISSING(ZK)=""
    125  . ;D GETS^DIQ(170,C0CDICN_",","*",,"C0CFDA")
    126  . S C0CVAR=$$GET1^DIQ(170,C0CDICN_",",.01) ; VARIABLE NAME
    127  . S C0CSEC=$$GET1^DIQ(170,C0CDICN_",",12) ;ELEMENT TYPE
    128  . W C0CSEC,":",C0CVAR,!
    129  Q
    130  ;
    131 GETACCR(AOUT,C0CDFN) ; EXTRACT A CCR FOR PATIENT ADFN AND PUT IT IN ARRAY AOUT
    132  ;PASSED BY NAME
    133  N ZT
    134  D CCRRPC^C0CCCR(.ZT,C0CDFN,"LABLIMIT:T-1000")
    135  M @AOUT=ZT
    136  Q
    137  ;
    138 TEST64 ;TEST BASE64 DECODING FOR IMPORTING CCR FROM THE NHIN
    139  W $$FTG^%ZISH("/tmp/","base64_encoded_ccr.txt","G64(1)",1)
    140  S G=G64(1)
    141  S ZI=""
    142  F  S ZI=$O(G64(1,"OVF",ZI)) Q:ZI=""  D  ; FOR EVERY OVERFLOW RECORD
    143  . S G=G_G64(1,"OVF",ZI) ;HOPE IT'S NOT TOO BIG
    144  S G2=$$DECODE^RGUTUU(G)
    145  Q
    146  ;
    147 NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
    148  ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
    149  ;
    150  N ZI,ZN,ZTMP
    151  S ZN=1
    152  S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">"
    153  S ZN=ZN+1
    154  F  S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)=""  D  ;
    155  . S @OUTXML@(ZN)=@OUTXML@(ZN)_">"
    156  . S ZN=ZN+1
    157  Q
    158  ;
    159 CLEANCR(OUTXML,INXML) ; USE $C(10) TO SEPARATE THE STRING INXML INTO
    160  ;AN ARRAY OUTXML(n) OUTXML AND INXML PASSED BY NAME
    161  N ZX,ZY,ZN
    162  S ZX=1,ZN=1
    163  F  S ZY=$F(@INXML,$C(10),ZX) Q:ZY=0  D  ;
    164  . S @OUTXML@(ZN)=$E(G2,ZX,ZY-2)
    165  . I @OUTXML@(ZN)'="" S ZN=ZN+1
    166  . S ZX=ZY
    167  Q
    168  ;
    169 LOAD(ZRTN,filepath) ; load an xml file into the ZRTN array, passed by name
    170  n i
    171  D  ;
    172  . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)=""
    173  . s ztmp=$na(^TMP("C0CLOAD",$J))
    174  . k @ztmp
    175  . s zfile=$re($p($re(filepath),"/",1)) ;file name
    176  . s zpath=$p(filepath,zfile,1) ; file path
    177  . s zok=$$FTG^%ZISH(zpath,zfile,$NA(@ztmp@(1)),3) ; import the file incr sub 3
    178  . m @ZRTN=@ztmp
    179  . k @ztmp
    180  . s i=$o(@ZRTN@(""),-1) ; highest line number
    181  q
    182  ;
    183 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
    184  K ZERR,C0CIEN
    185  D CLEAN^DILF
    186  D UPDATE^DIE("","C0CFDA","C0CIEN","ZERR")
    187  I $D(ZERR) D  ;
    188  . W "ERROR",!
    189  . ZWR ZERR
    190  . B
    191  K C0CFDA
    192  Q
    193  ;
     1C0CIN     ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        W "This is the CCR Import Utility Library ",!
     21        Q
     22        ;
     23TEST    ; TESTS BOTH ROUTINES AT ONCE
     24        N ZI,ZJ
     25        S ZI="/home/vademo2/CCR" ;directory purposely leaving off the trailing /
     26        S ZJ="PAT_358_CCR_V1_0_21.xml" ; random test patient
     27        D RPCFIN(.GPL,358,135,"GPLTEST","CCR",ZJ,ZI)
     28        Q
     29        ;
     30RPCAIN(RTN,DFN,DUZ,SOURCE,TYPE,ARY)     ; ARRAY IN RPC - ACCEPT AN XML DOCUMENT
     31        ; AND STORE IT IN THE INCOMING XML FILE
     32        ; RETURNS THE IEN OF THE RECORD OR TEXT IF THERE IS AN ERROR
     33        I $G(DFN)="" S RTN="DFN NOT DEFINED" Q  ;
     34        N C0CXF S C0CXF=175 ; FILE NUMBER FOR INCOMING XML FILE
     35        N C0CFDA,ZX
     36        S C0CFDA(C0CXF,"+1,",.01)=DFN ; PATIENT
     37        S C0CFDA(C0CXF,"+1,",.02)=DUZ ; PROVIDER CREATING THE RECORD
     38        S C0CFDA(C0CXF,"+1,",1)=$$NOW^XLFDT ;DATE
     39        S C0CFDA(C0CXF,"+1,",2)=TYPE  ;TYPE
     40        S C0CFDA(C0CXF,"+1,",3)=$$ADDSRC(SOURCE) ;SOURCE
     41        S C0CFDA(C0CXF,"+1,",7)="NEW" ; STATUS OF NEW FOR NOT PROCESSED
     42        D UPDIE ; CREATE THE RECORD
     43        S ZX=C0CIEN(1) ; CAPTURE THE RECORD NUMBER
     44        D WP^DIE(C0CXF,ZX_",",4,,ARY,"ZERR")
     45        ;W "RECORD:",ZX,!
     46        S RTN=ZX ; RETURN IEN OF THE XML FILE
     47        Q
     48        ;
     49ADDSRC(ZSRC)    ;EXTRISIC TO ADD A SOURCE TO THE CCR SOURCE FILE
     50        ; RETURNS RECORD NUMBER. IF SOURCE EXISTS, JUST RETURNS IT'S RECORD NUMBER
     51        ;
     52        N ZX,ZF,C0CFDA
     53        S ZF=171.401 ; FILE NUMBER FOR CCR SOURCE FILE
     54        S C0CFDA(ZF,"?+1,",.01)=ZSRC
     55        D UPDIE
     56        Q $O(^C0C(171.401,"B",ZSRC,""))
     57        ;
     58RPCFIN(RTN,DFN,DUZ,SOURCE,TYPE,FN,FP)   ; FILE IN RPC - READ AN XML DOCUMENT
     59        ; FROM A HOST FILE AND STORE IT IN THE INCOMING XML FILE
     60        N ZX,ZTMP
     61        I $E($RE(FP))'="/" S ZX=FP_"/"
     62        E  S ZX=FP
     63        S ZX=ZX_FN
     64        D LOAD("ZTMP",ZX)
     65        I '$D(ZTMP) D  Q  ; NO LUCK
     66        . W "FILE NOT LOADED",!
     67        D RPCAIN(.RTN,DFN,DUZ,SOURCE,TYPE,"ZTMP")
     68        N C0CFDA
     69        S C0CFDA(175,RTN_",",5)=FN ; FILE NAME
     70        S C0CFDA(175,RTN_",",6)=FP ; FILE PATH
     71        D UPDIE ; UPDATE WITH FILE NAME AND PATH
     72        Q
     73        ;
     74RPCLIST(RTN,DFN)        ; CCR LIST - LIST XML DOCUMENTS FOR PATIENT DFN
     75        ; THAT ARE STORED IN THE INCOMING XML FILE
     76        ; RETURNS AN ARRAY OF THE FORM
     77        ; RTN(x)="IEN^DATE^TYPE^SOURCE^STATUS^CREATEDBY" WHERE
     78        ; IEN IS THE RECORD NUMBER OF THE XML DOCUMENT
     79        ; DATE IS THE DATE THE DOCUMENT WAS STORED IN THE FILE
     80        ; TYPE IS "CCD" OR "CCR" OR "OTHER"
     81        ; SOURCE IS THE NAME OF THE DOCUMENT SOURCE FROM THE CCR SOURCE FILE
     82        ; STATUS IS THE STATUS OF THE DOCUMENT (VALUES TO BE DEFINED)
     83        ; CREATEDBY IS THE NAME OF THE PROVIDER WHO UPLOADED THE XML
     84        N ZF S ZF=175 ; FILE NUMBER OF INCOMING XML FILE
     85        N ZI S ZI=""
     86        N ZN S ZN=0
     87        F  S ZI=$O(^C0CIN("B",DFN,ZI),-1) Q:ZI=""  D  ; FOR EACH RECORD FOR THIS PATIENT
     88        . S ZN=ZN+1 ;INCREMENT COUNT OF RETURN ARRAY
     89        . S $P(RTN(ZN),"^",1)=ZI ; IEN OF RECORD
     90        . S $P(RTN(ZN),"^",2)=$$GET1^DIQ(ZF,ZI_",",1,"E") ;DATE
     91        . S $P(RTN(ZN),"^",3)=$$GET1^DIQ(ZF,ZI_",",2,"E") ;TYPE
     92        . S $P(RTN(ZN),"^",4)=$$GET1^DIQ(ZF,ZI_",",3,"E") ;SOURCE
     93        . S $P(RTN(ZN),"^",5)=$$GET1^DIQ(ZF,ZI_",",7,"I") ; STATUS
     94        . S $P(RTN(ZN),"^",6)=$$GET1^DIQ(ZF,ZI_",",.02,"E") ; CREATED BY
     95        Q
     96        ;
     97RPCDOC(RTN,IEN) ; RETRIEVE DOCUMENT NUMBER IEN FROM THE INCOMING XML FILE
     98        ; RETURNED IN ARRAY RTN
     99        N ZI
     100        S ZI=$$GET1^DIQ(175,IEN_",",4,,"RTN")
     101        Q
     102        ;
     103EN(INXML,SOURCE,C0CDFN) ; IMPORT A CCR, PASSED BY NAME INXML
     104        ; FILE UNDER SOURCE, WHICH IS A POINTER TO THE CCR SOURCE FILE
     105        ; FOR PATIENT C0CDFN
     106        ;N C0CXP
     107        S C0CINB=$NA(^TMP("C0CIN",$J,"VARS",C0CDFN))
     108        S C0CDOCID=$$PARSE^C0CMXML(INXML) ;W !,"DocID: ",C0CDOCID
     109        ;S REDUX="//ContinuityOfCareRecord/Body"
     110        S REDUX=""
     111        D XPATH^C0CMXML(1,"/","C0CIDX","C0CXP",,REDUX)
     112        ;D INDEX^C0CXPATH(INXML,"C0CXP",-1) ; GENERATE XPATHS FROM THE CCR
     113        ;N ZI,ZJ,ZK
     114        S ZI=""
     115        F  S ZI=$O(C0CXP(ZI)) Q:ZI=""  D  ; FOR EACH XPATH
     116        . D DEMUX^C0CMXP("ZJ",ZI) ;
     117        . W ZJ,!
     118        . S ZK=$P(ZJ,"^",3) ; PULL OUT THE XPATH
     119        . S ZM=$P(ZJ,"^",1) ; PULL OUT THE MULTIPLE
     120        . S ZS=$P(ZJ,"^",2) ; PULL OUT THE SUBMULTIPLE
     121        . S C0CDICN=$O(^C0CDIC(170,"XPATH",ZK,""))
     122        . I C0CDICN="" D  Q  ;
     123        . . W "MISSING XPATH:",!,ZK,! ; OOPS, XPATH NOT IN C0CDIC
     124        . . S MISSING(ZK)=""
     125        . ;D GETS^DIQ(170,C0CDICN_",","*",,"C0CFDA")
     126        . S C0CVAR=$$GET1^DIQ(170,C0CDICN_",",.01) ; VARIABLE NAME
     127        . S C0CSEC=$$GET1^DIQ(170,C0CDICN_",",12) ;ELEMENT TYPE
     128        . W C0CSEC,":",C0CVAR,!
     129        Q
     130        ;
     131GETACCR(AOUT,C0CDFN)    ; EXTRACT A CCR FOR PATIENT ADFN AND PUT IT IN ARRAY AOUT
     132        ;PASSED BY NAME
     133        N ZT
     134        D CCRRPC^C0CCCR(.ZT,C0CDFN,"LABLIMIT:T-1000")
     135        M @AOUT=ZT
     136        Q
     137        ;
     138TEST64  ;TEST BASE64 DECODING FOR IMPORTING CCR FROM THE NHIN
     139        W $$FTG^%ZISH("/tmp/","base64_encoded_ccr.txt","G64(1)",1)
     140        S G=G64(1)
     141        S ZI=""
     142        F  S ZI=$O(G64(1,"OVF",ZI)) Q:ZI=""  D  ; FOR EVERY OVERFLOW RECORD
     143        . S G=G_G64(1,"OVF",ZI) ;HOPE IT'S NOT TOO BIG
     144        S G2=$$DECODE^RGUTUU(G)
     145        Q
     146        ;
     147NORMAL(OUTXML,INXML)    ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
     148        ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
     149        ;
     150        N ZI,ZN,ZTMP
     151        S ZN=1
     152        S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">"
     153        S ZN=ZN+1
     154        F  S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)=""  D  ;
     155        . S @OUTXML@(ZN)=@OUTXML@(ZN)_">"
     156        . S ZN=ZN+1
     157        Q
     158        ;
     159CLEANCR(OUTXML,INXML)   ; USE $C(10) TO SEPARATE THE STRING INXML INTO
     160        ;AN ARRAY OUTXML(n) OUTXML AND INXML PASSED BY NAME
     161        N ZX,ZY,ZN
     162        S ZX=1,ZN=1
     163        F  S ZY=$F(@INXML,$C(10),ZX) Q:ZY=0  D  ;
     164        . S @OUTXML@(ZN)=$E(G2,ZX,ZY-2)
     165        . I @OUTXML@(ZN)'="" S ZN=ZN+1
     166        . S ZX=ZY
     167        Q
     168        ;
     169LOAD(ZRTN,filepath)     ; load an xml file into the ZRTN array, passed by name
     170        n i
     171        D  ;
     172        . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)=""
     173        . s ztmp=$na(^TMP("C0CLOAD",$J))
     174        . k @ztmp
     175        . s zfile=$re($p($re(filepath),"/",1)) ;file name
     176        . s zpath=$p(filepath,zfile,1) ; file path
     177        . s zok=$$FTG^%ZISH(zpath,zfile,$NA(@ztmp@(1)),3) ; import the file incr sub 3
     178        . m @ZRTN=@ztmp
     179        . k @ztmp
     180        . s i=$o(@ZRTN@(""),-1) ; highest line number
     181        q
     182        ;
     183UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
     184        K ZERR,C0CIEN
     185        D CLEAN^DILF
     186        D UPDATE^DIE("","C0CFDA","C0CIEN","ZERR")
     187        I $D(ZERR) D  ;
     188        . W "ERROR",!
     189        . ZWR ZERR
     190        . B
     191        K C0CFDA
     192        Q
     193        ;

  • ccr/branches/ohum/p/C0CLA7DD.m

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

  • ccr/branches/ohum/p/C0CLA7Q.m

    r1342 r1428  
    1 C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;
    4  ;
    5  Q
    6  ;
    7  ;
    8 LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for Lab Result Query
    9  ;
    10  ;
    11  K ^TMP("C0C-VLAB",$J)
    12  ;
    13  ; Check and retrieve lab results from LAB DATA file (#63)
    14  S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7))
    15  ;
    16  ; If V LAB file present then check for lab results that are only in this file
    17  ; If results found in V Lab file then build results and add to above results.
    18  I $D(^AUPNVLAB) D
    19  . D VCHECK
    20  . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD
    21  ;
    22  ;K ^TMP("C0C-VLAB",$J)
    23  ;
    24  Q C0CDEST
    25  ;
    26  ;
    27 VCHECK ; If V LAB file present then check for lab results that are only in this file.
    28  ;
    29  N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC
    30  ;
    31  S LA7PTID=C0CPTID
    32  D PATID^LA7QRY2
    33  I $D(LA7ERR) Q
    34  ;
    35  ; Resolve search codes to lab datanames
    36  S LA7SC=$G(C0CSC)
    37  I $T(SCLIST^LA7QRY2)'="" D
    38  . N TMP
    39  . S LA7SCRC=$G(C0CSC)
    40  . S TMP=$$SCLIST^LA7QRY2(LA7SCRC)
    41  . S LA7SC=TMP
    42  ;
    43  I LA7SC'="*" D CHKSC^LA7QRY1
    44  ;
    45  ; Convert specimen codes to file #61 Topography entries
    46  S LA7SPEC=$G(C0CSPEC)
    47  I LA7SPEC'="*"  D SPEC^LA7QRY1
    48  ;
    49  S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0
    50  ;
    51  F  S C0CROOT=$Q(@C0CROOT) Q:C0CROOT=""  D  Q:C0CEND
    52  . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q  ; Left x-ref or patient
    53  . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q  ; Exceeded end date/time
    54  . S C0CDA=$QS(C0CROOT,4)
    55  . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q  ; Already checked during scan of file #63
    56  . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q  ; Source is LAB DATA file - skip
    57  . D VCHK1
    58  ;
    59  ;
    60  Q
    61  ;
    62  ;
    63 VBUILD ; Build results found only in V LAB file into HL7 structure.
    64  ;
    65  ;
    66  Q
    67  ;
    68  ;
    69 LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63.
    70  ; Call from LA7QRY2
    71  ;
    72  N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X
    73  ;
    74  S DFN=$P(^LR(LRDFN,0),"^",3)
    75  S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0)
    76  S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5)
    77  S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)=""
    78  ;
    79  ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)=""
    80  ;
    81  S C0C60=""
    82  F  S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60  D  Q:C0CLN'=""
    83  . D FINDDT
    84  . I C0CDA<1 Q
    85  . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q  ; Source is not LAB DATA file - skip
    86  . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13)
    87  . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8)
    88  . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer
    89  . I C0CPDA="" S C0CPDA=C0CDA
    90  . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2)
    91  . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2)
    92  . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^")
    93  . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2)
    94  . S ^TMP("C0C-VLAB",$J,1,C0CDA)=""
    95  . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)=""
    96  . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST
    97  ;
    98  S X=$P(LA7X,"^",3)
    99  ; If order NLT then update if no order NLT
    100  I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64)
    101  ;
    102  ; If result NLT then update if no result NLT
    103  I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64)
    104  ;
    105  ; If LOINC found then update variable with LN code
    106  I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN
    107  ;
    108  S $P(LA7X,"^",3)=X
    109  ;
    110  Q
    111  ;
    112  ;
    113 TMPCHK ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments
    114  ; Called from LA7VOBX1
    115  ;
    116  N I,X
    117  ;
    118  S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB))
    119  I X="" Q
    120  F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I)
    121  S $P(LA7VAL,"^",3)=LA7X
    122  ;
    123  Q
    124  ;
    125  ;
    126 VCHK1 ; Check the entry in V Lab to determine if it meets criteria
    127  ;
    128  N C0CVLAB,I
    129  ;
    130  F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I))
    131  ;
    132  ; JMC 04/13/09 - Store anything for now that meets date criteria.
    133  D VSTORE
    134  ;
    135  Q
    136  ;
    137  ;
    138 VSTORE ; Store entry for building in HL7 message when parent is from V LAB file.
    139  ;
    140  N C0CPDA,C0CPTEST
    141  ;
    142  ; Determine parent test to use for OBR segment
    143  S C0CPDA=$P(C0CVLAB(12),"^",8)
    144  I C0CPDA="" S C0CPDA=C0CDA
    145  ;
    146  ; Determine parent test
    147  S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^")
    148  ;
    149  S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA
    150  ;
    151  Q
    152  ;
    153  ;
    154 FINDDT ; Find entry in V LAB for the date/time or one close to it.
    155  ; RPMS stores related specimen entries under the same date/time.
    156  ; Lab file #63 creates unique entries with slightly different times.
    157  ;
    158  S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0))
    159  I C0CDA>0 Q
    160  ;
    161  ; If entry found then confirm that specimen type matches.
    162  N C0CDTY
    163  S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0))
    164  I C0CDTY D
    165  . I $P(C0CDT,".")'=$P(C0CDTY,".") Q
    166  . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0))
    167  . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA=""
    168  ;
    169  Q
     1C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;
     4        ;
     5        Q
     6        ;
     7        ;
     8LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7)  ; Entry point for Lab Result Query
     9        ;
     10        ;
     11        K ^TMP("C0C-VLAB",$J)
     12        ;
     13        ; Check and retrieve lab results from LAB DATA file (#63)
     14        S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7))
     15        ;
     16        ; If V LAB file present then check for lab results that are only in this file
     17        ; If results found in V Lab file then build results and add to above results.
     18        I $D(^AUPNVLAB) D
     19        . D VCHECK
     20        . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD
     21        ;
     22        ;K ^TMP("C0C-VLAB",$J)
     23        ;
     24        Q C0CDEST
     25        ;
     26        ;
     27VCHECK  ; If V LAB file present then check for lab results that are only in this file.
     28        ;
     29        N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC
     30        ;
     31        S LA7PTID=C0CPTID
     32        D PATID^LA7QRY2
     33        I $D(LA7ERR) Q
     34        ;
     35        ; Resolve search codes to lab datanames
     36        S LA7SC=$G(C0CSC)
     37        I $T(SCLIST^LA7QRY2)'="" D
     38        . N TMP
     39        . S LA7SCRC=$G(C0CSC)
     40        . S TMP=$$SCLIST^LA7QRY2(LA7SCRC)
     41        . S LA7SC=TMP
     42        ;
     43        I LA7SC'="*" D CHKSC^LA7QRY1
     44        ;
     45        ; Convert specimen codes to file #61 Topography entries
     46        S LA7SPEC=$G(C0CSPEC)
     47        I LA7SPEC'="*"  D SPEC^LA7QRY1
     48        ;
     49        S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0
     50        ;
     51        F  S C0CROOT=$Q(@C0CROOT) Q:C0CROOT=""  D  Q:C0CEND
     52        . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q  ; Left x-ref or patient
     53        . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q  ; Exceeded end date/time
     54        . S C0CDA=$QS(C0CROOT,4)
     55        . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q  ; Already checked during scan of file #63
     56        . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q  ; Source is LAB DATA file - skip
     57        . D VCHK1
     58        ;
     59        ;
     60        Q
     61        ;
     62        ;
     63VBUILD  ; Build results found only in V LAB file into HL7 structure.
     64        ;
     65        ;
     66        Q
     67        ;
     68        ;
     69LNCHK   ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63.
     70        ; Call from LA7QRY2
     71        ;
     72        N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X
     73        ;
     74        S DFN=$P(^LR(LRDFN,0),"^",3)
     75        S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0)
     76        S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5)
     77        S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)=""
     78        ;
     79        ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)=""
     80        ;
     81        S C0C60=""
     82        F  S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60  D  Q:C0CLN'=""
     83        . D FINDDT
     84        . I C0CDA<1 Q
     85        . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q  ; Source is not LAB DATA file - skip
     86        . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13)
     87        . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8)
     88        . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer
     89        . I C0CPDA="" S C0CPDA=C0CDA
     90        . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2)
     91        . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2)
     92        . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^")
     93        . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2)
     94        . S ^TMP("C0C-VLAB",$J,1,C0CDA)=""
     95        . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)=""
     96        . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST
     97        ;
     98        S X=$P(LA7X,"^",3)
     99        ; If order NLT then update if no order NLT
     100        I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64)
     101        ;
     102        ; If result NLT then update if no result NLT
     103        I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64)
     104        ;
     105        ; If LOINC found then update variable with LN code
     106        I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN
     107        ;
     108        S $P(LA7X,"^",3)=X
     109        ;
     110        Q
     111        ;
     112        ;
     113TMPCHK  ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments
     114        ; Called from LA7VOBX1
     115        ;
     116        N I,X
     117        ;
     118        S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB))
     119        I X="" Q
     120        F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I)
     121        S $P(LA7VAL,"^",3)=LA7X
     122        ;
     123        Q
     124        ;
     125        ;
     126VCHK1   ; Check the entry in V Lab to determine if it meets criteria
     127        ;
     128        N C0CVLAB,I
     129        ;
     130        F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I))
     131        ;
     132        ; JMC 04/13/09 - Store anything for now that meets date criteria.
     133        D VSTORE
     134        ;
     135        Q
     136        ;
     137        ;
     138VSTORE  ; Store entry for building in HL7 message when parent is from V LAB file.
     139        ;
     140        N C0CPDA,C0CPTEST
     141        ;
     142        ; Determine parent test to use for OBR segment
     143        S C0CPDA=$P(C0CVLAB(12),"^",8)
     144        I C0CPDA="" S C0CPDA=C0CDA
     145        ;
     146        ; Determine parent test
     147        S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^")
     148        ;
     149        S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA
     150        ;
     151        Q
     152        ;
     153        ;
     154FINDDT  ; Find entry in V LAB for the date/time or one close to it.
     155        ; RPMS stores related specimen entries under the same date/time.
     156        ; Lab file #63 creates unique entries with slightly different times.
     157        ;
     158        S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0))
     159        I C0CDA>0 Q
     160        ;
     161        ; If entry found then confirm that specimen type matches.
     162        N C0CDTY
     163        S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0))
     164        I C0CDTY D
     165        . I $P(C0CDT,".")'=$P(C0CDTY,".") Q
     166        . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0))
     167        . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA=""
     168        ;
     169        Q

  • ccr/branches/ohum/p/C0CLABS.m

    r1342 r1428  
    1 C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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 MAP(MIXML,DFN,MOXML) ;TO MAKE THIS COMPATIBLE WITH OLD CALLING FOR EXTRACT
    22  ; ASSUMES THAT EXTRACT HAS BEEN RUN AND THE VARIABLES STORED IN MIVAR
    23  ; MIXML,MIVAR, AND MOXML ARE PASSED BY NAME
    24  ; MIXML IS THE TEMPLATE TO USE
    25  ; MOXML IS THE OUTPUT XML ARRAY
    26  ; DFN IS THE PATIENT RECORD NUMBER
    27  N C0COXML,C0CO,C0CV,C0CIXML
    28  I '$D(MIVAR) S C0CV="" ;DEFAULT
    29  E  S C0CV=MIVAR ;PASSED VARIABLE ARRAY
    30  I '$D(MIXML) S C0CIXML="" ;DEFAULT
    31  E  S C0CIXML=MIXML ;PASSED INPUT XML
    32  D RPCMAP(.C0COXML,DFN,C0CV,C0CIXML) ; CALL RPC TO DO THE WORK
    33  I '$D(MOXML) S C0CO=$NA(^TMP("C0CCCR",$J,DFN,"RESULTS")) ;DEFAULT FOR OUTPUT
    34  E  S C0CO=MOXML
    35  ; ZWR C0COXML
    36  M @C0CO=C0COXML ; COPY RESULTS TO OUTPUT
    37  Q
    38  ;
    39 RPCMAP(RTN,DFN,RMIVAR,RMIXML) ; RPC ENTRY POINT FOR MAPPING RESULTS
    40  ; RTN IS PASSED BY REFERENCE
    41  ;N C0CT0,C0CT,C0CV ; CCR TEMPLATE, RESULTS SUBTEMPLATE, VARIABLES
    42  ;N C0CRT,C0CTT ; TEST REQUEST TEMPLATE, TEST RESULT TEMPLATE
    43  I '$D(DEBUG) S DEBUG=0 ; DEFAULT NO DEBUGGING
    44  I RMIXML="" D  ; INPUT XML NOT PASSED
    45  . D LOAD^C0CCCR0("C0CT0") ; LOAD ENTIRE CCR TEMPLATE
    46  . D QUERY^C0CXPATH("C0CT0","//ContinuityOfCareRecord/Body/Results","C0CT0R")
    47  . S C0CT="C0CT0R" ; NAME OF EXTRACTED RESULTS TEMPLATE
    48  E  S C0CT=RMIXML ; WE ARE PASSED THE RESULTS PART OF THE TEMPLATE
    49  I RMIVAR="" D  ; LOCATION OF VARIABLES NOT PASSED
    50  . S C0CV=$NA(^TMP("C0CCCR",$J,"RESULTS")) ;DEFAULT VARIABLE LOCATION
    51  E  S C0CV=RMIVAR ; PASSED LOCATIONS OF VARS
    52  D CP^C0CXPATH(C0CT,"C0CRT") ; START MAKING TEST REQUEST TEMPLATE
    53  D REPLACE^C0CXPATH("C0CRT","","//Results/Result/Test") ; DELETE TEST FROM REQ
    54  D QUERY^C0CXPATH(C0CT,"//Results/Result/Test","C0CTT") ; MAKE TEST TEMPLATE
    55  I '$D(C0CQT) S C0CQT=0 ; DEFAULT NOT SILENT
    56  I 'C0CQT D  ; WE ARE DEBUGGING
    57  . W "I MAPPED",!
    58  . W "VARS:",C0CV,!
    59  . W "DFN:",DFN,!
    60  . ;D PARY^C0CXPATH("C0CT") ; SECTION TEMPLATE
    61  . ;D PARY^C0CXPATH("C0CRT") ;REQUEST TEMPLATE (OCR)
    62  . ;D PARY^C0CXPATH("C0CTT") ;TEST TEMPLATE (OCX)
    63  D EXTRACT("C0CT",DFN,) ; FIRST CALL EXTRACT
    64  I '$D(@C0CV@(0)) D  Q  ; NO VARS THERE
    65  . S RTN(0)=0 ; PASS BACK NO RESULTS INDICATOR
    66  I @C0CV@(0)=0 S RTN(0)=0 Q ; NO RESULTS
    67  S RIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"RESULTS"))
    68  K @RIMVARS
    69  M @RIMVARS=@C0CV ; UPDATE RIMVARS SO THEY STAY IN SYNCH
    70  N C0CI,C0CJ,C0CMAP,C0CTMAP,C0CTMP
    71  S C0CIN=@C0CV@(0) ; COUNT OF RESULTS (OBR)
    72  N C0CRTMP ; AREA TO BUILD ONE RESULT REQUEST AND ALL TESTS FOR IT
    73  N C0CRBASE S C0CRBASE=$NA(^TMP($J,"TESTTMP")) ;WORK AREA
    74  N C0CRBLD ; BUILD LIST FOR XML - THE BUILD IS DELAYED UNTIL THE END
    75  ; TO IMPROVE PERFORMANCE
    76  D QUEUE^C0CXPATH("C0CRBLD","C0CRT",1,1) ;<Results>
    77  F C0CI=1:1:C0CIN D  ; LOOP THROUGH VARIABLES
    78  . K C0CMAP,C0CTMP ;EMPTY OUT LAST BATCH OF VARIABLES
    79  . S C0CRTMP=$NA(@C0CRBASE@(C0CI)) ;PARTITION OF WORK AREA FOR EACH TEST
    80  . S C0CMAP=$NA(@C0CV@(C0CI)) ;
    81  . I 'C0CQT W "MAPOBR:",C0CMAP,!
    82  . ;MAPPING FOR TEST REQUEST GOES HERE
    83  . D MAP^C0CXPATH("C0CRT",C0CMAP,C0CRTMP) ; MAP OBR DATA
    84  . ;D QOPEN^C0CXPATH("C0CRBLD",C0CRTMP,C0CIS) ;1ST PART OF XML
    85  . D QUEUE^C0CXPATH("C0CRBLD",C0CRTMP,2,@C0CRTMP@(0)-4) ;UP TO <Test>
    86  . I $D(@C0CMAP@("M","TEST",0)) D  ; TESTS EXIST
    87  . . S C0CJN=@C0CMAP@("M","TEST",0) ; NUMBER OF TESTS
    88  . . K C0CTO ; CLEAR OUTPUT VARIABLE
    89  . . F C0CJ=1:1:C0CJN D   ;FOR EACH TEST RESULT
    90  . . . K C0CTMAP ; EMPTY MAPS FOR TEST RESULTS
    91  . . . S C0CTMP=$NA(@C0CRBASE@(C0CI,C0CJ)) ;WORK AREA FOR TEST RESULTS
    92  . . . S C0CTMAP=$NA(@C0CMAP@("M","TEST",C0CJ)) ;
    93  . . . I 'C0CQT W "MAPOBX:",C0CTMAP,!
    94  . . . D MAP^C0CXPATH("C0CTT",C0CTMAP,C0CTMP) ; MAP TO TMP
    95  . . . I C0CJ=1 S C0CJS=2 E  S C0CJS=1 ;FIRST TIME,SKIP THE <Test>
    96  . . . I C0CJ=C0CJN S C0CJE=@C0CTMP@(0)-1 E  S C0CJE=@C0CTMP@(0) ;</Test>
    97  . . . S C0CJS=1 S C0CJE=@C0CTMP@(0) ; INSERT ALL OF THE TEXT XML
    98  . . . D QUEUE^C0CXPATH("C0CRBLD",C0CTMP,C0CJS,C0CJE) ; ADD TO BUILD LIST
    99  . . . ;I C0CJ=1 D  ; FIRST TIME, JUST COPY
    100  . . . ;. D CP^C0CXPATH("C0CTMP","C0CTO") ; START BUILDING TEST XML
    101  . . . ;E  D INSINNER^C0CXPATH("C0CTO","C0CTMP")
    102  . . . ;
    103  . . . ;D PUSHA^C0CXPATH("C0CTO",C0CTMP) ;ADD THE TEST TO BUFFER
    104  . . ; I 'C0CQT D PARY^C0CXPATH("C0CTO")
    105  . . ;D INSINNER^C0CXPATH(C0CRTMP,"C0CTO","//Results/Result/Test") ;INSERT TST
    106  . ;D QCLOSE^C0CXPATH("C0CRBLD",C0CRTMP,"//Results/Result/Test") ;END OF XML
    107  . D QUEUE^C0CXPATH("C0CRBLD","C0CRT",C0CRT(0)-1,C0CRT(0)-1) ;</Result>
    108  . ;I C0CI=1 D  ; FIRST TIME, COPY INSTEAD OF INSERT
    109  . . ;D CP^C0CXPATH(C0CRTMP,"RTN") ;
    110  . ;E  D INSINNER^C0CXPATH("RTN",C0CRTMP) ; INSERT THIS TEST REQUEST
    111  D QUEUE^C0CXPATH("C0CRBLD","C0CRT",C0CRT(0),C0CRT(0)) ;</Results>
    112  D BUILD^C0CXPATH("C0CRBLD","RTN") ;RENDER THE XML
    113  K @C0CRBASE ; CLEAR OUT TEMPORARY STURCTURE
    114  Q
    115  ;
    116 EXTRACT(ILXML,DFN,OLXML) ; EXTRACT LABS INTO THE C0CLVAR GLOBAL
    117  ;
    118  ; LABXML AND LABOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
    119  ;
    120  ;
    121  ;
    122  N C0CNSSN ; IS THERE AN SSN FLAG
    123  S C0CNSSN=0
    124  S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS
    125  D GHL7 ; GET HL7 MESSAGE FOR THIS PATIENT
    126  I C0CNSSN=1 D  Q  ; NO SSN, CAN'T GET HL7 FOR THIS PATIENT
    127  . S @C0CLB@(0)=0
    128  K @C0CLB ; CLEAR OUT OLD VARS IF ANY
    129  N QTSAV S QTSAV=C0CQT ;SAVE QUIET FLAG
    130  S C0CQT=1 ; SURPRESS LISTING
    131  D LIST ; EXTRACT THE VARIABLES
    132  ; FOR CERTIFICATION, SEE IF THERE ARE OTHER RESULTS TO ADD
    133  D EN^C0CORSLT(C0CLB,DFN) ; LOOKS FOR ECG TESTS
    134  S C0CQT=QTSAV ; RESET SILENT FLAG
    135  K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT
    136  I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^C0CLABS
    137  Q
    138      ;
    139 GHL7 ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT
    140  ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR
    141  ; SET UP FOR LAB API CALL
    142  S C0CPTID=$$SSN^C0CDPT(DFN) ; GET THE SSN FOR THIS PATIENT
    143  I C0CPTID="" D  Q  ; NO SSN, COMPLAIN AND QUIT
    144  . W "LAB LOOKUP FAILED, NO SSN",!
    145  . S C0CNSSN=1 ; SET NO SSN FLAG
    146  S C0CSPC="*" ; LOOKING FOR ALL LABS
    147  ;I $D(^TMP("C0CCCR","RPMS")) D  ; RUNNING RPMS
    148  ;. D DT^DILF(,"T-365",.C0CSDT) ; START DATE ONE YEAR AGO TO LIMIT VOLUME
    149  ;E  D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING
    150  ;D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY
    151  S C0CLLMT=$$GET^C0CPARMS("LABLIMIT") ; GET THE LIMIT PARM
    152  S C0CLSTRT=$$GET^C0CPARMS("LABSTART") ; GET START PARM
    153  D DT^DILF(,C0CLLMT,.C0CSDT) ;
    154  W "LAB LIMIT: ",C0CLLMT,!
    155  D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM
    156  S C0CEDT=$$NOW^XLFDT ; PULL LABS STARTING NOW
    157  S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP
    158  Q
    159  ;
    160 LIST ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB
    161  ;
    162  ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR
    163  I '$D(C0CLB) S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS
    164  I '$D(C0CQT) S C0CQT=0
    165  I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT
    166  I '$D(^TMP("C0CCCR","LABTBL",0)) D SETTBL ;INITIALIZE LAB TABLE
    167  I ^TMP("C0CCCR","LABTBL",0)'="V3" D SETTBL ;NEED NEWEST VERSION
    168  I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE
    169  S C0CTAB=$NA(^TMP("C0CCCR","LABTBL")) ; BASE OF OBX TABLE
    170  S C0CHB=$NA(^TMP("HLS",$J))
    171  S C0CI=""
    172  S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT
    173  F  S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI=""  D  ; FOR ALL RECORDS IN HL7 MSG
    174  . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES
    175  . S C0CTYP=$P(@C0CHB@(C0CI),"|",1)
    176  . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT)
    177  . I $G(C0CVAR("RESULTCODINGSYSTEM"))="LN" D  ; gpl - for certification
    178  . . S C0CVAR("RESULTCODINGSYSTEM")="LOINC" ; NEED TO SPELL IT OUT
    179  . . N C0CRDT S C0CRDT=C0CVAR("RESULTDESCRIPTIONTEXT") ; THE DESCRIPTION
    180  . . N C0CRCD S C0CRCD=C0CVAR("RESULTCODE") ; THE LOINC CODE
    181  . . S C0CVAR("RESULTDESCRIPTIONTEXT")=C0CRDT_" LOINC: "_C0CRCD
    182  . M XV=C0CVAR ;
    183  . I C0CTYP="OBR" D  ; BEGINNING OF NEW SECTION
    184  . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT
    185  . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT
    186  . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS
    187  . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI
    188  . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR
    189  . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1)
    190  . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT
    191  . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL
    192  . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME
    193  . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS
    194  . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION
    195  . I C0CTYP="OBX" D  ; SPECIAL CASE FOR OBX3
    196  . . ; RESULTTESTCODEVALUE
    197  . . ; RESULTTESTDESCRIPTIONTEXT
    198  . . I C0CVAR("C3")="LN" D  ; PRIMARY CODE IS LOINC
    199  . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE
    200  . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC
    201  . . . ;S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESC TXT
    202  . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2")_" LOINC: "_C0CVAR("C1")
    203  . . E  I C0CVAR("C6")="LN" D  ; SECONDARY CODE IS LOINC
    204  . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE
    205  . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC
    206  . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT
    207  . . E  I C0CVAR("C6")'="" D  ; NO LOINC CODES, USE SECONDARY IF PRESENT
    208  . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE
    209  . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME
    210  . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT
    211  . . E  D  ; NO SECONDARY, USE PRIMARY
    212  . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE
    213  . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME
    214  . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT
    215  . . N C0CZG S C0CZG=XV("RESULTTESTNORMALDESCTEXT") ;
    216  . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH
    217  . . ;S XV("RESULTTESTNORMALDESCTEXT")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE
    218  . . S XV("RESULTTESTNORMALDESCTEXT")=C0CZG
    219  . . S C0CZG=XV("RESULTTESTVALUE")
    220   . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH
    221  . . ;S XV("RESULTTESTVALUE")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE
    222  . . S XV("RESULTTESTVALUE")=C0CZG
    223  . I C0CTYP="OBX" D  ; PROCESS TEST RESULTS
    224  . . I C0CLOBX=0 D  ; FIRST TEST RESULT FOR THIS SECTION
    225  . . . S C0CLB2=$NA(@C0CLB@(C0CLI,"M","TEST")) ; INDENT FOR TEST RESULTS
    226  . . S C0CLOBX=C0CLOBX+1 ; INCREMENT TEST COUNT
    227  . . S @C0CLB2@(0)=C0CLOBX ; STORE THE TEST COUNT
    228  . . S XV("RESULTTESTOBJECTID")="RESULTTEST_"_C0CLI_"_"_C0CLOBX
    229  . . S C0CX1=XV("RESULTTESTSOURCEACTORID") ; TEST SOURCE
    230  . . S C0CX2=$P($P(C0CX1,"^",1),"-",1) ; PULL OUT STATION NUMBER
    231  . . S XV("RESULTTESTSOURCEACTORID")="ACTORORGANIZATION_"_C0CX2
    232  . . S XV("RESULTTESTNORMALSOURCEACTORID")=XV("RESULTTESTSOURCEACTORID")
    233  . . S C0CX1=XV("RESULTTESTDATETIME") ;DATE TIME IN HL7 FORMAT
    234  . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL
    235  . . S XV("RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME
    236  . . ; I 'C0CQT ZWR XV
    237  . . M @C0CLB2@(C0CLOBX)=XV ; PERSIST THE TEST RESULT VARIABLES
    238  . I 'C0CQT D  ;
    239  . . W C0CI," ",C0CTYP,!
    240  . ; S C0CI=$O(@C0CHB@(C0CI))
    241  ;K ^TMP("C0CRIM","VARS",DFN,"RESULTS")
    242  ;M ^TMP("C0CRIM","VARS",DFN,"RESULTS")=@C0CLB
    243  Q
    244 LTYP(OSEG,OTYP,OVARA,OC0CQT) ;
    245  S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE
    246  I '$D(OC0CQT) S C0CQT=0 ; NOT C0CQT IS DEFAULT
    247  E  S C0CQT=OC0CQT ; ACCEPT C0CQT FLAG
    248  I 1 D  ; FOR HL7 SEGMENT TYPE
    249  . S OI="" ; INDEX INTO FIELDS IN SEG
    250  . F  S OI=$O(@OTAB@(OI)) Q:OI=""  D  ; FOR EACH FIELD OF THE SEGMENT
    251  . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX
    252  . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED
    253  . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE
    254  . . I $P(OI,";",2)'="" D  ; THIS IS DEFINING A SUB-VALUE
    255  . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX
    256  . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE
    257  . . I OVAR'="" S OVARA(OVAR)=OV ; PASS BACK VARIABLE AND VALUE
    258  . . I 'C0CQT D  ; PRINT OUTPUT IF C0CQT IS FALSE
    259  . . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,!
    260  Q
    261 LOBX ;
    262  Q
    263  ;
    264 OUT(DFN) ; WRITE OUT A CCR THAT HAS JUST BEEN PROCESSED (FOR TESTING)
    265  N GA,GF,GD
    266  S GA=$NA(^TMP("C0CCCR",$J,DFN,"CCR",1))
    267  S GF="RPMS_CCR_"_DFN_"_"_DT_".xml"
    268  S GD=^TMP("C0CCCR","ODIR")
    269  W $$OUTPUT^C0CXPATH(GA,GF,GD)
    270  Q
    271  ;
    272 SETTBL ;
    273  K X ; CLEAR X
    274  S X("PID","PID1")="1^00104^Set ID - Patient ID"
    275  S X("PID","PID2")="2^00105^Patient ID (External ID)"
    276  S X("PID","PID3")="3^00106^Patient ID (Internal ID)"
    277  S X("PID","PID4")="4^00107^Alternate Patient ID"
    278  S X("PID","PID5")="5^00108^Patient's Name"
    279  S X("PID","PID6")="6^00109^Mother's Maiden Name"
    280  S X("PID","PID7")="7^00110^Date of Birth"
    281  S X("PID","PID8")="8^00111^Sex"
    282  S X("PID","PID9")="9^00112^Patient Alias"
    283  S X("PID","PID10")="10^00113^Race"
    284  S X("PID","PID11")="11^00114^Patient Address"
    285  S X("PID","PID12")="12^00115^County Code"
    286  S X("PID","PID13")="13^00116^Phone Number - Home"
    287  S X("PID","PID14")="14^00117^Phone Number - Business"
    288  S X("PID","PID15")="15^00118^Language - Patient"
    289  S X("PID","PID16")="16^00119^Marital Status"
    290  S X("PID","PID17")="17^00120^Religion"
    291  S X("PID","PID18")="18^00121^Patient Account Number"
    292  S X("PID","PID19")="19^00122^SSN Number - Patient"
    293  S X("PID","PID20")="20^00123^Drivers License - Patient"
    294  S X("PID","PID21")="21^00124^Mother's Identifier"
    295  S X("PID","PID22")="22^00125^Ethnic Group"
    296  S X("PID","PID23")="23^00126^Birth Place"
    297  S X("PID","PID24")="24^00127^Multiple Birth Indicator"
    298  S X("PID","PID25")="25^00128^Birth Order"
    299  S X("PID","PID26")="26^00129^Citizenship"
    300  S X("PID","PID27")="27^00130^Veteran.s Military Status"
    301  S X("PID","PID28")="28^00739^Nationality"
    302  S X("PID","PID29")="29^00740^Patient Death Date/Time"
    303  S X("PID","PID30")="30^00741^Patient Death Indicator"
    304  S X("NTE","NTE1")="1^00573^Set ID - NTE"
    305  S X("NTE","NTE2")="2^00574^Source of Comment"
    306  S X("NTE","NTE3")="3^00575^Comment"
    307  S X("ORC","ORC1")="1^00215^Order Control"
    308  S X("ORC","ORC2")="2^00216^Placer Order Number"
    309  S X("ORC","ORC3")="3^00217^Filler Order Number"
    310  S X("ORC","ORC4")="4^00218^Placer Order Number"
    311  S X("ORC","ORC5")="5^00219^Order Status"
    312  S X("ORC","ORC6")="6^00220^Response Flag"
    313  S X("ORC","ORC7")="7^00221^Quantity/Timing"
    314  S X("ORC","ORC8")="8^00222^Parent"
    315  S X("ORC","ORC9")="9^00223^Date/Time of Transaction"
    316  S X("ORC","ORC10")="10^00224^Entered By"
    317  S X("ORC","ORC11")="11^00225^Verified By"
    318  S X("ORC","ORC12")="12^00226^Ordering Provider"
    319  S X("ORC","ORC13")="13^00227^Enterer's Location"
    320  S X("ORC","ORC14")="14^00228^Call Back Phone Number"
    321  S X("ORC","ORC15")="15^00229^Order Effective Date/Time"
    322  S X("ORC","ORC16")="16^00230^Order Control Code Reason"
    323  S X("ORC","ORC17")="17^00231^Entering Organization"
    324  S X("ORC","ORC18")="18^00232^Entering Device"
    325  S X("ORC","ORC19")="19^00233^Action By"
    326  S X("OBR","OBR1")="1^00237^Set ID - Observation Request"
    327  S X("OBR","OBR2")="2^00216^Placer Order Number"
    328  S X("OBR","OBR3")="3^00217^Filler Order Number"
    329  S X("OBR","OBR4")="4^00238^Universal Service ID"
    330  S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE"
    331  S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT"
    332  S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE^RESULTCODINGSYSTEM"
    333  S X("OBR","OBR5")="5^00239^Priority"
    334  S X("OBR","OBR6")="6^00240^Requested Date/Time"
    335  S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME"
    336  S X("OBR","OBR8")="8^00242^Observation End Date/Time"
    337  S X("OBR","OBR9")="9^00243^Collection Volume"
    338  S X("OBR","OBR10")="10^00244^Collector Identifier"
    339  S X("OBR","OBR11")="11^00245^Specimen Action Code"
    340  S X("OBR","OBR12")="12^00246^Danger Code"
    341  S X("OBR","OBR13")="13^00247^Relevant Clinical Info."
    342  S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time"
    343  S X("OBR","OBR15")="15^00249^Specimen Source"
    344  S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID"
    345  S X("OBR","OBR17")="17^00250^Order Callback Phone Number"
    346  S X("OBR","OBR18")="18^00251^Placers Field 1"
    347  S X("OBR","OBR19")="19^00252^Placers Field 2"
    348  S X("OBR","OBR20")="20^00253^Filler Field 1"
    349  S X("OBR","OBR21")="21^00254^Filler Field 2"
    350  S X("OBR","OBR22")="22^00255^Results Rpt./Status Change"
    351  S X("OBR","OBR23")="23^00256^Charge to Practice"
    352  S X("OBR","OBR24")="24^00257^Diagnostic Service Sect"
    353  S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS"
    354  S X("OBR","OBR26")="26^00259^Parent Result"
    355  S X("OBR","OBR27")="27^00221^Quantity/Timing"
    356  S X("OBR","OBR28")="28^00260^Result Copies to"
    357  S X("OBR","OBR29")="29^00261^Parent Number"
    358  S X("OBR","OBR30")="30^00262^Transportation Mode"
    359  S X("OBR","OBR31")="31^00263^Reason for Study"
    360  S X("OBR","OBR32")="32^00264^Principal Result Interpreter"
    361  S X("OBR","OBR33")="33^00265^Assistant Result Interpreter"
    362  S X("OBR","OBR34")="34^00266^Technician"
    363  S X("OBR","OBR35")="35^00267^Transcriptionist"
    364  S X("OBR","OBR36")="36^00268^Scheduled Date/Time"
    365  S X("OBR","OBR37")="37^01028^Number of Sample Containers"
    366  S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample"
    367  S X("OBR","OBR39")="39^01030^Collector.s Comment"
    368  S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility"
    369  S X("OBR","OBR41")="41^01032^Transport Arranged"
    370  S X("OBR","OBR42")="42^01033^Escort Required"
    371  S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment"
    372  S X("OBX","OBX1")="1^00559^Set ID - OBX"
    373  S X("OBX","OBX2")="2^00676^Value Type"
    374  S X("OBX","OBX3")="3^00560^Observation Identifier"
    375  S X("OBX","OBX3;C1")="3;1^00560^Observation Identifier^C1"
    376  S X("OBX","OBX3;C2")="3;2^00560^Observation Identifier^C2"
    377  S X("OBX","OBX3;C3")="3;3^00560^Observation Identifier^C3"
    378  S X("OBX","OBX3;C4")="3;4^00560^Observation Identifier^C4"
    379  S X("OBX","OBX3;C5")="3;5^00560^Observation Identifier^C5"
    380  S X("OBX","OBX3;C6")="3;6^00560^Observation Identifier^C6"
    381  S X("OBX","OBX4")="4^00769^Observation Sub-Id"
    382  S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE"
    383  S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS"
    384  S X("OBX","OBX7")="7^00563^Reference Range^RESULTTESTNORMALDESCTEXT"
    385  S X("OBX","OBX8")="8^00564^Abnormal Flags^RESULTTESTFLAG"
    386  S X("OBX","OBX9")="9^00639^Probability"
    387  S X("OBX","OBX10")="10^00565^Nature of Abnormal Test"
    388  S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT"
    389  S X("OBX","OBX12")="12^00567^Date Last Normal Value"
    390  S X("OBX","OBX13")="13^00581^User Defined Access Checks"
    391  S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME"
    392  S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID"
    393  S X("OBX","OBX16")="16^00584^Responsible Observer"
    394  S X("OBX","OBX17")="17^00936^Observation Method"
    395  K ^TMP("C0CCCR","LABTBL")
    396  M ^TMP("C0CCCR","LABTBL")=X ; SET VALUES IN LAB TBL
    397  S ^TMP("C0CCCR","LABTBL",0)="V3"
    398  Q
    399  ;
     1C0CLABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 ; 5/10/12 2:49pm
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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                  ;
     21MAP(MIXML,DFN,MOXML)    ;TO MAKE THIS COMPATIBLE WITH OLD CALLING FOR EXTRACT
     22        ; ASSUMES THAT EXTRACT HAS BEEN RUN AND THE VARIABLES STORED IN MIVAR
     23        ; MIXML,MIVAR, AND MOXML ARE PASSED BY NAME
     24        ; MIXML IS THE TEMPLATE TO USE
     25        ; MOXML IS THE OUTPUT XML ARRAY
     26        ; DFN IS THE PATIENT RECORD NUMBER
     27        N C0COXML,C0CO,C0CV,C0CIXML
     28        I '$D(MIVAR) S C0CV="" ;DEFAULT
     29        E  S C0CV=MIVAR ;PASSED VARIABLE ARRAY
     30        I '$D(MIXML) S C0CIXML="" ;DEFAULT
     31        E  S C0CIXML=MIXML ;PASSED INPUT XML
     32        D RPCMAP(.C0COXML,DFN,C0CV,C0CIXML) ; CALL RPC TO DO THE WORK
     33        I '$D(MOXML) S C0CO=$NA(^TMP("C0CCCR",$J,DFN,"RESULTS")) ;DEFAULT FOR OUTPUT
     34        E  S C0CO=MOXML
     35        ; ZWR C0COXML
     36        M @C0CO=C0COXML ; COPY RESULTS TO OUTPUT
     37        Q
     38        ;
     39RPCMAP(RTN,DFN,RMIVAR,RMIXML)   ; RPC ENTRY POINT FOR MAPPING RESULTS
     40        ; RTN IS PASSED BY REFERENCE
     41        ;N C0CT0,C0CT,C0CV ; CCR TEMPLATE, RESULTS SUBTEMPLATE, VARIABLES
     42        ;N C0CRT,C0CTT ; TEST REQUEST TEMPLATE, TEST RESULT TEMPLATE
     43        I '$D(DEBUG) S DEBUG=0 ; DEFAULT NO DEBUGGING
     44        I RMIXML="" D  ; INPUT XML NOT PASSED
     45        . D LOAD^C0CCCR0("C0CT0") ; LOAD ENTIRE CCR TEMPLATE
     46        . D QUERY^C0CXPATH("C0CT0","//ContinuityOfCareRecord/Body/Results","C0CT0R")
     47        . S C0CT="C0CT0R" ; NAME OF EXTRACTED RESULTS TEMPLATE
     48        E  S C0CT=RMIXML ; WE ARE PASSED THE RESULTS PART OF THE TEMPLATE
     49        I RMIVAR="" D  ; LOCATION OF VARIABLES NOT PASSED
     50        . S C0CV=$NA(^TMP("C0CCCR",$J,"RESULTS")) ;DEFAULT VARIABLE LOCATION
     51        E  S C0CV=RMIVAR ; PASSED LOCATIONS OF VARS
     52        D CP^C0CXPATH(C0CT,"C0CRT") ; START MAKING TEST REQUEST TEMPLATE
     53        D REPLACE^C0CXPATH("C0CRT","","//Results/Result/Test") ; DELETE TEST FROM REQ
     54        D QUERY^C0CXPATH(C0CT,"//Results/Result/Test","C0CTT") ; MAKE TEST TEMPLATE
     55        I '$D(C0CQT) S C0CQT=0 ; DEFAULT NOT SILENT
     56        I 'C0CQT D  ; WE ARE DEBUGGING
     57        . W "I MAPPED",!
     58        . W "VARS:",C0CV,!
     59        . W "DFN:",DFN,!
     60        . ;D PARY^C0CXPATH("C0CT") ; SECTION TEMPLATE
     61        . ;D PARY^C0CXPATH("C0CRT") ;REQUEST TEMPLATE (OCR)
     62        . ;D PARY^C0CXPATH("C0CTT") ;TEST TEMPLATE (OCX)
     63        D EXTRACT("C0CT",DFN,) ; FIRST CALL EXTRACT
     64        I '$D(@C0CV@(0)) D  Q  ; NO VARS THERE
     65        . S RTN(0)=0 ; PASS BACK NO RESULTS INDICATOR
     66        I @C0CV@(0)=0 S RTN(0)=0 Q ; NO RESULTS
     67        S RIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"RESULTS"))
     68        K @RIMVARS
     69        M @RIMVARS=@C0CV ; UPDATE RIMVARS SO THEY STAY IN SYNCH
     70        N C0CI,C0CJ,C0CMAP,C0CTMAP,C0CTMP
     71        S C0CIN=@C0CV@(0) ; COUNT OF RESULTS (OBR)
     72        N C0CRTMP ; AREA TO BUILD ONE RESULT REQUEST AND ALL TESTS FOR IT
     73        N C0CRBASE S C0CRBASE=$NA(^TMP($J,"TESTTMP")) ;WORK AREA
     74        N C0CRBLD ; BUILD LIST FOR XML - THE BUILD IS DELAYED UNTIL THE END
     75        ; TO IMPROVE PERFORMANCE
     76        D QUEUE^C0CXPATH("C0CRBLD","C0CRT",1,1) ;<Results>
     77        F C0CI=1:1:C0CIN D  ; LOOP THROUGH VARIABLES
     78        . K C0CMAP,C0CTMP ;EMPTY OUT LAST BATCH OF VARIABLES
     79        . S C0CRTMP=$NA(@C0CRBASE@(C0CI)) ;PARTITION OF WORK AREA FOR EACH TEST
     80        . S C0CMAP=$NA(@C0CV@(C0CI)) ;
     81        . I 'C0CQT W "MAPOBR:",C0CMAP,!
     82        . ;MAPPING FOR TEST REQUEST GOES HERE
     83        . D MAP^C0CXPATH("C0CRT",C0CMAP,C0CRTMP) ; MAP OBR DATA
     84        . ;D QOPEN^C0CXPATH("C0CRBLD",C0CRTMP,C0CIS) ;1ST PART OF XML
     85        . D QUEUE^C0CXPATH("C0CRBLD",C0CRTMP,2,@C0CRTMP@(0)-4) ;UP TO <Test>
     86        . I $D(@C0CMAP@("M","TEST",0)) D  ; TESTS EXIST
     87        . . S C0CJN=@C0CMAP@("M","TEST",0) ; NUMBER OF TESTS
     88        . . K C0CTO ; CLEAR OUTPUT VARIABLE
     89        . . F C0CJ=1:1:C0CJN D   ;FOR EACH TEST RESULT
     90        . . . K C0CTMAP ; EMPTY MAPS FOR TEST RESULTS
     91        . . . S C0CTMP=$NA(@C0CRBASE@(C0CI,C0CJ)) ;WORK AREA FOR TEST RESULTS
     92        . . . S C0CTMAP=$NA(@C0CMAP@("M","TEST",C0CJ)) ;
     93        . . . I 'C0CQT W "MAPOBX:",C0CTMAP,!
     94        . . . D MAP^C0CXPATH("C0CTT",C0CTMAP,C0CTMP) ; MAP TO TMP
     95        . . . I C0CJ=1 S C0CJS=2 E  S C0CJS=1 ;FIRST TIME,SKIP THE <Test>
     96        . . . I C0CJ=C0CJN S C0CJE=@C0CTMP@(0)-1 E  S C0CJE=@C0CTMP@(0) ;</Test>
     97        . . . S C0CJS=1 S C0CJE=@C0CTMP@(0) ; INSERT ALL OF THE TEXT XML
     98        . . . D QUEUE^C0CXPATH("C0CRBLD",C0CTMP,C0CJS,C0CJE) ; ADD TO BUILD LIST
     99        . . . ;I C0CJ=1 D  ; FIRST TIME, JUST COPY
     100        . . . ;. D CP^C0CXPATH("C0CTMP","C0CTO") ; START BUILDING TEST XML
     101        . . . ;E  D INSINNER^C0CXPATH("C0CTO","C0CTMP")
     102        . . . ;
     103        . . . ;D PUSHA^C0CXPATH("C0CTO",C0CTMP) ;ADD THE TEST TO BUFFER
     104        . . ; I 'C0CQT D PARY^C0CXPATH("C0CTO")
     105        . . ;D INSINNER^C0CXPATH(C0CRTMP,"C0CTO","//Results/Result/Test") ;INSERT TST
     106        . ;D QCLOSE^C0CXPATH("C0CRBLD",C0CRTMP,"//Results/Result/Test") ;END OF XML
     107        . D QUEUE^C0CXPATH("C0CRBLD","C0CRT",C0CRT(0)-1,C0CRT(0)-1) ;</Result>
     108        . ;I C0CI=1 D  ; FIRST TIME, COPY INSTEAD OF INSERT
     109        . . ;D CP^C0CXPATH(C0CRTMP,"RTN") ;
     110        . ;E  D INSINNER^C0CXPATH("RTN",C0CRTMP) ; INSERT THIS TEST REQUEST
     111        D QUEUE^C0CXPATH("C0CRBLD","C0CRT",C0CRT(0),C0CRT(0)) ;</Results>
     112        D BUILD^C0CXPATH("C0CRBLD","RTN") ;RENDER THE XML
     113        K @C0CRBASE ; CLEAR OUT TEMPORARY STURCTURE
     114        Q
     115        ;
     116EXTRACT(ILXML,DFN,OLXML)        ; EXTRACT LABS INTO THE C0CLVAR GLOBAL
     117        ;
     118        ; LABXML AND LABOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
     119        ;
     120        ;
     121        ;
     122        N C0CNSSN ; IS THERE AN SSN FLAG
     123        S C0CNSSN=0
     124        S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS
     125        D GHL7 ; GET HL7 MESSAGE FOR THIS PATIENT
     126        I C0CNSSN=1 D  Q  ; NO SSN, CAN'T GET HL7 FOR THIS PATIENT
     127        . S @C0CLB@(0)=0
     128        K @C0CLB ; CLEAR OUT OLD VARS IF ANY
     129        N QTSAV S QTSAV=C0CQT ;SAVE QUIET FLAG
     130        S C0CQT=1 ; SURPRESS LISTING
     131        D LIST ; EXTRACT THE VARIABLES
     132        ; FOR CERTIFICATION, SEE IF THERE ARE OTHER RESULTS TO ADD
     133        D EN^C0CORSLT(C0CLB,DFN) ; LOOKS FOR ECG TESTS
     134        S C0CQT=QTSAV ; RESET SILENT FLAG
     135        K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT
     136        I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^C0CLABS
     137        Q
     138            ;
     139GHL7    ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT
     140        ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR
     141        ; SET UP FOR LAB API CALL
     142        S C0CPTID=$$SSN^C0CDPT(DFN) ; GET THE SSN FOR THIS PATIENT
     143        I C0CPTID="" D  Q  ; NO SSN, COMPLAIN AND QUIT
     144        . W "LAB LOOKUP FAILED, NO SSN",!
     145        . S C0CNSSN=1 ; SET NO SSN FLAG
     146        S C0CSPC="*" ; LOOKING FOR ALL LABS
     147        ;I $D(^TMP("C0CCCR","RPMS")) D  ; RUNNING RPMS
     148        ;. D DT^DILF(,"T-365",.C0CSDT) ; START DATE ONE YEAR AGO TO LIMIT VOLUME
     149        ;E  D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING
     150        ;D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY
     151        S C0CLLMT=$$GET^C0CPARMS("LABLIMIT") ; GET THE LIMIT PARM
     152        S C0CLSTRT=$$GET^C0CPARMS("LABSTART") ; GET START PARM
     153        D DT^DILF(,C0CLLMT,.C0CSDT) ;
     154        W "LAB LIMIT: ",C0CLLMT,!
     155        D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM
     156        S C0CEDT=$$NOW^XLFDT ; PULL LABS STARTING NOW
     157        S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP
     158        Q
     159        ;
     160LIST    ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB
     161        ;
     162        ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR
     163        I '$D(C0CLB) S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS
     164        I '$D(C0CQT) S C0CQT=0
     165        I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT
     166        I '$D(^TMP("C0CCCR","LABTBL",0)) D SETTBL ;INITIALIZE LAB TABLE
     167        I ^TMP("C0CCCR","LABTBL",0)'="V3" D SETTBL ;NEED NEWEST VERSION
     168        I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE
     169        S C0CTAB=$NA(^TMP("C0CCCR","LABTBL")) ; BASE OF OBX TABLE
     170        S C0CHB=$NA(^TMP("HLS",$J))
     171        S C0CI=""
     172        S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT
     173        F  S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI=""  D  ; FOR ALL RECORDS IN HL7 MSG
     174        . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES
     175        . S C0CTYP=$P(@C0CHB@(C0CI),"|",1)
     176        . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT)
     177        . I $G(C0CVAR("RESULTCODINGSYSTEM"))="LN" D  ; gpl - for certification
     178        . . S C0CVAR("RESULTCODINGSYSTEM")="LOINC" ; NEED TO SPELL IT OUT
     179        . . N C0CRDT S C0CRDT=C0CVAR("RESULTDESCRIPTIONTEXT") ; THE DESCRIPTION
     180        . . N C0CRCD S C0CRCD=C0CVAR("RESULTCODE") ; THE LOINC CODE
     181        . . S C0CVAR("RESULTDESCRIPTIONTEXT")=C0CRDT_" LOINC: "_C0CRCD
     182        . M XV=C0CVAR ;
     183        . I C0CTYP="OBR" D  ; BEGINNING OF NEW SECTION
     184        . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT
     185        . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT
     186        . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS
     187        . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI
     188        . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR
     189        . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1)
     190        . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT
     191        . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL
     192        . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME
     193        . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS
     194        . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION
     195        . I C0CTYP="OBX" D  ; SPECIAL CASE FOR OBX3
     196        . . ; RESULTTESTCODEVALUE
     197        . . ; RESULTTESTDESCRIPTIONTEXT
     198        . . I C0CVAR("C3")="LN" D  ; PRIMARY CODE IS LOINC
     199        . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE
     200        . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC
     201        . . . ;S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESC TXT
     202        . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2")_" LOINC: "_C0CVAR("C1")
     203        . . E  I C0CVAR("C6")="LN" D  ; SECONDARY CODE IS LOINC
     204        . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE
     205        . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC
     206        . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT
     207        . . E  I C0CVAR("C6")'="" D  ; NO LOINC CODES, USE SECONDARY IF PRESENT
     208        . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE
     209        . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME
     210        . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT
     211        . . E  D  ; NO SECONDARY, USE PRIMARY
     212        . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE
     213        . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME
     214        . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT
     215        . . N C0CZG S C0CZG=XV("RESULTTESTNORMALDESCTEXT") ;
     216        . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH
     217        . . ;S XV("RESULTTESTNORMALDESCTEXT")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE
     218        . . S XV("RESULTTESTNORMALDESCTEXT")=C0CZG
     219        . . S C0CZG=XV("RESULTTESTVALUE")
     220        . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH
     221        . . ;S XV("RESULTTESTVALUE")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE
     222        . . S XV("RESULTTESTVALUE")=C0CZG
     223        . I C0CTYP="OBX" D  ; PROCESS TEST RESULTS
     224        . . I C0CLOBX=0 D  ; FIRST TEST RESULT FOR THIS SECTION
     225        . . . S C0CLB2=$NA(@C0CLB@(C0CLI,"M","TEST")) ; INDENT FOR TEST RESULTS
     226        . . S C0CLOBX=C0CLOBX+1 ; INCREMENT TEST COUNT
     227        . . S @C0CLB2@(0)=C0CLOBX ; STORE THE TEST COUNT
     228        . . S XV("RESULTTESTOBJECTID")="RESULTTEST_"_C0CLI_"_"_C0CLOBX
     229        . . S C0CX1=XV("RESULTTESTSOURCEACTORID") ; TEST SOURCE
     230        . . S C0CX2=$P($P(C0CX1,"^",1),"-",1) ; PULL OUT STATION NUMBER
     231        . . S XV("RESULTTESTSOURCEACTORID")="ACTORORGANIZATION_"_C0CX2
     232        . . S XV("RESULTTESTNORMALSOURCEACTORID")=XV("RESULTTESTSOURCEACTORID")
     233        . . S C0CX1=XV("RESULTTESTDATETIME") ;DATE TIME IN HL7 FORMAT
     234        . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL
     235        . . S XV("RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME
     236        . . ; I 'C0CQT ZWR XV
     237        . . M @C0CLB2@(C0CLOBX)=XV ; PERSIST THE TEST RESULT VARIABLES
     238        . I 'C0CQT D  ;
     239        . . W C0CI," ",C0CTYP,!
     240        . ; S C0CI=$O(@C0CHB@(C0CI))
     241        ;K ^TMP("C0CRIM","VARS",DFN,"RESULTS")
     242        ;M ^TMP("C0CRIM","VARS",DFN,"RESULTS")=@C0CLB
     243        Q
     244LTYP(OSEG,OTYP,OVARA,OC0CQT)    ;
     245        S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE
     246        I '$D(OC0CQT) S C0CQT=0 ; NOT C0CQT IS DEFAULT
     247        E  S C0CQT=OC0CQT ; ACCEPT C0CQT FLAG
     248        I 1 D  ; FOR HL7 SEGMENT TYPE
     249        . S OI="" ; INDEX INTO FIELDS IN SEG
     250        . F  S OI=$O(@OTAB@(OI)) Q:OI=""  D  ; FOR EACH FIELD OF THE SEGMENT
     251        . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX
     252        . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED
     253        . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE
     254        . . I $P(OI,";",2)'="" D  ; THIS IS DEFINING A SUB-VALUE
     255        . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX
     256        . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE
     257        . . I OVAR'="" S OVARA(OVAR)=OV ; PASS BACK VARIABLE AND VALUE
     258        . . I 'C0CQT D  ; PRINT OUTPUT IF C0CQT IS FALSE
     259        . . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,!
     260        Q
     261LOBX    ;
     262        Q
     263        ;
     264OUT(DFN)        ; WRITE OUT A CCR THAT HAS JUST BEEN PROCESSED (FOR TESTING)
     265        N GA,GF,GD
     266        S GA=$NA(^TMP("C0CCCR",$J,DFN,"CCR",1))
     267        S GF="RPMS_CCR_"_DFN_"_"_DT_".xml"
     268        S GD=^TMP("C0CCCR","ODIR")
     269        W $$OUTPUT^C0CXPATH(GA,GF,GD)
     270        Q
     271        ;
     272SETTBL  ;
     273        K X ; CLEAR X
     274        S X("PID","PID1")="1^00104^Set ID - Patient ID"
     275        S X("PID","PID2")="2^00105^Patient ID (External ID)"
     276        S X("PID","PID3")="3^00106^Patient ID (Internal ID)"
     277        S X("PID","PID4")="4^00107^Alternate Patient ID"
     278        S X("PID","PID5")="5^00108^Patient's Name"
     279        S X("PID","PID6")="6^00109^Mother's Maiden Name"
     280        S X("PID","PID7")="7^00110^Date of Birth"
     281        S X("PID","PID8")="8^00111^Sex"
     282        S X("PID","PID9")="9^00112^Patient Alias"
     283        S X("PID","PID10")="10^00113^Race"
     284        S X("PID","PID11")="11^00114^Patient Address"
     285        S X("PID","PID12")="12^00115^County Code"
     286        S X("PID","PID13")="13^00116^Phone Number - Home"
     287        S X("PID","PID14")="14^00117^Phone Number - Business"
     288        S X("PID","PID15")="15^00118^Language - Patient"
     289        S X("PID","PID16")="16^00119^Marital Status"
     290        S X("PID","PID17")="17^00120^Religion"
     291        S X("PID","PID18")="18^00121^Patient Account Number"
     292        S X("PID","PID19")="19^00122^SSN Number - Patient"
     293        S X("PID","PID20")="20^00123^Drivers License - Patient"
     294        S X("PID","PID21")="21^00124^Mother's Identifier"
     295        S X("PID","PID22")="22^00125^Ethnic Group"
     296        S X("PID","PID23")="23^00126^Birth Place"
     297        S X("PID","PID24")="24^00127^Multiple Birth Indicator"
     298        S X("PID","PID25")="25^00128^Birth Order"
     299        S X("PID","PID26")="26^00129^Citizenship"
     300        S X("PID","PID27")="27^00130^Veteran.s Military Status"
     301        S X("PID","PID28")="28^00739^Nationality"
     302        S X("PID","PID29")="29^00740^Patient Death Date/Time"
     303        S X("PID","PID30")="30^00741^Patient Death Indicator"
     304        S X("NTE","NTE1")="1^00573^Set ID - NTE"
     305        S X("NTE","NTE2")="2^00574^Source of Comment"
     306        S X("NTE","NTE3")="3^00575^Comment"
     307        S X("ORC","ORC1")="1^00215^Order Control"
     308        S X("ORC","ORC2")="2^00216^Placer Order Number"
     309        S X("ORC","ORC3")="3^00217^Filler Order Number"
     310        S X("ORC","ORC4")="4^00218^Placer Order Number"
     311        S X("ORC","ORC5")="5^00219^Order Status"
     312        S X("ORC","ORC6")="6^00220^Response Flag"
     313        S X("ORC","ORC7")="7^00221^Quantity/Timing"
     314        S X("ORC","ORC8")="8^00222^Parent"
     315        S X("ORC","ORC9")="9^00223^Date/Time of Transaction"
     316        S X("ORC","ORC10")="10^00224^Entered By"
     317        S X("ORC","ORC11")="11^00225^Verified By"
     318        S X("ORC","ORC12")="12^00226^Ordering Provider"
     319        S X("ORC","ORC13")="13^00227^Enterer's Location"
     320        S X("ORC","ORC14")="14^00228^Call Back Phone Number"
     321        S X("ORC","ORC15")="15^00229^Order Effective Date/Time"
     322        S X("ORC","ORC16")="16^00230^Order Control Code Reason"
     323        S X("ORC","ORC17")="17^00231^Entering Organization"
     324        S X("ORC","ORC18")="18^00232^Entering Device"
     325        S X("ORC","ORC19")="19^00233^Action By"
     326        S X("OBR","OBR1")="1^00237^Set ID - Observation Request"
     327        S X("OBR","OBR2")="2^00216^Placer Order Number"
     328        S X("OBR","OBR3")="3^00217^Filler Order Number"
     329        S X("OBR","OBR4")="4^00238^Universal Service ID"
     330        S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE"
     331        S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT"
     332        S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE^RESULTCODINGSYSTEM"
     333        S X("OBR","OBR5")="5^00239^Priority"
     334        S X("OBR","OBR6")="6^00240^Requested Date/Time"
     335        S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME"
     336        S X("OBR","OBR8")="8^00242^Observation End Date/Time"
     337        S X("OBR","OBR9")="9^00243^Collection Volume"
     338        S X("OBR","OBR10")="10^00244^Collector Identifier"
     339        S X("OBR","OBR11")="11^00245^Specimen Action Code"
     340        S X("OBR","OBR12")="12^00246^Danger Code"
     341        S X("OBR","OBR13")="13^00247^Relevant Clinical Info."
     342        S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time"
     343        S X("OBR","OBR15")="15^00249^Specimen Source"
     344        S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID"
     345        S X("OBR","OBR17")="17^00250^Order Callback Phone Number"
     346        S X("OBR","OBR18")="18^00251^Placers Field 1"
     347        S X("OBR","OBR19")="19^00252^Placers Field 2"
     348        S X("OBR","OBR20")="20^00253^Filler Field 1"
     349        S X("OBR","OBR21")="21^00254^Filler Field 2"
     350        S X("OBR","OBR22")="22^00255^Results Rpt./Status Change"
     351        S X("OBR","OBR23")="23^00256^Charge to Practice"
     352        S X("OBR","OBR24")="24^00257^Diagnostic Service Sect"
     353        S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS"
     354        S X("OBR","OBR26")="26^00259^Parent Result"
     355        S X("OBR","OBR27")="27^00221^Quantity/Timing"
     356        S X("OBR","OBR28")="28^00260^Result Copies to"
     357        S X("OBR","OBR29")="29^00261^Parent Number"
     358        S X("OBR","OBR30")="30^00262^Transportation Mode"
     359        S X("OBR","OBR31")="31^00263^Reason for Study"
     360        S X("OBR","OBR32")="32^00264^Principal Result Interpreter"
     361        S X("OBR","OBR33")="33^00265^Assistant Result Interpreter"
     362        S X("OBR","OBR34")="34^00266^Technician"
     363        S X("OBR","OBR35")="35^00267^Transcriptionist"
     364        S X("OBR","OBR36")="36^00268^Scheduled Date/Time"
     365        S X("OBR","OBR37")="37^01028^Number of Sample Containers"
     366        S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample"
     367        S X("OBR","OBR39")="39^01030^Collector.s Comment"
     368        S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility"
     369        S X("OBR","OBR41")="41^01032^Transport Arranged"
     370        S X("OBR","OBR42")="42^01033^Escort Required"
     371        S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment"
     372        S X("OBX","OBX1")="1^00559^Set ID - OBX"
     373        S X("OBX","OBX2")="2^00676^Value Type"
     374        S X("OBX","OBX3")="3^00560^Observation Identifier"
     375        S X("OBX","OBX3;C1")="3;1^00560^Observation Identifier^C1"
     376        S X("OBX","OBX3;C2")="3;2^00560^Observation Identifier^C2"
     377        S X("OBX","OBX3;C3")="3;3^00560^Observation Identifier^C3"
     378        S X("OBX","OBX3;C4")="3;4^00560^Observation Identifier^C4"
     379        S X("OBX","OBX3;C5")="3;5^00560^Observation Identifier^C5"
     380        S X("OBX","OBX3;C6")="3;6^00560^Observation Identifier^C6"
     381        S X("OBX","OBX4")="4^00769^Observation Sub-Id"
     382        S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE"
     383        S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS"
     384        S X("OBX","OBX7")="7^00563^Reference Range^RESULTTESTNORMALDESCTEXT"
     385        S X("OBX","OBX8")="8^00564^Abnormal Flags^RESULTTESTFLAG"
     386        S X("OBX","OBX9")="9^00639^Probability"
     387        S X("OBX","OBX10")="10^00565^Nature of Abnormal Test"
     388        S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT"
     389        S X("OBX","OBX12")="12^00567^Date Last Normal Value"
     390        S X("OBX","OBX13")="13^00581^User Defined Access Checks"
     391        S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME"
     392        S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID"
     393        S X("OBX","OBX16")="16^00584^Responsible Observer"
     394        S X("OBX","OBX17")="17^00936^Observation Method"
     395        K ^TMP("C0CCCR","LABTBL")
     396        M ^TMP("C0CCCR","LABTBL")=X ; SET VALUES IN LAB TBL
     397        S ^TMP("C0CCCR","LABTBL",0)="V3"
     398        Q
     399        ;

  • ccr/branches/ohum/p/C0CMAIL.m

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

  • ccr/branches/ohum/p/C0CMAIL2.m

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

  • ccr/branches/ohum/p/C0CMAIL3.m

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

  • ccr/branches/ohum/p/C0CMCCD.m

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

  • ccr/branches/ohum/p/C0CMED.m

    r1342 r1428  
    1 C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel.
    4  ; Licensed under the terms of the GNU General Public License.
    5  ; See attached copy of the License.
    6  ;
    7  ; This program is free software; you can redistribute it and/or modify
    8  ; it under the terms of the GNU General Public License as published by
    9  ; the Free Software Foundation; either version 2 of the License, or
    10  ; (at your option) any later version.
    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  ; --Revision History
    22  ; July 2008 - Initial Version/GPL
    23  ; July 2008 - March 2009 various revisions
    24  ; March 2009 - Reconstruction of routine as driver for other med routines/SMH
    25  ;
    26  Q
    27 EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template
    28  ; DFN passed by reference
    29  ; MEDXML and MEDOUTXML are passed by Name
    30  ; MEDXML is the input template
    31  ; MEDOUTXML is the output template
    32  ; Both of them refer to ^TMP globals where the XML documents are stored
    33  ;
    34  ; -- This ep is the driver for extracting medications into the provided XML template
    35  ; 1. VA Outpatient Meds are in C0CMED1
    36  ; 2. VA Pending Meds are in C0CMED2
    37  ; 3. VA non-VA Meds are in C0CMED3
    38  ; 4. VA Inpatient IV Meds are in C0CMED4 (not functional)
    39  ; 5. VA Inpatient UD Meds are in C0CMED5 (doesn't exist yet)--March 2009
    40  ; 6. RPMS Meds are in C0CMED6. Need to create other routines for subdivisions of RPMS Meds is not known at this time.
    41  ;
    42  ; --Get parameters for meds
    43  S @MEDOUTXML@(0)=0 ; By default, empty.
    44  N C0CMFLAG
    45  S C0CMFLAG=$$GET^C0CPARMS("MEDALL")_"^"_$$GET^C0CPARMS("MEDLIMIT")_"^"_$$GET^C0CPARMS("MEDACTIVE")_"^"_$$GET^C0CPARMS("MEDPENDING")
    46  W:$G(DEBUG) "Med Parameters: ",!
    47  W:$G(DEBUG) "ALL: ",+C0CMFLAG,!
    48  W:$G(DEBUG) "LIMIT: ",$P(C0CMFLAG,U,2),!
    49  W:$G(DEBUG) "ACTIVE: ",$P(C0CMFLAG,U,3),!
    50  W:$G(DEBUG) "PEND: ",$P(C0CMFLAG,U,4),!
    51  ; --Find out what system we are on and branch out...
    52  W:$G(DEBUG) "Agenecy: ",$G(DUZ("AG"))
    53  I $$RPMS^C0CUTIL() D RPMS QUIT
    54  I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT
    55 RPMS 
    56  ;D EXTRACT^C0CMED6(MEDXML,DFN,MEDOUTXML,C0CMFLAG) QUIT
    57  N MEDCOUNT S MEDCOUNT=0
    58  K ^TMP($J,"MED")
    59  N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed
    60  N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds
    61  S @HIST@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors)
    62  D EXTRACT^C0CMED6(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds
    63  D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds
    64  I @HIST@(0)>0 D 
    65  . D CP^C0CXPATH(HIST,MEDOUTXML)
    66  . W:$G(DEBUG) "HAS ACTIVE OP MEDS",!
    67  I @NVA@(0)>0 D
    68  . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,NVA)
    69  . ;E  D CP^C0CXPATH(NVA,MEDOUTXML)
    70  . W:$G(DEBUG) "HAS NON-VA MEDS",!
    71  Q
    72 VISTA 
    73  N MEDCOUNT S MEDCOUNT=0
    74  K ^TMP($J,"MED")
    75  N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed
    76  N PEND S PEND=$NA(^TMP($J,"MED","PEND")) ; Pending Meds
    77  N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds
    78  K @HIST K @PEND K @NVA ; MAKE SURE THEY ARE EMPTY
    79  S @HIST@(0)=0,@PEND@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors)
    80  ; N IPIV ; Inpatient IV Meds
    81  N IPUD S IPUD=$NA(^TMP($J,"MED","IPUD")) ; Inpatient UD Meds
    82  K @IPUD
    83  S @IPUD@(0)=0
    84  ;
    85  D EXTRACT^C0CMED1(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds
    86  D:$P(C0CMFLAG,U,4) EXTRACT^C0CMED2(MEDXML,DFN,PEND,.MEDCOUNT) ; Pending Meds
    87  ;D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds
    88  D EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds GPL
    89  D EXTRACT^C0CNMED4(MEDXML,DFN,IPUD,.MEDCOUNT) ; inpatient gpl
    90  I @HIST@(0)>0 D 
    91  . D CP^C0CXPATH(HIST,MEDOUTXML)
    92  . W:$G(DEBUG) "HAS ACTIVE OP MEDS",!
    93  I @PEND@(0)>0 D 
    94  . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,PEND) ;Add Pending to Historical
    95  . E  D CP^C0CXPATH(PEND,MEDOUTXML) ; No historical, just copy
    96  . W:$G(DEBUG) "HAS OP PENDING MEDS",!
    97  I @NVA@(0)>0 D
    98  . I @HIST@(0)>0!(@PEND@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,NVA)
    99  . E  D CP^C0CXPATH(NVA,MEDOUTXML)
    100  . W:$G(DEBUG) "HAS NON-VA MEDS",!
    101  I @IPUD@(0)>0 D
    102  . I @HIST@(0)>0!(@PEND@(0)>0)!(@NVA@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,IPUD)
    103  . E  D CP^C0CXPATH(IPUD,MEDOUTXML)
    104  . W:$G(DEBUG) "HAS INPATIENT MEDS",!
    105  N ZI
    106  S ZI=$NA(^TMP("C0CCCR",$J,"MEDMAP"))
    107  M ^TMP("C0CRIM","VARS",DFN,"MEDS")=@ZI ; PERSIST MEDS VARIABLES
    108  K @ZI ; CLEAN UP MED MAP AFTER - GPL 10/10
    109  K @PEND
    110  K @HIST
    111  K @NVA
    112  K @IPUD
    113  Q
    114  
     1C0CMED  ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel.
     4        ; Licensed under the terms of the GNU General Public License.
     5        ; See attached copy of the License.
     6        ;
     7        ; This program is free software; you can redistribute it and/or modify
     8        ; it under the terms of the GNU General Public License as published by
     9        ; the Free Software Foundation; either version 2 of the License, or
     10        ; (at your option) any later version.
     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        ; --Revision History
     22        ; July 2008 - Initial Version/GPL
     23        ; July 2008 - March 2009 various revisions
     24        ; March 2009 - Reconstruction of routine as driver for other med routines/SMH
     25        ;
     26        Q
     27EXTRACT(MEDXML,DFN,MEDOUTXML)   ; Private; Extract medications into provided XML template
     28        ; DFN passed by reference
     29        ; MEDXML and MEDOUTXML are passed by Name
     30        ; MEDXML is the input template
     31        ; MEDOUTXML is the output template
     32        ; Both of them refer to ^TMP globals where the XML documents are stored
     33        ;
     34        ; -- This ep is the driver for extracting medications into the provided XML template
     35        ; 1. VA Outpatient Meds are in C0CMED1
     36        ; 2. VA Pending Meds are in C0CMED2
     37        ; 3. VA non-VA Meds are in C0CMED3
     38        ; 4. VA Inpatient IV Meds are in C0CMED4 (not functional)
     39        ; 5. VA Inpatient UD Meds are in C0CMED5 (doesn't exist yet)--March 2009
     40        ; 6. RPMS Meds are in C0CMED6. Need to create other routines for subdivisions of RPMS Meds is not known at this time.
     41        ;
     42        ; --Get parameters for meds
     43        S @MEDOUTXML@(0)=0 ; By default, empty.
     44        N C0CMFLAG
     45        S C0CMFLAG=$$GET^C0CPARMS("MEDALL")_"^"_$$GET^C0CPARMS("MEDLIMIT")_"^"_$$GET^C0CPARMS("MEDACTIVE")_"^"_$$GET^C0CPARMS("MEDPENDING")
     46        W:$G(DEBUG) "Med Parameters: ",!
     47        W:$G(DEBUG) "ALL: ",+C0CMFLAG,!
     48        W:$G(DEBUG) "LIMIT: ",$P(C0CMFLAG,U,2),!
     49        W:$G(DEBUG) "ACTIVE: ",$P(C0CMFLAG,U,3),!
     50        W:$G(DEBUG) "PEND: ",$P(C0CMFLAG,U,4),!
     51        ; --Find out what system we are on and branch out...
     52        W:$G(DEBUG) "Agenecy: ",$G(DUZ("AG"))
     53        I $$RPMS^C0CUTIL() D RPMS QUIT
     54        I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT
     55RPMS   
     56        ;D EXTRACT^C0CMED6(MEDXML,DFN,MEDOUTXML,C0CMFLAG) QUIT
     57        N MEDCOUNT S MEDCOUNT=0
     58        K ^TMP($J,"MED")
     59        N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed
     60        N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds
     61        S @HIST@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors)
     62        D EXTRACT^C0CMED6(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds
     63        D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds
     64        I @HIST@(0)>0 D 
     65        . D CP^C0CXPATH(HIST,MEDOUTXML)
     66        . W:$G(DEBUG) "HAS ACTIVE OP MEDS",!
     67        I @NVA@(0)>0 D
     68        . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,NVA)
     69        . ;E  D CP^C0CXPATH(NVA,MEDOUTXML)
     70        . W:$G(DEBUG) "HAS NON-VA MEDS",!
     71        Q
     72VISTA   
     73        N MEDCOUNT S MEDCOUNT=0
     74        K ^TMP($J,"MED")
     75        N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed
     76        N PEND S PEND=$NA(^TMP($J,"MED","PEND")) ; Pending Meds
     77        N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds
     78        K @HIST K @PEND K @NVA ; MAKE SURE THEY ARE EMPTY
     79        S @HIST@(0)=0,@PEND@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors)
     80        ; N IPIV ; Inpatient IV Meds
     81        N IPUD S IPUD=$NA(^TMP($J,"MED","IPUD")) ; Inpatient UD Meds
     82        K @IPUD
     83        S @IPUD@(0)=0
     84        ;
     85        D EXTRACT^C0CMED1(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds
     86        D:$P(C0CMFLAG,U,4) EXTRACT^C0CMED2(MEDXML,DFN,PEND,.MEDCOUNT) ; Pending Meds
     87        ;D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds
     88        D EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds GPL
     89        D EXTRACT^C0CNMED4(MEDXML,DFN,IPUD,.MEDCOUNT) ; inpatient gpl
     90        I @HIST@(0)>0 D 
     91        . D CP^C0CXPATH(HIST,MEDOUTXML)
     92        . W:$G(DEBUG) "HAS ACTIVE OP MEDS",!
     93        I @PEND@(0)>0 D 
     94        . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,PEND) ;Add Pending to Historical
     95        . E  D CP^C0CXPATH(PEND,MEDOUTXML) ; No historical, just copy
     96        . W:$G(DEBUG) "HAS OP PENDING MEDS",!
     97        I @NVA@(0)>0 D
     98        . I @HIST@(0)>0!(@PEND@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,NVA)
     99        . E  D CP^C0CXPATH(NVA,MEDOUTXML)
     100        . W:$G(DEBUG) "HAS NON-VA MEDS",!
     101        I @IPUD@(0)>0 D
     102        . I @HIST@(0)>0!(@PEND@(0)>0)!(@NVA@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,IPUD)
     103        . E  D CP^C0CXPATH(IPUD,MEDOUTXML)
     104        . W:$G(DEBUG) "HAS INPATIENT MEDS",!
     105        N ZI
     106        S ZI=$NA(^TMP("C0CCCR",$J,"MEDMAP"))
     107        M ^TMP("C0CRIM","VARS",DFN,"MEDS")=@ZI ; PERSIST MEDS VARIABLES
     108        K @ZI ; CLEAN UP MED MAP AFTER - GPL 10/10
     109        K @PEND
     110        K @HIST
     111        K @NVA
     112        K @IPUD
     113        Q
     114       

  • ccr/branches/ohum/p/C0CMED1.m

    r1342 r1428  
    1 C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;;Last modified Sat Jan 10 21:42:27 PST 2009
    4  ; Copyright 2009 WorldVistA.  Licensed under the terms of the GNU
    5  ; General Public License See attached copy of the License.
    6  ;
    7  ; This program is free software; you can redistribute it and/or modify
    8  ; it under the terms of the GNU General Public License as published by
    9  ; the Free Software Foundation; either version 2 of the License, or
    10  ; (at your option) any later version.
    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  W "NO ENTRY FROM TOP",!
    22  Q
    23  ;
    24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
    25  ;
    26  ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
    27  ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE
    28  ;
    29  ; MEDS is return array from RPC.
    30  ; MAP is a mapping variable map (store result) for each med
    31  ; MED is holds each array element from MEDS(J), one medicine
    32  ; MEDCOUNT is a counter passed by Reference.
    33  ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool)
    34  ; FLAGS are set-up in C0CMED.
    35  ;
    36  ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all
    37  ; med data available.
    38  ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf
    39  ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS).
    40  ; D PARY^C0CXPATH(MINXML)
    41  N MEDS,MAP
    42  K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!!
    43  N ALL S ALL=+FLAGS
    44  N ACTIVE S ACTIVE=$P(FLAGS,U,3)
    45  ; Below, X1 is today; X2 is the number of days we want to go back
    46  ; X is the result of this calculation using C^%DTC.
    47  N X,X1,X2
    48  S X1=DT
    49  S X2=-$P($P(FLAGS,U,2),"-",2)
    50  D C^%DTC
    51  ; I discovered that I shouldn't put an ending date (last parameter)
    52  ; because it seems that it will get meds whose beginning is after X but
    53  ; whose exipriation is before the ending date.
    54  D RX^PSO52API(DFN,"CCDCCR","","","",X,"")
    55  M MEDS=^TMP($J,"CCDCCR",DFN)
    56  ; @(0) contains the number of meds or -1^NO DATA FOUND
    57  ; If it is -1, we quit.
    58  I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 Q
    59  ZWRITE:$G(DEBUG) MEDS
    60  N RXIEN S RXIEN=0
    61  F  S RXIEN=$O(MEDS(RXIEN)) Q:$G(RXIEN)=""  D  ; FOR EACH MEDICATION IN THE LIST
    62  . N MED M MED=MEDS(RXIEN)
    63  . I 'ALL,ACTIVE,$P(MED(100),U,2)'="ACTIVE" QUIT
    64  . S MEDCOUNT=MEDCOUNT+1
    65  . W:$G(DEBUG) "RXIEN IS ",RXIEN,!
    66  . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
    67  . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED
    68  . W:$G(DEBUG) "MAP= ",MAP,!
    69  . S @MAP@("MEDOBJECTID")="MED"_MEDCOUNT ; MEDCOUNT FOR ID
    70  . ; S @MAP@("MEDOBJECTID")="MED"_MED(.01) ;Rx Number
    71  . S @MAP@("MEDISSUEDATETXT")="Issue Date"
    72  . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(1),U))
    73  . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date"
    74  . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P($G(MED(101)),U))
    75  . S @MAP@("MEDRXNOTXT")="Prescription Number"
    76  . S @MAP@("MEDRXNO")=MED(.01)
    77  . S @MAP@("MEDTYPETEXT")="Medication"
    78  . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
    79  . S @MAP@("MEDSTATUSTEXT")=$P(MED(100),U,2)
    80  . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(4),U)
    81  . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(6),U,2)
    82  . ; 12/30/08: I will be using RxNorm for coding...
    83  . ; 176.001 is the file for Concepts; 176.003 is the file for
    84  . ; sources (i.e. for RxNorm Version)
    85  . ;
    86  . ; We need the VUID first for the National Drug File entry first
    87  . ; We get the VUID of the drug, by looking up the VA Product entry
    88  . ; (file 50.68) using the call NDF^PSS50, returned in node 22.
    89  . ; Field 99.99 is the VUID.
    90  . ;
    91  . ; We use the VUID to look up the RxNorm in file 176.001; same idea.
    92  . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by
    93  . ; $$GET1^DIQ.
    94  . ;
    95  . ; I get the RxNorm name and version from the RxNorm Sources (file
    96  . ; 176.003), by searching for "RXNORM", then get the data.
    97  . N MEDIEN S MEDIEN=$P(MED(6),U)
    98  . D NDF^PSS50(MEDIEN,,,,,"NDF")
    99  . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN)
    100  . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
    101  . N VAPROD S VAPROD=$P(NDFDATA(22),U)
    102  . ;
    103  . ; NDFIEN is not necessarily defined; it won't be if the drug
    104  . ; is not matched to the national drug file (e.g. if the drug is
    105  . ; new on the market, compounded, or is a fake drug [blue pill].
    106  . ; To protect against failure, I will put an if/else block
    107  . ;
    108  . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
    109  . I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
    110  . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
    111  . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
    112  . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01)
    113  . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM")
    114  . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
    115  . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
    116  . ;
    117  . E  S (RXNORM,RXNNAME,RXNVER)=""
    118  . ; End if/else block
    119  . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
    120  . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
    121  . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
    122  . ;
    123  . S @MAP@("MEDBRANDNAMETEXT")=MED(6.5)
    124  . D DOSE^PSS50(MEDIEN,,,,,"DOSE")
    125  . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
    126  . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901)
    127  . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2)
    128  . ; Units, concentration, etc, come from another call
    129  . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
    130  . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
    131  . ; NDF Entry IEN, and VA Product IEN
    132  . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
    133  . ; These have been collected above.
    134  . N CONCDATA
    135  . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
    136  . ; and this will crash the call. So...
    137  . I NDFIEN="" S CONCDATA=""
    138  . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
    139  . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1)
    140  . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3)
    141  . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4)
    142  . S @MAP@("MEDQUANTITYVALUE")=MED(7)
    143  . ; Oddly, there is no easy place to find the dispense unit.
    144  . ; It's not included in the original call, so we have to go to the drug file.
    145  . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
    146  . ; Node 14.5 is the Dispense Unit
    147  . D DATA^PSS50(MEDIEN,,,,,"QTY")
    148  . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
    149  . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
    150  . ;
    151  . ; --- START OF DIRECTIONS ---
    152  . ; Sig data not in any API :-(  Oh yes, you can get the whole thing, but...
    153  . ; we want the compoenents.
    154  . ; It's in node 6 of ^PSRX(IEN)
    155  . ; So, here we go again
    156  . ; ^PSRX(D0,6,D1,0)= (#.01) DOSAGE ORDERED [1F] ^ (#1) DISPENSE UNITS PER DOSE
    157  . ; ==>[2N] ^ (#2) UNITS [3P:50.607] ^ (#3) NOUN [4F] ^ (#4)
    158  . ; ==>DURATION [5F] ^ (#5) CONJUNCTION [6S] ^ (#6) ROUTE
    159  . ; ==>[7P:51.2] ^ (#7) SCHEDULE [8F] ^ (#8) VERB [9F] ^
    160  . ;
    161  . N DIRNUM S DIRNUM=0 ; Sigline number
    162  . S DIRCNT=0 ; COUNT OF MULTIPLE DIRECTIONS
    163  . F  S DIRNUM=$O(^PSRX(RXIEN,6,DIRNUM)) Q:DIRNUM=""  D
    164  . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT
    165  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")=""  ; This is reserved for systems not able to generate the sig in components.
    166  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1"  ; means that we are specifying it. See E2369-05.
    167  . . N SIGDATA S SIGDATA=^PSRX(RXIEN,6,DIRNUM,0)
    168  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$P(SIGDATA,U,9)
    169  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$P(SIGDATA,U,1)
    170  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT")
    171  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")=""  ; For inpatient
    172  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")=""  ; For inpatient
    173  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")=""  ; For inpatient
    174  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$$GET1^DIQ(51.2,$P(SIGDATA,U,7),.01)
    175  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$P(SIGDATA,U,8)
    176  . . ; Invervals... again another call.
    177  . . ; In the wisdom of the original programmers, the schedule is a free text field
    178  . . ; However, it gets translated by a call to the administration schedule file
    179  . . ; to see if that schedule exists.
    180  . . ; That's the same thing I am going to do.
    181  . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ).
    182  . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO--
    183  . . ; I looked), PSSFT is the name, and list is the ^TMP name to store the data in.
    184  . . ; So...
    185  . . D AP^PSS51P1("PSJ",$P(SIGDATA,U,8),,,"SCHEDULE")
    186  . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE")
    187  . . N INTERVAL
    188  . . I $P(SCHEDATA(0),U)=-1 S INTERVAL=""
    189  . . E  D
    190  . . . N SUB S SUB=$O(SCHEDATA(0))
    191  . . . S INTERVAL=SCHEDATA(SUB,2)
    192  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
    193  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
    194  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$P(SIGDATA,U,5)
    195  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=""
    196  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$P(SIGDATA,U,8)["PRN"
    197  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")=""
    198  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")=""
    199  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")=""
    200  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")=""
    201  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")=""
    202  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")=""
    203  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")=""
    204  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")=""
    205  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM
    206  . . N DIRMOD S DIRMOD=$P(SIGDATA,U,6)
    207  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$S(DIRMOD="T":"THEN",DIRMOD="A":"AND",DIRMOD="X":"EXCEPT",1:"")
    208  . ;
    209  . ; --- END OF DIRECTIONS ---
    210  . ;
    211  . ; ^PSRX(22,"INS1",1,0)="FOR BLOOD PRESSURE"
    212  . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"INS1",1,0))
    213  . ; ^PSRX(22,"PRC",1,0)="Pharmacist: you must obey my command"
    214  . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PRC",1,0))
    215  . S @MAP@("MEDRFNO")=MED(9)
    216  . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
    217  . K @RESULT
    218  . D MAP^C0CXPATH(MINXML,MAP,RESULT)
    219  . ; MAPPING DIRECTIONS
    220  . N DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
    221  . N DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
    222  . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
    223  . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
    224  . ; N MDZ1,MDZNA
    225  . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
    226  . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
    227  . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
    228  . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
    229  . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
    230  . I MEDCOUNT=1 D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
    231  . E  D INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML
    232  N MEDTMP,MEDI
    233  D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
    234  I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
    235  . W "MEDICATION MISSING ",!
    236  . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
    237  Q
    238  ;
     1C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;;Last modified Sat Jan 10 21:42:27 PST 2009
     4        ; Copyright 2009 WorldVistA.  Licensed under the terms of the GNU
     5        ; General Public License See attached copy of the License.
     6        ;
     7        ; This program is free software; you can redistribute it and/or modify
     8        ; it under the terms of the GNU General Public License as published by
     9        ; the Free Software Foundation; either version 2 of the License, or
     10        ; (at your option) any later version.
     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        W "NO ENTRY FROM TOP",!
     22        Q
     23        ;
     24EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS)       ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
     25        ;
     26        ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
     27        ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE
     28        ;
     29        ; MEDS is return array from RPC.
     30        ; MAP is a mapping variable map (store result) for each med
     31        ; MED is holds each array element from MEDS(J), one medicine
     32        ; MEDCOUNT is a counter passed by Reference.
     33        ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool)
     34        ; FLAGS are set-up in C0CMED.
     35        ;
     36        ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all
     37        ; med data available.
     38        ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf
     39        ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS).
     40        ; D PARY^C0CXPATH(MINXML)
     41        N MEDS,MAP
     42        K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!!
     43        N ALL S ALL=+FLAGS
     44        N ACTIVE S ACTIVE=$P(FLAGS,U,3)
     45        ; Below, X1 is today; X2 is the number of days we want to go back
     46        ; X is the result of this calculation using C^%DTC.
     47        N X,X1,X2
     48        S X1=DT
     49        S X2=-$P($P(FLAGS,U,2),"-",2)
     50        D C^%DTC
     51        ; I discovered that I shouldn't put an ending date (last parameter)
     52        ; because it seems that it will get meds whose beginning is after X but
     53        ; whose exipriation is before the ending date.
     54        D RX^PSO52API(DFN,"CCDCCR","","","",X,"")
     55        M MEDS=^TMP($J,"CCDCCR",DFN)
     56        ; @(0) contains the number of meds or -1^NO DATA FOUND
     57        ; If it is -1, we quit.
     58        I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 Q
     59        ZWRITE:$G(DEBUG) MEDS
     60        N RXIEN S RXIEN=0
     61        F  S RXIEN=$O(MEDS(RXIEN)) Q:$G(RXIEN)=""  D  ; FOR EACH MEDICATION IN THE LIST
     62        . N MED M MED=MEDS(RXIEN)
     63        . I 'ALL,ACTIVE,$P(MED(100),U,2)'="ACTIVE" QUIT
     64        . S MEDCOUNT=MEDCOUNT+1
     65        . W:$G(DEBUG) "RXIEN IS ",RXIEN,!
     66        . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
     67        . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED
     68        . W:$G(DEBUG) "MAP= ",MAP,!
     69        . S @MAP@("MEDOBJECTID")="MED"_MEDCOUNT ; MEDCOUNT FOR ID
     70        . ; S @MAP@("MEDOBJECTID")="MED"_MED(.01) ;Rx Number
     71        . S @MAP@("MEDISSUEDATETXT")="Issue Date"
     72        . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(1),U))
     73        . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date"
     74        . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P($G(MED(101)),U))
     75        . S @MAP@("MEDRXNOTXT")="Prescription Number"
     76        . S @MAP@("MEDRXNO")=MED(.01)
     77        . S @MAP@("MEDTYPETEXT")="Medication"
     78        . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
     79        . S @MAP@("MEDSTATUSTEXT")=$P(MED(100),U,2)
     80        . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(4),U)
     81        . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(6),U,2)
     82        . ; 12/30/08: I will be using RxNorm for coding...
     83        . ; 176.001 is the file for Concepts; 176.003 is the file for
     84        . ; sources (i.e. for RxNorm Version)
     85        . ;
     86        . ; We need the VUID first for the National Drug File entry first
     87        . ; We get the VUID of the drug, by looking up the VA Product entry
     88        . ; (file 50.68) using the call NDF^PSS50, returned in node 22.
     89        . ; Field 99.99 is the VUID.
     90        . ;
     91        . ; We use the VUID to look up the RxNorm in file 176.001; same idea.
     92        . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by
     93        . ; $$GET1^DIQ.
     94        . ;
     95        . ; I get the RxNorm name and version from the RxNorm Sources (file
     96        . ; 176.003), by searching for "RXNORM", then get the data.
     97        . N MEDIEN S MEDIEN=$P(MED(6),U)
     98        . D NDF^PSS50(MEDIEN,,,,,"NDF")
     99        . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN)
     100        . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
     101        . N VAPROD S VAPROD=$P(NDFDATA(22),U)
     102        . ;
     103        . ; NDFIEN is not necessarily defined; it won't be if the drug
     104        . ; is not matched to the national drug file (e.g. if the drug is
     105        . ; new on the market, compounded, or is a fake drug [blue pill].
     106        . ; To protect against failure, I will put an if/else block
     107        . ;
     108        . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
     109        . I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
     110        . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
     111        . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
     112        . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01)
     113        . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM")
     114        . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
     115        . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
     116        . ;
     117        . E  S (RXNORM,RXNNAME,RXNVER)=""
     118        . ; End if/else block
     119        . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
     120        . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
     121        . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
     122        . ;
     123        . S @MAP@("MEDBRANDNAMETEXT")=MED(6.5)
     124        . D DOSE^PSS50(MEDIEN,,,,,"DOSE")
     125        . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
     126        . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901)
     127        . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2)
     128        . ; Units, concentration, etc, come from another call
     129        . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
     130        . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
     131        . ; NDF Entry IEN, and VA Product IEN
     132        . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
     133        . ; These have been collected above.
     134        . N CONCDATA
     135        . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
     136        . ; and this will crash the call. So...
     137        . I NDFIEN="" S CONCDATA=""
     138        . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
     139        . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1)
     140        . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3)
     141        . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4)
     142        . S @MAP@("MEDQUANTITYVALUE")=MED(7)
     143        . ; Oddly, there is no easy place to find the dispense unit.
     144        . ; It's not included in the original call, so we have to go to the drug file.
     145        . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
     146        . ; Node 14.5 is the Dispense Unit
     147        . D DATA^PSS50(MEDIEN,,,,,"QTY")
     148        . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
     149        . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
     150        . ;
     151        . ; --- START OF DIRECTIONS ---
     152        . ; Sig data not in any API :-(  Oh yes, you can get the whole thing, but...
     153        . ; we want the compoenents.
     154        . ; It's in node 6 of ^PSRX(IEN)
     155        . ; So, here we go again
     156        . ; ^PSRX(D0,6,D1,0)= (#.01) DOSAGE ORDERED [1F] ^ (#1) DISPENSE UNITS PER DOSE
     157        . ; ==>[2N] ^ (#2) UNITS [3P:50.607] ^ (#3) NOUN [4F] ^ (#4)
     158        . ; ==>DURATION [5F] ^ (#5) CONJUNCTION [6S] ^ (#6) ROUTE
     159        . ; ==>[7P:51.2] ^ (#7) SCHEDULE [8F] ^ (#8) VERB [9F] ^
     160        . ;
     161        . N DIRNUM S DIRNUM=0 ; Sigline number
     162        . S DIRCNT=0 ; COUNT OF MULTIPLE DIRECTIONS
     163        . F  S DIRNUM=$O(^PSRX(RXIEN,6,DIRNUM)) Q:DIRNUM=""  D
     164        . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT
     165        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")=""  ; This is reserved for systems not able to generate the sig in components.
     166        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1"  ; means that we are specifying it. See E2369-05.
     167        . . N SIGDATA S SIGDATA=^PSRX(RXIEN,6,DIRNUM,0)
     168        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$P(SIGDATA,U,9)
     169        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$P(SIGDATA,U,1)
     170        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT")
     171        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")=""  ; For inpatient
     172        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")=""  ; For inpatient
     173        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")=""  ; For inpatient
     174        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$$GET1^DIQ(51.2,$P(SIGDATA,U,7),.01)
     175        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$P(SIGDATA,U,8)
     176        . . ; Invervals... again another call.
     177        . . ; In the wisdom of the original programmers, the schedule is a free text field
     178        . . ; However, it gets translated by a call to the administration schedule file
     179        . . ; to see if that schedule exists.
     180        . . ; That's the same thing I am going to do.
     181        . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ).
     182        . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO--
     183        . . ; I looked), PSSFT is the name, and list is the ^TMP name to store the data in.
     184        . . ; So...
     185        . . D AP^PSS51P1("PSJ",$P(SIGDATA,U,8),,,"SCHEDULE")
     186        . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE")
     187        . . N INTERVAL
     188        . . I $P(SCHEDATA(0),U)=-1 S INTERVAL=""
     189        . . E  D
     190        . . . N SUB S SUB=$O(SCHEDATA(0))
     191        . . . S INTERVAL=SCHEDATA(SUB,2)
     192        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
     193        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
     194        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$P(SIGDATA,U,5)
     195        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=""
     196        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$P(SIGDATA,U,8)["PRN"
     197        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")=""
     198        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")=""
     199        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")=""
     200        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")=""
     201        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")=""
     202        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")=""
     203        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")=""
     204        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")=""
     205        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM
     206        . . N DIRMOD S DIRMOD=$P(SIGDATA,U,6)
     207        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$S(DIRMOD="T":"THEN",DIRMOD="A":"AND",DIRMOD="X":"EXCEPT",1:"")
     208        . ;
     209        . ; --- END OF DIRECTIONS ---
     210        . ;
     211        . ; ^PSRX(22,"INS1",1,0)="FOR BLOOD PRESSURE"
     212        . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"INS1",1,0))
     213        . ; ^PSRX(22,"PRC",1,0)="Pharmacist: you must obey my command"
     214        . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PRC",1,0))
     215        . S @MAP@("MEDRFNO")=MED(9)
     216        . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
     217        . K @RESULT
     218        . D MAP^C0CXPATH(MINXML,MAP,RESULT)
     219        . ; MAPPING DIRECTIONS
     220        . N DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
     221        . N DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
     222        . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
     223        . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
     224        . ; N MDZ1,MDZNA
     225        . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
     226        . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
     227        . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
     228        . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
     229        . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
     230        . I MEDCOUNT=1 D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
     231        . E  D INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML
     232        N MEDTMP,MEDI
     233        D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
     234        I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
     235        . W "MEDICATION MISSING ",!
     236        . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
     237        Q
     238        ;

  • ccr/branches/ohum/p/C0CMED2.m

    r1342 r1428  
    1 C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;;Last Modified Sat Jan 10 21:41:14 PST 2009
    4  ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    5  ; General Public License See attached copy of the License.
    6  ;
    7  ; This program is free software; you can redistribute it and/or modify
    8  ; it under the terms of the GNU General Public License as published by
    9  ; the Free Software Foundation; either version 2 of the License, or
    10  ; (at your option) any later version.
    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  W "NO ENTRY FROM TOP",!
    22  Q
    23  ;
    24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT)           ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
    25  ;
    26  ; MINXML is the Input XML Template, passed by name
    27  ; DFN is Patient IEN (by Value)
    28  ; OUTXML is the resultant XML (by Name)
    29  ; MEDCOUNT is the current count of extracted meds, passed by Reference
    30  ;
    31  ; MEDS is return array from RPC.
    32  ; MAP is a mapping variable map (store result) for each med
    33  ; MED is holds each array element from MEDS, one medicine
    34  ;
    35  ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending
    36  ; meds data available.
    37  ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf
    38  ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS).
    39  ; File for pending meds is 52.41
    40  ; Unfortuantely, API does not supply us with any useful info beyond
    41  ; the IEN in 52.41, and the Med Name, and route.
    42  ; So, most of the info is going to get pulled from 52.41.
    43  N MEDS,MAP
    44  K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!!
    45  D PEN^PSO5241(DFN,"CCDCCR")
    46  M MEDS=^TMP($J,"CCDCCR",DFN)
    47  ; @(0) contains the number of meds or -1^NO DATA FOUND
    48  ; If it is -1, we quit.
    49  I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT
    50  ZWRITE:$G(DEBUG) MEDS
    51  N RXIEN S RXIEN=0
    52  N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED IN THIS SECTION FOR MERGING
    53  F  S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B"  D  ; FOR EACH MEDICATION IN THE LIST
    54  . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT  ; Dont' want refill request as a "pending" order
    55  . S MEDCOUNT=MEDCOUNT+1
    56  . I DEBUG W "RXIEN IS ",RXIEN,!
    57  . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
    58  . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN C0CMED
    59  . I DEBUG W "MAP= ",MAP,!
    60  . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM
    61  . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID
    62  . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN
    63  . S @MAP@("MEDISSUEDATETXT")="Issue Date"
    64  . ; Field 6 is "Effective date", and we pull it in timson format w/ I
    65  . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($$GET1^DIQ(52.41,RXIEN,6,"I"),"DT")
    66  . ; Med never filled; next 4 fields are not applicable.
    67  . S @MAP@("MEDLASTFILLDATETXT")=""
    68  . S @MAP@("MEDLASTFILLDATE")=""
    69  . S @MAP@("MEDRXNOTXT")=""
    70  . S @MAP@("MEDRXNO")=""
    71  . S @MAP@("MEDTYPETEXT")="Medication"
    72  . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
    73  . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds
    74  . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I")
    75  . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2)
    76  . ; NDC not supplied in API, but is rather trivial to obtain
    77  . ; MED(11) piece 1 has the IEN of the drug (file 50)
    78  . ; IEN is field 31 in the drug file.
    79  . ;
    80  . ; MEDIEN (node 11 in the returned output) might not necessarily be defined
    81  . ; It is not defined when a dose in not chosen in CPRS. There is a long
    82  . ; series of fields that depend on it. We will use If and Else to deal
    83  . ; with that
    84  . N MEDIEN S MEDIEN=$P(MED(11),U)
    85  . I +MEDIEN>0 D  ; start of if/else block
    86  . . ; 12/30/08: I will be using RxNorm for coding...
    87  . . ; 176.001 is the file for Concepts; 176.003 is the file for
    88  . . ; sources (i.e. for RxNorm Version)
    89  . . ;
    90  . . ; We need the VUID first for the National Drug File entry first
    91  . . ; We get the VUID of the drug, by looking up the VA Product entry
    92  . . ; (file 50.68) using the call NDF^PSS50, returned in node 22.
    93  . . ; Field 99.99 is the VUID.
    94  . . ;
    95  . . ; We use the VUID to look up the RxNorm in file 176.001; same idea.
    96  . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by
    97  . . ; $$GET1^DIQ.
    98  . . ;
    99  . . ; I get the RxNorm name and version from the RxNorm Sources (file
    100  . . ; 176.003), by searching for "RXNORM", then get the data.
    101  . . D NDF^PSS50(MEDIEN,,,,,"NDF")
    102  . . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN)
    103  . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
    104  . . N VAPROD S VAPROD=$P(NDFDATA(22),U)
    105  . . ;
    106  . . ; NDFIEN is not necessarily defined; it won't be if the drug
    107  . . ; is not matched to the national drug file (e.g. if the drug is
    108  . . ; new on the market, compounded, or is a fake drug [blue pill].
    109  . . ; To protect against failure, I will put an if/else block
    110  . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
    111  . . I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
    112  . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
    113  . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
    114  . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01)
    115  . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM")
    116  . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
    117  . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
    118  . . ;
    119  . . E  S (RXNORM,RXNNAME,RXNVER)=""
    120  . . ; End if/else block
    121  . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
    122  . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
    123  . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
    124  . . ;
    125  . . S @MAP@("MEDBRANDNAMETEXT")=""
    126  . . D DOSE^PSS50(MEDIEN,,,,,"DOSE")
    127  . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
    128  . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901)
    129  . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2)
    130  . . ; Units, concentration, etc, come from another call
    131  . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
    132  . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
    133  . . ; NDF Entry IEN, and VA Product Name
    134  . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
    135  . . ; Documented in the same manual; executed above.
    136  . . N CONCDATA
    137  . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
    138  . . ; and this will crash the call. So...
    139  . . I NDFIEN="" S CONCDATA=""
    140  . . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
    141  . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1)
    142  . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3)
    143  . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4)
    144  . . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12)
    145  . . ; Oddly, there is no easy place to find the dispense unit.
    146  . . ; It's not included in the original call, so we have to go to the drug file.
    147  . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
    148  . . ; Node 14.5 is the Dispense Unit
    149  . . D DATA^PSS50(MEDIEN,,,,,"QTY")
    150  . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
    151  . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
    152  . E  D
    153  . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=""
    154  . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=""
    155  . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=""
    156  . . S @MAP@("MEDBRANDNAMETEXT")=""
    157  . . S @MAP@("MEDSTRENGTHVALUE")=""
    158  . . S @MAP@("MEDSTRENGTHUNIT")=""
    159  . . S @MAP@("MEDFORMTEXT")=""
    160  . . S @MAP@("MEDCONCVALUE")=""
    161  . . S @MAP@("MEDCONCUNIT")=""
    162  . . S @MAP@("MEDSIZETEXT")=""
    163  . . S @MAP@("MEDQUANTITYVALUE")=""
    164  . . S @MAP@("MEDQUANTITYUNIT")=""
    165  . ; end of if/else block
    166  . ;
    167  . ; --- START OF DIRECTIONS ---
    168  . ; Sig data is not in any API. We obtain it using the IEN from
    169  . ; the PEN API to file 52.41. It's in field 3, which is a multiple.
    170  . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT)
    171  . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call
    172  . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG")
    173  . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman.
    174  . ; FMSIGNUM gets outputted as "IEN,RXIEN,".
    175  . ; DIRNUM will be first piece for IEN.
    176  . ; DIRNUM is the proper Sigline numer.
    177  . ; SIGDATA is the simplfied array. Subscripts are really field numbers
    178  . ; in subfile 52.413.
    179  . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS
    180  . F  S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM=""  D
    181  . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",")
    182  . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT
    183  . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM)
    184  . . ; If this is an order for a refill; it's not really a new order; move on to next
    185  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")=""  ; This is reserved for systems not able to generate the sig in components.
    186  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1"  ; means that we are specifying it. See E2369-05.
    187  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13)
    188  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8)
    189  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT")
    190  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")=""  ; For inpatient
    191  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")=""  ; For inpatient
    192  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")=""  ; For inpatient
    193  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10)
    194  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1)
    195  . . ; Invervals... again another call.
    196  . . ; The schedule is a free text field
    197  . . ; However, it gets translated by a call to the administration
    198  . . ; schedule file to see if that schedule exists.
    199  . . ; That's the same thing I am going to do.
    200  . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ).
    201  . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO--
    202  . . ; I looked), PSSFT is the name,
    203  . . ; and list is the ^TMP name to store the data in.
    204  . . ; Also, freqency may have "PRN" in it, so strip that out
    205  . . N FREQ S FREQ=SIGDATA(1)
    206  . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp
    207  . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE")
    208  . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE")
    209  . . N INTERVAL
    210  . . I $P(SCHEDATA(0),U)=-1 S INTERVAL=""
    211  . . E  D
    212  . . . N SUB S SUB=$O(SCHEDATA(0))
    213  . . . S INTERVAL=SCHEDATA(SUB,2)
    214  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
    215  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
    216  . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months
    217  . . N DUR S DUR=SIGDATA(2)
    218  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR))
    219  . . N DURUNIT S DURUNIT=$E(DUR)
    220  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"")
    221  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN"
    222  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")=""
    223  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")=""
    224  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")=""
    225  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")=""
    226  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")=""
    227  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")=""
    228  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")=""
    229  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field
    230  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM
    231  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6)
    232  . ;
    233  . ; --- END OF DIRECTIONS ---
    234  . ;
    235  . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
    236  . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL
    237  . ; W @MAP@("MEDPTINSTRUCTIONS"),!
    238  . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9"
    239  . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL
    240  . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),!
    241  . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13)
    242  . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
    243  . K @RESULT
    244  . D MAP^C0CXPATH(MINXML,MAP,RESULT)
    245  . ; D PARY^C0CXPATH(RESULT)
    246  . ; MAPPING DIRECTIONS
    247  . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
    248  . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
    249  . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
    250  . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
    251  . ; N MDZ1,MDZNA
    252  . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
    253  . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
    254  . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
    255  . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
    256  . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
    257  . I MEDFIRST D  ;
    258  . . S MEDFIRST=0 ; RESET FIRST FLAG
    259  . . D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
    260  . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER
    261  N MEDTMP,MEDI
    262  D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
    263  I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
    264  . W "Pending Medication MISSING ",!
    265  . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
    266  Q
    267  ;
     1C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;;Last Modified Sat Jan 10 21:41:14 PST 2009
     4        ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     5        ; General Public License See attached copy of the License.
     6        ;
     7        ; This program is free software; you can redistribute it and/or modify
     8        ; it under the terms of the GNU General Public License as published by
     9        ; the Free Software Foundation; either version 2 of the License, or
     10        ; (at your option) any later version.
     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        W "NO ENTRY FROM TOP",!
     22        Q
     23        ;
     24EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT)               ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
     25        ;
     26        ; MINXML is the Input XML Template, passed by name
     27        ; DFN is Patient IEN (by Value)
     28        ; OUTXML is the resultant XML (by Name)
     29        ; MEDCOUNT is the current count of extracted meds, passed by Reference
     30        ;
     31        ; MEDS is return array from RPC.
     32        ; MAP is a mapping variable map (store result) for each med
     33        ; MED is holds each array element from MEDS, one medicine
     34        ;
     35        ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending
     36        ; meds data available.
     37        ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf
     38        ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS).
     39        ; File for pending meds is 52.41
     40        ; Unfortuantely, API does not supply us with any useful info beyond
     41        ; the IEN in 52.41, and the Med Name, and route.
     42        ; So, most of the info is going to get pulled from 52.41.
     43        N MEDS,MAP
     44        K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!!
     45        D PEN^PSO5241(DFN,"CCDCCR")
     46        M MEDS=^TMP($J,"CCDCCR",DFN)
     47        ; @(0) contains the number of meds or -1^NO DATA FOUND
     48        ; If it is -1, we quit.
     49        I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT
     50        ZWRITE:$G(DEBUG) MEDS
     51        N RXIEN S RXIEN=0
     52        N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED IN THIS SECTION FOR MERGING
     53        F  S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B"  D  ; FOR EACH MEDICATION IN THE LIST
     54        . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT  ; Dont' want refill request as a "pending" order
     55        . S MEDCOUNT=MEDCOUNT+1
     56        . I DEBUG W "RXIEN IS ",RXIEN,!
     57        . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
     58        . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN C0CMED
     59        . I DEBUG W "MAP= ",MAP,!
     60        . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM
     61        . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID
     62        . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN
     63        . S @MAP@("MEDISSUEDATETXT")="Issue Date"
     64        . ; Field 6 is "Effective date", and we pull it in timson format w/ I
     65        . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($$GET1^DIQ(52.41,RXIEN,6,"I"),"DT")
     66        . ; Med never filled; next 4 fields are not applicable.
     67        . S @MAP@("MEDLASTFILLDATETXT")=""
     68        . S @MAP@("MEDLASTFILLDATE")=""
     69        . S @MAP@("MEDRXNOTXT")=""
     70        . S @MAP@("MEDRXNO")=""
     71        . S @MAP@("MEDTYPETEXT")="Medication"
     72        . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
     73        . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds
     74        . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I")
     75        . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2)
     76        . ; NDC not supplied in API, but is rather trivial to obtain
     77        . ; MED(11) piece 1 has the IEN of the drug (file 50)
     78        . ; IEN is field 31 in the drug file.
     79        . ;
     80        . ; MEDIEN (node 11 in the returned output) might not necessarily be defined
     81        . ; It is not defined when a dose in not chosen in CPRS. There is a long
     82        . ; series of fields that depend on it. We will use If and Else to deal
     83        . ; with that
     84        . N MEDIEN S MEDIEN=$P(MED(11),U)
     85        . I +MEDIEN>0 D  ; start of if/else block
     86        . . ; 12/30/08: I will be using RxNorm for coding...
     87        . . ; 176.001 is the file for Concepts; 176.003 is the file for
     88        . . ; sources (i.e. for RxNorm Version)
     89        . . ;
     90        . . ; We need the VUID first for the National Drug File entry first
     91        . . ; We get the VUID of the drug, by looking up the VA Product entry
     92        . . ; (file 50.68) using the call NDF^PSS50, returned in node 22.
     93        . . ; Field 99.99 is the VUID.
     94        . . ;
     95        . . ; We use the VUID to look up the RxNorm in file 176.001; same idea.
     96        . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by
     97        . . ; $$GET1^DIQ.
     98        . . ;
     99        . . ; I get the RxNorm name and version from the RxNorm Sources (file
     100        . . ; 176.003), by searching for "RXNORM", then get the data.
     101        . . D NDF^PSS50(MEDIEN,,,,,"NDF")
     102        . . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN)
     103        . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
     104        . . N VAPROD S VAPROD=$P(NDFDATA(22),U)
     105        . . ;
     106        . . ; NDFIEN is not necessarily defined; it won't be if the drug
     107        . . ; is not matched to the national drug file (e.g. if the drug is
     108        . . ; new on the market, compounded, or is a fake drug [blue pill].
     109        . . ; To protect against failure, I will put an if/else block
     110        . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
     111        . . I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
     112        . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
     113        . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
     114        . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01)
     115        . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM")
     116        . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
     117        . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
     118        . . ;
     119        . . E  S (RXNORM,RXNNAME,RXNVER)=""
     120        . . ; End if/else block
     121        . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
     122        . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
     123        . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
     124        . . ;
     125        . . S @MAP@("MEDBRANDNAMETEXT")=""
     126        . . D DOSE^PSS50(MEDIEN,,,,,"DOSE")
     127        . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
     128        . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901)
     129        . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2)
     130        . . ; Units, concentration, etc, come from another call
     131        . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
     132        . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
     133        . . ; NDF Entry IEN, and VA Product Name
     134        . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
     135        . . ; Documented in the same manual; executed above.
     136        . . N CONCDATA
     137        . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
     138        . . ; and this will crash the call. So...
     139        . . I NDFIEN="" S CONCDATA=""
     140        . . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
     141        . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1)
     142        . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3)
     143        . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4)
     144        . . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12)
     145        . . ; Oddly, there is no easy place to find the dispense unit.
     146        . . ; It's not included in the original call, so we have to go to the drug file.
     147        . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
     148        . . ; Node 14.5 is the Dispense Unit
     149        . . D DATA^PSS50(MEDIEN,,,,,"QTY")
     150        . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
     151        . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
     152        . E  D
     153        . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=""
     154        . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=""
     155        . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=""
     156        . . S @MAP@("MEDBRANDNAMETEXT")=""
     157        . . S @MAP@("MEDSTRENGTHVALUE")=""
     158        . . S @MAP@("MEDSTRENGTHUNIT")=""
     159        . . S @MAP@("MEDFORMTEXT")=""
     160        . . S @MAP@("MEDCONCVALUE")=""
     161        . . S @MAP@("MEDCONCUNIT")=""
     162        . . S @MAP@("MEDSIZETEXT")=""
     163        . . S @MAP@("MEDQUANTITYVALUE")=""
     164        . . S @MAP@("MEDQUANTITYUNIT")=""
     165        . ; end of if/else block
     166        . ;
     167        . ; --- START OF DIRECTIONS ---
     168        . ; Sig data is not in any API. We obtain it using the IEN from
     169        . ; the PEN API to file 52.41. It's in field 3, which is a multiple.
     170        . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT)
     171        . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call
     172        . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG")
     173        . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman.
     174        . ; FMSIGNUM gets outputted as "IEN,RXIEN,".
     175        . ; DIRNUM will be first piece for IEN.
     176        . ; DIRNUM is the proper Sigline numer.
     177        . ; SIGDATA is the simplfied array. Subscripts are really field numbers
     178        . ; in subfile 52.413.
     179        . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS
     180        . F  S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM=""  D
     181        . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",")
     182        . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT
     183        . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM)
     184        . . ; If this is an order for a refill; it's not really a new order; move on to next
     185        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")=""  ; This is reserved for systems not able to generate the sig in components.
     186        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1"  ; means that we are specifying it. See E2369-05.
     187        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13)
     188        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8)
     189        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT")
     190        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")=""  ; For inpatient
     191        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")=""  ; For inpatient
     192        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")=""  ; For inpatient
     193        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10)
     194        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1)
     195        . . ; Invervals... again another call.
     196        . . ; The schedule is a free text field
     197        . . ; However, it gets translated by a call to the administration
     198        . . ; schedule file to see if that schedule exists.
     199        . . ; That's the same thing I am going to do.
     200        . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ).
     201        . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO--
     202        . . ; I looked), PSSFT is the name,
     203        . . ; and list is the ^TMP name to store the data in.
     204        . . ; Also, freqency may have "PRN" in it, so strip that out
     205        . . N FREQ S FREQ=SIGDATA(1)
     206        . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp
     207        . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE")
     208        . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE")
     209        . . N INTERVAL
     210        . . I $P(SCHEDATA(0),U)=-1 S INTERVAL=""
     211        . . E  D
     212        . . . N SUB S SUB=$O(SCHEDATA(0))
     213        . . . S INTERVAL=SCHEDATA(SUB,2)
     214        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
     215        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
     216        . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months
     217        . . N DUR S DUR=SIGDATA(2)
     218        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR))
     219        . . N DURUNIT S DURUNIT=$E(DUR)
     220        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"")
     221        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN"
     222        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")=""
     223        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")=""
     224        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")=""
     225        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")=""
     226        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")=""
     227        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")=""
     228        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")=""
     229        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field
     230        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM
     231        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6)
     232        . ;
     233        . ; --- END OF DIRECTIONS ---
     234        . ;
     235        . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
     236        . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL
     237        . ; W @MAP@("MEDPTINSTRUCTIONS"),!
     238        . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9"
     239        . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL
     240        . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),!
     241        . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13)
     242        . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
     243        . K @RESULT
     244        . D MAP^C0CXPATH(MINXML,MAP,RESULT)
     245        . ; D PARY^C0CXPATH(RESULT)
     246        . ; MAPPING DIRECTIONS
     247        . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
     248        . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
     249        . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
     250        . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
     251        . ; N MDZ1,MDZNA
     252        . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
     253        . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
     254        . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
     255        . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
     256        . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
     257        . I MEDFIRST D  ;
     258        . . S MEDFIRST=0 ; RESET FIRST FLAG
     259        . . D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
     260        . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER
     261        N MEDTMP,MEDI
     262        D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
     263        I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
     264        . W "Pending Medication MISSING ",!
     265        . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
     266        Q
     267        ;

  • ccr/branches/ohum/p/C0CMED3.m

    r1342 r1428  
    1 C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;;Last Modified: Sun Jan 11 05:45:03 UTC 2009
    4  ; Copyright 2009 WorldVistA.  Licensed under the terms of the GNU
    5  ; General Public License See attached copy of the License.
    6  ;
    7  ; This program is free software; you can redistribute it and/or modify
    8  ; it under the terms of the GNU General Public License as published by
    9  ; the Free Software Foundation; either version 2 of the License, or
    10  ; (at your option) any later version.
    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  W "NO ENTRY FROM TOP",!
    22  Q
    23  ;
    24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml template
    25  ;
    26  ; MINXML is the Input XML Template, (passed by name)
    27  ; DFN is Patient IEN (passed by value)
    28  ; OUTXML is the resultant XML (passed by name)
    29  ; MEDCOUNT is the number of Meds extracted so far (passed by reference)
    30  ;
    31  ; MEDS is return array from RPC.
    32  ; MAP is a mapping variable map (store result) for each med
    33  ; MED is holds each array element from MEDS, one medicine
    34  ;
    35  ; Non-VA meds don't have an API. They are stored in file 55, subfile 52.2
    36  ; Discontinued meds are indicated by the presence of a value in fields
    37  ; 5 or 6 (STATUS 1 or 2, and DISCONTINUED DATE)
    38  ; Will use Fileman API GETS^DIQ
    39  ;
    40  N MEDS,MAP
    41  K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!!
    42  N NVA
    43  D GETS^DIQ(55,DFN,"52.2*","IE","NVA") ; Output in NVA in FDA array format.
    44  ; If NVA does not exist, then patient has no non-VA meds
    45  I $D(NVA)=0 S @OUTXML@(0)=0 QUIT
    46  ; Otherwise, we go on...
    47  M MEDS=NVA(55.05)
    48  ; We are done with NVA
    49  K NVA
    50  ;
    51  I DEBUG ZWRITE MEDS
    52  N FDAIEN S FDAIEN=0 ; For use in $Order in the MEDS array.
    53  N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED PROCESSED HERE
    54  F  S FDAIEN=$O(MEDS(FDAIEN)) Q:FDAIEN=""  D  ; FOR EACH MEDICATION IN THE LIST
    55  . N MED M MED=MEDS(FDAIEN)
    56  . I MED(5,"I")!MED(6,"I") QUIT  ; If disconinued, we don't want to pull it.
    57  . S MEDCOUNT=MEDCOUNT+1
    58  . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
    59  . N RXIEN S RXIEN=$P(FDAIEN,",") ; First piece of FDAIEN is the number of the med for this patient
    60  . I DEBUG W "RXIEN IS ",RXIEN,!
    61  . I DEBUG W "MAP= ",MAP,!
    62  . S @MAP@("MEDOBJECTID")="MED_OUTSIDE"_MEDCOUNT ; MEDCOUNT FOR ID
    63  . S @MAP@("MEDISSUEDATETXT")="Documented Date"
    64  . ; Field 6 is "Effective date", and we pull it in timson format w/ I
    65  . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL(MED(11,"I"),"DT")
    66  . ; Med never filled; next 4 fields are not applicable.
    67  . S @MAP@("MEDLASTFILLDATETXT")=""
    68  . S @MAP@("MEDLASTFILLDATE")=""
    69  . S @MAP@("MEDRXNOTXT")=""
    70  . S @MAP@("MEDRXNO")=""
    71  . S @MAP@("MEDTYPETEXT")="Medication"
    72  . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
    73  . S @MAP@("MEDSTATUSTEXT")="Active" ; nearest status for pending meds
    74  . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I")
    75  . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E")
    76  . ; NDC is field 31 in the drug file.
    77  . ; The actual drug entry in the drug file (MEDIEN) is not necessarily supplied.
    78  . ; It' node 1, internal form.
    79  . N MEDIEN S MEDIEN=MED(1,"I")
    80  . I +MEDIEN D  ; start of if/else block
    81  . . ; 12/30/08: I will be using RxNorm for coding...
    82  . . ; 176.001 is the file for Concepts; 176.003 is the file for
    83  . . ; sources (i.e. for RxNorm Version)
    84  . . ;
    85  . . ; We need the VUID first for the National Drug File entry first
    86  . . ; We get the VUID of the drug, by looking up the VA Product entry
    87  . . ; (file 50.68) using the call NDF^PSS50, returned in node 22.
    88  . . ; Field 99.99 is the VUID.
    89  . . ;
    90  . . ; We use the VUID to look up the RxNorm in file 176.001; same idea.
    91  . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by
    92  . . ; $$GET1^DIQ.
    93  . . ;
    94  . . ; I get the RxNorm name and version from the RxNorm Sources (file
    95  . . ; 176.003), by searching for "RXNORM", then get the data.
    96  . . ; NDF^PSS50 ONLY EXISTS ON VISTA
    97  . . N NDFDATA,NDFIEN,VAPROD
    98  . . S NDFIEN=""
    99  . . I '$$RPMS^C0CUTIL() D
    100  . . . D NDF^PSS50(MEDIEN,,,,,"NDF")
    101  . . . ;N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN)
    102  . . . ;N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
    103  . . . ;N VAPROD S VAPROD=$P(NDFDATA(22),U)
    104  . . . M NDFDATA=^TMP($J,"NDF",MEDIEN)
    105  . . . S NDFIEN=$P(NDFDATA(20),U)
    106  . . . S VAPROD=$P(NDFDATA(22),U)
    107  . . . S @MAP@("MEDPRODUCTNAMETEXT")=$$GET1^DIQ(50.68,VAPROD,.01) ;
    108  . . ; GPL - RESET THE NAME TO THE REAL NAME OF THE DRUG NOW THAT WE
    109  . . ;   HAVE IT.
    110  . . ;
    111  . . ; NDFIEN is not necessarily defined; it won't be if the drug
    112  . . ; is not matched to the national drug file (e.g. if the drug is
    113  . . ; new on the market, compounded, or is a fake drug [blue pill].
    114  . . ; To protect against failure, I will put an if/else block
    115  . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
    116  . . ;
    117  . . ; begin changes for systems that have eRx installed
    118  . . ; RxNorm is found in the ^C0P("RXN") global - gpl
    119  . . ;
    120  . . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
    121  . . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE
    122  . . S (RXNORM,RXNNAME,RXNVER)="" ;INITIALIZE
    123  . . I NDFIEN,$D(^C0P("RXN")) D  ;
    124  . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
    125  . . . S ZC=$$CODE^C0CUTIL(VUID)
    126  . . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
    127  . . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
    128  . . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
    129  . . . S RXNORM=ZCD ; THE CODE
    130  . . . S RXNNAME=ZCDS ; THE CODING SYSTEM
    131  . . . S RXNVER=ZCDSV ; THE CODING SYSTEM VERSION
    132  . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT")
    133  . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_ZCDS_": "_ZCD
    134  . . E  I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
    135  . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
    136  . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
    137  . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01)
    138  . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM")
    139  . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
    140  . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
    141  . . ;
    142  . . ;E  S (RXNORM,RXNNAME,RXNVER)=""
    143  . . ; End if/else block
    144  . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
    145  . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
    146  . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
    147  . . ;
    148  . . S @MAP@("MEDBRANDNAMETEXT")=""
    149  . . ; DOSE^PSS50 ONLY ESISTS ON VISTA
    150  . . I '$$RPMS^C0CUTIL() D
    151  . . . D DOSE^PSS50(MEDIEN,,,,,"DOSE")
    152  . . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
    153  . . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901)
    154  . . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2)
    155  . . E  S @MAP@("MEDSTRENGTHVALUE")="" S @MAP@("MEDSTRENGTHUNIT")=""
    156  . . ; Units, concentration, etc, come from another call
    157  . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
    158  . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
    159  . . ; NDF Entry IEN, and VA Product Name
    160  . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
    161  . . ; Documented in the same manual; executed above.
    162  . . ;
    163  . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
    164  . . ; and this will crash the call. So...
    165  . . I NDFIEN="" S CONCDATA=""
    166  . . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
    167  . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1)
    168  . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3)
    169  . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4)
    170  . . S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
    171  . . ; Oddly, there is no easy place to find the dispense unit.
    172  . . ; It's not included in the original call, so we have to go to the drug file.
    173  . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
    174  . . ; Node 14.5 is the Dispense Unit
    175  . . ; PSS50 ONLY EXISTS ON VISTA
    176  . . I '$$RPMS^C0CUTIL() D
    177  . . . D DATA^PSS50(MEDIEN,,,,,"QTY")
    178  . . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
    179  . . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
    180  . . E  S @MAP@("MEDQUANTITYUNIT")=""
    181  . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these
    182  . E  D
    183  . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=""
    184  . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=""
    185  . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=""
    186  . . S @MAP@("MEDBRANDNAMETEXT")=""
    187  . . S @MAP@("MEDSTRENGTHVALUE")=""
    188  . . S @MAP@("MEDSTRENGTHUNIT")=""
    189  . . S @MAP@("MEDFORMTEXT")=""
    190  . . S @MAP@("MEDCONCVALUE")=""
    191  . . S @MAP@("MEDCONCUNIT")=""
    192  . . S @MAP@("MEDSIZETEXT")=""
    193  . . S @MAP@("MEDQUANTITYVALUE")=""
    194  . . S @MAP@("MEDQUANTITYUNIT")=""
    195  . ; End If/Else
    196  . ; --- START OF DIRECTIONS ---
    197  . ; Dosage is field 2, route is 3, schedule is 4
    198  . ; These are all free text fields, and don't point to any files
    199  . ; For that reason, I will use the field I never used before:
    200  . ; MEDDIRECTIONDESCRIPTIONTEXT
    201  . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS
    202  . ;
    203  . ; change for eRx meds - gpl 6/25/2011
    204  . ;
    205  . N ZERX S ZERX=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
    206  . I ZERX["|" S ZERX=$P(ZERX,"|",2) ; GET RID OF MED NAME
    207  . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=ZERX
    208  . N ZERX2 S ZERX2=$P(MED(2,"E"),"|",2) ; sig for quantity
    209  . N ZFDBDRUG S ZFDBDRUG=$P(MED(2,"E"),"|",1) ; FDB DRUG NAME
    210  . I @MAP@("MEDPRODUCTNAMETEXT")["FREE TXT" D  ; FIX THE DRUG NAME
    211  . . S @MAP@("MEDPRODUCTNAMETEXT")=ZFDBDRUG ; USE FDB NAME
    212  . . S RXNORM=$P($P($G(MED(14,7)),"RXNORM:",2)," ",1) ; THE RXNORM
    213  . . S RXNORM=$$NISTMAP^C0CUTIL(RXNORM) ; CHANGE IF NECESSARY
    214  . . I RXNORM'="" D  ;
    215  . . . W !,"FOUND FREE TEXT RXNORM:",RXNORM
    216  . . . S RXNNAME="RXNORM" ; THE CODING SYSTEM
    217  . . . S RXNVER="" ; THE CODING SYSTEM VERSION
    218  . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT")
    219  . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_RXNNAME_": "_RXNORM
    220  . . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
    221  . . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
    222  . . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
    223  . . . I RXNORM["979334" D  ; PATCH FOR CERTIFICATION
    224  . . . . S @MAP@("MEDSTRENGTHVALUE")=650
    225  . . . . S @MAP@("MEDSTRENGTHUNIT")="mcg"
    226  . . . . S @MAP@("MEDFORMTEXT")="INHALER"
    227  . S @MAP@("MEDQUANTITYUNIT")=$P(ZERX2," ",3) ; THE UNITS
    228  . S @MAP@("MEDQUANTITYVALUE")=$P(ZERX2," ",2) ; THE QUANTITY
    229  . I @MAP@("MEDFORMTEXT")="" S @MAP@("MEDFORMTEXT")=$P(ZERX2," ",3) ;
    230  . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
    231  . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4"  ; means look in description text. See E2369-05.
    232  . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
    233  . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")=""
    234  . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")=""
    235  . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")=""
    236  . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")=""
    237  . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")=""
    238  . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")=""
    239  . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")=""
    240  . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")=""
    241  . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")=""
    242  . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")=""
    243  . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")=""
    244  . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")=""
    245  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")=""
    246  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")=""
    247  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")=""
    248  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")=""
    249  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")=""
    250  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")=""
    251  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")=""
    252  . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")=""
    253  . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")=""
    254  . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")=""
    255  . ;
    256  . ; --- END OF DIRECTIONS ---
    257  . ;
    258  . S @MAP@("MEDRFNO")=""
    259  . I $D(MED(14,1)) D  ;
    260  . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
    261  . E  S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=""
    262  . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" ; don't put in these - gpl
    263  . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
    264  . K @RESULT
    265  . D MAP^C0CXPATH(MINXML,MAP,RESULT)
    266  . ; D PARY^C0CXPATH(RESULT)
    267  . ; MAPPING DIRECTIONS
    268  . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
    269  . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
    270  . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
    271  . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
    272  . N MDZ1,MDZNA
    273  . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
    274  . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
    275  . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
    276  . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
    277  . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
    278  . ;
    279  . ; MAP PATIENT INSTRUCTIONS - HAVE TO DO THIS AFTER MAPPING DIRECTIONS DUE TO XML SCHEMA VALIDATION
    280  . N MEDINT1,INTXML1 S INTXML1="MENINT1" ; VARIABLE AND NAME VARIABLE TEMPLATE
    281  . N MEDINT2,INTXML2 S INTXML2="MEDINT2" ; VARIABLE AND NAME VARIABLE RESULT
    282  . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/PatientInstructions",INTXML1)
    283  . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/PatientInstructions")
    284  . ;N MDI1 ; removing the "I" which is not in the protocol gpl 1/2010
    285  . ;S MDI1=$NA(@MAP@("I"))
    286  . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
    287  . I $D(MED(10,1)) D  ;
    288  . . ;S @MAP@("I","MEDPTINSTRUCTIONS")=$P(MED(10,1),"  ",1) ; WP Field
    289  . . S @MAP@("MEDPTINSTRUCTIONS")=$P(MED(10,1),"  ",1) ; WP Field
    290  . E  S @MAP@("MEDPTINSTRUCTIONS")=""
    291  . ;E  S @MAP@("I","MEDPTINSTRUCTIONS")=""
    292  . ;D MAP^C0CXPATH(INTXML1,MDI1,INTXML2)
    293  . D MAP^C0CXPATH(INTXML1,MAP,INTXML2) ; JUST MAP WORKS.. GPL
    294  . D INSERT^C0CXPATH(RESULT,INTXML2,"//Medications/Medication")
    295  . ;
    296  . ; FLAG HAS TO BE RESET OUTSIDE THE IF STATMENT.
    297  . ;I MEDFIRST D  ;
    298  . ;. S MEDFIRST=0 ; RESET FIRST FLAG
    299  . ;. D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
    300  . ;D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML
    301  . D:MEDFIRST CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
    302  . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
    303  . I MEDFIRST S MEDFIRST=0
    304  N MEDTMP,MEDI
    305  D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
    306  I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
    307  . W "MEDICATION MISSING ",!
    308  . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
    309  Q
    310  ;
     1C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;;Last Modified: Sun Jan 11 05:45:03 UTC 2009
     4        ; Copyright 2009 WorldVistA.  Licensed under the terms of the GNU
     5        ; General Public License See attached copy of the License.
     6        ;
     7        ; This program is free software; you can redistribute it and/or modify
     8        ; it under the terms of the GNU General Public License as published by
     9        ; the Free Software Foundation; either version 2 of the License, or
     10        ; (at your option) any later version.
     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        W "NO ENTRY FROM TOP",!
     22        Q
     23        ;
     24EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT)     ; Extract medications into provided xml template
     25        ;
     26        ; MINXML is the Input XML Template, (passed by name)
     27        ; DFN is Patient IEN (passed by value)
     28        ; OUTXML is the resultant XML (passed by name)
     29        ; MEDCOUNT is the number of Meds extracted so far (passed by reference)
     30        ;
     31        ; MEDS is return array from RPC.
     32        ; MAP is a mapping variable map (store result) for each med
     33        ; MED is holds each array element from MEDS, one medicine
     34        ;
     35        ; Non-VA meds don't have an API. They are stored in file 55, subfile 52.2
     36        ; Discontinued meds are indicated by the presence of a value in fields
     37        ; 5 or 6 (STATUS 1 or 2, and DISCONTINUED DATE)
     38        ; Will use Fileman API GETS^DIQ
     39        ;
     40        N MEDS,MAP
     41        K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!!
     42        N NVA
     43        D GETS^DIQ(55,DFN,"52.2*","IE","NVA") ; Output in NVA in FDA array format.
     44        ; If NVA does not exist, then patient has no non-VA meds
     45        I $D(NVA)=0 S @OUTXML@(0)=0 QUIT
     46        ; Otherwise, we go on...
     47        M MEDS=NVA(55.05)
     48        ; We are done with NVA
     49        K NVA
     50        ;
     51        I DEBUG ZWRITE MEDS
     52        N FDAIEN S FDAIEN=0 ; For use in $Order in the MEDS array.
     53        N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED PROCESSED HERE
     54        F  S FDAIEN=$O(MEDS(FDAIEN)) Q:FDAIEN=""  D  ; FOR EACH MEDICATION IN THE LIST
     55        . N MED M MED=MEDS(FDAIEN)
     56        . I MED(5,"I")!MED(6,"I") QUIT  ; If disconinued, we don't want to pull it.
     57        . S MEDCOUNT=MEDCOUNT+1
     58        . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
     59        . N RXIEN S RXIEN=$P(FDAIEN,",") ; First piece of FDAIEN is the number of the med for this patient
     60        . I DEBUG W "RXIEN IS ",RXIEN,!
     61        . I DEBUG W "MAP= ",MAP,!
     62        . S @MAP@("MEDOBJECTID")="MED_OUTSIDE"_MEDCOUNT ; MEDCOUNT FOR ID
     63        . S @MAP@("MEDISSUEDATETXT")="Documented Date"
     64        . ; Field 6 is "Effective date", and we pull it in timson format w/ I
     65        . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL(MED(11,"I"),"DT")
     66        . ; Med never filled; next 4 fields are not applicable.
     67        . S @MAP@("MEDLASTFILLDATETXT")=""
     68        . S @MAP@("MEDLASTFILLDATE")=""
     69        . S @MAP@("MEDRXNOTXT")=""
     70        . S @MAP@("MEDRXNO")=""
     71        . S @MAP@("MEDTYPETEXT")="Medication"
     72        . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
     73        . S @MAP@("MEDSTATUSTEXT")="Active" ; nearest status for pending meds
     74        . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I")
     75        . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E")
     76        . ; NDC is field 31 in the drug file.
     77        . ; The actual drug entry in the drug file (MEDIEN) is not necessarily supplied.
     78        . ; It' node 1, internal form.
     79        . N MEDIEN S MEDIEN=MED(1,"I")
     80        . I +MEDIEN D  ; start of if/else block
     81        . . ; 12/30/08: I will be using RxNorm for coding...
     82        . . ; 176.001 is the file for Concepts; 176.003 is the file for
     83        . . ; sources (i.e. for RxNorm Version)
     84        . . ;
     85        . . ; We need the VUID first for the National Drug File entry first
     86        . . ; We get the VUID of the drug, by looking up the VA Product entry
     87        . . ; (file 50.68) using the call NDF^PSS50, returned in node 22.
     88        . . ; Field 99.99 is the VUID.
     89        . . ;
     90        . . ; We use the VUID to look up the RxNorm in file 176.001; same idea.
     91        . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by
     92        . . ; $$GET1^DIQ.
     93        . . ;
     94        . . ; I get the RxNorm name and version from the RxNorm Sources (file
     95        . . ; 176.003), by searching for "RXNORM", then get the data.
     96        . . ; NDF^PSS50 ONLY EXISTS ON VISTA
     97        . . N NDFDATA,NDFIEN,VAPROD
     98        . . S NDFIEN=""
     99        . . I '$$RPMS^C0CUTIL() D
     100        . . . D NDF^PSS50(MEDIEN,,,,,"NDF")
     101        . . . ;N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN)
     102        . . . ;N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
     103        . . . ;N VAPROD S VAPROD=$P(NDFDATA(22),U)
     104        . . . M NDFDATA=^TMP($J,"NDF",MEDIEN)
     105        . . . S NDFIEN=$P(NDFDATA(20),U)
     106        . . . S VAPROD=$P(NDFDATA(22),U)
     107        . . . S @MAP@("MEDPRODUCTNAMETEXT")=$$GET1^DIQ(50.68,VAPROD,.01) ;
     108        . . ; GPL - RESET THE NAME TO THE REAL NAME OF THE DRUG NOW THAT WE
     109        . . ;   HAVE IT.
     110        . . ;
     111        . . ; NDFIEN is not necessarily defined; it won't be if the drug
     112        . . ; is not matched to the national drug file (e.g. if the drug is
     113        . . ; new on the market, compounded, or is a fake drug [blue pill].
     114        . . ; To protect against failure, I will put an if/else block
     115        . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
     116        . . ;
     117        . . ; begin changes for systems that have eRx installed
     118        . . ; RxNorm is found in the ^C0P("RXN") global - gpl
     119        . . ;
     120        . . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
     121        . . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE
     122        . . S (RXNORM,RXNNAME,RXNVER)="" ;INITIALIZE
     123        . . I NDFIEN,$D(^C0P("RXN")) D  ;
     124        . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
     125        . . . S ZC=$$CODE^C0CUTIL(VUID)
     126        . . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
     127        . . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
     128        . . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
     129        . . . S RXNORM=ZCD ; THE CODE
     130        . . . S RXNNAME=ZCDS ; THE CODING SYSTEM
     131        . . . S RXNVER=ZCDSV ; THE CODING SYSTEM VERSION
     132        . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT")
     133        . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_ZCDS_": "_ZCD
     134        . . E  I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
     135        . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
     136        . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
     137        . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01)
     138        . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM")
     139        . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
     140        . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
     141        . . ;
     142        . . ;E  S (RXNORM,RXNNAME,RXNVER)=""
     143        . . ; End if/else block
     144        . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
     145        . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
     146        . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
     147        . . ;
     148        . . S @MAP@("MEDBRANDNAMETEXT")=""
     149        . . ; DOSE^PSS50 ONLY ESISTS ON VISTA
     150        . . I '$$RPMS^C0CUTIL() D
     151        . . . D DOSE^PSS50(MEDIEN,,,,,"DOSE")
     152        . . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
     153        . . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901)
     154        . . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2)
     155        . . E  S @MAP@("MEDSTRENGTHVALUE")="" S @MAP@("MEDSTRENGTHUNIT")=""
     156        . . ; Units, concentration, etc, come from another call
     157        . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
     158        . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
     159        . . ; NDF Entry IEN, and VA Product Name
     160        . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
     161        . . ; Documented in the same manual; executed above.
     162        . . ;
     163        . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
     164        . . ; and this will crash the call. So...
     165        . . I NDFIEN="" S CONCDATA=""
     166        . . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
     167        . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1)
     168        . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3)
     169        . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4)
     170        . . S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
     171        . . ; Oddly, there is no easy place to find the dispense unit.
     172        . . ; It's not included in the original call, so we have to go to the drug file.
     173        . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
     174        . . ; Node 14.5 is the Dispense Unit
     175        . . ; PSS50 ONLY EXISTS ON VISTA
     176        . . I '$$RPMS^C0CUTIL() D
     177        . . . D DATA^PSS50(MEDIEN,,,,,"QTY")
     178        . . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
     179        . . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
     180        . . E  S @MAP@("MEDQUANTITYUNIT")=""
     181        . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these
     182        . E  D
     183        . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=""
     184        . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=""
     185        . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=""
     186        . . S @MAP@("MEDBRANDNAMETEXT")=""
     187        . . S @MAP@("MEDSTRENGTHVALUE")=""
     188        . . S @MAP@("MEDSTRENGTHUNIT")=""
     189        . . S @MAP@("MEDFORMTEXT")=""
     190        . . S @MAP@("MEDCONCVALUE")=""
     191        . . S @MAP@("MEDCONCUNIT")=""
     192        . . S @MAP@("MEDSIZETEXT")=""
     193        . . S @MAP@("MEDQUANTITYVALUE")=""
     194        . . S @MAP@("MEDQUANTITYUNIT")=""
     195        . ; End If/Else
     196        . ; --- START OF DIRECTIONS ---
     197        . ; Dosage is field 2, route is 3, schedule is 4
     198        . ; These are all free text fields, and don't point to any files
     199        . ; For that reason, I will use the field I never used before:
     200        . ; MEDDIRECTIONDESCRIPTIONTEXT
     201        . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS
     202        . ;
     203        . ; change for eRx meds - gpl 6/25/2011
     204        . ;
     205        . N ZERX S ZERX=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
     206        . I ZERX["|" S ZERX=$P(ZERX,"|",2) ; GET RID OF MED NAME
     207        . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=ZERX
     208        . N ZERX2 S ZERX2=$P(MED(2,"E"),"|",2) ; sig for quantity
     209        . N ZFDBDRUG S ZFDBDRUG=$P(MED(2,"E"),"|",1) ; FDB DRUG NAME
     210        . I @MAP@("MEDPRODUCTNAMETEXT")["FREE TXT" D  ; FIX THE DRUG NAME
     211        . . S @MAP@("MEDPRODUCTNAMETEXT")=ZFDBDRUG ; USE FDB NAME
     212        . . S RXNORM=$P($P($G(MED(14,7)),"RXNORM:",2)," ",1) ; THE RXNORM
     213        . . S RXNORM=$$NISTMAP^C0CUTIL(RXNORM) ; CHANGE IF NECESSARY
     214        . . I RXNORM'="" D  ;
     215        . . . W !,"FOUND FREE TEXT RXNORM:",RXNORM
     216        . . . S RXNNAME="RXNORM" ; THE CODING SYSTEM
     217        . . . S RXNVER="" ; THE CODING SYSTEM VERSION
     218        . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT")
     219        . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_RXNNAME_": "_RXNORM
     220        . . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
     221        . . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
     222        . . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
     223        . . . I RXNORM["979334" D  ; PATCH FOR CERTIFICATION
     224        . . . . S @MAP@("MEDSTRENGTHVALUE")=650
     225        . . . . S @MAP@("MEDSTRENGTHUNIT")="mcg"
     226        . . . . S @MAP@("MEDFORMTEXT")="INHALER"
     227        . S @MAP@("MEDQUANTITYUNIT")=$P(ZERX2," ",3) ; THE UNITS
     228        . S @MAP@("MEDQUANTITYVALUE")=$P(ZERX2," ",2) ; THE QUANTITY
     229        . I @MAP@("MEDFORMTEXT")="" S @MAP@("MEDFORMTEXT")=$P(ZERX2," ",3) ;
     230        . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
     231        . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4"  ; means look in description text. See E2369-05.
     232        . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
     233        . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")=""
     234        . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")=""
     235        . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")=""
     236        . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")=""
     237        . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")=""
     238        . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")=""
     239        . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")=""
     240        . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")=""
     241        . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")=""
     242        . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")=""
     243        . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")=""
     244        . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")=""
     245        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")=""
     246        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")=""
     247        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")=""
     248        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")=""
     249        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")=""
     250        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")=""
     251        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")=""
     252        . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")=""
     253        . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")=""
     254        . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")=""
     255        . ;
     256        . ; --- END OF DIRECTIONS ---
     257        . ;
     258        . S @MAP@("MEDRFNO")=""
     259        . I $D(MED(14,1)) D  ;
     260        . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
     261        . E  S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=""
     262        . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" ; don't put in these - gpl
     263        . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
     264        . K @RESULT
     265        . D MAP^C0CXPATH(MINXML,MAP,RESULT)
     266        . ; D PARY^C0CXPATH(RESULT)
     267        . ; MAPPING DIRECTIONS
     268        . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
     269        . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
     270        . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
     271        . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
     272        . N MDZ1,MDZNA
     273        . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
     274        . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
     275        . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
     276        . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
     277        . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
     278        . ;
     279        . ; MAP PATIENT INSTRUCTIONS - HAVE TO DO THIS AFTER MAPPING DIRECTIONS DUE TO XML SCHEMA VALIDATION
     280        . N MEDINT1,INTXML1 S INTXML1="MENINT1" ; VARIABLE AND NAME VARIABLE TEMPLATE
     281        . N MEDINT2,INTXML2 S INTXML2="MEDINT2" ; VARIABLE AND NAME VARIABLE RESULT
     282        . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/PatientInstructions",INTXML1)
     283        . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/PatientInstructions")
     284        . ;N MDI1 ; removing the "I" which is not in the protocol gpl 1/2010
     285        . ;S MDI1=$NA(@MAP@("I"))
     286        . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
     287        . I $D(MED(10,1)) D  ;
     288        . . ;S @MAP@("I","MEDPTINSTRUCTIONS")=$P(MED(10,1),"  ",1) ; WP Field
     289        . . S @MAP@("MEDPTINSTRUCTIONS")=$P(MED(10,1),"  ",1) ; WP Field
     290        . E  S @MAP@("MEDPTINSTRUCTIONS")=""
     291        . ;E  S @MAP@("I","MEDPTINSTRUCTIONS")=""
     292        . ;D MAP^C0CXPATH(INTXML1,MDI1,INTXML2)
     293        . D MAP^C0CXPATH(INTXML1,MAP,INTXML2) ; JUST MAP WORKS.. GPL
     294        . D INSERT^C0CXPATH(RESULT,INTXML2,"//Medications/Medication")
     295        . ;
     296        . ; FLAG HAS TO BE RESET OUTSIDE THE IF STATMENT.
     297        . ;I MEDFIRST D  ;
     298        . ;. S MEDFIRST=0 ; RESET FIRST FLAG
     299        . ;. D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
     300        . ;D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML
     301        . D:MEDFIRST CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
     302        . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
     303        . I MEDFIRST S MEDFIRST=0
     304        N MEDTMP,MEDI
     305        D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
     306        I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
     307        . W "MEDICATION MISSING ",!
     308        . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
     309        Q
     310        ;

  • ccr/branches/ohum/p/C0CMED4.m

    r1342 r1428  
    1 C0CMED4         ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08
    2  ;;0.1;CCDCCR;;;Build 2
    3  ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4  ; General Public License See attached copy of the License.
    5  ;
    6  ; This program is free software; you can redistribute it and/or modify
    7  ; it under the terms of the GNU General Public License as published by
    8  ; the Free Software Foundation; either version 2 of the License, or
    9  ; (at your option) any later version.
    10  ;
    11  ; This program is distributed in the hope that it will be useful,
    12  ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ; GNU General Public License for more details.
    15  ;
    16  ; You should have received a copy of the GNU General Public License along
    17  ; with this program; if not, write to the Free Software Foundation, Inc.,
    18  ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  W "NO ENTRY FROM TOP",!
    21  Q
    22  ;
    23 EXTRACT(MINXML,DFN,OUTXML)           ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
    24  ;
    25  ; MINXML is the Input XML Template, passed by name
    26  ; DFN is Patient IEN
    27  ; OUTXML is the resultant XML.
    28  ;
    29  ; MEDS is return array from API.
    30  ; MED is holds each array element from MEDS, one medicine
    31  ; MAP is a mapping variable map (store result) for each med
    32  ;
    33  ; Inpatient Meds will be extracted using this routine and and the one following.
    34  ; Inpatient Meds Unit Dose is going to be C0CMED4
    35  ; Inpatient Meds IVs is going to be C0CMED5
    36  ;
    37  ; We will use two Pharmacy ReEnginnering API's:
    38  ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info
    39  ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info
    40  ; For more information, see the PRE documentation at:
    41  ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf
    42  ;
    43  ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient
    44  ;
    45  N MEDS,MAP
    46  K ^TMP($J)
    47  D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*)
    48  I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT  ; No Meds - Quit
    49  ; Otherwise, we go on...
    50  M MEDS=^TMP($J,"UD")
    51  I DEBUG ZWR MEDS
    52  S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP"))
    53  N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array
    54  N I S I=0
    55  F  S I=$O(MEDS("B",I)) Q:'I  D  ; For each medication in B index
    56  . N MED M MED=MEDS(I)
    57  . S MEDCOUNT=MEDCOUNT+1
    58  . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter
    59  . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT))
    60  . N RXIEN S RXIEN=MED(.01) ; Order Number
    61  . I DEBUG W "RXIEN IS ",RXIEN,!
    62  . I DEBUG W "MAP= ",MAP,!
    63  . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN
    64  . S @MAP@("MEDISSUEDATETXT")="Order Date"
    65  . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT")
    66  . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient
    67  . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient
    68  . S @MAP@("MEDRXNOTXT")="" ; For Outpatient
    69  . S @MAP@("MEDRXNO")="" ; For Outpatient
    70  . S @MAP@("MEDTYPETEXT")="Medication"
    71  . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
    72  . S @MAP@("MEDSTATUSTEXT")="ACTIVE"
    73  . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U)
    74  . S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01)
    75  . ; NDC is field 31 in the drug file.
    76  . ; The actual drug entry in the drug file is not necessarily supplied.
    77  . ; It' node 1, internal form.
    78  . N MEDIEN S MEDIEN=MED(1,"I")
    79  . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"")
    80  . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"")
    81  . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"")
    82  . S @MAP@("MEDBRANDNAMETEXT")=""
    83  . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE")
    84  . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
    85  . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"")
    86  . S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"")
    87  . ; Units, concentration, etc, come from another call
    88  . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
    89  . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
    90  . ; NDF Entry IEN, and VA Product Name
    91  . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
    92  . ; Documented in the same manual.
    93  . N NDFDATA,CONCDATA
    94  . I $L(MEDIEN) D
    95  . . D NDF^PSS50(MEDIEN,,,,,"CONC")
    96  . . M NDFDATA=^TMP($J,"CONC",MEDIEN)
    97  . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
    98  . . N VAPROD S VAPROD=$P(NDFDATA(22),U)
    99  . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
    100  . . ; and this will crash the call. So...
    101  . . I NDFIEN="" S CONCDATA=""
    102  . . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
    103  . E  S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors.
    104  . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"")
    105  . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"")
    106  . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"")
    107  . S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
    108  . ; Oddly, there is no easy place to find the dispense unit.
    109  . ; It's not included in the original call, so we have to go to the drug file.
    110  . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
    111  . ; Node 14.5 is the Dispense Unit
    112  . I $L(MEDIEN) D
    113  . . D DATA^PSS50(MEDIEN,,,,,"QTY")
    114  . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
    115  . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
    116    E  S @MAP@("MEDQUANTITYUNIT")=""
    117  . ;
    118  . ; --- START OF DIRECTIONS ---
    119  . ; Dosage is field 2, route is 3, schedule is 4
    120  . ; These are all free text fields, and don't point to any files
    121  . ; For that reason, I will use the field I never used before:
    122  . ; MEDDIRECTIONDESCRIPTIONTEXT
    123  . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
    124  . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4"  ; means look in description text. See E2369-05.
    125  . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
    126  . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")=""
    127  . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")=""
    128  . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" 
    129  . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" 
    130  . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" 
    131  . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")=""
    132  . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")=""
    133  . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")=""
    134  . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")=""
    135  . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")=""
    136  . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")=""
    137  . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")=""
    138  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")=""
    139  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")=""
    140  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")=""
    141  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")=""
    142  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")=""
    143  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")=""
    144  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")=""
    145  . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")=""
    146  . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")=""
    147  . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")=""
    148  . ;
    149  . ; --- END OF DIRECTIONS ---
    150  . ;
    151  . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
    152  . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field
    153  . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
    154  . S @MAP@("MEDRFNO")=""
    155  . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED"))
    156  . K @RESULT
    157  . D MAP^GPLXPATH(MINXML,MAP,RESULT)
    158  . ; D PARY^GPLXPATH(RESULT)
    159  . ; MAPPING DIRECTIONS
    160  . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
    161  . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
    162  . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
    163  . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions")
    164  . ; N MDZ1,MDZNA
    165  . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
    166  . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
    167  . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
    168  . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2)
    169  . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication")
    170  . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy
    171  . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
    172  N MEDTMP,MEDI
    173  D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
    174  I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
    175  . W "MEDICATION MISSING ",!
    176  . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
    177  Q
    178  ;
     1C0CMED4         ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 ; 5/10/12 2:38pm
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     4        ; General Public License See attached copy of the License.
     5        ;
     6        ; This program is free software; you can redistribute it and/or modify
     7        ; it under the terms of the GNU General Public License as published by
     8        ; the Free Software Foundation; either version 2 of the License, or
     9        ; (at your option) any later version.
     10        ;
     11        ; This program is distributed in the hope that it will be useful,
     12        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ; GNU General Public License for more details.
     15        ;
     16        ; You should have received a copy of the GNU General Public License along
     17        ; with this program; if not, write to the Free Software Foundation, Inc.,
     18        ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        W "NO ENTRY FROM TOP",!
     21        Q
     22        ;
     23EXTRACT(MINXML,DFN,OUTXML)                ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
     24        ;
     25        ; MINXML is the Input XML Template, passed by name
     26        ; DFN is Patient IEN
     27        ; OUTXML is the resultant XML.
     28        ;
     29        ; MEDS is return array from API.
     30        ; MED is holds each array element from MEDS, one medicine
     31        ; MAP is a mapping variable map (store result) for each med
     32        ;
     33        ; Inpatient Meds will be extracted using this routine and and the one following.
     34        ; Inpatient Meds Unit Dose is going to be C0CMED4
     35        ; Inpatient Meds IVs is going to be C0CMED5
     36        ;
     37        ; We will use two Pharmacy ReEnginnering API's:
     38        ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info
     39        ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info
     40        ; For more information, see the PRE documentation at:
     41        ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf
     42        ;
     43        ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient
     44        ;
     45        N MEDS,MAP
     46        K ^TMP($J)
     47        D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*)
     48        I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT  ; No Meds - Quit
     49        ; Otherwise, we go on...
     50        M MEDS=^TMP($J,"UD")
     51        I DEBUG ZWR MEDS
     52        S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP"))
     53        N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array
     54        N I S I=0
     55        F  S I=$O(MEDS("B",I)) Q:'I  D  ; For each medication in B index
     56        . N MED M MED=MEDS(I)
     57        . S MEDCOUNT=MEDCOUNT+1
     58        . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter
     59        . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT))
     60        . N RXIEN S RXIEN=MED(.01) ; Order Number
     61        . I DEBUG W "RXIEN IS ",RXIEN,!
     62        . I DEBUG W "MAP= ",MAP,!
     63        . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN
     64        . S @MAP@("MEDISSUEDATETXT")="Order Date"
     65        . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT")
     66        . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient
     67        . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient
     68        . S @MAP@("MEDRXNOTXT")="" ; For Outpatient
     69        . S @MAP@("MEDRXNO")="" ; For Outpatient
     70        . S @MAP@("MEDTYPETEXT")="Medication"
     71        . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
     72        . S @MAP@("MEDSTATUSTEXT")="ACTIVE"
     73        . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U)
     74        . S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01)
     75        . ; NDC is field 31 in the drug file.
     76        . ; The actual drug entry in the drug file is not necessarily supplied.
     77        . ; It' node 1, internal form.
     78        . N MEDIEN S MEDIEN=MED(1,"I")
     79        . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"")
     80        . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"")
     81        . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"")
     82        . S @MAP@("MEDBRANDNAMETEXT")=""
     83        . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE")
     84        . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
     85        . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"")
     86        . S @MAP@("MEDSTRENGTHUNIT")=$S($L(MEDIEN):$P(DOSEDATA(902),U,2),1:"")
     87        . ; Units, concentration, etc, come from another call
     88        . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
     89        . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
     90        . ; NDF Entry IEN, and VA Product Name
     91        . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
     92        . ; Documented in the same manual.
     93        . N NDFDATA,CONCDATA
     94        . I $L(MEDIEN) D
     95        . . D NDF^PSS50(MEDIEN,,,,,"CONC")
     96        . . M NDFDATA=^TMP($J,"CONC",MEDIEN)
     97        . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
     98        . . N VAPROD S VAPROD=$P(NDFDATA(22),U)
     99        . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
     100        . . ; and this will crash the call. So...
     101        . . I NDFIEN="" S CONCDATA=""
     102        . . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
     103        . E  S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors.
     104        . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"")
     105        . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"")
     106        . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"")
     107        . S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
     108        . ; Oddly, there is no easy place to find the dispense unit.
     109        . ; It's not included in the original call, so we have to go to the drug file.
     110        . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
     111        . ; Node 14.5 is the Dispense Unit
     112        . I $L(MEDIEN) D
     113        . . D DATA^PSS50(MEDIEN,,,,,"QTY")
     114        . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
     115        . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
     116          E  S @MAP@("MEDQUANTITYUNIT")=""
     117        . ;
     118        . ; --- START OF DIRECTIONS ---
     119        . ; Dosage is field 2, route is 3, schedule is 4
     120        . ; These are all free text fields, and don't point to any files
     121        . ; For that reason, I will use the field I never used before:
     122        . ; MEDDIRECTIONDESCRIPTIONTEXT
     123        . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
     124        . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4"  ; means look in description text. See E2369-05.
     125        . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
     126        . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")=""
     127        . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")=""
     128        . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" 
     129        . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" 
     130        . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" 
     131        . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")=""
     132        . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")=""
     133        . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")=""
     134        . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")=""
     135        . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")=""
     136        . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")=""
     137        . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")=""
     138        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")=""
     139        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")=""
     140        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")=""
     141        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")=""
     142        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")=""
     143        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")=""
     144        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")=""
     145        . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")=""
     146        . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")=""
     147        . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")=""
     148        . ;
     149        . ; --- END OF DIRECTIONS ---
     150        . ;
     151        . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
     152        . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field
     153        . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
     154        . S @MAP@("MEDRFNO")=""
     155        . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED"))
     156        . K @RESULT
     157        . D MAP^GPLXPATH(MINXML,MAP,RESULT)
     158        . ; D PARY^GPLXPATH(RESULT)
     159        . ; MAPPING DIRECTIONS
     160        . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
     161        . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
     162        . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
     163        . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions")
     164        . ; N MDZ1,MDZNA
     165        . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
     166        . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
     167        . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
     168        . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2)
     169        . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication")
     170        . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy
     171        . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
     172        N MEDTMP,MEDI
     173        D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
     174        I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
     175        . W "MEDICATION MISSING ",!
     176        . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
     177        Q
     178        ;

  • ccr/branches/ohum/p/C0CMED6.m

    r1342 r1428  
    1 C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4  ; General Public License See attached copy of the License.
    5  ;
    6  ; This program is free software; you can redistribute it and/or modify
    7  ; it under the terms of the GNU General Public License as published by
    8  ; the Free Software Foundation; either version 2 of the License, or
    9  ; (at your option) any later version.
    10  ;
    11  ; This program is distributed in the hope that it will be useful,
    12  ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ; GNU General Public License for more details.
    15  ;
    16  ; You should have received a copy of the GNU General Public License along
    17  ; with this program; if not, write to the Free Software Foundation, Inc.,
    18  ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  W "NO ENTRY FROM TOP",!
    21  Q
    22  ;
    23 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS)  ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
    24  ;
    25  ; MINXML and OUTXML are passed by name so globals can be used
    26  ; MINXML will contain only the medications skeleton of the overall template
    27  ; MEDCOUNT is a counter passed by Reference.
    28  ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool)
    29  ; FLAGS are set-up in C0CMED.
    30  ;
    31  ; MEDS is return array from RPC.
    32  ; MAP is a mapping variable map (store result) for each med
    33  ; MED is holds each array element from MEDS(J), one medicine
    34  ; J is a counter.
    35  ;
    36  ; GETRXS^BEHORXFN(ARRAYNAME,DFN,DAYS) will be the the API used.
    37  ; This API has been developed by Medsphere for IHS for getting
    38  ; Medications from RPMS. It has most of what we need.
    39  ; API written by Doug Martin when he worked for Medsphere (thanks Doug!)
    40  ; -- ARRAYNAME is passed by name (required)
    41  ; -- DFN is passed by value (required)
    42  ; -- DAYS is passed by value (optional; if not passed defaults to 365)
    43  ;
    44  ; Return:
    45  ; ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID
    46  ; ^Status^LastFill^Chronic^Issued^Rx #^Provider^
    47  ; Status Reason^DEA Handling
    48  ;
    49  N MEDS,MEDS1,MAP
    50  D GETRXS^BEHORXFN("MEDS1",DFN,$P($P(FLAGS,U,2),"-",2)) ; 2nd piece of FLAGS is # of days to retrieve, which comes in the form "T-360"
    51  N ALL S ALL=+FLAGS
    52  N ACTIVE S ACTIVE=$P(FLAGS,U,3)
    53  N PENDING S PENDING=$P(FLAGS,U,4)
    54  S @OUTXML@(0)=0  ;By default, no meds
    55  ; If MEDS1 is not defined, then no meds
    56  I '$D(MEDS1) QUIT
    57  I DEBUG ZWR MEDS1,MINXML
    58  N MEDCNT S MEDCNT=0 ; Med Count
    59  ; The next line is a super line. It goes through the array return
    60  ; and if the first characters are ~OP, it grabs the line.
    61  ; This means that line is for a dispensed Outpatient Med.
    62  ; That line has the metadata about the med that I need.
    63  ; The next lines, however many, are the med and the sig.
    64  ; I won't be using those because I have to get the sig parsed exactly.
    65  N J S J="" F  S J=$O(MEDS1(J)) Q:J=""  I $E(MEDS1(J),1,3)="~OP" S MEDCNT=MEDCNT+1 S MEDS(MEDCNT)=MEDS1(J)
    66  K MEDS1
    67  S MEDCNT="" ; Initialize for $Order
    68  F  S MEDCNT=$O(MEDS(MEDCNT)) Q:MEDCNT=""  D  ; for each medication in the list
    69  . I 'ALL,ACTIVE,$P(MEDS(MEDCNT),U,10)'="ACTIVE" QUIT
    70  . I 'ALL,PENDING,$P(MEDS(MEDCNT),U,10)'="PENDING" QUIT
    71  . I DEBUG W "MEDCNT IS ",MEDCNT,!
    72  . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCNT))
    73  . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED
    74  . I DEBUG W "MAP= ",MAP,!
    75  . S @MAP@("MEDOBJECTID")="MED"_MEDCNT ; MEDCNT FOR ID
    76  . S @MAP@("MEDISSUEDATETXT")="Issue Date"
    77  . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,15),"DT")
    78  . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date"
    79  . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,11),"DT")
    80  . S @MAP@("MEDRXNOTXT")="Prescription Number"
    81  . S @MAP@("MEDRXNO")=$P(MEDS(MEDCNT),U,14)
    82  . S @MAP@("MEDTYPETEXT")="Medication"
    83  . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
    84  . S @MAP@("MEDSTATUSTEXT")=$P(MEDS(MEDCNT),U,10)
    85  . ; Provider only provided in API as text, not DUZ.
    86  . ; We need to get DUZ from filman file 52 (Prescription)
    87  . ; Field 4; IEN is Piece 2 of Meds stripped of trailing characters.
    88  . ; Note that I will use RXIEN several times later
    89  . N RXIEN S RXIEN=+$P(MEDS(MEDCNT),U,2)
    90  . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52,RXIEN,4,"I")
    91  . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MEDS(MEDCNT),U,3)
    92  . ; --- RxNorm Stuff
    93  . ; 176.001 is the file for Concepts; 176.003 is the file for
    94  . ; sources (i.e. for RxNorm Version)
    95  . ;
    96  . ; I use 176.001 for the Vista version of this routine (files 1-3)
    97  . ; Since IHS does not have VUID's, I will be getting RxNorm codes
    98  . ; using NDCs. My specially crafted index (sounds evil) named "NDC"
    99  . ; is in file 176.002. The file is called RxNorm NDC to VUID.
    100  . ; Except that I don't need the VUID, but it's there if I need it.
    101  . ;
    102  . ; We obviously need the NDC. That is easily obtained from the prescription.
    103  . ; Field 27 in file 52
    104  . N NDC S NDC=$$GET1^DIQ(52,RXIEN,27,"I")
    105  . ; I discovered that file 176.002 might give you two codes for the NDC
    106  . ; One for the Clinical Drug, and one for the ingredient.
    107  . ; So the plan is to get the two RxNorm codes, and then find from
    108  . ; file 176.001 which one is the Clinical Drug.
    109  . ; ... I refactored this into GETRXN
    110  . N RXNORM,SRCIEN,RXNNAME,RXNVER
    111  . I +NDC,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
    112  . . S RXNORM=$$GETRXN(NDC)
    113  . . S SRCIEN=$$FIND1^DIC(176.003,,,"RXNORM","B")
    114  . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
    115  . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
    116  . ;
    117  . E  S (RXNORM,RXNNAME,RXNVER)=""
    118  . ; End if/else block
    119  . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
    120  . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
    121  . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
    122  . ; --- End RxNorm section
    123  . ;
    124  . ; Brand name is 52 field 6.5
    125  . S @MAP@("MEDBRANDNAMETEXT")=$$GET1^DIQ(52,RXIEN,6.5)
    126  . ;
    127  . ; Next I need Med Form (tab, cap etc), strength (250mg)
    128  . ; concentration for liquids (250mg/mL)
    129  . ; Since IHS does not have any of the new calls that
    130  . ; Vista has, I will be doing a crosswalk:
    131  . ; File 52, field 6 is Drug IEN in file 50
    132  . ; File 50, field 22 is VA Product IEN in file 50.68
    133  . ; In file 50.68, I will get the following:
    134  . ; -- 1: Dosage Form
    135  . ; -- 2: Strength
    136  . ; -- 3: Units
    137  . ; -- 8: Dispense Units
    138  . ; -- Conc is 2 concatenated with 3
    139  . ;
    140  . ; *** If Drug is not matched to NDF, then VA Product will be "" ***
    141  . ;
    142  . N MEDIEN S MEDIEN=$$GET1^DIQ(52,RXIEN,6,"I") ; Drug IEN in 50
    143  . N VAPROD S VAPROD=$$GET1^DIQ(50,MEDIEN,22,"I") ; VA Product in file 50.68
    144  . I +VAPROD D
    145  . . S @MAP@("MEDSTRENGTHVALUE")=$$GET1^DIQ(50.68,VAPROD,2)
    146  . . S @MAP@("MEDSTRENGTHUNIT")=$$GET1^DIQ(50.68,VAPROD,3)
    147  . . S @MAP@("MEDFORMTEXT")=$$GET1^DIQ(50.68,VAPROD,1)
    148  . . S @MAP@("MEDCONCVALUE")=@MAP@("MEDSTRENGTHVALUE")
    149  . . S @MAP@("MEDCONCUNIT")=@MAP@("MEDSTRENGTHUNIT")
    150  . E  D
    151  . . S @MAP@("MEDSTRENGTHVALUE")=""
    152  . . S @MAP@("MEDSTRENGTHUNIT")=""
    153  . . S @MAP@("MEDFORMTEXT")=""
    154  . . S @MAP@("MEDCONCVALUE")=""
    155  . . S @MAP@("MEDCONCUNIT")=""
    156  . ; End Strengh/Conc stuff
    157  . ;
    158  . ; Quantity is in the prescription, field 7
    159  . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52,RXIEN,7)
    160  . ; Dispense unit is in the drug file, field 14.5
    161  . S @MAP@("MEDQUANTITYUNIT")=$$GET1^DIQ(50,MEDIEN,14.5)
    162  . ;
    163  . ; --- START OF DIRECTIONS ---
    164  . ; Sig data not in any API :-(  Oh yes, you can get the whole thing, but...
    165  . ; we want the components.
    166  . ; It's in multiple 113 in the Prescription File (52)
    167  . ; #.01 DOSAGE ORDERED [1F]    "20"
    168  . ; #1 DISPENSE UNITS PER DOSE [2N]  "1"
    169  . ; #2 UNITS [3P:50.607]     "MG"
    170  . ; #3 NOUN [4F]      "TABLET"
    171  . ; #4 DURATION [5F]      "10D"
    172  . ; #5 CONJUNCTION [6S]     "AND"
    173  . ; #6 ROUTE [7P:51.2]     "ORAL"
    174  . ; #7 SCHEDULE [8F]      "BID"
    175  . ; #8 VERB [9F]       "TAKE"
    176  . ;
    177  . ; Will use GETS^DIQ to get fields.
    178  . ; Data comes out like this:
    179  . ; SAMINS(52.0113,"1,23,",.01)=20
    180  . ; SAMINS(52.0113,"1,23,",1)=1
    181  . ; SAMINS(52.0113,"1,23,",2)="MG"
    182  . ; SAMINS(52.0113,"1,23,",3)="TABLET"
    183  . ; SAMINS(52.0113,"1,23,",4)="5D"
    184  . ; SAMINS(52.0113,"1,23,",5)="THEN"
    185  . ;
    186  . N RAWDATA
    187  . D GETS^DIQ(52,RXIEN,"113*",,"RAWDATA","DIERR")
    188  . D:$D(DIERR) ^%ZTER  ; Log if there's an error in retrieving sig field
    189  . ; none the less, continue; some parts are retrievable.
    190  . N FMSIG M FMSIG=RAWDATA(52.0113) ; Merge into subfile...
    191  . K RAWDATA
    192  . N FMSIGNUM S FMSIGNUM="" ; Sigline number in fileman.
    193  . ; FMSIGNUM gets outputted as "IEN,RXIEN,".
    194  . ; DIRCNT is the proper Sigline numer.
    195  . ; SIGDATA is the simplfied array.
    196  . F  S FMSIGNUM=$O(FMSIG(FMSIGNUM)) Q:FMSIGNUM=""  D
    197  . . N DIRCNT S DIRCNT=$P(FMSIGNUM,",")
    198  . . N SIGDATA M SIGDATA=FMSIG(FMSIGNUM)
    199  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")=""  ; This is reserved for systems not able to generate the sig in components.
    200  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1"  ; means that we are specifying it. See E2369-05.
    201  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$G(SIGDATA(8))
    202  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$G(SIGDATA(.01))
    203  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=$G(SIGDATA(2))
    204  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")=""  ; For inpatient
    205  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")=""  ; For inpatient
    206  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")=""  ; For inpatient
    207  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$G(SIGDATA(6))
    208  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$G(SIGDATA(7))
    209  . . ; Invervals... again another call.
    210  . . ; In the wisdom of the original programmers, the schedule is a free text field
    211  . . ; However, it gets translated by a call to the administration schedule file
    212  . . ; to see if that schedule exists.
    213  . . ; That's the same thing I am going to do.
    214  . . ; Search B index of 51.1 (Admin Schedule) with schedule
    215  . . ; First, remove "PRN" if it exists (don't ask, that's how the file
    216  . . ; works; I wouldn't do it that way).
    217  . . N SCHNOPRN S SCHNOPRN=$G(SIGDATA(7))
    218  . . I SCHNOPRN["PRN" S SCHNOPRN=$E(SCHNOPRN,1,$F(SCHNOPRN,"PRN")-5)
    219  . . ; Super call below:
    220  . . ; 1=File 51.1 3=Field 2 (Frequency in Minutes)
    221  . . ; 4=Packed format, Exact Match 5=Lookup Value
    222  . . ; 6=# of entries to return 7=Index 10=Return Array
    223  . . ;
    224  . . ; I do not account for the fact that two schedules can be
    225  . . ; spelled identically (ie duplicate entry). In that case,
    226  . . ; I get the first. That's just a bad pharmacy pkg maintainer.
    227  . . N C0C515
    228  . . D FIND^DIC(51.1,,"@;2","PX",SCHNOPRN,1,"B",,,"C0C515")
    229  . . N INTERVAL S INTERVAL="" ; Default
    230  . . ; If there are entries found, get it
    231  . . I +$G(C0C515("DILIST",0)) S INTERVAL=$P(C0C515("DILIST",1,0),U,2)
    232  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
    233  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
    234  . . ; Duration is 10M minutes, 10H hours, 10D for Days
    235  . . ; 10W for weeks, 10L for months. I smell $Select
    236  . . ; But we don't need to do that if there isn't a duration
    237  . . I +$G(SIGDATA(4)) D
    238  . . . N DURUNIT S DURUNIT=$E(SIGDATA(4),$L(SIGDATA(4))) ; get last char
    239  . . . N DURTXT S DURTXT=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"Days")
    240  . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=+SIGDATA(4)
    241  . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=DURTXT
    242  . . E  D
    243  . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=""
    244  . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=""
    245  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$G(SIGDATA(4))["PRN"
    246  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" ; when avail
    247  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")=""
    248  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")=""
    249  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")=""
    250  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")=""
    251  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")=""
    252  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")=""
    253  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; not stored
    254  . . ; Another confusing line; I am pretty bad:
    255  . . ; If there is another entry in the FMSIG array (i.e. another line
    256  . . ; in the sig), set the direction count indicator.
    257  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=""  ; Default
    258  . . S:+$O(FMSIG(FMSIGNUM)) @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRCNT
    259  . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$G(SIGDATA(5))
    260  . ;
    261  . ; --- END OF DIRECTIONS ---
    262  . ;
    263  . ; Med instructions is a WP field, thus the acrobatics
    264  . ; Notice buffer overflow protection set at 10,000 chars
    265  . ; -- 1. Med Patient Instructions
    266  . N MEDPTIN1 S MEDPTIN1=$$GET1^DIQ(52,RXIEN,115,,"MEDPTIN1")
    267  . N MEDPTIN2,J  S (MEDPTIN2,J)=""
    268  . I $L(MEDPTIN1) F  S J=$O(@MEDPTIN1@(J)) Q:J=""  Q:$L(MEDPTIN2)>10000  S MEDPTIN2=MEDPTIN2_@MEDPTIN1@(J)_" "
    269  . S @MAP@("MEDPTINSTRUCTIONS")=MEDPTIN2
    270  . K J
    271  . ; -- 2. Med Provider Instructions
    272  . N MEDPVIN1 S MEDPVIN1=$$GET1^DIQ(52,RXIEN,39,,"MEDPVIN1")
    273  . N MEDPVIN2,J S (MEDPVIN2,J)=""
    274  . I $L(MEDPVIN1) F  S J=$O(@MEDPVIN1@(J)) Q:J=""  Q:$L(MEDPVIN2)>10000  S MEDPVIN2=MEDPVIN2_@MEDPVIN1@(J)_" "
    275  . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MEDPVIN2
    276  . ;
    277  . ; Remaining refills
    278  . S @MAP@("MEDRFNO")=$P(MEDS(MEDCNT),U,6)
    279  . ; ------ END OF MAPPING
    280  . ;
    281  . ; ------ BEGIN XML INSERTION
    282  . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
    283  . K @RESULT
    284  . D MAP^C0CXPATH(MINXML,MAP,RESULT)
    285  . ; D PARY^C0CXPATH(RESULT)
    286  . ; MAPPING DIRECTIONS
    287  . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
    288  . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
    289  . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
    290  . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
    291  . ; N MDZ1,MDZNA
    292  . N DIRCNT S DIRCNT=""
    293  . I +$O(@MAP@("M","DIRECTIONS",DIRCNT)) D  ; IF THERE ARE DIRCTIONS
    294  . . F DIRCNT=$O(@MAP@("M","DIRECTIONS",DIRCNT)) D  ; FOR EACH DIRECTION
    295  . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",DIRCNT))
    296  . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
    297  . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
    298  . D:MEDCNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
    299  . D:MEDCNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
    300  . S MEDCOUNT=MEDCNT
    301  N MEDTMP,MEDI
    302  D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
    303  I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
    304  . W "MEDICATION MISSING ",!
    305  . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
    306  Q
    307  ;
    308 GETRXN(NDC) ; Extrinsic Function; PUBLIC; NDC to RxNorm
    309  ;; Get RxNorm Concept Number for a Given NDC
    310  ;
    311  S NDC=$TR(NDC,"-")  ; Remove dashes
    312  N RXNORM,C0CZRXN,DIERR
    313  D FIND^DIC(176.002,,"@;.01","PX",NDC,"*","NDC",,,"C0CZRXN","DIERR")
    314  I $D(DIERR) D ^%ZTER BREAK
    315  S RXNORM(0)=+C0CZRXN("DILIST",0) ; RxNorm(0) will be # of entries
    316  N I S I=0
    317  F  S I=$O(C0CZRXN("DILIST",I)) Q:I=""  S RXNORM(I)=$P(C0CZRXN("DILIST",I,0),U,2)
    318  ; At this point, RxNorm(0) is # of entries; RxNorm(1...) are the entries
    319  ; If RxNorm(0) is 1, then we only have one entry, and that's it.
    320  I RXNORM(0)=1 QUIT RXNORM(1)  ; RETURN RXNORM(1)
    321  ; Otherwise, we need to find out which one is the semantic
    322  ; clinical drug. I built an index on 176.001 (RxNorm Concepts)
    323  ; for that purpose.
    324  I RXNORM(0)>1 D
    325  . S I=0
    326  . F  S I=$O(RXNORM(I)) Q:I=""  D  Q:$G(RXNORM)
    327  . . N RXNIEN S RXNIEN=$$FIND1^DIC(176.001,,,RXNORM(I),"SCD")
    328  . . I +$G(RXNIEN)=0 QUIT  ; try the next entry...
    329  . . E  S RXNORM=RXNORM(I) QUIT  ; We found the right code
    330  QUIT +$G(RXNORM)  ; RETURN RXNORM; if we couldn't find a clnical drug, return with 0
    331  
     1C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     4        ; General Public License See attached copy of the License.
     5        ;
     6        ; This program is free software; you can redistribute it and/or modify
     7        ; it under the terms of the GNU General Public License as published by
     8        ; the Free Software Foundation; either version 2 of the License, or
     9        ; (at your option) any later version.
     10        ;
     11        ; This program is distributed in the hope that it will be useful,
     12        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ; GNU General Public License for more details.
     15        ;
     16        ; You should have received a copy of the GNU General Public License along
     17        ; with this program; if not, write to the Free Software Foundation, Inc.,
     18        ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        W "NO ENTRY FROM TOP",!
     21        Q
     22        ;
     23EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS)        ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
     24        ;
     25        ; MINXML and OUTXML are passed by name so globals can be used
     26        ; MINXML will contain only the medications skeleton of the overall template
     27        ; MEDCOUNT is a counter passed by Reference.
     28        ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool)
     29        ; FLAGS are set-up in C0CMED.
     30        ;
     31        ; MEDS is return array from RPC.
     32        ; MAP is a mapping variable map (store result) for each med
     33        ; MED is holds each array element from MEDS(J), one medicine
     34        ; J is a counter.
     35        ;
     36        ; GETRXS^BEHORXFN(ARRAYNAME,DFN,DAYS) will be the the API used.
     37        ; This API has been developed by Medsphere for IHS for getting
     38        ; Medications from RPMS. It has most of what we need.
     39        ; API written by Doug Martin when he worked for Medsphere (thanks Doug!)
     40        ; -- ARRAYNAME is passed by name (required)
     41        ; -- DFN is passed by value (required)
     42        ; -- DAYS is passed by value (optional; if not passed defaults to 365)
     43        ;
     44        ; Return:
     45        ; ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID
     46        ; ^Status^LastFill^Chronic^Issued^Rx #^Provider^
     47        ; Status Reason^DEA Handling
     48        ;
     49        N MEDS,MEDS1,MAP
     50        D GETRXS^BEHORXFN("MEDS1",DFN,$P($P(FLAGS,U,2),"-",2)) ; 2nd piece of FLAGS is # of days to retrieve, which comes in the form "T-360"
     51        N ALL S ALL=+FLAGS
     52        N ACTIVE S ACTIVE=$P(FLAGS,U,3)
     53        N PENDING S PENDING=$P(FLAGS,U,4)
     54        S @OUTXML@(0)=0  ;By default, no meds
     55        ; If MEDS1 is not defined, then no meds
     56        I '$D(MEDS1) QUIT
     57        I DEBUG ZWR MEDS1,MINXML
     58        N MEDCNT S MEDCNT=0 ; Med Count
     59        ; The next line is a super line. It goes through the array return
     60        ; and if the first characters are ~OP, it grabs the line.
     61        ; This means that line is for a dispensed Outpatient Med.
     62        ; That line has the metadata about the med that I need.
     63        ; The next lines, however many, are the med and the sig.
     64        ; I won't be using those because I have to get the sig parsed exactly.
     65        N J S J="" F  S J=$O(MEDS1(J)) Q:J=""  I $E(MEDS1(J),1,3)="~OP" S MEDCNT=MEDCNT+1 S MEDS(MEDCNT)=MEDS1(J)
     66        K MEDS1
     67        S MEDCNT="" ; Initialize for $Order
     68        F  S MEDCNT=$O(MEDS(MEDCNT)) Q:MEDCNT=""  D  ; for each medication in the list
     69        . I 'ALL,ACTIVE,$P(MEDS(MEDCNT),U,10)'="ACTIVE" QUIT
     70        . I 'ALL,PENDING,$P(MEDS(MEDCNT),U,10)'="PENDING" QUIT
     71        . I DEBUG W "MEDCNT IS ",MEDCNT,!
     72        . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCNT))
     73        . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED
     74        . I DEBUG W "MAP= ",MAP,!
     75        . S @MAP@("MEDOBJECTID")="MED"_MEDCNT ; MEDCNT FOR ID
     76        . S @MAP@("MEDISSUEDATETXT")="Issue Date"
     77        . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,15),"DT")
     78        . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date"
     79        . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,11),"DT")
     80        . S @MAP@("MEDRXNOTXT")="Prescription Number"
     81        . S @MAP@("MEDRXNO")=$P(MEDS(MEDCNT),U,14)
     82        . S @MAP@("MEDTYPETEXT")="Medication"
     83        . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
     84        . S @MAP@("MEDSTATUSTEXT")=$P(MEDS(MEDCNT),U,10)
     85        . ; Provider only provided in API as text, not DUZ.
     86        . ; We need to get DUZ from filman file 52 (Prescription)
     87        . ; Field 4; IEN is Piece 2 of Meds stripped of trailing characters.
     88        . ; Note that I will use RXIEN several times later
     89        . N RXIEN S RXIEN=+$P(MEDS(MEDCNT),U,2)
     90        . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52,RXIEN,4,"I")
     91        . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MEDS(MEDCNT),U,3)
     92        . ; --- RxNorm Stuff
     93        . ; 176.001 is the file for Concepts; 176.003 is the file for
     94        . ; sources (i.e. for RxNorm Version)
     95        . ;
     96        . ; I use 176.001 for the Vista version of this routine (files 1-3)
     97        . ; Since IHS does not have VUID's, I will be getting RxNorm codes
     98        . ; using NDCs. My specially crafted index (sounds evil) named "NDC"
     99        . ; is in file 176.002. The file is called RxNorm NDC to VUID.
     100        . ; Except that I don't need the VUID, but it's there if I need it.
     101        . ;
     102        . ; We obviously need the NDC. That is easily obtained from the prescription.
     103        . ; Field 27 in file 52
     104        . N NDC S NDC=$$GET1^DIQ(52,RXIEN,27,"I")
     105        . ; I discovered that file 176.002 might give you two codes for the NDC
     106        . ; One for the Clinical Drug, and one for the ingredient.
     107        . ; So the plan is to get the two RxNorm codes, and then find from
     108        . ; file 176.001 which one is the Clinical Drug.
     109        . ; ... I refactored this into GETRXN
     110        . N RXNORM,SRCIEN,RXNNAME,RXNVER
     111        . I +NDC,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
     112        . . S RXNORM=$$GETRXN(NDC)
     113        . . S SRCIEN=$$FIND1^DIC(176.003,,,"RXNORM","B")
     114        . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
     115        . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
     116        . ;
     117        . E  S (RXNORM,RXNNAME,RXNVER)=""
     118        . ; End if/else block
     119        . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
     120        . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
     121        . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
     122        . ; --- End RxNorm section
     123        . ;
     124        . ; Brand name is 52 field 6.5
     125        . S @MAP@("MEDBRANDNAMETEXT")=$$GET1^DIQ(52,RXIEN,6.5)
     126        . ;
     127        . ; Next I need Med Form (tab, cap etc), strength (250mg)
     128        . ; concentration for liquids (250mg/mL)
     129        . ; Since IHS does not have any of the new calls that
     130        . ; Vista has, I will be doing a crosswalk:
     131        . ; File 52, field 6 is Drug IEN in file 50
     132        . ; File 50, field 22 is VA Product IEN in file 50.68
     133        . ; In file 50.68, I will get the following:
     134        . ; -- 1: Dosage Form
     135        . ; -- 2: Strength
     136        . ; -- 3: Units
     137        . ; -- 8: Dispense Units
     138        . ; -- Conc is 2 concatenated with 3
     139        . ;
     140        . ; *** If Drug is not matched to NDF, then VA Product will be "" ***
     141        . ;
     142        . N MEDIEN S MEDIEN=$$GET1^DIQ(52,RXIEN,6,"I") ; Drug IEN in 50
     143        . N VAPROD S VAPROD=$$GET1^DIQ(50,MEDIEN,22,"I") ; VA Product in file 50.68
     144        . I +VAPROD D
     145        . . S @MAP@("MEDSTRENGTHVALUE")=$$GET1^DIQ(50.68,VAPROD,2)
     146        . . S @MAP@("MEDSTRENGTHUNIT")=$$GET1^DIQ(50.68,VAPROD,3)
     147        . . S @MAP@("MEDFORMTEXT")=$$GET1^DIQ(50.68,VAPROD,1)
     148        . . S @MAP@("MEDCONCVALUE")=@MAP@("MEDSTRENGTHVALUE")
     149        . . S @MAP@("MEDCONCUNIT")=@MAP@("MEDSTRENGTHUNIT")
     150        . E  D
     151        . . S @MAP@("MEDSTRENGTHVALUE")=""
     152        . . S @MAP@("MEDSTRENGTHUNIT")=""
     153        . . S @MAP@("MEDFORMTEXT")=""
     154        . . S @MAP@("MEDCONCVALUE")=""
     155        . . S @MAP@("MEDCONCUNIT")=""
     156        . ; End Strengh/Conc stuff
     157        . ;
     158        . ; Quantity is in the prescription, field 7
     159        . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52,RXIEN,7)
     160        . ; Dispense unit is in the drug file, field 14.5
     161        . S @MAP@("MEDQUANTITYUNIT")=$$GET1^DIQ(50,MEDIEN,14.5)
     162        . ;
     163        . ; --- START OF DIRECTIONS ---
     164        . ; Sig data not in any API :-(  Oh yes, you can get the whole thing, but...
     165        . ; we want the components.
     166        . ; It's in multiple 113 in the Prescription File (52)
     167        . ; #.01 DOSAGE ORDERED [1F]    "20"
     168        . ; #1 DISPENSE UNITS PER DOSE [2N]  "1"
     169        . ; #2 UNITS [3P:50.607]     "MG"
     170        . ; #3 NOUN [4F]      "TABLET"
     171        . ; #4 DURATION [5F]      "10D"
     172        . ; #5 CONJUNCTION [6S]     "AND"
     173        . ; #6 ROUTE [7P:51.2]     "ORAL"
     174        . ; #7 SCHEDULE [8F]      "BID"
     175        . ; #8 VERB [9F]       "TAKE"
     176        . ;
     177        . ; Will use GETS^DIQ to get fields.
     178        . ; Data comes out like this:
     179        . ; SAMINS(52.0113,"1,23,",.01)=20
     180        . ; SAMINS(52.0113,"1,23,",1)=1
     181        . ; SAMINS(52.0113,"1,23,",2)="MG"
     182        . ; SAMINS(52.0113,"1,23,",3)="TABLET"
     183        . ; SAMINS(52.0113,"1,23,",4)="5D"
     184        . ; SAMINS(52.0113,"1,23,",5)="THEN"
     185        . ;
     186        . N RAWDATA
     187        . D GETS^DIQ(52,RXIEN,"113*",,"RAWDATA","DIERR")
     188        . D:$D(DIERR) ^%ZTER  ; Log if there's an error in retrieving sig field
     189        . ; none the less, continue; some parts are retrievable.
     190        . N FMSIG M FMSIG=RAWDATA(52.0113) ; Merge into subfile...
     191        . K RAWDATA
     192        . N FMSIGNUM S FMSIGNUM="" ; Sigline number in fileman.
     193        . ; FMSIGNUM gets outputted as "IEN,RXIEN,".
     194        . ; DIRCNT is the proper Sigline numer.
     195        . ; SIGDATA is the simplfied array.
     196        . F  S FMSIGNUM=$O(FMSIG(FMSIGNUM)) Q:FMSIGNUM=""  D
     197        . . N DIRCNT S DIRCNT=$P(FMSIGNUM,",")
     198        . . N SIGDATA M SIGDATA=FMSIG(FMSIGNUM)
     199        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")=""  ; This is reserved for systems not able to generate the sig in components.
     200        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1"  ; means that we are specifying it. See E2369-05.
     201        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$G(SIGDATA(8))
     202        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$G(SIGDATA(.01))
     203        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=$G(SIGDATA(2))
     204        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")=""  ; For inpatient
     205        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")=""  ; For inpatient
     206        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")=""  ; For inpatient
     207        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$G(SIGDATA(6))
     208        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$G(SIGDATA(7))
     209        . . ; Invervals... again another call.
     210        . . ; In the wisdom of the original programmers, the schedule is a free text field
     211        . . ; However, it gets translated by a call to the administration schedule file
     212        . . ; to see if that schedule exists.
     213        . . ; That's the same thing I am going to do.
     214        . . ; Search B index of 51.1 (Admin Schedule) with schedule
     215        . . ; First, remove "PRN" if it exists (don't ask, that's how the file
     216        . . ; works; I wouldn't do it that way).
     217        . . N SCHNOPRN S SCHNOPRN=$G(SIGDATA(7))
     218        . . I SCHNOPRN["PRN" S SCHNOPRN=$E(SCHNOPRN,1,$F(SCHNOPRN,"PRN")-5)
     219        . . ; Super call below:
     220        . . ; 1=File 51.1 3=Field 2 (Frequency in Minutes)
     221        . . ; 4=Packed format, Exact Match 5=Lookup Value
     222        . . ; 6=# of entries to return 7=Index 10=Return Array
     223        . . ;
     224        . . ; I do not account for the fact that two schedules can be
     225        . . ; spelled identically (ie duplicate entry). In that case,
     226        . . ; I get the first. That's just a bad pharmacy pkg maintainer.
     227        . . N C0C515
     228        . . D FIND^DIC(51.1,,"@;2","PX",SCHNOPRN,1,"B",,,"C0C515")
     229        . . N INTERVAL S INTERVAL="" ; Default
     230        . . ; If there are entries found, get it
     231        . . I +$G(C0C515("DILIST",0)) S INTERVAL=$P(C0C515("DILIST",1,0),U,2)
     232        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
     233        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
     234        . . ; Duration is 10M minutes, 10H hours, 10D for Days
     235        . . ; 10W for weeks, 10L for months. I smell $Select
     236        . . ; But we don't need to do that if there isn't a duration
     237        . . I +$G(SIGDATA(4)) D
     238        . . . N DURUNIT S DURUNIT=$E(SIGDATA(4),$L(SIGDATA(4))) ; get last char
     239        . . . N DURTXT S DURTXT=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"Days")
     240        . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=+SIGDATA(4)
     241        . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=DURTXT
     242        . . E  D
     243        . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=""
     244        . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=""
     245        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$G(SIGDATA(4))["PRN"
     246        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" ; when avail
     247        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")=""
     248        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")=""
     249        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")=""
     250        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")=""
     251        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")=""
     252        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")=""
     253        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; not stored
     254        . . ; Another confusing line; I am pretty bad:
     255        . . ; If there is another entry in the FMSIG array (i.e. another line
     256        . . ; in the sig), set the direction count indicator.
     257        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=""  ; Default
     258        . . S:+$O(FMSIG(FMSIGNUM)) @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRCNT
     259        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$G(SIGDATA(5))
     260        . ;
     261        . ; --- END OF DIRECTIONS ---
     262        . ;
     263        . ; Med instructions is a WP field, thus the acrobatics
     264        . ; Notice buffer overflow protection set at 10,000 chars
     265        . ; -- 1. Med Patient Instructions
     266        . N MEDPTIN1 S MEDPTIN1=$$GET1^DIQ(52,RXIEN,115,,"MEDPTIN1")
     267        . N MEDPTIN2,J  S (MEDPTIN2,J)=""
     268        . I $L(MEDPTIN1) F  S J=$O(@MEDPTIN1@(J)) Q:J=""  Q:$L(MEDPTIN2)>10000  S MEDPTIN2=MEDPTIN2_@MEDPTIN1@(J)_" "
     269        . S @MAP@("MEDPTINSTRUCTIONS")=MEDPTIN2
     270        . K J
     271        . ; -- 2. Med Provider Instructions
     272        . N MEDPVIN1 S MEDPVIN1=$$GET1^DIQ(52,RXIEN,39,,"MEDPVIN1")
     273        . N MEDPVIN2,J S (MEDPVIN2,J)=""
     274        . I $L(MEDPVIN1) F  S J=$O(@MEDPVIN1@(J)) Q:J=""  Q:$L(MEDPVIN2)>10000  S MEDPVIN2=MEDPVIN2_@MEDPVIN1@(J)_" "
     275        . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MEDPVIN2
     276        . ;
     277        . ; Remaining refills
     278        . S @MAP@("MEDRFNO")=$P(MEDS(MEDCNT),U,6)
     279        . ; ------ END OF MAPPING
     280        . ;
     281        . ; ------ BEGIN XML INSERTION
     282        . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
     283        . K @RESULT
     284        . D MAP^C0CXPATH(MINXML,MAP,RESULT)
     285        . ; D PARY^C0CXPATH(RESULT)
     286        . ; MAPPING DIRECTIONS
     287        . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
     288        . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
     289        . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
     290        . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
     291        . ; N MDZ1,MDZNA
     292        . N DIRCNT S DIRCNT=""
     293        . I +$O(@MAP@("M","DIRECTIONS",DIRCNT)) D  ; IF THERE ARE DIRCTIONS
     294        . . F DIRCNT=$O(@MAP@("M","DIRECTIONS",DIRCNT)) D  ; FOR EACH DIRECTION
     295        . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",DIRCNT))
     296        . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
     297        . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
     298        . D:MEDCNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
     299        . D:MEDCNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
     300        . S MEDCOUNT=MEDCNT
     301        N MEDTMP,MEDI
     302        D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
     303        I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
     304        . W "MEDICATION MISSING ",!
     305        . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
     306        Q
     307        ;
     308GETRXN(NDC)     ; Extrinsic Function; PUBLIC; NDC to RxNorm
     309        ;; Get RxNorm Concept Number for a Given NDC
     310        ;
     311        S NDC=$TR(NDC,"-")  ; Remove dashes
     312        N RXNORM,C0CZRXN,DIERR
     313        D FIND^DIC(176.002,,"@;.01","PX",NDC,"*","NDC",,,"C0CZRXN","DIERR")
     314        I $D(DIERR) D ^%ZTER BREAK
     315        S RXNORM(0)=+C0CZRXN("DILIST",0) ; RxNorm(0) will be # of entries
     316        N I S I=0
     317        F  S I=$O(C0CZRXN("DILIST",I)) Q:I=""  S RXNORM(I)=$P(C0CZRXN("DILIST",I,0),U,2)
     318        ; At this point, RxNorm(0) is # of entries; RxNorm(1...) are the entries
     319        ; If RxNorm(0) is 1, then we only have one entry, and that's it.
     320        I RXNORM(0)=1 QUIT RXNORM(1)  ; RETURN RXNORM(1)
     321        ; Otherwise, we need to find out which one is the semantic
     322        ; clinical drug. I built an index on 176.001 (RxNorm Concepts)
     323        ; for that purpose.
     324        I RXNORM(0)>1 D
     325        . S I=0
     326        . F  S I=$O(RXNORM(I)) Q:I=""  D  Q:$G(RXNORM)
     327        . . N RXNIEN S RXNIEN=$$FIND1^DIC(176.001,,,RXNORM(I),"SCD")
     328        . . I +$G(RXNIEN)=0 QUIT  ; try the next entry...
     329        . . E  S RXNORM=RXNORM(I) QUIT  ; We found the right code
     330        QUIT +$G(RXNORM)  ; RETURN RXNORM; if we couldn't find a clnical drug, return with 0
     331       

  • ccr/branches/ohum/p/C0CMIME.m

    r1342 r1428  
    1 C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm
    2  ;;1.0;C0C;;Mar 8, 2011;Build 2
    3  ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  Q
    21  ;
    22 TEST(ZDFN) ;
    23  D CCRRPC^C0CCCR(.ZCCR,ZDFN) ; GET A CCR TO WORK WITH
    24  ;M ZCOPY=ZCCR
    25  S ZCOPY(1)=""
    26  N ZI S ZI=0
    27  F  S ZI=$O(ZCCR(ZI)) Q:ZI=""  D  ; FOR EACH LINE
    28  . S ZCOPY(1)=ZCOPY(1)_ZCCR(ZI)
    29  ;D ENCODE("ZCOPY",1,ZCOPY(1))
    30  S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
    31  D CHUNK("G2","G",45)
    32  Q
    33 ENCODE(ZRTN,ZARY) ;
    34  ; ROUTINE TO ENCODE AN XML DOCUMENT FOR SENDING
    35  ; ZARY IS PASSED BY NAME
    36  ; ZRTN IS PASSED BY REFERENCE AND IS THE RETURN
    37  ;
    38  S ZCOPY(1)=""
    39  N ZI S ZI=0
    40  F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH LINE
    41  . S ZCOPY(1)=ZCOPY(1)_@ZARY@(ZI)
    42  N G
    43  S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
    44  D CHUNK(ZRTN,"G",45)
    45  Q
    46  ; THIS ROUTINE WAS COPIED FROM LRSRVR4 AND THEN MODIFIED . THANKS JOHN
    47 ENCODEOLD(IARY,LRNODE,LRSTR) ; Encode a string, keep remainder for next line
    48  ; Call with LRSTR by reference, Remainder returned in LRSTR
    49  ; IARY IS PASSED BY NAME
    50  S LRQUIT=0,LRLEN=$L(LRSTR)
    51  F  D  Q:LRQUIT
    52  . I $L(LRSTR)<45 S LRQUIT=1 Q
    53  . S LRX=$E(LRSTR,1,45)
    54  . S LRNODE=LRNODE+1,@IARY@(LRNODE)=$$UUEN^LRSRVR4(LRX)
    55  . S LRSTR=$E(LRSTR,46,LRLEN)
    56  Q
    57  ;
    58 TESTMAIL ;
    59  ; TEST OF MAILSEND
    60  ;S ZTO("glilly@glilly.net")=""
    61  S ZTO("mish@nhin.openforum.opensourcevista.net")=""
    62  ;S ZTO("martijn@djigzo.com")=""
    63  ;S ZTO("profmish@gmail.com")=""
    64  ;S ZTO("nanthracite@earthlink.net")=""
    65  S ZFROM="ANTHRACITE.NANCY"
    66  S ZATTACH=$NA(^GPL("CCR"))
    67  I $G(@ZATTACH@(1))="" D  ; NO CCR THERE
    68  . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
    69  . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
    70  S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
    71  D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,,ZATTACH)
    72  ZWR GR
    73  Q
    74  ;
    75 TESTMAIL2 ;
    76  ; TEST OF MAILSEND TO gpl.mdc-crew.net
    77  N C0CGM
    78  S C0CGM(1)="This is a test message."
    79  S C0CGM(2)="A Continuity of Care record is attached"
    80  S C0CGM(3)="It contains no Protected Health Information (PHI)"
    81  S C0CGM(4)="It is purely test data used for software development"
    82  S C0CGM(5)="It does not represent information about any person living or dead"
    83  ;S ZTO("glilly@glilly.net")=""
    84  ;S ZTO("george.lilly@pobox.com")=""
    85  ;S ZTO("george@nhin.openforum.opensourcevista.net")=""
    86  ;S ZTO("mish@nhin.openforum.opensourcevista.net")=""
    87  S ZTO("brooks.richard@securemail.opensourcevista.net")=""
    88  ;S ZTO("LILLY.GEORGE@mdc-crew.net")=""
    89  ;S ZTO("ncoal@live.com")=""
    90  ;S ZTO("martijn@djigzo.com")=""
    91  ;S ZTO("profmish@gmail.com")=""
    92  ;S ZTO("nanthracite@earthlink.net")=""
    93  S ZTO("gpl.doctortest@gmail.com")=""
    94  S ZFROM="LILLY.GEORGE"
    95  S ZATTACH=$NA(^GPL("CCR"))
    96  I $G(@ZATTACH@(1))="" D  ; NO CCR THERE
    97  . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
    98  . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
    99  S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
    100  D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH,"CCR.xml")
    101  ZWR GR
    102  Q
    103  ;
    104 LINE(C0CFILE,C0CTO) ; read a file name passed in C0CFILE and send it to
    105  ; the email address in C0CTO
    106  ; the directory and the "from" are all hard coded
    107  ;
    108  N ZZFROM S ZZFROM="LILLY.GEORGE"
    109  N GN S GN=$NA(^TMP("C0CMIME2",$J))
    110  N GN1 S GN1=$NA(@GN@(1))
    111  K @GN
    112  I '$D(C0CFILE) Q  ; NO FILENAME PASSED
    113  I '$D(C0CTO) S C0CTO="brooks.richard@securemail.opensourcevista.net"
    114  S ZZTO(C0CTO)=""
    115  N ZMESS S ZMESS(1)="file transmission from wvehr3-09"
    116  N GD S GD="/home/wvehr3-09/EHR/" ; directory
    117  I '$$FTG^%ZISH(GD,C0CFILE,GN1,3) Q  D  ;
    118  . W !,"error reading file",C0CFILE
    119  D MAILSEND(.ZRTN,ZZFROM,"ZZTO",,"file transmission","ZMESS",GN,C0CFILE)
    120  K @GN ; CLEAN UP
    121  ;ZWR ZRTN
    122  W !,$G(ZRTN(1))
    123  Q
    124  ;
    125 MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FNAME,FLAGS) ; MAIL SENDING INTERFACE
    126  ; RTN IS THE RETURN ARRAY PASSED BY REFERENCE
    127  ; FROM IS PASSED BY VALUE AND IS THE EMAIL ADDRESS OF THE SENDER
    128  ;  IF NULL, WILL SEND FROM THE CURRENT DUZ
    129  ; TO AND CC ARE RECIEPIENT EMAIL ADDRESSES PASSED BY NAME
    130  ;  @TO@("addr1@domain1.net")
    131  ;  @CC@("addr2@domain2.com")  both can be multiples
    132  ; SUBJECT IS PASSED BY VALUE AND WILL GO IN THE SUBJECT LINE
    133  ; MESSAGE IS PASSED BY NAME AND IS AN ARRAY OF TEXT
    134  ; ATTACH IS PASSED BY NAME AND IS AN XML OR HTML FILE TO BE ATTACHED
    135  ; FNAME IS THE FILENAME OF THE ATTACHMENT, DEFAULT IS ccr.xml
    136  ;
    137  I '$D(FNAME) S FNAME="ccr.xml" ; default filename
    138  N GN
    139  S GN=$NA(^TMP($J,"C0CMIME"))
    140  K @GN
    141  S GM(1)="MIME-Version: 1.0"
    142  S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
    143  S GM(3)=""
    144  S GM(4)=""
    145  ;S GM(5)="--123456788888"
    146  ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
    147  S GM(5)="--123456899999"
    148  S GM(6)="Content-Type: text/xml; name="_FNAME
    149  S GM(7)="Content-Transfer-Encoding: base64"
    150  S GM(8)="Content-Disposition: attachment; filename="_FNAME
    151  S GM(9)=""
    152  S GM(10)="" ; FOR THE END
    153  ;S GM(11)="--123456788888--"
    154  S GM(11)="--123456899999--"
    155  S GM(12)=""
    156  S GM(13)=""
    157  S GG(1)="--123456899999"
    158  S GG(2)="Content-Type: text/plain; charset=ISO-8859-1; format=flowed"
    159  S GG(3)="Content-Transfer-Encoding: 7bit"
    160  S GG(4)=""
    161  S GG(5)="This is a test message."
    162  S GG(6)="A Continuity of Care record is attached"
    163  S GG(7)="It contains no Protected Health Information (PHI)"
    164  S GG(8)="It is purely test data used for software development"
    165  S GG(9)="It does not represent information about any person living or dead"
    166  S GG(10)=""
    167  S GG(11)="--123456899999--"
    168  ;S GG(11)="Content-Type: text/plain; charset=""us-ascii"""
    169  S GG(12)=""
    170  ;S GG(13)="This is a test message."
    171  S GG(14)="A Continuity of Care record is attached"
    172  S GG(15)="It contains no Protected Health Information (PHI)"
    173  S GG(16)="It is purely test data used for software development"
    174  S GG(17)="It does not represent information about any person living or dead"
    175  S GG(18)=""
    176  S GG(19)="--123456899999"
    177  S GG(20)="--987654321--"
    178  K GBLD
    179  ;D QUEUE^C0CXPATH("GBLD","GGG",1,3) ; THE MESSAGE
    180  ;D QUEUE^C0CXPATH("GBLD","GG",1,10) ; THE MESSAGE
    181  I $D(MESSAGE)'="" D  ; THERE IS A MESSAGE
    182  . D QUEUE^C0CXPATH("GBLD","GG",1,4) ; THE MIME BOUNDARY
    183  . D QUEUE^C0CXPATH("GBLD",MESSAGE,1,$O(@MESSAGE@(""),-1)) ;THE MESSAGE
    184  . D QUEUE^C0CXPATH("GBLD","GG",10,10) ;A BLANK LINE
    185  D QUEUE^C0CXPATH("GBLD","GM",5,9)
    186  I $D(ATTACH)'="" D  ; IF WE HAVE AN ATTACHMENT
    187  . D ENCODE("G2",ATTACH) ; ENCODE FOR SENDING
    188  . D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
    189  D QUEUE^C0CXPATH("GBLD","GM",11,12)
    190  D BUILD^C0CXPATH("GBLD",GN)
    191  ;S GGG=$NA(^GPL("MIME2"))
    192  K @GN@(0) ; KILL THE LINE COUNT
    193  K LRINSTR,LRTASK,LRTO,XMERR,XMZ
    194  M LRTO=@TO
    195  I $D(CC) M LRTO=@CC
    196  S LRINSTR("ADDR FLAGS")="R"
    197  S LRINSTR("FROM")=$G(FROM)
    198  S LRMSUBJ=$G(SUBJECT)
    199  S LRMSUBJ=$E(LRMSUBJ,1,65)
    200  D SENDMSG^XMXAPI(DUZ,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
    201  I $G(XMERR)=1 S RTN(1)="ERROR SENDING MESSAGE" Q  ;
    202  S RTN(1)="OK"
    203  Q
    204  ;
    205 MAILSEND0(LRMSUBJ) ; Send extract back to requestor.
    206  ;
    207  ;D TEST
    208  S GN=$NA(^TMP($J,"C0CMIME"))
    209  K @GN
    210  ;M @GN=G2
    211  S GM(1)="MIME-Version: 1.0"
    212  S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
    213  S GM(3)=""
    214  S GM(4)=""
    215  S GM(5)="--1234567"
    216  ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
    217  S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
    218  S GM(7)="Content-Transfer-Encoding: base64"
    219  S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
    220  ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
    221  S GM(9)=""
    222  S GM(10)="" ; FOR THE END
    223  S GM(11)="--frontier--"
    224  S GM(12)="."
    225  S GM(13)=""
    226  K GBLD
    227  ;D QUEUE^C0CXPATH("GBLD","GM",1,9)
    228  ;D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
    229  ;D QUEUE^C0CXPATH("GBLD","GM",10,13)
    230  ;D BUILD^C0CXPATH("GBLD",GN)
    231  S GGG=$NA(^GPL("MIME2"))
    232  ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
    233  D QUEUE^C0CXPATH("GBLD",GGG,21,159)
    234  D BUILD^C0CXPATH("GBLD",GN)
    235  K @GN@(0) ; KILL THE LINE COUNT
    236  K LRINSTR,LRTASK,LRTO,XMERR,XMZ
    237  S XQSND="glilly@glilly.net"
    238  ;S XQSND="nanthracite@earthlink.net"
    239  ;S XQSND="dlefevre@orohosp.com"
    240  ;S XQSND="gregwoodhouse@me.com"
    241  ;S XQSND="rick.marshall@vistaexpertise.net"
    242  S LRTO(XQSND)=""
    243  S LRINSTR("ADDR FLAGS")="R"
    244  S LRINSTR("FROM")="CCR_PACKAGE"
    245  S LRMSUBJ="A SAMPLE CCR"
    246  S LRMSUBJ=$E(LRMSUBJ,1,65)
    247  D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
    248  I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q  ;
    249  ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
    250  ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
    251  Q
    252  ;
    253 MAILSEND2(UDFN,ADDR) ; Send extract back to requestor.
    254  ;
    255  I +$G(UDFN)=0 S UDFN=2 ;
    256  D TEST(UDFN)
    257  S GN=$NA(^TMP($J,"C0CMIME"))
    258  K @GN
    259  ;M @GN=G2
    260  S GM(1)="MIME-Version: 1.0"
    261  S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
    262  S GM(3)=""
    263  S GM(4)=""
    264  S GM(5)="--1234567"
    265  ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
    266  S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
    267  S GM(7)="Content-Transfer-Encoding: base64"
    268  S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
    269  ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
    270  S GM(9)=""
    271  S GM(10)="" ; FOR THE END
    272  S GM(11)="--1234567--"
    273  S GM(12)=""
    274  S GM(13)=""
    275  K GBLD
    276  D QUEUE^C0CXPATH("GBLD","GM",5,9)
    277  D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
    278  D QUEUE^C0CXPATH("GBLD","GM",10,12)
    279  D BUILD^C0CXPATH("GBLD",GN)
    280  S GGG=$NA(^GPL("MIME2"))
    281  ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
    282  ;D QUEUE^C0CXPATH("GBLD",GGG,21,159)
    283  ;D BUILD^C0CXPATH("GBLD",GN)
    284  K @GN@(0) ; KILL THE LINE COUNT
    285  K LRINSTR,LRTASK,LRTO,XMERR,XMZ
    286  I $G(ADDR)'="" S XQSND=ADDR
    287  E  S XQSND="glilly@glilly.net"
    288  ;S XQSND="nanthracite@earthlink.net"
    289  ;S XQSND="dlefevre@orohosp.com"
    290  ;S XQSND="gregwoodhouse@me.com"
    291  ;S XQSND="rick.marshall@vistaexpertise.net"
    292  S LRTO(XQSND)=""
    293  ;S LRTO("glilly@glilly.net")=""
    294  S LRINSTR("ADDR FLAGS")="R"
    295  S LRINSTR("FROM")="ANTHRACITE.NANCY"
    296  S LRMSUBJ="Sending a CCR with Mailman"
    297  S LRMSUBJ=$E(LRMSUBJ,1,65)
    298  D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
    299  I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q  ;
    300  ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
    301  ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
    302  Q
    303  ;
    304 SIMPLE ;
    305  S GN(1)="SIMPLE TEST MESSAGE"
    306  K LRINSTR,LRTASK,LRTO,XMERR,XMZ
    307  S XQSND="glilly@glilly.net"
    308  S LRTO(XQSND)=""
    309  S LRINSTR("ADDR FLAGS")="R"
    310  S LRINSTR("FROM")="CCR_PACKAGE"
    311  S LRMSUBJ="A SAMPLE CCR"
    312  S LRMSUBJ=$E(LRMSUBJ,1,65)
    313  D SENDMSG^XMXAPI(9,LRMSUBJ,"GN",.LRTO,.LRINSTR,.LRTASK)
    314  Q
    315 CHUNK(OUTXML,INXML,ZSIZE) ; BREAKS INXML INTO ZSIZE BLOCKS
    316  ; INXML IS AN ARRAY PASSED BY NAME OF STRINGS
    317  ; OUTXML IS ALSO PASSED BY NAME
    318  ; IF ZSIZE IS NOT PASSED, 1000 IS USED
    319  I '$D(ZSIZE) S ZSIZE=1000 ; DEFAULT BLOCK SIZE
    320  N ZB,ZI,ZJ,ZK,ZL,ZN
    321  S ZB=ZSIZE-1
    322  S ZN=1
    323  S ZI=0 ; BEGINNING OF INDEX TO INXML
    324  F  S ZI=$O(@INXML@(ZI)) Q:+ZI=0  D  ; FOR EACH STRING IN INXML
    325  . S ZL=$L(@INXML@(ZI)) ; LENGTH OF THE STRING
    326  . F ZJ=1:ZSIZE:ZL D  ;
    327  . . S ZK=$S(ZJ+ZB<ZL:ZJ+ZB,1:ZL) ; END FOR EXTRACT
    328  . . S @OUTXML@(ZN)=$E(@INXML@(ZI),ZJ,ZK) ; PULL OUT THE PIECE
    329  . . S ZN=ZN+1 ; INCREMENT OUT ARRAY INDEX
    330  Q
    331  ;
    332 CLEAN(IARY) ; RUNS THROUGH AN ARRAY PASSED BY NAME AND STRIPS OUT $C(13)
    333  ;
    334  N ZI S ZI=0
    335  F  S ZI=$O(@IARY@(ZI)) Q:+ZI=0  D  ;
    336  . S @IARY@(ZI)=$TR(@IARY@(ZI),$C(13)) ;
    337  . I $F(@IARY@(ZI)," <") S @IARY@(ZI)="<"_$P(@IARY@(ZI)," <",2) ; RM BLNKS
    338  Q
    339  ;
     1C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        Q
     21        ;
     22TEST(ZDFN)      ;
     23        D CCRRPC^C0CCCR(.ZCCR,ZDFN) ; GET A CCR TO WORK WITH
     24        ;M ZCOPY=ZCCR
     25        S ZCOPY(1)=""
     26        N ZI S ZI=0
     27        F  S ZI=$O(ZCCR(ZI)) Q:ZI=""  D  ; FOR EACH LINE
     28        . S ZCOPY(1)=ZCOPY(1)_ZCCR(ZI)
     29        ;D ENCODE("ZCOPY",1,ZCOPY(1))
     30        S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
     31        D CHUNK("G2","G",45)
     32        Q
     33ENCODE(ZRTN,ZARY)       ;
     34        ; ROUTINE TO ENCODE AN XML DOCUMENT FOR SENDING
     35        ; ZARY IS PASSED BY NAME
     36        ; ZRTN IS PASSED BY REFERENCE AND IS THE RETURN
     37        ;
     38        S ZCOPY(1)=""
     39        N ZI S ZI=0
     40        F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH LINE
     41        . S ZCOPY(1)=ZCOPY(1)_@ZARY@(ZI)
     42        N G
     43        S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
     44        D CHUNK(ZRTN,"G",45)
     45        Q
     46        ; THIS ROUTINE WAS COPIED FROM LRSRVR4 AND THEN MODIFIED . THANKS JOHN
     47ENCODEOLD(IARY,LRNODE,LRSTR)    ; Encode a string, keep remainder for next line
     48        ; Call with LRSTR by reference, Remainder returned in LRSTR
     49        ; IARY IS PASSED BY NAME
     50        S LRQUIT=0,LRLEN=$L(LRSTR)
     51        F  D  Q:LRQUIT
     52        . I $L(LRSTR)<45 S LRQUIT=1 Q
     53        . S LRX=$E(LRSTR,1,45)
     54        . S LRNODE=LRNODE+1,@IARY@(LRNODE)=$$UUEN^LRSRVR4(LRX)
     55        . S LRSTR=$E(LRSTR,46,LRLEN)
     56        Q
     57        ;
     58TESTMAIL        ;
     59        ; TEST OF MAILSEND
     60        ;S ZTO("glilly@glilly.net")=""
     61        S ZTO("mish@nhin.openforum.opensourcevista.net")=""
     62        ;S ZTO("martijn@djigzo.com")=""
     63        ;S ZTO("profmish@gmail.com")=""
     64        ;S ZTO("nanthracite@earthlink.net")=""
     65        S ZFROM="ANTHRACITE.NANCY"
     66        S ZATTACH=$NA(^GPL("CCR"))
     67        I $G(@ZATTACH@(1))="" D  ; NO CCR THERE
     68        . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
     69        . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
     70        S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
     71        D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,,ZATTACH)
     72        ZWR GR
     73        Q
     74        ;
     75TESTMAIL2       ;
     76        ; TEST OF MAILSEND TO gpl.mdc-crew.net
     77        N C0CGM
     78        S C0CGM(1)="This is a test message."
     79        S C0CGM(2)="A Continuity of Care record is attached"
     80        S C0CGM(3)="It contains no Protected Health Information (PHI)"
     81        S C0CGM(4)="It is purely test data used for software development"
     82        S C0CGM(5)="It does not represent information about any person living or dead"
     83        ;S ZTO("glilly@glilly.net")=""
     84        ;S ZTO("george.lilly@pobox.com")=""
     85        ;S ZTO("george@nhin.openforum.opensourcevista.net")=""
     86        ;S ZTO("mish@nhin.openforum.opensourcevista.net")=""
     87        S ZTO("brooks.richard@securemail.opensourcevista.net")=""
     88        ;S ZTO("LILLY.GEORGE@mdc-crew.net")=""
     89        ;S ZTO("ncoal@live.com")=""
     90        ;S ZTO("martijn@djigzo.com")=""
     91        ;S ZTO("profmish@gmail.com")=""
     92        ;S ZTO("nanthracite@earthlink.net")=""
     93        S ZTO("gpl.doctortest@gmail.com")=""
     94        S ZFROM="LILLY.GEORGE"
     95        S ZATTACH=$NA(^GPL("CCR"))
     96        I $G(@ZATTACH@(1))="" D  ; NO CCR THERE
     97        . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
     98        . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
     99        S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
     100        D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH,"CCR.xml")
     101        ZWR GR
     102        Q
     103        ;
     104LINE(C0CFILE,C0CTO)     ; read a file name passed in C0CFILE and send it to
     105        ; the email address in C0CTO
     106        ; the directory and the "from" are all hard coded
     107        ;
     108        N ZZFROM S ZZFROM="LILLY.GEORGE"
     109        N GN S GN=$NA(^TMP("C0CMIME2",$J))
     110        N GN1 S GN1=$NA(@GN@(1))
     111        K @GN
     112        I '$D(C0CFILE) Q  ; NO FILENAME PASSED
     113        I '$D(C0CTO) S C0CTO="brooks.richard@securemail.opensourcevista.net"
     114        S ZZTO(C0CTO)=""
     115        N ZMESS S ZMESS(1)="file transmission from wvehr3-09"
     116        N GD S GD="/home/wvehr3-09/EHR/" ; directory
     117        I '$$FTG^%ZISH(GD,C0CFILE,GN1,3) Q  D  ;
     118        . W !,"error reading file",C0CFILE
     119        D MAILSEND(.ZRTN,ZZFROM,"ZZTO",,"file transmission","ZMESS",GN,C0CFILE)
     120        K @GN ; CLEAN UP
     121        ;ZWR ZRTN
     122        W !,$G(ZRTN(1))
     123        Q
     124        ;
     125MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FNAME,FLAGS)     ; MAIL SENDING INTERFACE
     126        ; RTN IS THE RETURN ARRAY PASSED BY REFERENCE
     127        ; FROM IS PASSED BY VALUE AND IS THE EMAIL ADDRESS OF THE SENDER
     128        ;  IF NULL, WILL SEND FROM THE CURRENT DUZ
     129        ; TO AND CC ARE RECIEPIENT EMAIL ADDRESSES PASSED BY NAME
     130        ;  @TO@("addr1@domain1.net")
     131        ;  @CC@("addr2@domain2.com")  both can be multiples
     132        ; SUBJECT IS PASSED BY VALUE AND WILL GO IN THE SUBJECT LINE
     133        ; MESSAGE IS PASSED BY NAME AND IS AN ARRAY OF TEXT
     134        ; ATTACH IS PASSED BY NAME AND IS AN XML OR HTML FILE TO BE ATTACHED
     135        ; FNAME IS THE FILENAME OF THE ATTACHMENT, DEFAULT IS ccr.xml
     136        ;
     137        I '$D(FNAME) S FNAME="ccr.xml" ; default filename
     138        N GN
     139        S GN=$NA(^TMP($J,"C0CMIME"))
     140        K @GN
     141        S GM(1)="MIME-Version: 1.0"
     142        S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
     143        S GM(3)=""
     144        S GM(4)=""
     145        ;S GM(5)="--123456788888"
     146        ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
     147        S GM(5)="--123456899999"
     148        S GM(6)="Content-Type: text/xml; name="_FNAME
     149        S GM(7)="Content-Transfer-Encoding: base64"
     150        S GM(8)="Content-Disposition: attachment; filename="_FNAME
     151        S GM(9)=""
     152        S GM(10)="" ; FOR THE END
     153        ;S GM(11)="--123456788888--"
     154        S GM(11)="--123456899999--"
     155        S GM(12)=""
     156        S GM(13)=""
     157        S GG(1)="--123456899999"
     158        S GG(2)="Content-Type: text/plain; charset=ISO-8859-1; format=flowed"
     159        S GG(3)="Content-Transfer-Encoding: 7bit"
     160        S GG(4)=""
     161        S GG(5)="This is a test message."
     162        S GG(6)="A Continuity of Care record is attached"
     163        S GG(7)="It contains no Protected Health Information (PHI)"
     164        S GG(8)="It is purely test data used for software development"
     165        S GG(9)="It does not represent information about any person living or dead"
     166        S GG(10)=""
     167        S GG(11)="--123456899999--"
     168        ;S GG(11)="Content-Type: text/plain; charset=""us-ascii"""
     169        S GG(12)=""
     170        ;S GG(13)="This is a test message."
     171        S GG(14)="A Continuity of Care record is attached"
     172        S GG(15)="It contains no Protected Health Information (PHI)"
     173        S GG(16)="It is purely test data used for software development"
     174        S GG(17)="It does not represent information about any person living or dead"
     175        S GG(18)=""
     176        S GG(19)="--123456899999"
     177        S GG(20)="--987654321--"
     178        K GBLD
     179        ;D QUEUE^C0CXPATH("GBLD","GGG",1,3) ; THE MESSAGE
     180        ;D QUEUE^C0CXPATH("GBLD","GG",1,10) ; THE MESSAGE
     181        I $D(MESSAGE)'="" D  ; THERE IS A MESSAGE
     182        . D QUEUE^C0CXPATH("GBLD","GG",1,4) ; THE MIME BOUNDARY
     183        . D QUEUE^C0CXPATH("GBLD",MESSAGE,1,$O(@MESSAGE@(""),-1)) ;THE MESSAGE
     184        . D QUEUE^C0CXPATH("GBLD","GG",10,10) ;A BLANK LINE
     185        D QUEUE^C0CXPATH("GBLD","GM",5,9)
     186        I $D(ATTACH)'="" D  ; IF WE HAVE AN ATTACHMENT
     187        . D ENCODE("G2",ATTACH) ; ENCODE FOR SENDING
     188        . D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
     189        D QUEUE^C0CXPATH("GBLD","GM",11,12)
     190        D BUILD^C0CXPATH("GBLD",GN)
     191        ;S GGG=$NA(^GPL("MIME2"))
     192        K @GN@(0) ; KILL THE LINE COUNT
     193        K LRINSTR,LRTASK,LRTO,XMERR,XMZ
     194        M LRTO=@TO
     195        I $D(CC) M LRTO=@CC
     196        S LRINSTR("ADDR FLAGS")="R"
     197        S LRINSTR("FROM")=$G(FROM)
     198        S LRMSUBJ=$G(SUBJECT)
     199        S LRMSUBJ=$E(LRMSUBJ,1,65)
     200        D SENDMSG^XMXAPI(DUZ,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
     201        I $G(XMERR)=1 S RTN(1)="ERROR SENDING MESSAGE" Q  ;
     202        S RTN(1)="OK"
     203        Q
     204        ;
     205MAILSEND0(LRMSUBJ)      ; Send extract back to requestor.
     206        ;
     207        ;D TEST
     208        S GN=$NA(^TMP($J,"C0CMIME"))
     209        K @GN
     210        ;M @GN=G2
     211        S GM(1)="MIME-Version: 1.0"
     212        S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
     213        S GM(3)=""
     214        S GM(4)=""
     215        S GM(5)="--1234567"
     216        ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
     217        S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
     218        S GM(7)="Content-Transfer-Encoding: base64"
     219        S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
     220        ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
     221        S GM(9)=""
     222        S GM(10)="" ; FOR THE END
     223        S GM(11)="--frontier--"
     224        S GM(12)="."
     225        S GM(13)=""
     226        K GBLD
     227        ;D QUEUE^C0CXPATH("GBLD","GM",1,9)
     228        ;D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
     229        ;D QUEUE^C0CXPATH("GBLD","GM",10,13)
     230        ;D BUILD^C0CXPATH("GBLD",GN)
     231        S GGG=$NA(^GPL("MIME2"))
     232        ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
     233        D QUEUE^C0CXPATH("GBLD",GGG,21,159)
     234        D BUILD^C0CXPATH("GBLD",GN)
     235        K @GN@(0) ; KILL THE LINE COUNT
     236        K LRINSTR,LRTASK,LRTO,XMERR,XMZ
     237        S XQSND="glilly@glilly.net"
     238        ;S XQSND="nanthracite@earthlink.net"
     239        ;S XQSND="dlefevre@orohosp.com"
     240        ;S XQSND="gregwoodhouse@me.com"
     241        ;S XQSND="rick.marshall@vistaexpertise.net"
     242        S LRTO(XQSND)=""
     243        S LRINSTR("ADDR FLAGS")="R"
     244        S LRINSTR("FROM")="CCR_PACKAGE"
     245        S LRMSUBJ="A SAMPLE CCR"
     246        S LRMSUBJ=$E(LRMSUBJ,1,65)
     247        D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
     248        I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q  ;
     249        ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
     250        ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
     251        Q
     252        ;
     253MAILSEND2(UDFN,ADDR)    ; Send extract back to requestor.
     254        ;
     255        I +$G(UDFN)=0 S UDFN=2 ;
     256        D TEST(UDFN)
     257        S GN=$NA(^TMP($J,"C0CMIME"))
     258        K @GN
     259        ;M @GN=G2
     260        S GM(1)="MIME-Version: 1.0"
     261        S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
     262        S GM(3)=""
     263        S GM(4)=""
     264        S GM(5)="--1234567"
     265        ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
     266        S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
     267        S GM(7)="Content-Transfer-Encoding: base64"
     268        S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
     269        ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
     270        S GM(9)=""
     271        S GM(10)="" ; FOR THE END
     272        S GM(11)="--1234567--"
     273        S GM(12)=""
     274        S GM(13)=""
     275        K GBLD
     276        D QUEUE^C0CXPATH("GBLD","GM",5,9)
     277        D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
     278        D QUEUE^C0CXPATH("GBLD","GM",10,12)
     279        D BUILD^C0CXPATH("GBLD",GN)
     280        S GGG=$NA(^GPL("MIME2"))
     281        ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
     282        ;D QUEUE^C0CXPATH("GBLD",GGG,21,159)
     283        ;D BUILD^C0CXPATH("GBLD",GN)
     284        K @GN@(0) ; KILL THE LINE COUNT
     285        K LRINSTR,LRTASK,LRTO,XMERR,XMZ
     286        I $G(ADDR)'="" S XQSND=ADDR
     287        E  S XQSND="glilly@glilly.net"
     288        ;S XQSND="nanthracite@earthlink.net"
     289        ;S XQSND="dlefevre@orohosp.com"
     290        ;S XQSND="gregwoodhouse@me.com"
     291        ;S XQSND="rick.marshall@vistaexpertise.net"
     292        S LRTO(XQSND)=""
     293        ;S LRTO("glilly@glilly.net")=""
     294        S LRINSTR("ADDR FLAGS")="R"
     295        S LRINSTR("FROM")="ANTHRACITE.NANCY"
     296        S LRMSUBJ="Sending a CCR with Mailman"
     297        S LRMSUBJ=$E(LRMSUBJ,1,65)
     298        D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
     299        I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q  ;
     300        ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
     301        ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
     302        Q
     303        ;
     304SIMPLE  ;
     305        S GN(1)="SIMPLE TEST MESSAGE"
     306        K LRINSTR,LRTASK,LRTO,XMERR,XMZ
     307        S XQSND="glilly@glilly.net"
     308        S LRTO(XQSND)=""
     309        S LRINSTR("ADDR FLAGS")="R"
     310        S LRINSTR("FROM")="CCR_PACKAGE"
     311        S LRMSUBJ="A SAMPLE CCR"
     312        S LRMSUBJ=$E(LRMSUBJ,1,65)
     313        D SENDMSG^XMXAPI(9,LRMSUBJ,"GN",.LRTO,.LRINSTR,.LRTASK)
     314        Q
     315CHUNK(OUTXML,INXML,ZSIZE)       ; BREAKS INXML INTO ZSIZE BLOCKS
     316        ; INXML IS AN ARRAY PASSED BY NAME OF STRINGS
     317        ; OUTXML IS ALSO PASSED BY NAME
     318        ; IF ZSIZE IS NOT PASSED, 1000 IS USED
     319        I '$D(ZSIZE) S ZSIZE=1000 ; DEFAULT BLOCK SIZE
     320        N ZB,ZI,ZJ,ZK,ZL,ZN
     321        S ZB=ZSIZE-1
     322        S ZN=1
     323        S ZI=0 ; BEGINNING OF INDEX TO INXML
     324        F  S ZI=$O(@INXML@(ZI)) Q:+ZI=0  D  ; FOR EACH STRING IN INXML
     325        . S ZL=$L(@INXML@(ZI)) ; LENGTH OF THE STRING
     326        . F ZJ=1:ZSIZE:ZL D  ;
     327        . . S ZK=$S(ZJ+ZB<ZL:ZJ+ZB,1:ZL) ; END FOR EXTRACT
     328        . . S @OUTXML@(ZN)=$E(@INXML@(ZI),ZJ,ZK) ; PULL OUT THE PIECE
     329        . . S ZN=ZN+1 ; INCREMENT OUT ARRAY INDEX
     330        Q
     331        ;
     332CLEAN(IARY)     ; RUNS THROUGH AN ARRAY PASSED BY NAME AND STRIPS OUT $C(13)
     333        ;
     334        N ZI S ZI=0
     335        F  S ZI=$O(@IARY@(ZI)) Q:+ZI=0  D  ;
     336        . S @IARY@(ZI)=$TR(@IARY@(ZI),$C(13)) ;
     337        . I $F(@IARY@(ZI)," <") S @IARY@(ZI)="<"_$P(@IARY@(ZI)," <",2) ; RM BLNKS
     338        Q
     339        ;

  • ccr/branches/ohum/p/C0CMXML.m

    r1342 r1428  
    1 C0CMXML   ; GPL - MXML based XPath utilities;10/13/09  17:05
    2  ;;0.1;C0C;nopatch;noreleasedate;Build 2
    3  ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  Q
    21  ; THIS FILE CONTAINS THE XPATH CREATOR, THE PARSE CALL TO THE MXML PARSER
    22  ; AND THE OUTXML XML GENERATOR THAT OUTPUTS XML FROM AN MXML DOM
    23  ; FOR CCD SPECIFIC ROUTINES, SEE C0CMCCD
    24  ; FOR TEMPLATE FILE RELATED ROUTINES, SEE C0CMXP
    25  ;
    26 TEST ;
    27  S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
    28  K GARY
    29  W $$FTG^%ZISH("/home/vademo2/EHR/p/","mxml-test.xml",$NA(@C0CXMLIN@(1)),3)
    30  S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DocID: ",C0CDOCID
    31  S REDUX="//ContinuityOfCareRecord/Body"
    32  D XPATH(1,"/","GIDX","GARY",,REDUX)
    33  D SEPARATE^C0CMCCD("GARY2","GARY")
    34  S ZI=""
    35  F  S ZI=$O(GARY2(ZI)) Q:ZI=""  D  ;
    36  . N GTMP,G2
    37  . M G2=GARY2(ZI)
    38  . D DEMUX2^C0CMXP("GTMP","G2",2)
    39  . M GARY3(ZI)=GTMP
    40  Q
    41  ;
    42 TEST2 ;
    43  S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail"
    44  D XPATH(1,"/","GIDX","GARY","",REDUX)
    45  Q
    46  ;
    47 TEST3 
    48  S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
    49  K GARY,GTMP,GIDX
    50  K @C0CXMLIN
    51  W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3)
    52  D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS
    53  K @C0CXMLIN
    54  M @C0CXMLIN=GTMP
    55  K GTMP
    56  D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN)
    57  K @C0CXMLIN
    58  M @C0CXMLIN=GTMP
    59  K GTMP
    60  S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID
    61  S REDUX="//ClinicalDocument/component/structuredBody"
    62  D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS
    63  D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS
    64  D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS
    65  D XPATH(1,"/","GIDX","GARY",,REDUX)
    66  K C0CCBK("TAG")
    67  D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING
    68  D TEST3A
    69  Q
    70  ;
    71 TEST3A ; INTERNAL ROUTINE
    72  S ZI=""
    73  F  S ZI=$O(GARY2(ZI)) Q:ZI=""  D  ;
    74  . N GTMP,G2
    75  . M G2=GARY2(ZI)
    76  . D DEMUX2^C0CMXP("GTMP","G2",2)
    77  . M GARY4(ZI)=GTMP
    78  Q
    79  ;
    80 TESTQ ; TEST OF THE QRDA TEMPLATE GPL 7/8/2010
    81  S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
    82  K GARY,GTMP,GIDX
    83  K @C0CXMLIN
    84  W $$FTG^%ZISH("/home/vademo2/","QRDA_CategoryI_WorldVistA1.xml",$NA(@C0CXMLIN@(1)),3)
    85  D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS
    86  K @C0CXMLIN
    87  S GTMP(1)="<"_$P(GTMP(1),"<",2)
    88  M @C0CXMLIN=GTMP
    89  K GTMP
    90  D TESTQ2
    91  Q
    92  ;
    93 TESTQ2 ; SECOND PART OF TESTQ
    94  D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN)
    95  K @C0CXMLIN
    96  M @C0CXMLIN=GTMP
    97  K GTMP
    98  S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID
    99  S REDUX="//ClinicalDocument/component/structuredBody"
    100  D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS
    101  D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS
    102  D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS
    103  D XPATH(1,"/","GIDX","GARY",,REDUX)
    104  K C0CCBK("TAG")
    105  D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING
    106  D TEST3A
    107  Q
    108  ;
    109 TEST4 ; TEST OF OUTPUTING AN XML FILE FROM THE DOM .. this one is the CCR
    110  ;
    111  D TEST ; SET UP THE DOM
    112  D START^C0CMXMLB($$TAG(1),,"G")
    113  D NDOUT($$FIRST(1))
    114  D END^C0CMXMLB ;END THE DOCUMENT
    115  M ZCCR=^TMP("MXMLBLD",$J)
    116  ZWR ZCCR
    117  Q
    118  ;
    119 TEST5 ; SAME AS TEST4, BUT THIS TIME THE CCD
    120  S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
    121  K GARY,GTMP,GIDX
    122  K @C0CXMLIN
    123  W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3)
    124  D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS
    125  K @C0CXMLIN
    126  M @C0CXMLIN=GTMP
    127  K GTMP
    128  D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN)
    129  K @C0CXMLIN
    130  M @C0CXMLIN=GTMP
    131  K GTMP
    132  S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DOCID: ",C0CDOCID  ;CALL REGULAR PARSER
    133  ;D XPATH(1,"/","GIDX2","GARY2",,REDUX)
    134  D OUTXML("ZCCD",C0CDOCID)
    135  ;D START^C0CMXMLB($$TAG(1),,"G")
    136  ;D NDOUT($$FIRST(1))
    137  ;D END^C0CMXMLB ;EOND THE DOCUMENT
    138  ;M ZCCD=^TMP("MXMLBLD",$J)
    139  ZWR ZCCD(1:30)
    140  Q
    141  ;
    142 XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE
    143  ; THE XPATH INDEX ZXIDX, PASSED BY NAME
    144  ; THE XPATH ARRAY XPARY, PASSED BY NAME
    145  ; ZOID IS THE STARTING OID
    146  ; ZPATH IS THE STARTING XPATH, USUALLY "/"
    147  ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
    148  ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
    149  I $G(ZREDUX)="" S ZREDUX=""
    150  N NEWPATH
    151  N NEWNUM S NEWNUM=""
    152  I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
    153  S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
    154  I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
    155  . N GT S GT=$P(NEWPATH,ZREDUX,2)
    156  . I GT'="" S NEWPATH=GT
    157  S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
    158  N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
    159  I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
    160  E  I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
    161  N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
    162  I ZFRST'=0 D  ; THERE IS A CHILD
    163  . N ZNUM
    164  . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
    165  . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD
    166  N GNXT S GNXT=$$NXTSIB(ZOID)
    167  I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES
    168  I GNXT'=0 D  ;
    169  . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE?
    170  . I (ZNUM="")&(ZMULT) D  ; SIBLING IS FIRST OF MULTIPLES
    171  . . N ZNUM S ZNUM=1 ;
    172  . . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
    173  . E  D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB
    174  Q
    175  ;
    176 PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME
    177  ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW
    178  ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML
    179  ;Q $$EN^MXMLDOM(INXML)
    180  Q $$EN^MXMLDOM(INXML,"W")
    181  ;
    182 ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
    183  N ZN
    184  ;I $$TAG(ZOID)["entry" B
    185  S ZN=$$NXTSIB(ZOID)
    186  I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
    187  Q 0
    188  ;
    189 FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
    190  Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
    191  ;
    192 PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID
    193  Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
    194  ;
    195 ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID
    196  S HANDLE=C0CDOCID
    197  K @RTN
    198  D GETTXT^MXMLDOM("A")
    199  Q
    200  ;
    201 TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE
    202  ;I ZOID=149 B ;GPLTEST
    203  N X,Y
    204  S Y=""
    205  S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
    206  I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
    207  I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
    208  Q Y
    209  ;
    210 NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING
    211  Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
    212  ;
    213 DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE
    214  ;N ZT,ZN S ZT=""
    215  ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
    216  ;Q $G(@C0CDOM@(ZOID,"T",1))
    217  S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
    218  Q
    219  ;
    220 OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM
    221  ;
    222  S C0CDOCID=INID
    223  D START^C0CMXMLB($$TAG(1),,"G")
    224  D NDOUT($$FIRST(1))
    225  D END^C0CMXMLB ;END THE DOCUMENT
    226  M @ZRTN=^TMP("MXMLBLD",$J)
    227  K ^TMP("MXMLBLD",$J)
    228  Q
    229  ;
    230 NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE
    231  N ZI S ZI=$$FIRST(ZOID)
    232  I ZI'=0 D  ; THERE IS A CHILD
    233  . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT
    234  . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN
    235  E  D  ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT
    236  . ;W "DOING",ZOID,!
    237  . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA
    238  . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES
    239  . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN
    240  I $$NXTSIB(ZOID)'=0 D  ; THERE IS A SIBLING
    241  . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS
    242  Q
    243  ;
    244 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
    245  K ZERR
    246  D CLEAN^DILF
    247  D UPDATE^DIE("","C0CFDA","","ZERR")
    248  I $D(ZERR) D  ;
    249  . W "ERROR",!
    250  . ZWR ZERR
    251  . B
    252  K C0CFDA
    253  Q
    254  ;
     1C0CMXML   ; GPL - MXML based XPath utilities;10/13/09  17:05
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        Q
     21        ; THIS FILE CONTAINS THE XPATH CREATOR, THE PARSE CALL TO THE MXML PARSER
     22        ; AND THE OUTXML XML GENERATOR THAT OUTPUTS XML FROM AN MXML DOM
     23        ; FOR CCD SPECIFIC ROUTINES, SEE C0CMCCD
     24        ; FOR TEMPLATE FILE RELATED ROUTINES, SEE C0CMXP
     25        ;
     26TEST    ;
     27        S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
     28        K GARY
     29        W $$FTG^%ZISH("/home/vademo2/EHR/p/","mxml-test.xml",$NA(@C0CXMLIN@(1)),3)
     30        S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DocID: ",C0CDOCID
     31        S REDUX="//ContinuityOfCareRecord/Body"
     32        D XPATH(1,"/","GIDX","GARY",,REDUX)
     33        D SEPARATE^C0CMCCD("GARY2","GARY")
     34        S ZI=""
     35        F  S ZI=$O(GARY2(ZI)) Q:ZI=""  D  ;
     36        . N GTMP,G2
     37        . M G2=GARY2(ZI)
     38        . D DEMUX2^C0CMXP("GTMP","G2",2)
     39        . M GARY3(ZI)=GTMP
     40        Q
     41        ;
     42TEST2   ;
     43        S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail"
     44        D XPATH(1,"/","GIDX","GARY","",REDUX)
     45        Q
     46        ;
     47TEST3   
     48        S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
     49        K GARY,GTMP,GIDX
     50        K @C0CXMLIN
     51        W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3)
     52        D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS
     53        K @C0CXMLIN
     54        M @C0CXMLIN=GTMP
     55        K GTMP
     56        D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN)
     57        K @C0CXMLIN
     58        M @C0CXMLIN=GTMP
     59        K GTMP
     60        S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID
     61        S REDUX="//ClinicalDocument/component/structuredBody"
     62        D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS
     63        D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS
     64        D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS
     65        D XPATH(1,"/","GIDX","GARY",,REDUX)
     66        K C0CCBK("TAG")
     67        D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING
     68        D TEST3A
     69        Q
     70        ;
     71TEST3A  ; INTERNAL ROUTINE
     72        S ZI=""
     73        F  S ZI=$O(GARY2(ZI)) Q:ZI=""  D  ;
     74        . N GTMP,G2
     75        . M G2=GARY2(ZI)
     76        . D DEMUX2^C0CMXP("GTMP","G2",2)
     77        . M GARY4(ZI)=GTMP
     78        Q
     79        ;
     80TESTQ   ; TEST OF THE QRDA TEMPLATE GPL 7/8/2010
     81        S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
     82        K GARY,GTMP,GIDX
     83        K @C0CXMLIN
     84        W $$FTG^%ZISH("/home/vademo2/","QRDA_CategoryI_WorldVistA1.xml",$NA(@C0CXMLIN@(1)),3)
     85        D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS
     86        K @C0CXMLIN
     87        S GTMP(1)="<"_$P(GTMP(1),"<",2)
     88        M @C0CXMLIN=GTMP
     89        K GTMP
     90        D TESTQ2
     91        Q
     92        ;
     93TESTQ2  ; SECOND PART OF TESTQ
     94        D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN)
     95        K @C0CXMLIN
     96        M @C0CXMLIN=GTMP
     97        K GTMP
     98        S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID
     99        S REDUX="//ClinicalDocument/component/structuredBody"
     100        D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS
     101        D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS
     102        D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS
     103        D XPATH(1,"/","GIDX","GARY",,REDUX)
     104        K C0CCBK("TAG")
     105        D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING
     106        D TEST3A
     107        Q
     108        ;
     109TEST4   ; TEST OF OUTPUTING AN XML FILE FROM THE DOM .. this one is the CCR
     110        ;
     111        D TEST ; SET UP THE DOM
     112        D START^C0CMXMLB($$TAG(1),,"G")
     113        D NDOUT($$FIRST(1))
     114        D END^C0CMXMLB ;END THE DOCUMENT
     115        M ZCCR=^TMP("MXMLBLD",$J)
     116        ZWR ZCCR
     117        Q
     118        ;
     119TEST5   ; SAME AS TEST4, BUT THIS TIME THE CCD
     120        S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
     121        K GARY,GTMP,GIDX
     122        K @C0CXMLIN
     123        W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3)
     124        D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS
     125        K @C0CXMLIN
     126        M @C0CXMLIN=GTMP
     127        K GTMP
     128        D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN)
     129        K @C0CXMLIN
     130        M @C0CXMLIN=GTMP
     131        K GTMP
     132        S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DOCID: ",C0CDOCID  ;CALL REGULAR PARSER
     133        ;D XPATH(1,"/","GIDX2","GARY2",,REDUX)
     134        D OUTXML("ZCCD",C0CDOCID)
     135        ;D START^C0CMXMLB($$TAG(1),,"G")
     136        ;D NDOUT($$FIRST(1))
     137        ;D END^C0CMXMLB ;EOND THE DOCUMENT
     138        ;M ZCCD=^TMP("MXMLBLD",$J)
     139        ZWR ZCCD(1:30)
     140        Q
     141        ;
     142XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX)      ; RECURSIVE ROUTINE TO POPULATE
     143        ; THE XPATH INDEX ZXIDX, PASSED BY NAME
     144        ; THE XPATH ARRAY XPARY, PASSED BY NAME
     145        ; ZOID IS THE STARTING OID
     146        ; ZPATH IS THE STARTING XPATH, USUALLY "/"
     147        ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
     148        ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
     149        I $G(ZREDUX)="" S ZREDUX=""
     150        N NEWPATH
     151        N NEWNUM S NEWNUM=""
     152        I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
     153        S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
     154        I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
     155        . N GT S GT=$P(NEWPATH,ZREDUX,2)
     156        . I GT'="" S NEWPATH=GT
     157        S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
     158        N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
     159        I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
     160        E  I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
     161        N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
     162        I ZFRST'=0 D  ; THERE IS A CHILD
     163        . N ZNUM
     164        . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
     165        . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD
     166        N GNXT S GNXT=$$NXTSIB(ZOID)
     167        I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES
     168        I GNXT'=0 D  ;
     169        . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE?
     170        . I (ZNUM="")&(ZMULT) D  ; SIBLING IS FIRST OF MULTIPLES
     171        . . N ZNUM S ZNUM=1 ;
     172        . . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
     173        . E  D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB
     174        Q
     175        ;
     176PARSE(INXML,INDOC)      ;CALL THE MXML PARSER ON INXML, PASSED BY NAME
     177        ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW
     178        ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML
     179        ;Q $$EN^MXMLDOM(INXML)
     180        Q $$EN^MXMLDOM(INXML,"W")
     181        ;
     182ISMULT(ZOID)    ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
     183        N ZN
     184        ;I $$TAG(ZOID)["entry" B
     185        S ZN=$$NXTSIB(ZOID)
     186        I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
     187        Q 0
     188        ;
     189FIRST(ZOID)     ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
     190        Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
     191        ;
     192PARENT(ZOID)    ;RETURNS THE OID OF THE PARENT OF ZOID
     193        Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
     194        ;
     195ATT(RTN,NODE)   ;GET ATTRIBUTES FOR ZOID
     196        S HANDLE=C0CDOCID
     197        K @RTN
     198        D GETTXT^MXMLDOM("A")
     199        Q
     200        ;
     201TAG(ZOID)       ; RETURNS THE XML TAG FOR THE NODE
     202        ;I ZOID=149 B ;GPLTEST
     203        N X,Y
     204        S Y=""
     205        S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
     206        I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
     207        I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
     208        Q Y
     209        ;
     210NXTSIB(ZOID)    ; RETURNS THE NEXT SIBLING
     211        Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
     212        ;
     213DATA(ZT,ZOID)   ; RETURNS DATA FOR THE NODE
     214        ;N ZT,ZN S ZT=""
     215        ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
     216        ;Q $G(@C0CDOM@(ZOID,"T",1))
     217        S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
     218        Q
     219        ;
     220OUTXML(ZRTN,INID)       ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM
     221        ;
     222        S C0CDOCID=INID
     223        D START^C0CMXMLB($$TAG(1),,"G")
     224        D NDOUT($$FIRST(1))
     225        D END^C0CMXMLB ;END THE DOCUMENT
     226        M @ZRTN=^TMP("MXMLBLD",$J)
     227        K ^TMP("MXMLBLD",$J)
     228        Q
     229        ;
     230NDOUT(ZOID)     ;CALLBACK ROUTINE - IT IS RECURSIVE
     231        N ZI S ZI=$$FIRST(ZOID)
     232        I ZI'=0 D  ; THERE IS A CHILD
     233        . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT
     234        . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN
     235        E  D  ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT
     236        . ;W "DOING",ZOID,!
     237        . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA
     238        . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES
     239        . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN
     240        I $$NXTSIB(ZOID)'=0 D  ; THERE IS A SIBLING
     241        . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS
     242        Q
     243        ;
     244UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
     245        K ZERR
     246        D CLEAN^DILF
     247        D UPDATE^DIE("","C0CFDA","","ZERR")
     248        I $D(ZERR) D  ;
     249        . W "ERROR",!
     250        . ZWR ZERR
     251        . B
     252        K C0CFDA
     253        Q
     254        ;

  • ccr/branches/ohum/p/C0CMXMLB.m

    r1342 r1428  
    1 MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09  16:55
    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"))
     1C0CMXMLB        ;;ISF/RWF - Tool to build XML ; 5/10/12 2:51pm
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     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"))

  • ccr/branches/ohum/p/C0CMXP.m

    r1342 r1428  
    1 C0CMXP   ; GPL - MXML based XPath utilities;12/04/09  17:05
    2  ;;0.1;C0C;nopatch;noreleasedate;Build 2
    3  ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  Q
    21  ;
    22 INITXPF(ARY) ;INITIAL XML/XPATH FILE ARRAY
    23  ; DON'T USE THIS ONE ... USE INITFARY^C0CSOAP("FARY") INSTEAD
    24  D INITFARY^C0CSOAP(ARY) ;
    25  Q
    26  S @ARY@("XML FILE NUMBER")=178.101
    27  S @ARY@("XML SOURCE FIELD")=2.1
    28  S @ARY@("XML TEMPLATE FIELD")=3
    29  S @ARY@("XPATH BINDING SUBFILE")=178.1014
    30  S @ARY@("REDUX FIELD")=2.5
    31  Q
    32  ;
    33 SETXPF(ARY) ; SET FILE AND FIELD VARIABLES FROM XPF ARRAY
    34  ;
    35  S C0CXPF=@ARY@("XML FILE NUMBER")
    36  S C0CXFLD=@ARY@("XML")
    37  S C0CXTFLD=@ARY@("TEMPLATE XML")
    38  S C0CXPBF=@ARY@("BINDING SUBFILE NUMBER")
    39  S C0CRDUXF=@ARY@("XPATH REDUCTION STRING")
    40  Q
    41  ;
    42 ADDXP(INARY,TID,FARY) ;ADD XPATH .01 FIELD TO BINDING SUBFILE OF TEMPLATE TID
    43  I '$D(FARY) D  ;
    44  . S FARY="FARY" ; FILE ARRAY
    45  . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
    46  D SETXPF(FARY) ;SET FILE VARIABLES
    47  N C0CA,C0CB
    48  S C0CA="" S C0CB=0
    49  F  S C0CA=$O(@INARY@(C0CA)) Q:C0CA=""  D  ; FOR EACH XPATH
    50  . S C0CB=C0CB+1 ; COUNT OF XPATHS
    51  . S C0CFDA(C0CXPBF,"?+"_C0CB_","_TID_",",.01)=C0CA
    52  . D UPDIE ; CREATE THE BINDING SUBFILE FOR THIS XPATH
    53  Q
    54  ;
    55 FIXICD9 ; FIX THE ICD9RESULT XML
    56  D GETXML("GPL","ICD9RESULT") ; GET SOME BAD XML OUT OF THE FILE
    57  S ZI=""
    58  S G=""
    59  F  S ZI=$O(GPL(ZI)) Q:ZI=""  D  ; FOR EACH LINE
    60  . S G=G_GPL(ZI) ; MAKE ONE BIG STRING OF XML
    61  D NORMAL^C0CSOAP("G2","G") ;NO NORMALIZE IT BACK INTO AN ARRAY
    62  D ADDXML("G2","ICD9RESULT") ; AND PUT IT BACK
    63  Q
    64 ADDXML(INXML,TEMPID,INFARY) ;ADD XML TO A TEMPLATE ID TEMPID
    65  ; INXML IS PASSED BY NAME
    66  I '$D(INFARY) D  ;
    67  . S INFARY="FARY" ; FILE ARRAY
    68  . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
    69  I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME
    70  D SETXPF(INFARY) ;SET FILE VARIABLES
    71  D WP^DIE(C0CXPF,TEMPID_",",C0CXFLD,,INXML)
    72  Q
    73  ;
    74 ADDTEMP(INXML,TEMPID,INFARY) ;ADD XML TEMPLATE TO TEMPLATE RECORD TEMPID
    75  ;
    76  I '$D(INFARY) D  ;
    77  . S INFARY="FARY" ; FILE ARRAY
    78  . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
    79  I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME
    80  D SETXPF(INFARY) ;SET FILE VARIABLES
    81  D WP^DIE(C0CXPF,TEMPID_",",C0CXTFLD,,INXML)
    82  Q
    83  ;
    84 GETXML(OUTXML,TEMPID,INFARY) ;GET THE XML FROM TEMPLATE TEMPID
    85  ;
    86  I '$D(INFARY) D  ;
    87  . S INFARY="FARY" ; FILE ARRAY
    88  . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
    89  D SETXPF(INFARY) ;SET FILE VARIABLES
    90  I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME
    91  I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXFLD,,OUTXML)'=OUTXML D  Q  ;
    92  . W "ERROR RETRIEVING TEMPLATE",!
    93  Q
    94  ;
    95 GETTEMP(OUTXML,TEMPID,FARY) ;GET THE TEMPLATE XML FROM TEMPLATE TEMPID
    96  ;
    97  I '$D(FARY) D  ;
    98  . S FARY="FARY" ; FILE ARRAY
    99  . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
    100  D SETXPF(FARY) ;SET FILE VARIABLES
    101  I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,FARY) ;RESOLVE TEMPLATE NAME
    102  I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXTFLD,,OUTXML)'=OUTXML D  Q  ;
    103  . W "ERROR RETRIEVING TEMPLATE",!
    104  Q
    105  ;
    106 COPYWP(ZFLD,ZSRCREC,ZDESTREC,ZSRCF,ZDESTF) ; COPIES A WORD PROCESSING FIELD
    107  ; FROM ONE RECORD TO ANOTHER RECORD
    108  ; ZFLD IS EITHER A NUMBERIC FIELD OR A NAME IN ZSRCF
    109  ; ZSRCF IS THE SOURCE FILE, IN FILE REDIRECT FORMAT
    110  ; IF ZSRCF IS OMMITED, THE DEFAULT C0C XML MISC FILE WILL BE ASSUMED
    111  ; ZDESTF IS DESTINATION FILE. IF OMMITED, IS ASSUMED TO BE THE SAME
    112  ; A ZSRCF
    113  I '$D(ZSRCF) D  ;
    114  . S ZSRCF="ZSRCF"
    115  . D INITFARY^C0CSOAP(ZSRCF)
    116  I '$D(ZDESTF) D  ;
    117  . S ZDESTF="ZDESTF"
    118  . M @ZDESTF=@ZSRCF
    119  N ZSF,ZDF,ZSFREF,ZDFREF
    120  S ZSF=@ZSRCF@("XML FILE NUMBER")
    121  S ZSFREF=$$FILEREF^C0CRNF(ZSF)
    122  S ZDF=@ZDESTF@("XML FILE NUMBER")
    123  S ZDFREF=$$FILEREF^C0CRNF(ZDF)
    124  N ZSIEN,ZDIEN
    125  S ZSIEN=$O(@ZSFREF@("B",ZSRCREC,""))
    126  I ZSIEN="" W !,"ERROR SOURCE RECORD NOT FOUND" Q  ;
    127  S ZDIEN=$O(@ZDFREF@("B",ZDESTREC,""))
    128  I ZDIEN="" W !,"ERROR DESTINATION RECORD NOT FOUND" Q  ;
    129  N ZFLDNUM
    130  I +ZFLD=0 S ZFLDNUM=@ZSRCF@(ZFLD) ; IF FIELD IS PASSED BY NAME
    131  E  S ZFLDNUM=ZFLD ; IF FIELD IS PASSED BY NUMBER
    132  N ZWP,ZWPN
    133  S ZWPN=$$GET1^DIQ(ZSF,ZSIEN_",",ZFLDNUM,,"ZWP") ; GET WP FROM SOURCE
    134  I ZWPN'="ZWP" W !,"ERROR SOURCE FIELD EMPTY" Q  ;
    135  D WP^DIE(ZDF,ZDIEN_",",ZFLDNUM,,"ZWP") ; PUT WP FIELD TO DEST
    136  Q
    137  ;
    138 COMPILE(TID,UFARY) ; COMPILES AN XML TEMPLATE AND GENERATES XPATH BINDINGS
    139  ; UFARY IF SPECIFIED WILL REDIRECT THE XML FILE TO USE
    140  ; INTID IS THE IEN OF THE RECORD TO USE IN THE XML FILE
    141  ; XML IS PULLED FROM THE "XML" FIELD AND THE COMPILED RESULT PUT
    142  ; IN THE "XML TEMPLATE" FIELD. ALL XPATHS USED IN THE TEMPLATE
    143  ; WILL BE POPULATED TO THE XPATH BINDINGS SUBFILE AS .01
    144  I '$D(UFARY) D  ;
    145  . S UFARY="DEFFARY" ; FILE ARRAY
    146  . ;D INITXPF("UFARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
    147  . D INITFARY^C0CSOAP(UFARY)
    148  D SETXPF(UFARY) ;SET FILE VARIABLES
    149  I +TID=0 S INTID=$$RESTID^C0CSOAP(TID,UFARY)
    150  E  S INTID=TID
    151  ;B
    152  ;N C0CXML,C0CREDUX,C0CTEMP,C0CIDX
    153  D GETXML("C0CXML",INTID,UFARY)
    154  S C0CREDUX=$$GET1^DIQ(C0CXPF,INTID_",",C0CRDUXF,"E") ;XPATH REDUCTION STRING
    155  D MKTPLATE("C0CTEMP","C0CIDX","C0CXML",C0CREDUX) ; CREATE TEMPLATE AND IDX
    156  D ADDTEMP("C0CTEMP",INTID,UFARY) ; WRITE THE TEMPLATE TO FILE
    157  D ADDXP("C0CIDX",INTID,UFARY) ;CREATE XPATH SUBFILE ENTRIES FOR EVERY XPATH
    158  Q
    159  ;
    160 MKTPLATE(OUTT,OUTIDX,INXML,REDUX) ;MAKE A TEMPLATE FROM INXML, RETURNED IN OUTT
    161  ; BOTH PASSED BY NAME. THE REDUX XPATH REDUCTION STRING IS USED IF PASSED
    162  ; OUTIDX IS AN ARRAY OF THE XPATHS USED IN MAKING THE TEMPLATE
    163  ;
    164  S C0CXLOC=$NA(^TMP("C0CXML",$J))
    165  K @C0CXLOC
    166  M @C0CXLOC=@INXML
    167  S C0CDOCID=$$PARSE^C0CMXML(C0CXLOC,"C0CMKT")
    168  K @C0CXLOC
    169  S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
    170  ;N GIDX,GIDX2,GARY,GARY2
    171  I '$D(REDUX) S REDUX=""
    172  D XPATH^C0CMXML(1,"/","GIDX","GARY",,REDUX)
    173  D INVERT("GIDX2","GIDX") ;MAKE ARRAY TO LOOK UP XPATH BY NODE
    174  N ZI,ZD S ZI=""
    175  F  S ZI=$O(@C0CDOM@(ZI)) Q:ZI=""  D  ; FOR EACH NODE IN THE DOM
    176  . K ZD ;FOR DATA
    177  . D DATA^C0CMXML("ZD",ZI) ;SEE IF THERE IS DATA FOR THIS NODE
    178  . ;I $D(ZD(1)) D  ; IF YES
    179  . I $$FIRST^C0CMXML(ZI)=0 D  ; IF THERE ARE NO CHILDREN TO THIS NODE
    180  . . ;I ZI<3 B  ;W !,ZD(1)
    181  . . K @C0CDOM@(ZI,"T") ; KILL THE DATA
    182  . . N ZXPATH
    183  . . S ZXPATH=$G(GIDX2(ZI)) ;FIND AN XPATH FOR THIS NODE
    184  . . S @C0CDOM@(ZI,"T",1)="@@"_ZXPATH_"@@"
    185  . . I ZXPATH'="" S @OUTIDX@(ZXPATH)="" ; PASS BACK XPATH USED IN IDX
    186  D OUTXML^C0CMXML(OUTT,C0CDOCID)
    187  Q
    188  ;
    189 INVERT(OUTX,INX) ;INVERTS AN XPATH INDEX RETURNING @OUTX@(x)=XPath from
    190  ; @INX@(XPath)=x
    191  N ZI S ZI=""
    192  F  S ZI=$O(@INX@(ZI)) Q:ZI=""  D  ;FOR EACH XPATH IN THE INPUT
    193  . S @OUTX@(@INX@(ZI))=ZI ; SET INVERTED ENTRY
    194  Q
    195  ;
    196 DEMUX(OUTX,INX) ;PARSES XPATH PASSED BY VALUE IN INX TO REMOVE [x] MULTIPLES
    197  ; RETURNS OUTX: MULTIPLE^SUBMULTIPLE^XPATH
    198  N ZX,ZY,ZZ,ZZ1,ZMULT,ZSUB
    199  S (ZMULT,ZSUB)=""
    200  S ZX=$P(INX,"[",2)
    201  I ZX'="" D  ; THERE IS A [x] MULTIPLE
    202  . S ZY=$P(INX,"[",1) ;FIRST PART OF XPATH
    203  . S ZMULT=$P(ZX,"]",1) ; NUMBER OF THE MULTIPLE
    204  . S ZX=ZY_$P(ZX,"]",2) ; REST OF THE XPATH
    205  . I $P(ZX,"[",2)'="" D  ; A SUB MULTIPLE EXISTS
    206  . . S ZZ=$P(ZX,"[",1) ; FIRST PART OF XPATH
    207  . . S ZX=$P(ZX,"[",2) ; DELETE THE [
    208  . . S ZSUB=$P(ZX,"]",1) ; NUMBER OF THE SUBMULTIPLE
    209  . . S ZX=ZZ_$P(ZX,"]",2) ; REST OF THE XPATH
    210  E  S ZX=INX ;NO MULTIPLE HERE
    211  S @OUTX=ZMULT_"^"_ZSUB_"^"_ZX ;RETURN MULTIPLE^SUBMULTIPLE^XPATH
    212  Q
    213  ;
    214 DEMUXARY(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
    215  ; FORMAT @OARY@(x,variablename) where x is the first multiple
    216  ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED
    217  N ZI,ZJ,ZK,ZL,ZM S ZI=""
    218  F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ;
    219  . D DEMUX^C0CMXP("ZJ",ZI)
    220  . S ZK=$P(ZJ,"^",3)
    221  . S ZM=$RE($P($RE(ZK),"/",1))
    222  . I $G(DEPTH)=2 D  ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME
    223  . . S ZM=$RE($P($RE(ZK),"/",2))_ZM
    224  . S ZL=$P(ZJ,"^",1)
    225  . I ZL="" S ZL=1
    226  . I $D(@OARY@(ZL,ZM)) D  ;IT'S A DUP
    227  . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI)
    228  . E  S @OARY@(ZL,ZM)=@IARY@(ZI)
    229  Q
    230  ;
    231 DEMUX2(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
    232  ; FORMAT @OARY@(x,variablename) where x is the first multiple
    233  ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED
    234  N ZI,ZJ,ZK,ZL,ZM S ZI=""
    235  F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ;
    236  . D DEMUX^C0CMXP("ZJ",ZI)
    237  . S ZK=$P(ZJ,"^",3)
    238  . S ZM=$RE($P($RE(ZK),"/",1))
    239  . I $G(DEPTH)=2 D  ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME
    240  . . S ZM=$RE($P($RE(ZK),"/",2))_"."_ZM
    241  . S ZL=$P(ZJ,"^",1)
    242  . I ZL="" S ZL=1
    243  . I $D(@OARY@(ZL,ZM)) D  ;IT'S A DUP
    244  . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI)
    245  . E  S @OARY@(ZL,ZM)=@IARY@(ZI)
    246  Q
    247  ;
    248 DEMUXXP1(OARY,IARY) ;IARY IS INCOMING XPATH ARRAY
    249  ; BOTH IARY AND OARY ARE PASSED BY NAME
    250  ; RETURNS A SIMPLE XPATH ARRAY WITHOUT MULTIPLES. DUPLICATES ARE REMOVED
    251  N ZI,ZJ,ZK
    252  S ZI=""
    253  F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH XPATH IN IARY
    254  . D DEMUX^C0CMXP("ZJ",ZI)
    255  . S ZK=$P(ZJ,"^",3) ;THE XPATH
    256  . S @OARY@(ZK)=@IARY@(ZI) ;THE RESULT. DUPLICATES WILL NOT SHOW
    257  . ; CAUTION, IF THERE ARE MULTIPLES, ONLY THE DATA FOR THE LAST
    258  . ; MULTIPLE WILL BE INCLUDED IN THE OUTPUT ARRAY, ASSIGNED TO THE
    259  . ; COMMON XPATH
    260  Q
    261  ;
    262 DEMUXXP2(OARY,IARY) ; IARY AND OARY ARE PASSED BY NAME
    263  ; IARY IS AN XPATH ARRAY THAT MAY CONTAIN MULTIPLES
    264  ; OARY IS THE OUTPUT ARRAY WHERE MULTIPLES ARE RETURNED IN THE FORM
    265  ; @OARY@(x,Xpath)=data or @OARY@(x,y,Xpath)=data WHERE x AND y ARE
    266  ; THE MULTIPLES AND Xpath IS THE BASE XPATH WITHOUT [x] AND [y]
    267  ;
    268  N ZI,ZJ,ZK,ZX,ZY,ZP
    269  S ZI=""
    270  F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH INPUT XPATH
    271  . D DEMUX("ZJ",ZI) ; PULL OUT THE MULTIPLES
    272  . S ZX=$P(ZJ,"^",1) ;x
    273  . S ZY=$P(ZJ,"^",2) ;y
    274  . S ZP=$P(ZJ,"^",3) ;Xpath
    275  . I ZX="" S ZX=1 ; NO MULTIPLE WILL STORE IN x=1
    276  . I ZY'="" D  ;IS THERE A y?
    277  . . S @OARY@(ZX,ZY,ZP)=@IARY@(ZI)
    278  . E  D  ;NO y
    279  . . S @OARY@(ZX,ZP)=@IARY@(ZI)
    280  Q
    281  ;
    282 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
    283  K ZERR
    284  D CLEAN^DILF
    285  D UPDATE^DIE("","C0CFDA","","ZERR")
    286  I $D(ZERR) D  ;
    287  . W "ERROR",!
    288  . ZWR ZERR
    289  . B
    290  K C0CFDA
    291  Q
    292  ;
     1C0CMXP    ; GPL - MXML based XPath utilities;12/04/09  17:05
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        Q
     21        ;
     22INITXPF(ARY)    ;INITIAL XML/XPATH FILE ARRAY
     23        ; DON'T USE THIS ONE ... USE INITFARY^C0CSOAP("FARY") INSTEAD
     24        D INITFARY^C0CSOAP(ARY) ;
     25        Q
     26        S @ARY@("XML FILE NUMBER")=178.101
     27        S @ARY@("XML SOURCE FIELD")=2.1
     28        S @ARY@("XML TEMPLATE FIELD")=3
     29        S @ARY@("XPATH BINDING SUBFILE")=178.1014
     30        S @ARY@("REDUX FIELD")=2.5
     31        Q
     32        ;
     33SETXPF(ARY)     ; SET FILE AND FIELD VARIABLES FROM XPF ARRAY
     34        ;
     35        S C0CXPF=@ARY@("XML FILE NUMBER")
     36        S C0CXFLD=@ARY@("XML")
     37        S C0CXTFLD=@ARY@("TEMPLATE XML")
     38        S C0CXPBF=@ARY@("BINDING SUBFILE NUMBER")
     39        S C0CRDUXF=@ARY@("XPATH REDUCTION STRING")
     40        Q
     41        ;
     42ADDXP(INARY,TID,FARY)   ;ADD XPATH .01 FIELD TO BINDING SUBFILE OF TEMPLATE TID
     43        I '$D(FARY) D  ;
     44        . S FARY="FARY" ; FILE ARRAY
     45        . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
     46        D SETXPF(FARY) ;SET FILE VARIABLES
     47        N C0CA,C0CB
     48        S C0CA="" S C0CB=0
     49        F  S C0CA=$O(@INARY@(C0CA)) Q:C0CA=""  D  ; FOR EACH XPATH
     50        . S C0CB=C0CB+1 ; COUNT OF XPATHS
     51        . S C0CFDA(C0CXPBF,"?+"_C0CB_","_TID_",",.01)=C0CA
     52        . D UPDIE ; CREATE THE BINDING SUBFILE FOR THIS XPATH
     53        Q
     54        ;
     55FIXICD9 ; FIX THE ICD9RESULT XML
     56        D GETXML("GPL","ICD9RESULT") ; GET SOME BAD XML OUT OF THE FILE
     57        S ZI=""
     58        S G=""
     59        F  S ZI=$O(GPL(ZI)) Q:ZI=""  D  ; FOR EACH LINE
     60        . S G=G_GPL(ZI) ; MAKE ONE BIG STRING OF XML
     61        D NORMAL^C0CSOAP("G2","G") ;NO NORMALIZE IT BACK INTO AN ARRAY
     62        D ADDXML("G2","ICD9RESULT") ; AND PUT IT BACK
     63        Q
     64ADDXML(INXML,TEMPID,INFARY)     ;ADD XML TO A TEMPLATE ID TEMPID
     65        ; INXML IS PASSED BY NAME
     66        I '$D(INFARY) D  ;
     67        . S INFARY="FARY" ; FILE ARRAY
     68        . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
     69        I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME
     70        D SETXPF(INFARY) ;SET FILE VARIABLES
     71        D WP^DIE(C0CXPF,TEMPID_",",C0CXFLD,,INXML)
     72        Q
     73        ;
     74ADDTEMP(INXML,TEMPID,INFARY)    ;ADD XML TEMPLATE TO TEMPLATE RECORD TEMPID
     75        ;
     76        I '$D(INFARY) D  ;
     77        . S INFARY="FARY" ; FILE ARRAY
     78        . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
     79        I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME
     80        D SETXPF(INFARY) ;SET FILE VARIABLES
     81        D WP^DIE(C0CXPF,TEMPID_",",C0CXTFLD,,INXML)
     82        Q
     83        ;
     84GETXML(OUTXML,TEMPID,INFARY)    ;GET THE XML FROM TEMPLATE TEMPID
     85        ;
     86        I '$D(INFARY) D  ;
     87        . S INFARY="FARY" ; FILE ARRAY
     88        . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
     89        D SETXPF(INFARY) ;SET FILE VARIABLES
     90        I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME
     91        I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXFLD,,OUTXML)'=OUTXML D  Q  ;
     92        . W "ERROR RETRIEVING TEMPLATE",!
     93        Q
     94        ;
     95GETTEMP(OUTXML,TEMPID,FARY)     ;GET THE TEMPLATE XML FROM TEMPLATE TEMPID
     96        ;
     97        I '$D(FARY) D  ;
     98        . S FARY="FARY" ; FILE ARRAY
     99        . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
     100        D SETXPF(FARY) ;SET FILE VARIABLES
     101        I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,FARY) ;RESOLVE TEMPLATE NAME
     102        I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXTFLD,,OUTXML)'=OUTXML D  Q  ;
     103        . W "ERROR RETRIEVING TEMPLATE",!
     104        Q
     105        ;
     106COPYWP(ZFLD,ZSRCREC,ZDESTREC,ZSRCF,ZDESTF)      ; COPIES A WORD PROCESSING FIELD
     107        ; FROM ONE RECORD TO ANOTHER RECORD
     108        ; ZFLD IS EITHER A NUMBERIC FIELD OR A NAME IN ZSRCF
     109        ; ZSRCF IS THE SOURCE FILE, IN FILE REDIRECT FORMAT
     110        ; IF ZSRCF IS OMMITED, THE DEFAULT C0C XML MISC FILE WILL BE ASSUMED
     111        ; ZDESTF IS DESTINATION FILE. IF OMMITED, IS ASSUMED TO BE THE SAME
     112        ; A ZSRCF
     113        I '$D(ZSRCF) D  ;
     114        . S ZSRCF="ZSRCF"
     115        . D INITFARY^C0CSOAP(ZSRCF)
     116        I '$D(ZDESTF) D  ;
     117        . S ZDESTF="ZDESTF"
     118        . M @ZDESTF=@ZSRCF
     119        N ZSF,ZDF,ZSFREF,ZDFREF
     120        S ZSF=@ZSRCF@("XML FILE NUMBER")
     121        S ZSFREF=$$FILEREF^C0CRNF(ZSF)
     122        S ZDF=@ZDESTF@("XML FILE NUMBER")
     123        S ZDFREF=$$FILEREF^C0CRNF(ZDF)
     124        N ZSIEN,ZDIEN
     125        S ZSIEN=$O(@ZSFREF@("B",ZSRCREC,""))
     126        I ZSIEN="" W !,"ERROR SOURCE RECORD NOT FOUND" Q  ;
     127        S ZDIEN=$O(@ZDFREF@("B",ZDESTREC,""))
     128        I ZDIEN="" W !,"ERROR DESTINATION RECORD NOT FOUND" Q  ;
     129        N ZFLDNUM
     130        I +ZFLD=0 S ZFLDNUM=@ZSRCF@(ZFLD) ; IF FIELD IS PASSED BY NAME
     131        E  S ZFLDNUM=ZFLD ; IF FIELD IS PASSED BY NUMBER
     132        N ZWP,ZWPN
     133        S ZWPN=$$GET1^DIQ(ZSF,ZSIEN_",",ZFLDNUM,,"ZWP") ; GET WP FROM SOURCE
     134        I ZWPN'="ZWP" W !,"ERROR SOURCE FIELD EMPTY" Q  ;
     135        D WP^DIE(ZDF,ZDIEN_",",ZFLDNUM,,"ZWP") ; PUT WP FIELD TO DEST
     136        Q
     137        ;
     138COMPILE(TID,UFARY)      ; COMPILES AN XML TEMPLATE AND GENERATES XPATH BINDINGS
     139        ; UFARY IF SPECIFIED WILL REDIRECT THE XML FILE TO USE
     140        ; INTID IS THE IEN OF THE RECORD TO USE IN THE XML FILE
     141        ; XML IS PULLED FROM THE "XML" FIELD AND THE COMPILED RESULT PUT
     142        ; IN THE "XML TEMPLATE" FIELD. ALL XPATHS USED IN THE TEMPLATE
     143        ; WILL BE POPULATED TO THE XPATH BINDINGS SUBFILE AS .01
     144        I '$D(UFARY) D  ;
     145        . S UFARY="DEFFARY" ; FILE ARRAY
     146        . ;D INITXPF("UFARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
     147        . D INITFARY^C0CSOAP(UFARY)
     148        D SETXPF(UFARY) ;SET FILE VARIABLES
     149        I +TID=0 S INTID=$$RESTID^C0CSOAP(TID,UFARY)
     150        E  S INTID=TID
     151        ;B
     152        ;N C0CXML,C0CREDUX,C0CTEMP,C0CIDX
     153        D GETXML("C0CXML",INTID,UFARY)
     154        S C0CREDUX=$$GET1^DIQ(C0CXPF,INTID_",",C0CRDUXF,"E") ;XPATH REDUCTION STRING
     155        D MKTPLATE("C0CTEMP","C0CIDX","C0CXML",C0CREDUX) ; CREATE TEMPLATE AND IDX
     156        D ADDTEMP("C0CTEMP",INTID,UFARY) ; WRITE THE TEMPLATE TO FILE
     157        D ADDXP("C0CIDX",INTID,UFARY) ;CREATE XPATH SUBFILE ENTRIES FOR EVERY XPATH
     158        Q
     159        ;
     160MKTPLATE(OUTT,OUTIDX,INXML,REDUX)       ;MAKE A TEMPLATE FROM INXML, RETURNED IN OUTT
     161        ; BOTH PASSED BY NAME. THE REDUX XPATH REDUCTION STRING IS USED IF PASSED
     162        ; OUTIDX IS AN ARRAY OF THE XPATHS USED IN MAKING THE TEMPLATE
     163        ;
     164        S C0CXLOC=$NA(^TMP("C0CXML",$J))
     165        K @C0CXLOC
     166        M @C0CXLOC=@INXML
     167        S C0CDOCID=$$PARSE^C0CMXML(C0CXLOC,"C0CMKT")
     168        K @C0CXLOC
     169        S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
     170        ;N GIDX,GIDX2,GARY,GARY2
     171        I '$D(REDUX) S REDUX=""
     172        D XPATH^C0CMXML(1,"/","GIDX","GARY",,REDUX)
     173        D INVERT("GIDX2","GIDX") ;MAKE ARRAY TO LOOK UP XPATH BY NODE
     174        N ZI,ZD S ZI=""
     175        F  S ZI=$O(@C0CDOM@(ZI)) Q:ZI=""  D  ; FOR EACH NODE IN THE DOM
     176        . K ZD ;FOR DATA
     177        . D DATA^C0CMXML("ZD",ZI) ;SEE IF THERE IS DATA FOR THIS NODE
     178        . ;I $D(ZD(1)) D  ; IF YES
     179        . I $$FIRST^C0CMXML(ZI)=0 D  ; IF THERE ARE NO CHILDREN TO THIS NODE
     180        . . ;I ZI<3 B  ;W !,ZD(1)
     181        . . K @C0CDOM@(ZI,"T") ; KILL THE DATA
     182        . . N ZXPATH
     183        . . S ZXPATH=$G(GIDX2(ZI)) ;FIND AN XPATH FOR THIS NODE
     184        . . S @C0CDOM@(ZI,"T",1)="@@"_ZXPATH_"@@"
     185        . . I ZXPATH'="" S @OUTIDX@(ZXPATH)="" ; PASS BACK XPATH USED IN IDX
     186        D OUTXML^C0CMXML(OUTT,C0CDOCID)
     187        Q
     188        ;
     189INVERT(OUTX,INX)        ;INVERTS AN XPATH INDEX RETURNING @OUTX@(x)=XPath from
     190        ; @INX@(XPath)=x
     191        N ZI S ZI=""
     192        F  S ZI=$O(@INX@(ZI)) Q:ZI=""  D  ;FOR EACH XPATH IN THE INPUT
     193        . S @OUTX@(@INX@(ZI))=ZI ; SET INVERTED ENTRY
     194        Q
     195        ;
     196DEMUX(OUTX,INX) ;PARSES XPATH PASSED BY VALUE IN INX TO REMOVE [x] MULTIPLES
     197        ; RETURNS OUTX: MULTIPLE^SUBMULTIPLE^XPATH
     198        N ZX,ZY,ZZ,ZZ1,ZMULT,ZSUB
     199        S (ZMULT,ZSUB)=""
     200        S ZX=$P(INX,"[",2)
     201        I ZX'="" D  ; THERE IS A [x] MULTIPLE
     202        . S ZY=$P(INX,"[",1) ;FIRST PART OF XPATH
     203        . S ZMULT=$P(ZX,"]",1) ; NUMBER OF THE MULTIPLE
     204        . S ZX=ZY_$P(ZX,"]",2) ; REST OF THE XPATH
     205        . I $P(ZX,"[",2)'="" D  ; A SUB MULTIPLE EXISTS
     206        . . S ZZ=$P(ZX,"[",1) ; FIRST PART OF XPATH
     207        . . S ZX=$P(ZX,"[",2) ; DELETE THE [
     208        . . S ZSUB=$P(ZX,"]",1) ; NUMBER OF THE SUBMULTIPLE
     209        . . S ZX=ZZ_$P(ZX,"]",2) ; REST OF THE XPATH
     210        E  S ZX=INX ;NO MULTIPLE HERE
     211        S @OUTX=ZMULT_"^"_ZSUB_"^"_ZX ;RETURN MULTIPLE^SUBMULTIPLE^XPATH
     212        Q
     213        ;
     214DEMUXARY(OARY,IARY,DEPTH)       ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
     215        ; FORMAT @OARY@(x,variablename) where x is the first multiple
     216        ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED
     217        N ZI,ZJ,ZK,ZL,ZM S ZI=""
     218        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ;
     219        . D DEMUX^C0CMXP("ZJ",ZI)
     220        . S ZK=$P(ZJ,"^",3)
     221        . S ZM=$RE($P($RE(ZK),"/",1))
     222        . I $G(DEPTH)=2 D  ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME
     223        . . S ZM=$RE($P($RE(ZK),"/",2))_ZM
     224        . S ZL=$P(ZJ,"^",1)
     225        . I ZL="" S ZL=1
     226        . I $D(@OARY@(ZL,ZM)) D  ;IT'S A DUP
     227        . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI)
     228        . E  S @OARY@(ZL,ZM)=@IARY@(ZI)
     229        Q
     230        ;
     231DEMUX2(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
     232        ; FORMAT @OARY@(x,variablename) where x is the first multiple
     233        ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED
     234        N ZI,ZJ,ZK,ZL,ZM S ZI=""
     235        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ;
     236        . D DEMUX^C0CMXP("ZJ",ZI)
     237        . S ZK=$P(ZJ,"^",3)
     238        . S ZM=$RE($P($RE(ZK),"/",1))
     239        . I $G(DEPTH)=2 D  ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME
     240        . . S ZM=$RE($P($RE(ZK),"/",2))_"."_ZM
     241        . S ZL=$P(ZJ,"^",1)
     242        . I ZL="" S ZL=1
     243        . I $D(@OARY@(ZL,ZM)) D  ;IT'S A DUP
     244        . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI)
     245        . E  S @OARY@(ZL,ZM)=@IARY@(ZI)
     246        Q
     247        ;
     248DEMUXXP1(OARY,IARY)     ;IARY IS INCOMING XPATH ARRAY
     249        ; BOTH IARY AND OARY ARE PASSED BY NAME
     250        ; RETURNS A SIMPLE XPATH ARRAY WITHOUT MULTIPLES. DUPLICATES ARE REMOVED
     251        N ZI,ZJ,ZK
     252        S ZI=""
     253        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH XPATH IN IARY
     254        . D DEMUX^C0CMXP("ZJ",ZI)
     255        . S ZK=$P(ZJ,"^",3) ;THE XPATH
     256        . S @OARY@(ZK)=@IARY@(ZI) ;THE RESULT. DUPLICATES WILL NOT SHOW
     257        . ; CAUTION, IF THERE ARE MULTIPLES, ONLY THE DATA FOR THE LAST
     258        . ; MULTIPLE WILL BE INCLUDED IN THE OUTPUT ARRAY, ASSIGNED TO THE
     259        . ; COMMON XPATH
     260        Q
     261        ;
     262DEMUXXP2(OARY,IARY)     ; IARY AND OARY ARE PASSED BY NAME
     263        ; IARY IS AN XPATH ARRAY THAT MAY CONTAIN MULTIPLES
     264        ; OARY IS THE OUTPUT ARRAY WHERE MULTIPLES ARE RETURNED IN THE FORM
     265        ; @OARY@(x,Xpath)=data or @OARY@(x,y,Xpath)=data WHERE x AND y ARE
     266        ; THE MULTIPLES AND Xpath IS THE BASE XPATH WITHOUT [x] AND [y]
     267        ;
     268        N ZI,ZJ,ZK,ZX,ZY,ZP
     269        S ZI=""
     270        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH INPUT XPATH
     271        . D DEMUX("ZJ",ZI) ; PULL OUT THE MULTIPLES
     272        . S ZX=$P(ZJ,"^",1) ;x
     273        . S ZY=$P(ZJ,"^",2) ;y
     274        . S ZP=$P(ZJ,"^",3) ;Xpath
     275        . I ZX="" S ZX=1 ; NO MULTIPLE WILL STORE IN x=1
     276        . I ZY'="" D  ;IS THERE A y?
     277        . . S @OARY@(ZX,ZY,ZP)=@IARY@(ZI)
     278        . E  D  ;NO y
     279        . . S @OARY@(ZX,ZP)=@IARY@(ZI)
     280        Q
     281        ;
     282UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
     283        K ZERR
     284        D CLEAN^DILF
     285        D UPDATE^DIE("","C0CFDA","","ZERR")
     286        I $D(ZERR) D  ;
     287        . W "ERROR",!
     288        . ZWR ZERR
     289        . B
     290        K C0CFDA
     291        Q
     292        ;

  • ccr/branches/ohum/p/C0CNHIN.m

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

  • ccr/branches/ohum/p/C0CNMED2.m

    r1342 r1428  
    1 C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel.
    4  ; Licensed under the terms of the GNU General Public License.
    5  ; See attached copy of the License.
    6  ;
    7  ; This program is free software; you can redistribute it and/or modify
    8  ; it under the terms of the GNU General Public License as published by
    9  ; the Free Software Foundation; either version 2 of the License, or
    10  ; (at your option) any later version.
    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  ; --Revision History
    22  ; July 2008 - Initial Version/GPL
    23  ; July 2008 - March 2009 various revisions
    24  ; March 2009 - Reconstruction of routine as driver for other med routines/SMH
    25  ; June 2011 - Redone to support all meds using the FOIA NHIN routines/gpl
    26  ;
    27  Q
    28  ;
    29  ; THIS VERSION IS DEPRECATED BECAUSE IT DOES NOT GENEREATE XML IN
    30  ; THE RIGHT ORDER... AND IT HAS TO BE IN THE RIGHT ORDER... :(
    31  ; GPL
    32  ;
    33 EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template
    34  ; DFN passed by reference
    35  ; MEDXML and MEDOUTXML are passed by Name
    36  ; MEDXML is the input template
    37  ; MEDOUTXML is the output template
    38  ; Both of them refer to ^TMP globals where the XML documents are stored
    39  ;
    40  N GN
    41  D EN^C0CNHIN(.GN,DFN,"MED;",1) ; RETRIEVE NHIN ARRAY OF MEDS
    42  ; this call uses GET^NHINV to retrieve xml of the meds and then
    43  ; parses with MXML and uses DOMO^C0CDOM to extract an NHIN array
    44  ;
    45  ; we now create an NHIN Array of the Meds section of the CCR
    46  ;
    47  N ZI S ZI=""
    48  F  S ZI=$O(GN("med",ZI)) Q:ZI=""  D  ; for each med
    49  . N GA S GA=$NA(GN("med",ZI))
    50  . N GM S GM="Medication" ; to keep the lines shorter
    51  . S GC(GM,ZI,"CCRDataObjectID")="MED_"_ZI
    52  . N ZD,ZD2 S ZD=$G(@GA@("ordered@value")) ; FILEMAN DATE
    53  . I ZD="" S ZD=$G(@GA@("start@value")) ; for inpatient meds
    54  . S ZD2=$$FMDTOUTC^C0CUTIL(ZD,"DT")
    55  . S GC(GM,ZI,"DateTime[1].ExactDateTime")=ZD2
    56  . S GC(GM,ZI,"DateTime[1].Type.Text")="Documented Date"
    57  . ;S GC(GM,ZI,"DateTime[2].ExactDateTime")=""
    58  . ;S GC(GM,ZI,"DateTime[2].Type.Text")=""
    59  . N GSIG S GSIG=$G(@GA@("sig"))
    60  . I GSIG["|" S GSIG=$P(GSIG,"|",2) ; eRx has name of drug separated by |
    61  . S GC(GM,ZI,"Description.Text")=GSIG
    62  . N GD S GD="Directions.Direction" ; MAKING THE STRINGS SHORTER
    63  . ;S GC(GM,ZI,GD_".DeliveryMethod.Text")="@@MEDDELIVERYMETHOD@@"
    64  . ;S GC(GM,ZI,GD_".Description.Text")=""
    65  . ;S GC(GM,ZI,GD_".DirectionSequenceModifier")="@@MEDDIRSEQ@@"
    66  . ;S GC(GM,ZI,GD_".Dose.Rate.Units.Unit")="@@MEDRATEUNIT@@"
    67  . ;S GC(GM,ZI,GD_".Dose.Rate.Value")="@@MEDRATEVALUE@@"
    68  . ;S GC(GM,ZI,GD_".Dose.Units.Unit")="@@MEDDOSEUNIT@@"
    69  . ;S GC(GM,ZI,GD_".Dose.Value")="@@MEDDOSEVALUE@@"
    70  . ;S GC(GM,ZI,GD_".DoseIndicator.Text")="@@MEDDOSEINDICATOR@@"
    71  . ;S GC(GM,ZI,GD_".Duration.Units.Unit")="@@MEDDURATIONUNIT@@"
    72  . ;S GC(GM,ZI,GD_".Duration.Value")="@@MEDDURATIONVALUE@@"
    73  . ;S GC(GM,ZI,GD_".Frequency.Value")="@@MEDFREQUENCYVALUE@@"
    74  . ;S GC(GM,ZI,GD_".Indication.PRNFlag.Text")="@@MEDPRNFLAG@@"
    75  . ;S GC(GM,ZI,GD_".Indication.Problem.CCRDataObjectID")=""
    76  . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.CodingSystem")=""
    77  . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Value")=""
    78  . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Version")=""
    79  . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Text")=""
    80  . ;S GC(GM,ZI,GD_".Indication.Problem.Source.Actor.ActorID")=""
    81  . ;S GC(GM,ZI,GD_".Indication.Problem.Type.Text")=""
    82  . ;S GC(GM,ZI,GD_".Interval.Units.Unit")="@@MEDINTERVALUNIT@@"
    83  . ;S GC(GM,ZI,GD_".Interval.Value")="@@MEDINTERVALVALUE@@"
    84  . ;S GC(GM,ZI,GD_".MultipleDirectionModifier.Text")="@@MEDMULDIRMOD@@"
    85  . S GC(GM,ZI,GD_".Route.Text")=$G(@GA@("doses.dose@route"))
    86  . ;S GC(GM,ZI,GD_".StopIndicator.Text")="@@MEDSTOPINDICATOR@@"
    87  . ;S GC(GM,ZI,GD_".Vehicle.Text")="@@MEDVEHICLETEXT@@"
    88  . ;S GC(GM,ZI,"FullfillmentInstructions.Text")=""
    89  . ;S GC(GM,ZI,"IDs.ID")="@@MEDRXNO@@"
    90  . ;S GC(GM,ZI,"IDs.Type.Text")="@@MEDRXNOTXT@@"
    91  . ;S GC(GM,ZI,"PatientInstructions.Instruction.Text")="@@MEDPTINSTRUCTIONS@@"
    92  . ;S GC(GM,ZI,"Product.BrandName.Text")="@@MEDBRANDNAMETEXT@@"
    93  . S GC(GM,ZI,"Product.Concentration.Units.Unit")=$G(@GA@("doses.dose@units"))
    94  . S GC(GM,ZI,"Product.Concentration.Value")=$G(@GA@("doses.dose@dose"))
    95  . S GC(GM,ZI,"Product.Form.Text")=$G(@GA@("form@value"))
    96  . N GV S GV=$G(@GA@("products.product.vaProduct@vuid"))
    97  . N GR S GR=$$RXNCUI3^C0PLKUP(GV)
    98  . S GC(GM,ZI,"Product.ProductName.Code.CodingSystem")=$S(GR:"RxNorm",1:"VUID")
    99  . S GC(GM,ZI,"Product.ProductName.Code.Value")=$S(GR:GR,1:GV)
    100  . S GC(GM,ZI,"Product.ProductName.Code.Version")="08AB_081201F"
    101  . S GC(GM,ZI,"Product.ProductName.Text")=$G(@GA@("name@value"))
    102  . S GC(GM,ZI,"Product.Strength.Units.Unit")=$G(@GA@("doses.dose@units"))
    103  . S GC(GM,ZI,"Product.Strength.Value")=$G(@GA@("doses.dose@dose"))
    104  . ;S GC(GM,ZI,"Quantity.Units.Unit")="@@MEDQUANTITYUNIT@@"
    105  . ;S GC(GM,ZI,"Quantity.Value")="@@MEDQUANTITYVALUE@@"
    106  . ;S GC(GM,ZI,"Refills.Refill.Number")="@@MEDRFNO@@"
    107  . N GDUZ S GDUZ=$G(@GA@("orderingProvider@code")) ;PROVIDER DUZ
    108  . S GC(GM,ZI,"Source.Actor.ActorID")="PROVIDER_"_GDUZ
    109  . S GC(GM,ZI,"Status.Text")=$G(@GA@("status@value"))
    110  . S GC(GM,ZI,"Type.Text")="Medication"
    111  N C0CDOCID
    112  S C0CDOCID=$$DOMI^C0CDOM("GC",,"Medications") ; insert to dom
    113  D OUTXML^C0CDOM(MEDOUTXML,C0CDOCID,1) ; render the xml
    114  N ZSIZE S ZSIZE=$O(@MEDOUTXML@(""),-1)
    115  S @MEDOUTXML@(0)=ZSIZE ; RETURN STATUS IS NUMBER OF LINES OF XML
    116  W !,MEDOUTXML
    117  ;ZWR GN
    118  ;ZWR GC
    119  ;B
    120  Q
    121  ;
     1C0CNMED2        ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 ; 5/10/12 2:53pm
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel.
     4        ; Licensed under the terms of the GNU General Public License.
     5        ; See attached copy of the License.
     6        ;
     7        ; This program is free software; you can redistribute it and/or modify
     8        ; it under the terms of the GNU General Public License as published by
     9        ; the Free Software Foundation; either version 2 of the License, or
     10        ; (at your option) any later version.
     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        ; --Revision History
     22        ; July 2008 - Initial Version/GPL
     23        ; July 2008 - March 2009 various revisions
     24        ; March 2009 - Reconstruction of routine as driver for other med routines/SMH
     25        ; June 2011 - Redone to support all meds using the FOIA NHIN routines/gpl
     26        ;
     27        Q
     28        ;
     29        ; THIS VERSION IS DEPRECATED BECAUSE IT DOES NOT GENEREATE XML IN
     30        ; THE RIGHT ORDER... AND IT HAS TO BE IN THE RIGHT ORDER... :(
     31        ; GPL
     32        ;
     33EXTRACT(MEDXML,DFN,MEDOUTXML)   ; Private; Extract medications into provided XML template
     34        ; DFN passed by reference
     35        ; MEDXML and MEDOUTXML are passed by Name
     36        ; MEDXML is the input template
     37        ; MEDOUTXML is the output template
     38        ; Both of them refer to ^TMP globals where the XML documents are stored
     39        ;
     40        N GN
     41        D EN^C0CNHIN(.GN,DFN,"MED;",1) ; RETRIEVE NHIN ARRAY OF MEDS
     42        ; this call uses GET^NHINV to retrieve xml of the meds and then
     43        ; parses with MXML and uses DOMO^C0CDOM to extract an NHIN array
     44        ;
     45        ; we now create an NHIN Array of the Meds section of the CCR
     46        ;
     47        N ZI S ZI=""
     48        F  S ZI=$O(GN("med",ZI)) Q:ZI=""  D  ; for each med
     49        . N GA S GA=$NA(GN("med",ZI))
     50        . N GM S GM="Medication" ; to keep the lines shorter
     51        . S GC(GM,ZI,"CCRDataObjectID")="MED_"_ZI
     52        . N ZD,ZD2 S ZD=$G(@GA@("ordered@value")) ; FILEMAN DATE
     53        . I ZD="" S ZD=$G(@GA@("start@value")) ; for inpatient meds
     54        . S ZD2=$$FMDTOUTC^C0CUTIL(ZD,"DT")
     55        . S GC(GM,ZI,"DateTime[1].ExactDateTime")=ZD2
     56        . S GC(GM,ZI,"DateTime[1].Type.Text")="Documented Date"
     57        . ;S GC(GM,ZI,"DateTime[2].ExactDateTime")=""
     58        . ;S GC(GM,ZI,"DateTime[2].Type.Text")=""
     59        . N GSIG S GSIG=$G(@GA@("sig"))
     60        . I GSIG["|" S GSIG=$P(GSIG,"|",2) ; eRx has name of drug separated by |
     61        . S GC(GM,ZI,"Description.Text")=GSIG
     62        . N GD S GD="Directions.Direction" ; MAKING THE STRINGS SHORTER
     63        . ;S GC(GM,ZI,GD_".DeliveryMethod.Text")="@@MEDDELIVERYMETHOD@@"
     64        . ;S GC(GM,ZI,GD_".Description.Text")=""
     65        . ;S GC(GM,ZI,GD_".DirectionSequenceModifier")="@@MEDDIRSEQ@@"
     66        . ;S GC(GM,ZI,GD_".Dose.Rate.Units.Unit")="@@MEDRATEUNIT@@"
     67        . ;S GC(GM,ZI,GD_".Dose.Rate.Value")="@@MEDRATEVALUE@@"
     68        . ;S GC(GM,ZI,GD_".Dose.Units.Unit")="@@MEDDOSEUNIT@@"
     69        . ;S GC(GM,ZI,GD_".Dose.Value")="@@MEDDOSEVALUE@@"
     70        . ;S GC(GM,ZI,GD_".DoseIndicator.Text")="@@MEDDOSEINDICATOR@@"
     71        . ;S GC(GM,ZI,GD_".Duration.Units.Unit")="@@MEDDURATIONUNIT@@"
     72        . ;S GC(GM,ZI,GD_".Duration.Value")="@@MEDDURATIONVALUE@@"
     73        . ;S GC(GM,ZI,GD_".Frequency.Value")="@@MEDFREQUENCYVALUE@@"
     74        . ;S GC(GM,ZI,GD_".Indication.PRNFlag.Text")="@@MEDPRNFLAG@@"
     75        . ;S GC(GM,ZI,GD_".Indication.Problem.CCRDataObjectID")=""
     76        . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.CodingSystem")=""
     77        . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Value")=""
     78        . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Version")=""
     79        . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Text")=""
     80        . ;S GC(GM,ZI,GD_".Indication.Problem.Source.Actor.ActorID")=""
     81        . ;S GC(GM,ZI,GD_".Indication.Problem.Type.Text")=""
     82        . ;S GC(GM,ZI,GD_".Interval.Units.Unit")="@@MEDINTERVALUNIT@@"
     83        . ;S GC(GM,ZI,GD_".Interval.Value")="@@MEDINTERVALVALUE@@"
     84        . ;S GC(GM,ZI,GD_".MultipleDirectionModifier.Text")="@@MEDMULDIRMOD@@"
     85        . S GC(GM,ZI,GD_".Route.Text")=$G(@GA@("doses.dose@route"))
     86        . ;S GC(GM,ZI,GD_".StopIndicator.Text")="@@MEDSTOPINDICATOR@@"
     87        . ;S GC(GM,ZI,GD_".Vehicle.Text")="@@MEDVEHICLETEXT@@"
     88        . ;S GC(GM,ZI,"FullfillmentInstructions.Text")=""
     89        . ;S GC(GM,ZI,"IDs.ID")="@@MEDRXNO@@"
     90        . ;S GC(GM,ZI,"IDs.Type.Text")="@@MEDRXNOTXT@@"
     91        . ;S GC(GM,ZI,"PatientInstructions.Instruction.Text")="@@MEDPTINSTRUCTIONS@@"
     92        . ;S GC(GM,ZI,"Product.BrandName.Text")="@@MEDBRANDNAMETEXT@@"
     93        . S GC(GM,ZI,"Product.Concentration.Units.Unit")=$G(@GA@("doses.dose@units"))
     94        . S GC(GM,ZI,"Product.Concentration.Value")=$G(@GA@("doses.dose@dose"))
     95        . S GC(GM,ZI,"Product.Form.Text")=$G(@GA@("form@value"))
     96        . N GV S GV=$G(@GA@("products.product.vaProduct@vuid"))
     97        . N GR S GR=$$RXNCUI3^C0PLKUP(GV)
     98        . S GC(GM,ZI,"Product.ProductName.Code.CodingSystem")=$S(GR:"RxNorm",1:"VUID")
     99        . S GC(GM,ZI,"Product.ProductName.Code.Value")=$S(GR:GR,1:GV)
     100        . S GC(GM,ZI,"Product.ProductName.Code.Version")="08AB_081201F"
     101        . S GC(GM,ZI,"Product.ProductName.Text")=$G(@GA@("name@value"))
     102        . S GC(GM,ZI,"Product.Strength.Units.Unit")=$G(@GA@("doses.dose@units"))
     103        . S GC(GM,ZI,"Product.Strength.Value")=$G(@GA@("doses.dose@dose"))
     104        . ;S GC(GM,ZI,"Quantity.Units.Unit")="@@MEDQUANTITYUNIT@@"
     105        . ;S GC(GM,ZI,"Quantity.Value")="@@MEDQUANTITYVALUE@@"
     106        . ;S GC(GM,ZI,"Refills.Refill.Number")="@@MEDRFNO@@"
     107        . N GDUZ S GDUZ=$G(@GA@("orderingProvider@code")) ;PROVIDER DUZ
     108        . S GC(GM,ZI,"Source.Actor.ActorID")="PROVIDER_"_GDUZ
     109        . S GC(GM,ZI,"Status.Text")=$G(@GA@("status@value"))
     110        . S GC(GM,ZI,"Type.Text")="Medication"
     111        N C0CDOCID
     112        S C0CDOCID=$$DOMI^C0CDOM("GC",,"Medications") ; insert to dom
     113        D OUTXML^C0CDOM(MEDOUTXML,C0CDOCID,1) ; render the xml
     114        N ZSIZE S ZSIZE=$O(@MEDOUTXML@(""),-1)
     115        S @MEDOUTXML@(0)=ZSIZE ; RETURN STATUS IS NUMBER OF LINES OF XML
     116        W !,MEDOUTXML
     117        ;ZWR GN
     118        ;ZWR GC
     119        ;B
     120        Q
     121        ;

  • ccr/branches/ohum/p/C0CNMED4.m

    r1342 r1428  
    1 C0CMED4         ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08
    2  ;;0.1;CCDCCR;;;Build 2
    3  ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4  ; General Public License See attached copy of the License.
    5  ;
    6  ; This program is free software; you can redistribute it and/or modify
    7  ; it under the terms of the GNU General Public License as published by
    8  ; the Free Software Foundation; either version 2 of the License, or
    9  ; (at your option) any later version.
    10  ;
    11  ; This program is distributed in the hope that it will be useful,
    12  ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ; GNU General Public License for more details.
    15  ;
    16  ; You should have received a copy of the GNU General Public License along
    17  ; with this program; if not, write to the Free Software Foundation, Inc.,
    18  ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  W "NO ENTRY FROM TOP",!
    21  Q
    22  ;
    23 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
    24  ;
    25  ; this routine has be adapted to retrieve meds from GET^NHINV by gpl 6/2011
    26  ;
    27  ; MINXML is the Input XML Template, passed by name
    28  ; DFN is Patient IEN
    29  ; OUTXML is the resultant XML.
    30  ;
    31  ; MEDS is return array from API.
    32  ; MED is holds each array element from MEDS, one medicine
    33  ; MAP is a mapping variable map (store result) for each med
    34  ;
    35  ; Inpatient Meds will be extracted using this routine and and the one following.
    36  ; Inpatient Meds Unit Dose is going to be C0CMED4
    37  ; Inpatient Meds IVs is going to be C0CMED5
    38  ;
    39  ; We will use two Pharmacy ReEnginnering API's:
    40  ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info
    41  ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info
    42  ; For more information, see the PRE documentation at:
    43  ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf
    44  ;
    45  ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient
    46  ;
    47  N MEDS,MAP
    48  ;K ^TMP($J)
    49  ;D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*)
    50  ;I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT  ; No Meds - Quit
    51  ;; Otherwise, we go on...
    52  D EN^C0CNHIN(.MEDS,DFN,"MED;") ; gpl get the NHIN Array of meds
    53  I '$D(MEDS) Q  ; no meds
    54  N ZI S ZI=""
    55  N ZCOUNT S ZCOUNT=0
    56  F  S ZI=$O(MEDS("med",ZI)) Q:ZI=""  D  ; for each returned med
    57  . I $G(MEDS("med",ZI,"vaType@value"))="I" S ZCOUNT=ZCOUNT+1
    58  IF ZCOUNT=0 Q  ; no inpatient meds
    59  ;M MEDS=^TMP($J,"UD")
    60  I DEBUG ZWR MEDS
    61  S MEDMAP=$NA(^TMP("C0CCCR",$J,"MEDMAP"))
    62  ;N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array
    63  N I S I=0
    64  F  S I=$O(MEDS("med",I)) Q:'I  D  ; For each medication
    65  . N MED M MED=MEDS("med",I)
    66  . I $G(MED("vaType@value"))'="I" Q  ; not inpatient
    67  . S MEDCOUNT=MEDCOUNT+1
    68  . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter
    69  . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
    70  . ;N RXIEN S RXIEN=MED(.01) ; Order Number
    71  . N RXIEN S RXIEN=$G(MED("orderID@value")) ; ien of the med
    72  . I DEBUG W "RXIEN IS ",RXIEN,!
    73  . I DEBUG W "MAP= ",MAP,!
    74  . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN
    75  . S @MAP@("MEDISSUEDATETXT")="Order Date"
    76  . ;S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT")
    77  . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($G(MED("start@value")),"DT")
    78  . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient
    79  . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient
    80  . S @MAP@("MEDRXNOTXT")="" ; For Outpatient
    81  . S @MAP@("MEDRXNO")="" ; For Outpatient
    82  . S @MAP@("MEDTYPETEXT")="Medication"
    83  . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
    84  . ;S @MAP@("MEDSTATUSTEXT")="ACTIVE"
    85  . N C0CMST S C0CMST=$G(MED("vaStatus@value")) ; need to filter status
    86  . I C0CMST="EXPIRED" S C0CMST="Prior History No Longer Active"
    87  . I C0CMST="ACTIVE" S C0CMST="Active" ;
    88  . S @MAP@("MEDSTATUSTEXT")=C0CMST
    89  . ;S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U)
    90  . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$G(MED("orderingProvider@code"))
    91  . ;S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01)
    92  . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))
    93  . ; NDC is field 31 in the drug file.
    94  . ; The actual drug entry in the drug file is not necessarily supplied.
    95  . ; It' node 1, internal form.
    96  . ;N MEDIEN S MEDIEN=MED(1,"I")
    97  . ;S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"")
    98  . N ZVUID S ZVUID=$G(MED("products.product.vaProduct@vuid")) ; VUID
    99  . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
    100  . D  ;
    101  . . S ZC=$$CODE^C0CUTIL(ZVUID)
    102  . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
    103  . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
    104  . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
    105  . ;N ZRXNORM S ZRXNORM=""
    106  . ;S ZRXNORM=$$RXNCUI3^C0PLKUP(ZVUID)
    107  . S @MAP@("MEDPRODUCTNAMECODEVALUE")=ZCD
    108  . ;S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"")
    109  . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=ZCDS
    110  . ;S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"")
    111  . S @MAP@("MEDPRODUCTNAMECODEVERSION")=ZCDSV
    112  . S @MAP@("MEDBRANDNAMETEXT")=""
    113  . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))_" "_ZCDS_": "_ZCD
    114  . ;I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE")
    115  . ;I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
    116  . ;S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"")
    117  . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("doses.dose@dose"))
    118  . ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"")
    119  . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("doses.dose@units"))
    120  . ; Units, concentration, etc, come from another call
    121  . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
    122  . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
    123  . ; NDF Entry IEN, and VA Product Name
    124  . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
    125  . ; Documented in the same manual.
    126  . ;N NDFDATA,CONCDATA
    127  . ;I $L(MEDIEN) D
    128  . ;. D NDF^PSS50(MEDIEN,,,,,"CONC")
    129  . ;. M NDFDATA=^TMP($J,"CONC",MEDIEN)
    130  . ;. N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
    131  . ;. N VAPROD S VAPROD=$P(NDFDATA(22),U)
    132  . ;. ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
    133  . ;. ; and this will crash the call. So...
    134  . ;. I NDFIEN="" S CONCDATA=""
    135  . ;. E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
    136  . ;E  S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors.
    137  . ;S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"")
    138  . S @MAP@("MEDFORMTEXT")=$G(MED("form@value"))
    139  . ;S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"")
    140  . S @MAP@("MEDCONCVALUE")=$G(MED("doses.dose@dose"))
    141  . ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"")
    142  . S @MAP@("MEDCONCUNIT")=$G(MED("doses.does@units"))
    143  . ;S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
    144  . S @MAP@("MEDQUANTITYVALUE")=$G(MED("doses.dose@unitsPerDose")) ;
    145  . ; Oddly, there is no easy place to find the dispense unit.
    146  . ; It's not included in the original call, so we have to go to the drug file.
    147  . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
    148  . ; Node 14.5 is the Dispense Unit
    149  . ;I $L(MEDIEN) D
    150  . ;. D DATA^PSS50(MEDIEN,,,,,"QTY")
    151  . ;. N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
    152  . ;. S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
    153  . ;E  S @MAP@("MEDQUANTITYUNIT")=""
    154  . S @MAP@("MEDQUANTITYUNIT")=$G(MED("dose.dose@unitsPerDose"))
    155  . ;
    156  . ; --- START OF DIRECTIONS ---
    157  . ; Dosage is field 2, route is 3, schedule is 4
    158  . ; These are all free text fields, and don't point to any files
    159  . ; For that reason, I will use the field I never used before:
    160  . ; MEDDIRECTIONDESCRIPTIONTEXT
    161  . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
    162  . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=$G(MED("sig"))
    163  . ; $G(MED("products.product.vaProduct@name"))
    164  . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4"  ; means look in description text. See E2369-05.
    165  . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
    166  . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")=""
    167  . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")=""
    168  . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" 
    169  . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" 
    170  . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" 
    171  . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")=""
    172  . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")=""
    173  . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")=""
    174  . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")=""
    175  . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")=""
    176  . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")=""
    177  . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")=""
    178  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")=""
    179  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")=""
    180  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")=""
    181  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")=""
    182  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")=""
    183  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")=""
    184  . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")=""
    185  . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")=""
    186  . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")=""
    187  . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")=""
    188  . ;
    189  . ; --- END OF DIRECTIONS ---
    190  . ;
    191  . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
    192  . ;S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field
    193  . S @MAP@("MEDPTINSTRUCTIONS")=""
    194  . ;S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
    195  . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=""
    196  . S @MAP@("MEDRFNO")=""
    197  . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
    198  . K @RESULT
    199  . D MAP^C0CXPATH(MINXML,MAP,RESULT)
    200  . ; D PARY^C0CXPATH(RESULT)
    201  . ; MAPPING DIRECTIONS
    202  . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
    203  . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
    204  . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
    205  . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
    206  . ; N MDZ1,MDZNA
    207  . N DIRCNT S DIRCNT=1 ; THERE ARE ALWAYS DIRECTIONS
    208  . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
    209  . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
    210  . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
    211  . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
    212  . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
    213  . D:MEDCOUNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
    214  . D:MEDCOUNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
    215  N MEDTMP,MEDI
    216  D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
    217  I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
    218  . W "MEDICATION MISSING ",!
    219  . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
    220  Q
    221  ;
     1C0CNMED4        ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 ; 5/10/12 2:54pm
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     4        ; General Public License See attached copy of the License.
     5        ;
     6        ; This program is free software; you can redistribute it and/or modify
     7        ; it under the terms of the GNU General Public License as published by
     8        ; the Free Software Foundation; either version 2 of the License, or
     9        ; (at your option) any later version.
     10        ;
     11        ; This program is distributed in the hope that it will be useful,
     12        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ; GNU General Public License for more details.
     15        ;
     16        ; You should have received a copy of the GNU General Public License along
     17        ; with this program; if not, write to the Free Software Foundation, Inc.,
     18        ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        W "NO ENTRY FROM TOP",!
     21        Q
     22        ;
     23EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT)     ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
     24        ;
     25        ; this routine has be adapted to retrieve meds from GET^NHINV by gpl 6/2011
     26        ;
     27        ; MINXML is the Input XML Template, passed by name
     28        ; DFN is Patient IEN
     29        ; OUTXML is the resultant XML.
     30        ;
     31        ; MEDS is return array from API.
     32        ; MED is holds each array element from MEDS, one medicine
     33        ; MAP is a mapping variable map (store result) for each med
     34        ;
     35        ; Inpatient Meds will be extracted using this routine and and the one following.
     36        ; Inpatient Meds Unit Dose is going to be C0CMED4
     37        ; Inpatient Meds IVs is going to be C0CMED5
     38        ;
     39        ; We will use two Pharmacy ReEnginnering API's:
     40        ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info
     41        ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info
     42        ; For more information, see the PRE documentation at:
     43        ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf
     44        ;
     45        ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient
     46        ;
     47        N MEDS,MAP
     48        ;K ^TMP($J)
     49        ;D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*)
     50        ;I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT  ; No Meds - Quit
     51        ;; Otherwise, we go on...
     52        D EN^C0CNHIN(.MEDS,DFN,"MED;") ; gpl get the NHIN Array of meds
     53        I '$D(MEDS) Q  ; no meds
     54        N ZI S ZI=""
     55        N ZCOUNT S ZCOUNT=0
     56        F  S ZI=$O(MEDS("med",ZI)) Q:ZI=""  D  ; for each returned med
     57        . I $G(MEDS("med",ZI,"vaType@value"))="I" S ZCOUNT=ZCOUNT+1
     58        IF ZCOUNT=0 Q  ; no inpatient meds
     59        ;M MEDS=^TMP($J,"UD")
     60        I DEBUG ZWR MEDS
     61        S MEDMAP=$NA(^TMP("C0CCCR",$J,"MEDMAP"))
     62        ;N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array
     63        N I S I=0
     64        F  S I=$O(MEDS("med",I)) Q:'I  D  ; For each medication
     65        . N MED M MED=MEDS("med",I)
     66        . I $G(MED("vaType@value"))'="I" Q  ; not inpatient
     67        . S MEDCOUNT=MEDCOUNT+1
     68        . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter
     69        . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
     70        . ;N RXIEN S RXIEN=MED(.01) ; Order Number
     71        . N RXIEN S RXIEN=$G(MED("orderID@value")) ; ien of the med
     72        . I DEBUG W "RXIEN IS ",RXIEN,!
     73        . I DEBUG W "MAP= ",MAP,!
     74        . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN
     75        . S @MAP@("MEDISSUEDATETXT")="Order Date"
     76        . ;S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT")
     77        . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($G(MED("start@value")),"DT")
     78        . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient
     79        . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient
     80        . S @MAP@("MEDRXNOTXT")="" ; For Outpatient
     81        . S @MAP@("MEDRXNO")="" ; For Outpatient
     82        . S @MAP@("MEDTYPETEXT")="Medication"
     83        . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
     84        . ;S @MAP@("MEDSTATUSTEXT")="ACTIVE"
     85        . N C0CMST S C0CMST=$G(MED("vaStatus@value")) ; need to filter status
     86        . I C0CMST="EXPIRED" S C0CMST="Prior History No Longer Active"
     87        . I C0CMST="ACTIVE" S C0CMST="Active" ;
     88        . S @MAP@("MEDSTATUSTEXT")=C0CMST
     89        . ;S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U)
     90        . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$G(MED("orderingProvider@code"))
     91        . ;S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01)
     92        . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))
     93        . ; NDC is field 31 in the drug file.
     94        . ; The actual drug entry in the drug file is not necessarily supplied.
     95        . ; It' node 1, internal form.
     96        . ;N MEDIEN S MEDIEN=MED(1,"I")
     97        . ;S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"")
     98        . N ZVUID S ZVUID=$G(MED("products.product.vaProduct@vuid")) ; VUID
     99        . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
     100        . D  ;
     101        . . S ZC=$$CODE^C0CUTIL(ZVUID)
     102        . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
     103        . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
     104        . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
     105        . ;N ZRXNORM S ZRXNORM=""
     106        . ;S ZRXNORM=$$RXNCUI3^C0PLKUP(ZVUID)
     107        . S @MAP@("MEDPRODUCTNAMECODEVALUE")=ZCD
     108        . ;S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"")
     109        . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=ZCDS
     110        . ;S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"")
     111        . S @MAP@("MEDPRODUCTNAMECODEVERSION")=ZCDSV
     112        . S @MAP@("MEDBRANDNAMETEXT")=""
     113        . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))_" "_ZCDS_": "_ZCD
     114        . ;I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE")
     115        . ;I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
     116        . ;S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"")
     117        . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("doses.dose@dose"))
     118        . ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"")
     119        . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("doses.dose@units"))
     120        . ; Units, concentration, etc, come from another call
     121        . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
     122        . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
     123        . ; NDF Entry IEN, and VA Product Name
     124        . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
     125        . ; Documented in the same manual.
     126        . ;N NDFDATA,CONCDATA
     127        . ;I $L(MEDIEN) D
     128        . ;. D NDF^PSS50(MEDIEN,,,,,"CONC")
     129        . ;. M NDFDATA=^TMP($J,"CONC",MEDIEN)
     130        . ;. N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
     131        . ;. N VAPROD S VAPROD=$P(NDFDATA(22),U)
     132        . ;. ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
     133        . ;. ; and this will crash the call. So...
     134        . ;. I NDFIEN="" S CONCDATA=""
     135        . ;. E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
     136        . ;E  S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors.
     137        . ;S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"")
     138        . S @MAP@("MEDFORMTEXT")=$G(MED("form@value"))
     139        . ;S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"")
     140        . S @MAP@("MEDCONCVALUE")=$G(MED("doses.dose@dose"))
     141        . ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"")
     142        . S @MAP@("MEDCONCUNIT")=$G(MED("doses.does@units"))
     143        . ;S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
     144        . S @MAP@("MEDQUANTITYVALUE")=$G(MED("doses.dose@unitsPerDose")) ;
     145        . ; Oddly, there is no easy place to find the dispense unit.
     146        . ; It's not included in the original call, so we have to go to the drug file.
     147        . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
     148        . ; Node 14.5 is the Dispense Unit
     149        . ;I $L(MEDIEN) D
     150        . ;. D DATA^PSS50(MEDIEN,,,,,"QTY")
     151        . ;. N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
     152        . ;. S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
     153        . ;E  S @MAP@("MEDQUANTITYUNIT")=""
     154        . S @MAP@("MEDQUANTITYUNIT")=$G(MED("dose.dose@unitsPerDose"))
     155        . ;
     156        . ; --- START OF DIRECTIONS ---
     157        . ; Dosage is field 2, route is 3, schedule is 4
     158        . ; These are all free text fields, and don't point to any files
     159        . ; For that reason, I will use the field I never used before:
     160        . ; MEDDIRECTIONDESCRIPTIONTEXT
     161        . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
     162        . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=$G(MED("sig"))
     163        . ; $G(MED("products.product.vaProduct@name"))
     164        . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4"  ; means look in description text. See E2369-05.
     165        . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
     166        . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")=""
     167        . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")=""
     168        . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" 
     169        . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" 
     170        . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" 
     171        . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")=""
     172        . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")=""
     173        . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")=""
     174        . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")=""
     175        . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")=""
     176        . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")=""
     177        . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")=""
     178        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")=""
     179        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")=""
     180        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")=""
     181        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")=""
     182        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")=""
     183        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")=""
     184        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")=""
     185        . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")=""
     186        . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")=""
     187        . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")=""
     188        . ;
     189        . ; --- END OF DIRECTIONS ---
     190        . ;
     191        . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
     192        . ;S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field
     193        . S @MAP@("MEDPTINSTRUCTIONS")=""
     194        . ;S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
     195        . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=""
     196        . S @MAP@("MEDRFNO")=""
     197        . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
     198        . K @RESULT
     199        . D MAP^C0CXPATH(MINXML,MAP,RESULT)
     200        . ; D PARY^C0CXPATH(RESULT)
     201        . ; MAPPING DIRECTIONS
     202        . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
     203        . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
     204        . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
     205        . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
     206        . ; N MDZ1,MDZNA
     207        . N DIRCNT S DIRCNT=1 ; THERE ARE ALWAYS DIRECTIONS
     208        . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
     209        . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
     210        . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
     211        . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
     212        . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
     213        . D:MEDCOUNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
     214        . D:MEDCOUNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
     215        N MEDTMP,MEDI
     216        D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
     217        I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
     218        . W "MEDICATION MISSING ",!
     219        . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
     220        Q
     221        ;

  • ccr/branches/ohum/p/C0CORSLT.m

    r1342 r1428  
    1 C0CORSLT ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11
    2  ;;1.0;C0C;;Jan 21, 2010;Build 2
    3  ;Copyright 2011 George Lilly.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  W "NO ENTRY FROM TOP",!
    22  Q
    23  ;
    24 EN(ZVARS,DFN) ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS
    25  ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE
    26  ; AN EXAMPLE IS EKG RESULTS THAT ARE FOUND IN NOTES AND CONSULTS
    27  ; THIS IS CREATED FOR MU CERTIFICATION BY GPL
    28  D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
    29  N ZN ; RESULT NUMBER
    30  S ZN=$O(@ZVARS@(""),-1) ; NEXT RESULT
    31  N ZI S ZI=""
    32  F  S ZI=$O(VISIT(ZI)) Q:ZI=""  D  ; FOR EACH VISIT
    33  . I $G(VISIT(ZI,"TEXT",1))["ECG DONE" D  ; GOT AN ECG
    34  . . S ZN=ZN+1 ; INCREMENT RESULT COUNT
    35  . . N ZDATE,ZPRV,ZTXT
    36  . . S ZDATE=$G(VISIT(ZI,"DATE",0)) ; DATE OF PROCEDURE
    37  . . S ZPRV=$P($G(VISIT(ZI,"PRV",2)),"^",1) ;PROVIDER
    38  . . S ZTXT=$P($G(VISIT(ZI,"TEXT",4)),"ECG RESULTS: ",2)
    39  . . S @ZVARS@(ZN,"RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT")
    40  . . S @ZVARS@(ZN,"RESULTCODE")="34534-8"
    41  . . S @ZVARS@(ZN,"RESULTCODINGSYSTEM")="LOINC"
    42  . . S @ZVARS@(ZN,"RESULTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8"
    43  . . S @ZVARS@(ZN,"RESULTOBJECTID")="RESULT"_ZN
    44  . . S @ZVARS@(ZN,"RESULTSOURCEACTORID")="ACTORPROVIDER_"_ZPRV
    45  . . S @ZVARS@(ZN,"RESULTSTATUS")=""
    46  . . S @ZVARS@(ZN,"M","TEST",0)=1
    47  . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODEVALUE")="34534-8"
    48  . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODINGSYSTEM")="LOINC"
    49  . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT")
    50  . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8"
    51  . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTFLAG")=""
    52  . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALDESCTEXT")=""
    53  . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALSOURCEACTORID")="ACTORORGANIZATION_VASTANUM"
    54  . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTOBJECTID")="RESULTTEST_ECG_"_ZN
    55  . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSOURCEACTORID")="ACTORPROVIDER"_ZPRV
    56  . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSTATUSTEXT")="F"
    57  . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTUNITS")=""
    58  . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTVALUE")=ZTXT
    59  . . S @ZVARS@(0)=ZN ; UPDATE RESULTS COUNT
    60  Q
    61  ;
    62 OLD ; OLD CODE FOR OTHER WAYS OF DOING THE ECG
    63  ; FOR CERTIFICATION - SAVE EKG RESULTS gpl
    64  W !,"CPT=",ZCPT
    65  I ZCPT["93000" D  ; THIS IS AN EKG
    66  . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS
    67  . M ^GPL("RNF2")=@C0CPRSLT
    68  Q
    69  ;
     1C0CORSLT        ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2011 George Lilly.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        W "NO ENTRY FROM TOP",!
     22        Q
     23        ;
     24EN(ZVARS,DFN)   ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS
     25        ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE
     26        ; AN EXAMPLE IS EKG RESULTS THAT ARE FOUND IN NOTES AND CONSULTS
     27        ; THIS IS CREATED FOR MU CERTIFICATION BY GPL
     28        D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
     29        N ZN ; RESULT NUMBER
     30        S ZN=$O(@ZVARS@(""),-1) ; NEXT RESULT
     31        N ZI S ZI=""
     32        F  S ZI=$O(VISIT(ZI)) Q:ZI=""  D  ; FOR EACH VISIT
     33        . I $G(VISIT(ZI,"TEXT",1))["ECG DONE" D  ; GOT AN ECG
     34        . . S ZN=ZN+1 ; INCREMENT RESULT COUNT
     35        . . N ZDATE,ZPRV,ZTXT
     36        . . S ZDATE=$G(VISIT(ZI,"DATE",0)) ; DATE OF PROCEDURE
     37        . . S ZPRV=$P($G(VISIT(ZI,"PRV",2)),"^",1) ;PROVIDER
     38        . . S ZTXT=$P($G(VISIT(ZI,"TEXT",4)),"ECG RESULTS: ",2)
     39        . . S @ZVARS@(ZN,"RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT")
     40        . . S @ZVARS@(ZN,"RESULTCODE")="34534-8"
     41        . . S @ZVARS@(ZN,"RESULTCODINGSYSTEM")="LOINC"
     42        . . S @ZVARS@(ZN,"RESULTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8"
     43        . . S @ZVARS@(ZN,"RESULTOBJECTID")="RESULT"_ZN
     44        . . S @ZVARS@(ZN,"RESULTSOURCEACTORID")="ACTORPROVIDER_"_ZPRV
     45        . . S @ZVARS@(ZN,"RESULTSTATUS")=""
     46        . . S @ZVARS@(ZN,"M","TEST",0)=1
     47        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODEVALUE")="34534-8"
     48        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODINGSYSTEM")="LOINC"
     49        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT")
     50        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8"
     51        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTFLAG")=""
     52        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALDESCTEXT")=""
     53        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALSOURCEACTORID")="ACTORORGANIZATION_VASTANUM"
     54        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTOBJECTID")="RESULTTEST_ECG_"_ZN
     55        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSOURCEACTORID")="ACTORPROVIDER"_ZPRV
     56        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSTATUSTEXT")="F"
     57        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTUNITS")=""
     58        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTVALUE")=ZTXT
     59        . . S @ZVARS@(0)=ZN ; UPDATE RESULTS COUNT
     60        Q
     61        ;
     62OLD     ; OLD CODE FOR OTHER WAYS OF DOING THE ECG
     63        ; FOR CERTIFICATION - SAVE EKG RESULTS gpl
     64        W !,"CPT=",ZCPT
     65        I ZCPT["93000" D  ; THIS IS AN EKG
     66        . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS
     67        . M ^GPL("RNF2")=@C0CPRSLT
     68        Q
     69        ;

  • ccr/branches/ohum/p/C0CPARMS.m

    r1342 r1428  
    1 C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20 SET(INPARMS) ;INITIALIZE RUNTIME PARMS USING INPARMS TO OVERRIDE DEFAULTS
    21  ; PARAMETERS ARE PASSED AS A STRING: "PARM1:VALUE1^PARM2:VALUE2^ETC"
    22  ; THE SAME FORMAT IS USED BY RPC AND COMMAND LINE ENTRY POINTS
    23  ;
    24  N PTMP ;
    25  S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;BASE FOR THIS RUN
    26  K @C0CPARMS ;START WITH EMPTY PARMS; MAY NOT WANT TO DO THIS KILL
    27  I $G(INPARMS)'="" D  ; OVERRIDES PROVIDED
    28  . N C0CI S C0CI=""
    29  . N C0CN S C0CN=1
    30  . F  S C0CI=$P(INPARMS,"^",C0CN) Q:C0CI=""  D  ;
    31  . . S C0CN=C0CN+1 ;NEXT PARM
    32  . . N C1,C2
    33  . . S C1=$P(C0CI,":",1) ; PARAMETER
    34  . . S C2=$P(C0CI,":",2) ; VALUE
    35  . . I C2="" S C2=1
    36  . . S @C0CPARMS@(C1)=C2
    37  . I C0CN=1 S @C0CPARMS@($P(INPARMS,":",1))=$P(C0CI,":",2) ; ONLY ONE
    38  ; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS
    39  ; IF THEY FAIL, THE FOLLOWING WILL BE HARDCODED DEFAULTS
    40  ;OHUM/RUT commented the hardcoded limits
    41  ;I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH
    42  ;I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
    43  ;I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS
    44  ;I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
    45  ;I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
    46  ;I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS
    47  ;I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
    48  ;I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
    49  ;I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE
    50  ;OHUM/RUT 3120109 ; commented all limits
    51  ;S @C0CPARMS@("LABLIMIT")=^TMP("C0CCCR","LABLIMIT"),@C0CPARMS@("VITLIMIT")=^TMP("C0CCCR","VITLIMIT"),@C0CPARMS@("TIULIMIT")=^TMP("C0CCCR","TIULIMIT"),@C0CPARMS@("MEDLIMIT")=^TMP("C0CCCR","MEDLIMIT")
    52  ;I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
    53  ;I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
    54  ;I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
    55  ;I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
    56  ;I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
    57  ;I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=1 ; NON-PENDING NON-ACTIVE
    58  ;;I '$D(@C0CPARMS@("RALIMIT")) S @C0CPARMS@("RALIMIT")="T-36500" ;ONE YR WORTH
    59  ;;I '$D(@C0CPARMS@("RASTART")) S @C0CPARMS@("RASTART")="T" ;TODAY
    60  ;I '$D(@C0CPARMS@("TIUSTART")) S @C0CPARMS@("TIUSTART")="T" ;TODAY
    61  ;;OHUM/RUT
    62  S @C0CPARMS@("LABLIMIT")=$P(^C0CPARM(1,0),"^",2),@C0CPARMS@("LABSTART")=$P(^C0CPARM(1,0),"^",3),@C0CPARMS@("VITLIMIT")=$P(^C0CPARM(1,0),"^",4),@C0CPARMS@("VITSTART")=$P(^C0CPARM(1,1),"^",1),@C0CPARMS@("MEDLIMIT")=$P(^C0CPARM(1,1),"^",2),@C0CPARMS@("MEDSTART")=$P(^C0CPARM(1,1),"^",3)
    63  I $P(^C0CPARM(1,1),"^",4)="ACT" S @C0CPARMS@("MEDACTIVE")=1
    64  I $P(^C0CPARM(1,1),"^",4)="PEN" S @C0CPARMS@("MEDPENDING")=1
    65  I $P(^C0CPARM(1,1),"^",4)="ALL" S @C0CPARMS@("MEDALL")=1
    66  ;S ^TMP("C0CCCR","TIULIMIT")="",^TMP("C0CCCR","TIUSTART")=""
    67  I $P(^C0CPARM(1,2),"^",3)=1 S @C0CPARMS@("TIULIMIT")=$P(^C0CPARM(1,2),"^",1),@C0CPARMS@("TIUSTART")=$P(^C0CPARM(1,2),"^",2)
    68  ;OHUM/RUT
    69  Q
    70  ;
    71 CHECK ; CHECK TO SEE IF PARMS ARE PRESENT, ELSE RUN SET
    72  ;
    73  I '$D(C0CPARMS) S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;SHOULDN'T HAPPEN
    74  I '$D(@C0CPARMS) D SET("SETWITHCHECK:1")
    75  Q
    76  ;
    77 GET(WHICHP) ;EXTRINSIC TO RETURN THE VALUE OF PARAMETER WHICHP
    78  ;
    79  D CHECK ; SHOULDN'T HAPPEN BUT TO BE SAFE
    80  N GTMP
    81  Q $G(@C0CPARMS@(WHICHP)) ;PULL THE PARM FROM THE TABLE
    82  ;
     1C0CPARMS        ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20SET(INPARMS)    ;INITIALIZE RUNTIME PARMS USING INPARMS TO OVERRIDE DEFAULTS
     21        ; PARAMETERS ARE PASSED AS A STRING: "PARM1:VALUE1^PARM2:VALUE2^ETC"
     22        ; THE SAME FORMAT IS USED BY RPC AND COMMAND LINE ENTRY POINTS
     23        ;
     24        N PTMP ;
     25        S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;BASE FOR THIS RUN
     26        K @C0CPARMS ;START WITH EMPTY PARMS; MAY NOT WANT TO DO THIS KILL
     27        I $G(INPARMS)'="" D  ; OVERRIDES PROVIDED
     28        . N C0CI S C0CI=""
     29        . N C0CN S C0CN=1
     30        . F  S C0CI=$P(INPARMS,"^",C0CN) Q:C0CI=""  D  ;
     31        . . S C0CN=C0CN+1 ;NEXT PARM
     32        . . N C1,C2
     33        . . S C1=$P(C0CI,":",1) ; PARAMETER
     34        . . S C2=$P(C0CI,":",2) ; VALUE
     35        . . I C2="" S C2=1
     36        . . S @C0CPARMS@(C1)=C2
     37        . I C0CN=1 S @C0CPARMS@($P(INPARMS,":",1))=$P(C0CI,":",2) ; ONLY ONE
     38        ; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS
     39        ; IF THEY FAIL, THE FOLLOWING WILL BE HARDCODED DEFAULTS
     40        ;OHUM/RUT commented the hardcoded limits
     41        ;I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH
     42        ;I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
     43        ;I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS
     44        ;I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
     45        ;I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
     46        ;I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS
     47        ;I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
     48        ;I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
     49        ;I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE
     50        ;OHUM/RUT 3120109 ; commented all limits
     51        ;S @C0CPARMS@("LABLIMIT")=^TMP("C0CCCR","LABLIMIT"),@C0CPARMS@("VITLIMIT")=^TMP("C0CCCR","VITLIMIT"),@C0CPARMS@("TIULIMIT")=^TMP("C0CCCR","TIULIMIT"),@C0CPARMS@("MEDLIMIT")=^TMP("C0CCCR","MEDLIMIT")
     52        ;I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
     53        ;I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
     54        ;I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
     55        ;I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
     56        ;I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
     57        ;I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=1 ; NON-PENDING NON-ACTIVE
     58        ;;I '$D(@C0CPARMS@("RALIMIT")) S @C0CPARMS@("RALIMIT")="T-36500" ;ONE YR WORTH
     59        ;;I '$D(@C0CPARMS@("RASTART")) S @C0CPARMS@("RASTART")="T" ;TODAY
     60        ;I '$D(@C0CPARMS@("TIUSTART")) S @C0CPARMS@("TIUSTART")="T" ;TODAY
     61        ;;OHUM/RUT
     62        S @C0CPARMS@("LABLIMIT")=$P(^C0CPARM(1,0),"^",2),@C0CPARMS@("LABSTART")=$P(^C0CPARM(1,0),"^",3),@C0CPARMS@("VITLIMIT")=$P(^C0CPARM(1,0),"^",4),@C0CPARMS@("VITSTART")=$P(^C0CPARM(1,1),"^",1),@C0CPARMS@("MEDLIMIT")=$P(^C0CPARM(1,1),"^",2),@C0CPARMS@("MEDSTART")=$P(^C0CPARM(1,1),"^",3)
     63        I $P(^C0CPARM(1,1),"^",4)="ACT" S @C0CPARMS@("MEDACTIVE")=1
     64        I $P(^C0CPARM(1,1),"^",4)="PEN" S @C0CPARMS@("MEDPENDING")=1
     65        I $P(^C0CPARM(1,1),"^",4)="ALL" S @C0CPARMS@("MEDALL")=1
     66        ;S ^TMP("C0CCCR","TIULIMIT")="",^TMP("C0CCCR","TIUSTART")=""
     67        I $P(^C0CPARM(1,2),"^",3)=1 S @C0CPARMS@("TIULIMIT")=$P(^C0CPARM(1,2),"^",1),@C0CPARMS@("TIUSTART")=$P(^C0CPARM(1,2),"^",2)
     68        ;OHUM/RUT
     69        Q
     70        ;
     71CHECK   ; CHECK TO SEE IF PARMS ARE PRESENT, ELSE RUN SET
     72        ;
     73        I '$D(C0CPARMS) S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;SHOULDN'T HAPPEN
     74        I '$D(@C0CPARMS) D SET("SETWITHCHECK:1")
     75        Q
     76        ;
     77GET(WHICHP)     ;EXTRINSIC TO RETURN THE VALUE OF PARAMETER WHICHP
     78        ;
     79        D CHECK ; SHOULDN'T HAPPEN BUT TO BE SAFE
     80        N GTMP
     81        Q $G(@C0CPARMS@(WHICHP)) ;PULL THE PARM FROM THE TABLE
     82        ;

  • ccr/branches/ohum/p/C0CPROBS.m

    r1342 r1428  
    1 C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  ;
    22  ; PROCESS THE PROBLEMS SECTION OF THE CCR
    23  ;
    24 EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT PROBLEMS INTO PROVIDED XML TEMPLATE
    25  ;
    26  ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
    27  ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE
    28  ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE
    29  ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS
    30  ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT
    31  ;
    32  N RPCRSLT,J,K,PTMP,X,VMAP,TBU
    33  S TVMAP=$NA(^TMP("C0CCCR",$J,"PROBVALS"))
    34  S TARYTMP=$NA(^TMP("C0CCCR",$J,"PROBARYTMP"))
    35  K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES
    36  I $$RPMS^C0CUTIL() D RPMS ; IF BGOPRB ROUTINE IS MISSING (IE RPMS)
    37  I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT
    38  Q
    39  ;
    40 RPMS ; GETS THE PROBLEM LIST FOR RPMS
    41  S RPCGLO=$NA(^TMP("BGO",$J))
    42  D GET^BGOPROB(.RPCRSLT,DFN) ; CALL THE PROBLEM LIST RPC
    43  ; FORMAT OF RPC:
    44  ;   Number Code [1] ^ Patient IEN [2] ^ ICD Code [3] ^ Modify Date [4] ^ Class [5] ^ Provider Narrative [6] ^
    45  ;   Date Entered [7] ^ Status [8] ^ Date Onset [9] ^ Problem IEN [10] ^ Notes [11] ^ ICD9 IEN [12] ^
    46  ;   ICD9 Short Name [13] ^ Provider [14] ^ Facility IEN [15] ^ Priority [16]
    47  I '$D(@RPCGLO) W "NULL RESULT FROM GET^BGOPROB ",! S @OUTXML@(0)=0 Q
    48  S J=""
    49  F  S J=$O(@RPCGLO@(J)) Q:J=""  D  ; FOR EACH PROBLEM IN THE LIST
    50  . S VMAP=$NA(@TVMAP@(J))
    51  . K @VMAP
    52  . I DEBUG W "VMAP= ",VMAP,!
    53  . S PTMP=@RPCRSLT@(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY
    54  . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL
    55  . D GETN1^C0CRNF("C0CG1",9000011,$P(PTMP,U,10),"") ;GET VALUES BY NAME
    56  . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM
    57  . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,10)
    58  . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,8)="A":"Active",$P(PTMP,U,8)="I":"Inactive",1:"")
    59  . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,6)
    60  . S @VMAP@("PROBLEMCODINGVERSION")=""
    61  . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,3)
    62  . ; FOR CERTIFICATION - GPL
    63  . I @VMAP@("PROBLEMCODEVALUE")=493.90 S @VMAP@("PROBLEMCODEVALUE")=493
    64  . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT")
    65  . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT")
    66  . ;S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) ;UNKNOWN NOT MAPPED IN C0CCCR0
    67  . ;S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) ;UNKNOWN NOT MAPPED IN C0CCCR0
    68  . ;S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) ;NOT MAPPED IN C0CCCR0
    69  . ;S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) ;NOT MAPPED IN C0CCCR0
    70  . ;S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) ;NOT MAPPED IN C0CCCR0
    71  . ;S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) ;NOT MAPPED IN C0CCCR0
    72  . ;S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER
    73  . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$$ZVALUEI^C0CRNF("RECORDING PROVIDER","C0CG1")
    74  . ;S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) ;NOT MAPPED IN C0CCCR0
    75  . ;S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) ;NOT MAPPED IN C0CCCR0
    76  . ;S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") ;NOT MAPPED IN C0CCCR0
    77  . ;S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") ;NOT MAPPED IN C0CCCR0
    78  . S ARYTMP=$NA(@TARYTMP@(J))
    79  . ; W "ARYTMP= ",ARYTMP,!
    80  . K @ARYTMP
    81  . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ;
    82  . I J=1 D  ; FIRST ONE IS JUST A COPY
    83  . . ; W "FIRST ONE",!
    84  . . D CP^C0CXPATH(ARYTMP,OUTXML)
    85  . . ; W "OUTXML ",OUTXML,!
    86  . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
    87  . . D INSINNER^C0CXPATH(OUTXML,ARYTMP)
    88  ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*)
    89  ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS
    90  ; ZWR @OUTXML
    91  ; $$HTML^DILF(
    92  ; GENERATE THE NARITIVE HTML FOR THE CCD
    93  I CCD D CCD ; IF THIS IS FOR A CCD
    94  D MISSINGVARS
    95  Q
    96  ;
    97 VISTA ; GETS THE PROBLEM LIST FOR VISTA
    98  D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC
    99  I '$D(RPCRSLT(1)) D  Q  ; RPC RETURNS NULL
    100  . W "NULL RESULT FROM LIST^ORQQPL3 ",!
    101  . S @OUTXML@(0)=0
    102  . ; Q
    103  ; I DEBUG ZWR RPCRSLT
    104  S @TVMAP@(0)=RPCRSLT(0) ; SAVE NUMBER OF PROBLEMS
    105  F J=1:1:RPCRSLT(0)  D  ; FOR EACH PROBLEM IN THE LIST
    106  . S VMAP=$NA(@TVMAP@(J))
    107  . K @VMAP
    108  . I DEBUG W "VMAP= ",VMAP,!
    109  . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY
    110  . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM
    111  . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1)
    112  . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"")
    113  . N ZPRIOR S ZPRIOR=$P(PTMP,U,14) ;PRIORITY FLAG
    114  . ; turn off acute/chronic for certification gpl
    115  . ;S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status
    116  . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3)
    117  . S @VMAP@("PROBLEMCODINGVERSION")=""
    118  . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4)
    119  . ; FOR CERTIFICATION - GPL
    120  . I @VMAP@("PROBLEMCODEVALUE")["493.90" S @VMAP@("PROBLEMCODEVALUE")=493
    121  . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT")
    122  . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT")
    123  . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7)
    124  . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8)
    125  . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9)
    126  . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10)
    127  . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11)
    128  . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12)
    129  . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER
    130  . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1)
    131  . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13)
    132  . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14)
    133  . S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT")
    134  . S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT")
    135  . S ARYTMP=$NA(@TARYTMP@(J))
    136  . ; W "ARYTMP= ",ARYTMP,!
    137  . K @ARYTMP
    138  . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ;
    139  . I J=1 D  ; FIRST ONE IS JUST A COPY
    140  . . ; W "FIRST ONE",!
    141  . . D CP^C0CXPATH(ARYTMP,OUTXML)
    142  . . ; W "OUTXML ",OUTXML,!
    143  . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
    144  . . D INSINNER^C0CXPATH(OUTXML,ARYTMP)
    145  ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*)
    146  ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS
    147  ; ZWR @OUTXML
    148  ; $$HTML^DILF(
    149  ; GENERATE THE NARITIVE HTML FOR THE CCD
    150  I CCD D CCD ; IF THIS IS FOR A CCD
    151  D MISSINGVARS
    152  Q
    153 CCD 
    154  N HTMP,HOUT,HTMLO,C0CPROBI,ZX
    155  F C0CPROBI=1:1:RPCRSLT(0) D  ; FOR EACH PROBLEM
    156  . S VMAP=$NA(@TVMAP@(C0CPROBI))
    157  . I DEBUG W "VMAP =",VMAP,!
    158  . D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Body/PROBLEMS-HTML","HTMP") ; GET THE HTML FROM THE TEMPLATE
    159  . D UNMARK^C0CXPATH("HTMP") ; REMOVE <PROBLEMS-HTML> MARKUP
    160  . ; D PARY^C0CXPATH("HTMP") ; PRINT IT
    161  . D MAP^C0CXPATH("HTMP",VMAP,"HOUT") ; MAP THE VARIABLES
    162  . ; D PARY^C0CXPATH("HOUT") ; PRINT IT AGAIN
    163  . I C0CPROBI=1 D  ; FIRST ONE IS JUST A COPY
    164  . . D CP^C0CXPATH("HOUT","HTMLO")
    165  . I C0CPROBI>1 D  ; AFTER THE FIRST, INSERT INNER HTML
    166  . . I DEBUG W "DOING INNER",!
    167  . . N HTMLBLD,HTMLTMP
    168  . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",1,HTMLO(0)-1)
    169  . . D QUEUE^C0CXPATH("HTMLBLD","HOUT",2,HOUT(0)-1)
    170  . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",HTMLO(0),HTMLO(0))
    171  . . D BUILD^C0CXPATH("HTMLBLD","HTMLTMP")
    172  . . D CP^C0CXPATH("HTMLTMP","HTMLO")
    173  . . ; D INSINNER^C0CXPATH("HOUT","HTMLO","//")
    174  I DEBUG D PARY^C0CXPATH("HTMLO")
    175  D INSB4^C0CXPATH(OUTXML,"HTMLO") ; INSERT AT TOP OF SECTION
    176  Q
    177 MISSINGVARS 
    178  N PROBSTMP,I
    179  D MISSING^C0CXPATH(ARYTMP,"PROBSTMP") ; SEARCH XML FOR MISSING VARS
    180  I PROBSTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
    181  . ; STRINGS MARKED AS @@X@@
    182  . W !,"PROBLEMS Missing list: ",!
    183  . F I=1:1:PROBSTMP(0) W PROBSTMP(I),!
    184  Q
    185  ;
     1C0CPROBS        ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        ;
     22        ; PROCESS THE PROBLEMS SECTION OF THE CCR
     23        ;
     24EXTRACT(IPXML,DFN,OUTXML)       ; EXTRACT PROBLEMS INTO PROVIDED XML TEMPLATE
     25        ;
     26        ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
     27        ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE
     28        ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE
     29        ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS
     30        ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT
     31        ;
     32        N RPCRSLT,J,K,PTMP,X,VMAP,TBU
     33        S TVMAP=$NA(^TMP("C0CCCR",$J,"PROBVALS"))
     34        S TARYTMP=$NA(^TMP("C0CCCR",$J,"PROBARYTMP"))
     35        K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES
     36        I $$RPMS^C0CUTIL() D RPMS ; IF BGOPRB ROUTINE IS MISSING (IE RPMS)
     37        I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT
     38        Q
     39        ;
     40RPMS    ; GETS THE PROBLEM LIST FOR RPMS
     41        S RPCGLO=$NA(^TMP("BGO",$J))
     42        D GET^BGOPROB(.RPCRSLT,DFN) ; CALL THE PROBLEM LIST RPC
     43        ; FORMAT OF RPC:
     44        ;   Number Code [1] ^ Patient IEN [2] ^ ICD Code [3] ^ Modify Date [4] ^ Class [5] ^ Provider Narrative [6] ^
     45        ;   Date Entered [7] ^ Status [8] ^ Date Onset [9] ^ Problem IEN [10] ^ Notes [11] ^ ICD9 IEN [12] ^
     46        ;   ICD9 Short Name [13] ^ Provider [14] ^ Facility IEN [15] ^ Priority [16]
     47        I '$D(@RPCGLO) W "NULL RESULT FROM GET^BGOPROB ",! S @OUTXML@(0)=0 Q
     48        S J=""
     49        F  S J=$O(@RPCGLO@(J)) Q:J=""  D  ; FOR EACH PROBLEM IN THE LIST
     50        . S VMAP=$NA(@TVMAP@(J))
     51        . K @VMAP
     52        . I DEBUG W "VMAP= ",VMAP,!
     53        . S PTMP=@RPCRSLT@(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY
     54        . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL
     55        . D GETN1^C0CRNF("C0CG1",9000011,$P(PTMP,U,10),"") ;GET VALUES BY NAME
     56        . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM
     57        . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,10)
     58        . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,8)="A":"Active",$P(PTMP,U,8)="I":"Inactive",1:"")
     59        . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,6)
     60        . S @VMAP@("PROBLEMCODINGVERSION")=""
     61        . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,3)
     62        . ; FOR CERTIFICATION - GPL
     63        . I @VMAP@("PROBLEMCODEVALUE")=493.90 S @VMAP@("PROBLEMCODEVALUE")=493
     64        . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT")
     65        . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT")
     66        . ;S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) ;UNKNOWN NOT MAPPED IN C0CCCR0
     67        . ;S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) ;UNKNOWN NOT MAPPED IN C0CCCR0
     68        . ;S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) ;NOT MAPPED IN C0CCCR0
     69        . ;S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) ;NOT MAPPED IN C0CCCR0
     70        . ;S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) ;NOT MAPPED IN C0CCCR0
     71        . ;S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) ;NOT MAPPED IN C0CCCR0
     72        . ;S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER
     73        . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$$ZVALUEI^C0CRNF("RECORDING PROVIDER","C0CG1")
     74        . ;S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) ;NOT MAPPED IN C0CCCR0
     75        . ;S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) ;NOT MAPPED IN C0CCCR0
     76        . ;S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") ;NOT MAPPED IN C0CCCR0
     77        . ;S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") ;NOT MAPPED IN C0CCCR0
     78        . S ARYTMP=$NA(@TARYTMP@(J))
     79        . ; W "ARYTMP= ",ARYTMP,!
     80        . K @ARYTMP
     81        . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ;
     82        . I J=1 D  ; FIRST ONE IS JUST A COPY
     83        . . ; W "FIRST ONE",!
     84        . . D CP^C0CXPATH(ARYTMP,OUTXML)
     85        . . ; W "OUTXML ",OUTXML,!
     86        . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
     87        . . D INSINNER^C0CXPATH(OUTXML,ARYTMP)
     88        ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*)
     89        ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS
     90        ; ZWR @OUTXML
     91        ; $$HTML^DILF(
     92        ; GENERATE THE NARITIVE HTML FOR THE CCD
     93        I CCD D CCD ; IF THIS IS FOR A CCD
     94        D MISSINGVARS
     95        Q
     96        ;
     97VISTA   ; GETS THE PROBLEM LIST FOR VISTA
     98        D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC
     99        I '$D(RPCRSLT(1)) D  Q  ; RPC RETURNS NULL
     100        . W "NULL RESULT FROM LIST^ORQQPL3 ",!
     101        . S @OUTXML@(0)=0
     102        . ; Q
     103        ; I DEBUG ZWR RPCRSLT
     104        S @TVMAP@(0)=RPCRSLT(0) ; SAVE NUMBER OF PROBLEMS
     105        F J=1:1:RPCRSLT(0)  D  ; FOR EACH PROBLEM IN THE LIST
     106        . S VMAP=$NA(@TVMAP@(J))
     107        . K @VMAP
     108        . I DEBUG W "VMAP= ",VMAP,!
     109        . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY
     110        . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM
     111        . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1)
     112        . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"")
     113        . N ZPRIOR S ZPRIOR=$P(PTMP,U,14) ;PRIORITY FLAG
     114        . ; turn off acute/chronic for certification gpl
     115        . ;S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status
     116        . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3)
     117        . S @VMAP@("PROBLEMCODINGVERSION")=""
     118        . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4)
     119        . ; FOR CERTIFICATION - GPL
     120        . I @VMAP@("PROBLEMCODEVALUE")["493.90" S @VMAP@("PROBLEMCODEVALUE")=493
     121        . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT")
     122        . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT")
     123        . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7)
     124        . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8)
     125        . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9)
     126        . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10)
     127        . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11)
     128        . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12)
     129        . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER
     130        . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1)
     131        . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13)
     132        . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14)
     133        . S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT")
     134        . S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT")
     135        . S ARYTMP=$NA(@TARYTMP@(J))
     136        . ; W "ARYTMP= ",ARYTMP,!
     137        . K @ARYTMP
     138        . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ;
     139        . I J=1 D  ; FIRST ONE IS JUST A COPY
     140        . . ; W "FIRST ONE",!
     141        . . D CP^C0CXPATH(ARYTMP,OUTXML)
     142        . . ; W "OUTXML ",OUTXML,!
     143        . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
     144        . . D INSINNER^C0CXPATH(OUTXML,ARYTMP)
     145        ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*)
     146        ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS
     147        ; ZWR @OUTXML
     148        ; $$HTML^DILF(
     149        ; GENERATE THE NARITIVE HTML FOR THE CCD
     150        I CCD D CCD ; IF THIS IS FOR A CCD
     151        D MISSINGVARS
     152        Q
     153CCD     
     154        N HTMP,HOUT,HTMLO,C0CPROBI,ZX
     155        F C0CPROBI=1:1:RPCRSLT(0) D  ; FOR EACH PROBLEM
     156        . S VMAP=$NA(@TVMAP@(C0CPROBI))
     157        . I DEBUG W "VMAP =",VMAP,!
     158        . D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Body/PROBLEMS-HTML","HTMP") ; GET THE HTML FROM THE TEMPLATE
     159        . D UNMARK^C0CXPATH("HTMP") ; REMOVE <PROBLEMS-HTML> MARKUP
     160        . ; D PARY^C0CXPATH("HTMP") ; PRINT IT
     161        . D MAP^C0CXPATH("HTMP",VMAP,"HOUT") ; MAP THE VARIABLES
     162        . ; D PARY^C0CXPATH("HOUT") ; PRINT IT AGAIN
     163        . I C0CPROBI=1 D  ; FIRST ONE IS JUST A COPY
     164        . . D CP^C0CXPATH("HOUT","HTMLO")
     165        . I C0CPROBI>1 D  ; AFTER THE FIRST, INSERT INNER HTML
     166        . . I DEBUG W "DOING INNER",!
     167        . . N HTMLBLD,HTMLTMP
     168        . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",1,HTMLO(0)-1)
     169        . . D QUEUE^C0CXPATH("HTMLBLD","HOUT",2,HOUT(0)-1)
     170        . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",HTMLO(0),HTMLO(0))
     171        . . D BUILD^C0CXPATH("HTMLBLD","HTMLTMP")
     172        . . D CP^C0CXPATH("HTMLTMP","HTMLO")
     173        . . ; D INSINNER^C0CXPATH("HOUT","HTMLO","//")
     174        I DEBUG D PARY^C0CXPATH("HTMLO")
     175        D INSB4^C0CXPATH(OUTXML,"HTMLO") ; INSERT AT TOP OF SECTION
     176        Q
     177MISSINGVARS     
     178        N PROBSTMP,I
     179        D MISSING^C0CXPATH(ARYTMP,"PROBSTMP") ; SEARCH XML FOR MISSING VARS
     180        I PROBSTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
     181        . ; STRINGS MARKED AS @@X@@
     182        . W !,"PROBLEMS Missing list: ",!
     183        . F I=1:1:PROBSTMP(0) W PROBSTMP(I),!
     184        Q
     185        ;

  • ccr/branches/ohum/p/C0CPROC.m

    r1342 r1428  
    1 C0CPROC  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10
    2  ;;1.0;C0C;;Jan 21, 2010;Build 2
    3  ;Copyright 2010 George Lilly, University of Minnesota and others.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  W "NO ENTRY FROM TOP",!
    22  Q
    23  ;
    24 SETVARS ; SET UP VARIABLES FOR PROCEDURES, ENCOUNTERS, AND NOTES
    25  S C0CENC=$NA(^TMP("C0CCCR",$J,"C0CENC",DFN))
    26  S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN))
    27  S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN))
    28  ; ADDITION FOR CERTIFICATION
    29  S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN))
    30  Q
    31  ;
    32 EXTRACT(PROCXML,DFN,PROCOUT) ; EXTRACT PROCEDURES INTO  XML TEMPLATE
    33  ; PROCXML AND PROCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
    34  ;
    35  D SETVARS ; SET UP VARIABLES
    36  I '$D(@C0CPRC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE
    37  D MAP(PROCXML,C0CPRC,PROCOUT) ;MAP RESULTS FOR PROCEDURES
    38  Q
    39  ;
    40 TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES,
    41  ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
    42  ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES
    43  ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT
    44  ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY
    45  ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM
    46  ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS
    47  ;
    48  K VISIT,LST,NOTE,C0CLPRC
    49  ; C0CLPRC IS A LOOKUP TABLE FOR USE IN BUILDING ENCOUNTERS
    50  ; FORMAT C0CLPRC(VISITIEN,CPT)=PROCOBJECTID FOR BUILDING LINKS TO PROCEDURES
    51  D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
    52  ; NEED TO ADD START AND END DATES FROM PARAMETERS
    53  N ZI S ZI=""
    54  N PREVCPT,PREVDT S (PREVCPT,PREVDT)=""
    55  F  S ZI=$O(VISIT(ZI),-1) Q:ZI=""  D  ; REVERSE TIME ORDER - MOST RECENT FIRST
    56  . N ZDATE
    57  . S ZDATE=$$DATE(VISIT(ZI,"DATE",0))
    58  . S ZPRVARY=$NA(VISIT(ZI,"PRV"))
    59  . N ZPRV
    60  . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM
    61  . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON
    62  . N ZJ S ZJ=""
    63  . F  S ZJ=$O(VISIT(ZI,"CPT",ZJ)) Q:ZJ=""  D  ;FOR EACH CPT SEG
    64  . . N ZRNF
    65  . . N ZCPT S ZCPT=$$CPT(VISIT(ZI,"CPT",ZJ)) ;GET CPT CODE AND TEXT
    66  . . I ZCPT'="" D  ;IF CPT CODE IS PRESENT
    67  . . . I (ZCPT=PREVCPT)&(ZDATE=PREVDT) Q  ; NO DUPS ALLOWED
    68  . . . W !,ZCPT," ",ZDATE," ",ZPRV
    69  . . . S ZRNF("PROCACTOROBJID")=ZPRV
    70  . . . N PROCCODE S PROCCODE=$P(ZCPT,U,1)
    71  . . . S ZRNF("PROCCODE")=PROCCODE
    72  . . . S ZRNF("PROCCODESYS")="CPT-4"
    73  . . . S ZRNF("PROCDATETEXT")="Procedure Date"
    74  . . . S ZRNF("PROCDATETIME")=ZDATE
    75  . . . S ZRNF("PROCDESCOBJATTRCODE")="" ;NO PROC ATTRIBUTES YET
    76  . . . S ZRNF("PROCDESCOBJATTR")=""
    77  . . . S ZRNF("PROCDESCOBJATTRCODESYS")="" ;WE DON'T HAVE PROC ATTRIBUTES
    78  . . . S ZRNF("PROCDESCOBJATTRVAL")=""
    79  . . . S ZRNF("PROCDESCTEXT")=$P(ZCPT,U,3)
    80  . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET
    81  . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET
    82  . . . ; additions for Certification - need to have EKG in Results
    83  . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT
    84  . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ
    85  . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS
    86  . . . S ZRNF("PROCSTATUS")="Completed" ; Is this right?
    87  . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE
    88  . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY
    89  . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl
    90  . . . W !,"CPT=",ZCPT
    91  . . . I ZCPT["93000" D  ; THIS IS AN EKG
    92  . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS
    93  . . . . M ^GPL("RNF2")=@C0CPRSLT
    94  . . . S PREVCPT=ZCPT
    95  . . . S PREVDT=ZDATE
    96  N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"PROCEDURES"))
    97  M @ZRIM=@C0CPRC@("V")
    98  Q
    99  ;
    100 PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME
    101  N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN=""
    102  F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH PRV SEG
    103  . I ZR'="" Q  ;ONLY WANT THE FIRST PRIMARY PROVIDER
    104  . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1)
    105  I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR
    106  Q ZRTN
    107  ;
    108 DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT
    109  Q $$FMDTOUTC^C0CUTIL(ISTR,"DT")
    110  ;
    111 CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS
    112  ; CPT^CATEGORY^TEXT
    113  N Z1,Z2,Z3,ZRTN
    114  S Z1=$P(ISTR,U,1)
    115  I Z1="" D  ;
    116  . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1)
    117  I Z1'="" D  ; IF THERE IS A CPT CODE IN THERE
    118  . ;S Z1=$P(ISTR,U,1)
    119  . S Z2=$P(ISTR,U,2)
    120  . S Z3=$P(ISTR,U,3)
    121  . S ZRTN=Z1_U_Z2_U_Z3
    122  E  S ZRTN=""
    123  Q ZRTN
    124  ;
    125 MAP(PROCXML,C0CPRC,PROCOUT) ; MAP PROCEDURES XML
    126  ;
    127  N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"PROCTEMP")) ;WORK AREA FOR TEMPLATE
    128  K @ZTEMP
    129  N ZBLD
    130  S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"PROCBLD")) ; BUILD LIST AREA
    131  D QUEUE^C0CXPATH(ZBLD,PROCXML,1,1) ; FIRST LINE
    132  N ZINNER
    133  D QUERY^C0CXPATH(PROCXML,"//Procedures/Procedure","ZINNER") ;ONE PROC
    134  N ZTMP,ZVAR,ZI
    135  S ZI=""
    136  F  S ZI=$O(@C0CPRC@("V",ZI)) Q:ZI=""  D  ;FOR EACH PROCEDURE
    137  . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS PROCEDURE XML
    138  . S ZVAR=$NA(@C0CPRC@("V",ZI)) ;THIS PROCEDURE VARIABLES
    139  . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE
    140  . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD
    141  D QUEUE^C0CXPATH(ZBLD,PROCXML,@PROCXML@(0),@PROCXML@(0))
    142  N ZZTMP
    143  D BUILD^C0CXPATH(ZBLD,PROCOUT) ;BUILD FINAL XML
    144  K @ZTEMP,@ZBLD,@C0CPRC
    145  Q
    146  ; 
     1C0CPROC  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2010 George Lilly, University of Minnesota and others.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        W "NO ENTRY FROM TOP",!
     22        Q
     23        ;
     24SETVARS ; SET UP VARIABLES FOR PROCEDURES, ENCOUNTERS, AND NOTES
     25        S C0CENC=$NA(^TMP("C0CCCR",$J,"C0CENC",DFN))
     26        S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN))
     27        S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN))
     28        ; ADDITION FOR CERTIFICATION
     29        S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN))
     30        Q
     31        ;
     32EXTRACT(PROCXML,DFN,PROCOUT)    ; EXTRACT PROCEDURES INTO  XML TEMPLATE
     33        ; PROCXML AND PROCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
     34        ;
     35        D SETVARS ; SET UP VARIABLES
     36        I '$D(@C0CPRC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE
     37        D MAP(PROCXML,C0CPRC,PROCOUT) ;MAP RESULTS FOR PROCEDURES
     38        Q
     39        ;
     40TIUGET(DFN,C0CENC,C0CPRC,C0CNTE)        ; CALLS ENTRY^C0CCPT TO GET PROCEDURES,
     41        ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
     42        ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES
     43        ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT
     44        ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY
     45        ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM
     46        ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS
     47        ;
     48        K VISIT,LST,NOTE,C0CLPRC
     49        ; C0CLPRC IS A LOOKUP TABLE FOR USE IN BUILDING ENCOUNTERS
     50        ; FORMAT C0CLPRC(VISITIEN,CPT)=PROCOBJECTID FOR BUILDING LINKS TO PROCEDURES
     51        D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
     52        ; NEED TO ADD START AND END DATES FROM PARAMETERS
     53        N ZI S ZI=""
     54        N PREVCPT,PREVDT S (PREVCPT,PREVDT)=""
     55        F  S ZI=$O(VISIT(ZI),-1) Q:ZI=""  D  ; REVERSE TIME ORDER - MOST RECENT FIRST
     56        . N ZDATE
     57        . S ZDATE=$$DATE(VISIT(ZI,"DATE",0))
     58        . S ZPRVARY=$NA(VISIT(ZI,"PRV"))
     59        . N ZPRV
     60        . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM
     61        . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON
     62        . N ZJ S ZJ=""
     63        . F  S ZJ=$O(VISIT(ZI,"CPT",ZJ)) Q:ZJ=""  D  ;FOR EACH CPT SEG
     64        . . N ZRNF
     65        . . N ZCPT S ZCPT=$$CPT(VISIT(ZI,"CPT",ZJ)) ;GET CPT CODE AND TEXT
     66        . . I ZCPT'="" D  ;IF CPT CODE IS PRESENT
     67        . . . I (ZCPT=PREVCPT)&(ZDATE=PREVDT) Q  ; NO DUPS ALLOWED
     68        . . . W !,ZCPT," ",ZDATE," ",ZPRV
     69        . . . S ZRNF("PROCACTOROBJID")=ZPRV
     70        . . . N PROCCODE S PROCCODE=$P(ZCPT,U,1)
     71        . . . S ZRNF("PROCCODE")=PROCCODE
     72        . . . S ZRNF("PROCCODESYS")="CPT-4"
     73        . . . S ZRNF("PROCDATETEXT")="Procedure Date"
     74        . . . S ZRNF("PROCDATETIME")=ZDATE
     75        . . . S ZRNF("PROCDESCOBJATTRCODE")="" ;NO PROC ATTRIBUTES YET
     76        . . . S ZRNF("PROCDESCOBJATTR")=""
     77        . . . S ZRNF("PROCDESCOBJATTRCODESYS")="" ;WE DON'T HAVE PROC ATTRIBUTES
     78        . . . S ZRNF("PROCDESCOBJATTRVAL")=""
     79        . . . S ZRNF("PROCDESCTEXT")=$P(ZCPT,U,3)
     80        . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET
     81        . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET
     82        . . . ; additions for Certification - need to have EKG in Results
     83        . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT
     84        . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ
     85        . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS
     86        . . . S ZRNF("PROCSTATUS")="Completed" ; Is this right?
     87        . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE
     88        . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY
     89        . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl
     90        . . . W !,"CPT=",ZCPT
     91        . . . I ZCPT["93000" D  ; THIS IS AN EKG
     92        . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS
     93        . . . . M ^GPL("RNF2")=@C0CPRSLT
     94        . . . S PREVCPT=ZCPT
     95        . . . S PREVDT=ZDATE
     96        N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"PROCEDURES"))
     97        M @ZRIM=@C0CPRC@("V")
     98        Q
     99        ;
     100PRV(IARY)       ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME
     101        N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN=""
     102        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH PRV SEG
     103        . I ZR'="" Q  ;ONLY WANT THE FIRST PRIMARY PROVIDER
     104        . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1)
     105        I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR
     106        Q ZRTN
     107        ;
     108DATE(ISTR)      ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT
     109        Q $$FMDTOUTC^C0CUTIL(ISTR,"DT")
     110        ;
     111CPT(ISTR)       ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS
     112        ; CPT^CATEGORY^TEXT
     113        N Z1,Z2,Z3,ZRTN
     114        S Z1=$P(ISTR,U,1)
     115        I Z1="" D  ;
     116        . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1)
     117        I Z1'="" D  ; IF THERE IS A CPT CODE IN THERE
     118        . ;S Z1=$P(ISTR,U,1)
     119        . S Z2=$P(ISTR,U,2)
     120        . S Z3=$P(ISTR,U,3)
     121        . S ZRTN=Z1_U_Z2_U_Z3
     122        E  S ZRTN=""
     123        Q ZRTN
     124        ;
     125MAP(PROCXML,C0CPRC,PROCOUT)     ; MAP PROCEDURES XML
     126        ;
     127        N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"PROCTEMP")) ;WORK AREA FOR TEMPLATE
     128        K @ZTEMP
     129        N ZBLD
     130        S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"PROCBLD")) ; BUILD LIST AREA
     131        D QUEUE^C0CXPATH(ZBLD,PROCXML,1,1) ; FIRST LINE
     132        N ZINNER
     133        D QUERY^C0CXPATH(PROCXML,"//Procedures/Procedure","ZINNER") ;ONE PROC
     134        N ZTMP,ZVAR,ZI
     135        S ZI=""
     136        F  S ZI=$O(@C0CPRC@("V",ZI)) Q:ZI=""  D  ;FOR EACH PROCEDURE
     137        . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS PROCEDURE XML
     138        . S ZVAR=$NA(@C0CPRC@("V",ZI)) ;THIS PROCEDURE VARIABLES
     139        . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE
     140        . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD
     141        D QUEUE^C0CXPATH(ZBLD,PROCXML,@PROCXML@(0),@PROCXML@(0))
     142        N ZZTMP
     143        D BUILD^C0CXPATH(ZBLD,PROCOUT) ;BUILD FINAL XML
     144        K @ZTEMP,@ZBLD,@C0CPRC
     145        Q
     146        ; 

  • ccr/branches/ohum/p/C0CPXRM.m

    r1338 r1428  
    1 C0CPXRM ;
    2 DOIT ;
    3  S G="PXRMXSEPCLINIC3110302.224804" ZWR ^XTMP(G,*)
    4  S G="PXRMXSEPCLINIC3110302.223957" ZWR ^XTMP(G,*)
    5  S G="PXRMXSEPCLINIC3110302.223738" ZWR ^XTMP(G,*)
    6  S G="PXRMXSEPCLINIC3110302.223516" ZWR ^XTMP(G,*)
    7  S G="PXRMXSEPCLINIC3110302.222158" ZWR ^XTMP(G,*)
    8  S G="PXRMXSEPCLINIC3110302.213944" ZWR ^XTMP(G,*)
    9  S G="PXRMXSEPCLINIC3110302.212219" ZWR ^XTMP(G,*)
    10  S G="PXRMXSEPCLINIC3110302.211506" ZWR ^XTMP(G,*)
    11  S G="PXRMXSEPCLINIC3110302.002714" ZWR ^XTMP(G,*)
    12  S G="PXRMXSEPCLINIC3110302.001841" ZWR ^XTMP(G,*)
    13  S G="PXRMXSEPCLINIC3110302.000846" ZWR ^XTMP(G,*)
    14  S G="PXRMXSEPCLINIC3110115.141918" ZWR ^XTMP(G,*)
    15  S G="PXRMXSEPCLINIC3110115.132312" ZWR ^XTMP(G,*)
    16  S G="PXRMXSEPCLINIC3110115.131653" ZWR ^XTMP(G,*)
    17  S G="PXRMXSEPCLINIC3110115.131008" ZWR ^XTMP(G,*)
    18  S G="PXRM PXK EVENT988 3110224.210456" ZWR ^XTMP(G,*)
    19  S G="PXRM PXK EVENT986 3110224.210456" ZWR ^XTMP(G,*)
    20  S G="PXRM PXK EVENT932 3110224.210456" ZWR ^XTMP(G,*)
    21  S G="PXRM PXK EVENT932 3110224.210455" ZWR ^XTMP(G,*)
    22  S G="PXRM PXK EVENT8015 3110301.215142" ZWR ^XTMP(G,*)
    23  S G="PXRM PXK EVENT8015 3110301.215141" ZWR ^XTMP(G,*)
    24  S G="PXRM PXK EVENT5265 3110309.124047" ZWR ^XTMP(G,*)
    25  S G="PXRM PXK EVENT5265 3110309.124046" ZWR ^XTMP(G,*)
    26  S G="PXRM PXK EVENT4742 3101129.221201" ZWR ^XTMP(G,*)
    27  S G="PXRM PXK EVENT4742 3101129.215741" ZWR ^XTMP(G,*)
    28  S G="PXRM PXK EVENT4710 3101129.215701" ZWR ^XTMP(G,*)
    29  S G="PXRM PXK EVENT3297 3101127.123134" ZWR ^XTMP(G,*)
    30  S G="PXRM PXK EVENT32495 3110224.194246" ZWR ^XTMP(G,*)
    31  S G="PXRM PXK EVENT32493 3110224.194246" ZWR ^XTMP(G,*)
    32  S G="PXRM PXK EVENT32354 3110224.194246" ZWR ^XTMP(G,*)
    33  S G="PXRM PXK EVENT32354 3110224.194245" ZWR ^XTMP(G,*)
    34  S G="PXRM PXK EVENT31106 3110224.175105" ZWR ^XTMP(G,*)
    35  S G="PXRM PXK EVENT31090 3110224.175105" ZWR ^XTMP(G,*)
    36  S G="PXRM PXK EVENT30339 3110224.175105" ZWR ^XTMP(G,*)
    37  S G="PXRM PXK EVENT30339 3110224.175103" ZWR ^XTMP(G,*)
    38  S G="PXRM PXK EVENT2761 3110115.174109" ZWR ^XTMP(G,*)
    39  S G="PXRM PXK EVENT2761 3110115.174108" ZWR ^XTMP(G,*)
    40  S G="PXRM PXK EVENT27327 3110227.013658" ZWR ^XTMP(G,*)
    41  S G="PXRM PXK EVENT27327 3110227.013657" ZWR ^XTMP(G,*)
    42  S G="PXRM PXK EVENT27327 3110227.013523" ZWR ^XTMP(G,*)
    43  S G="PXRM PXK EVENT27327 3110227.013522" ZWR ^XTMP(G,*)
    44  S G="PXRM PXK EVENT27253 3110227.012747" ZWR ^XTMP(G,*)
    45  S G="PXRM PXK EVENT27253 3110227.012746" ZWR ^XTMP(G,*)
    46  S G="PXRM PXK EVENT2559 3110115.170835" ZWR ^XTMP(G,*)
    47  S G="PXRM PXK EVENT25549 3110228.231135" ZWR ^XTMP(G,*)
    48  S G="PXRM PXK EVENT25549 3110228.231134" ZWR ^XTMP(G,*)
    49  S G="PXRM PXK EVENT2205 3101129.215343" ZWR ^XTMP(G,*)
    50  S G="PXRM PXK EVENT21092 3110114.195621" ZWR ^XTMP(G,*)
    51  S G="PXRM PXK EVENT21092 3110114.193803" ZWR ^XTMP(G,*)
    52  S G="PXRM PXK EVENT19640 3110226.032943" ZWR ^XTMP(G,*)
    53  S G="PXRM PXK EVENT19640 3110226.032941" ZWR ^XTMP(G,*)
    54  S G="PXRM PXK EVENT19353 3101212.162833" ZWR ^XTMP(G,*)
    55  S G="PXRM PXK EVENT18780 3110221.215603" ZWR ^XTMP(G,*)
    56  S G="PXRM PXK EVENT18156 3101212.152654" ZWR ^XTMP(G,*)
    57  S G="PXRM PXK EVENT17800 3110315.202432" ZWR ^XTMP(G,*)
    58  S G="PXRM PXK EVENT1650 3110220.192925" ZWR ^XTMP(G,*)
    59  S G="PXRM PXK EVENT16110 3110313.224636" ZWR ^XTMP(G,*)
    60  S G="PXRM PXK EVENT16004 3110317.151215" ZWR ^XTMP(G,*)
    61  S G="PXRM PXK EVENT16004 3110317.150834" ZWR ^XTMP(G,*)
    62  S G="PXRM PXK EVENT14955 3110315.165018" ZWR ^XTMP(G,*)
    63  S G="PXRM PXK EVENT14816 3110315.164839" ZWR ^XTMP(G,*)
    64  S G="PXRM PXK EVENT14816 3110315.164512" ZWR ^XTMP(G,*)
    65  S G="PXRM PXK EVENT12415 3110315.135514" ZWR ^XTMP(G,*)
    66  S G="PXRM PXK EVENT11797 3110315.131141" ZWR ^XTMP(G,*)
    67  S G="PXRM PXK EVENT11573 3110315.131811" ZWR ^XTMP(G,*)
    68  S G="PXRM PXK EVENT10728 3110114.025022" ZWR ^XTMP(G,*)
    69  S G="PXRM PXK EVENT10578 3110114.021524" ZWR ^XTMP(G,*)
    70  S G="PXRM PXK EVENT10243 3110114.020338" ZWR ^XTMP(G,*)
    71  S G="PXRM PXK EVENT10105 3101204.230554" ZWR ^XTMP(G,*)
    72  Q
    73  ;
     1C0CPXRM ;
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3DOIT    ;
     4        S G="PXRMXSEPCLINIC3110302.224804" ZWR ^XTMP(G,*)
     5        S G="PXRMXSEPCLINIC3110302.223957" ZWR ^XTMP(G,*)
     6        S G="PXRMXSEPCLINIC3110302.223738" ZWR ^XTMP(G,*)
     7        S G="PXRMXSEPCLINIC3110302.223516" ZWR ^XTMP(G,*)
     8        S G="PXRMXSEPCLINIC3110302.222158" ZWR ^XTMP(G,*)
     9        S G="PXRMXSEPCLINIC3110302.213944" ZWR ^XTMP(G,*)
     10        S G="PXRMXSEPCLINIC3110302.212219" ZWR ^XTMP(G,*)
     11        S G="PXRMXSEPCLINIC3110302.211506" ZWR ^XTMP(G,*)
     12        S G="PXRMXSEPCLINIC3110302.002714" ZWR ^XTMP(G,*)
     13        S G="PXRMXSEPCLINIC3110302.001841" ZWR ^XTMP(G,*)
     14        S G="PXRMXSEPCLINIC3110302.000846" ZWR ^XTMP(G,*)
     15        S G="PXRMXSEPCLINIC3110115.141918" ZWR ^XTMP(G,*)
     16        S G="PXRMXSEPCLINIC3110115.132312" ZWR ^XTMP(G,*)
     17        S G="PXRMXSEPCLINIC3110115.131653" ZWR ^XTMP(G,*)
     18        S G="PXRMXSEPCLINIC3110115.131008" ZWR ^XTMP(G,*)
     19        S G="PXRM PXK EVENT988 3110224.210456" ZWR ^XTMP(G,*)
     20        S G="PXRM PXK EVENT986 3110224.210456" ZWR ^XTMP(G,*)
     21        S G="PXRM PXK EVENT932 3110224.210456" ZWR ^XTMP(G,*)
     22        S G="PXRM PXK EVENT932 3110224.210455" ZWR ^XTMP(G,*)
     23        S G="PXRM PXK EVENT8015 3110301.215142" ZWR ^XTMP(G,*)
     24        S G="PXRM PXK EVENT8015 3110301.215141" ZWR ^XTMP(G,*)
     25        S G="PXRM PXK EVENT5265 3110309.124047" ZWR ^XTMP(G,*)
     26        S G="PXRM PXK EVENT5265 3110309.124046" ZWR ^XTMP(G,*)
     27        S G="PXRM PXK EVENT4742 3101129.221201" ZWR ^XTMP(G,*)
     28        S G="PXRM PXK EVENT4742 3101129.215741" ZWR ^XTMP(G,*)
     29        S G="PXRM PXK EVENT4710 3101129.215701" ZWR ^XTMP(G,*)
     30        S G="PXRM PXK EVENT3297 3101127.123134" ZWR ^XTMP(G,*)
     31        S G="PXRM PXK EVENT32495 3110224.194246" ZWR ^XTMP(G,*)
     32        S G="PXRM PXK EVENT32493 3110224.194246" ZWR ^XTMP(G,*)
     33        S G="PXRM PXK EVENT32354 3110224.194246" ZWR ^XTMP(G,*)
     34        S G="PXRM PXK EVENT32354 3110224.194245" ZWR ^XTMP(G,*)
     35        S G="PXRM PXK EVENT31106 3110224.175105" ZWR ^XTMP(G,*)
     36        S G="PXRM PXK EVENT31090 3110224.175105" ZWR ^XTMP(G,*)
     37        S G="PXRM PXK EVENT30339 3110224.175105" ZWR ^XTMP(G,*)
     38        S G="PXRM PXK EVENT30339 3110224.175103" ZWR ^XTMP(G,*)
     39        S G="PXRM PXK EVENT2761 3110115.174109" ZWR ^XTMP(G,*)
     40        S G="PXRM PXK EVENT2761 3110115.174108" ZWR ^XTMP(G,*)
     41        S G="PXRM PXK EVENT27327 3110227.013658" ZWR ^XTMP(G,*)
     42        S G="PXRM PXK EVENT27327 3110227.013657" ZWR ^XTMP(G,*)
     43        S G="PXRM PXK EVENT27327 3110227.013523" ZWR ^XTMP(G,*)
     44        S G="PXRM PXK EVENT27327 3110227.013522" ZWR ^XTMP(G,*)
     45        S G="PXRM PXK EVENT27253 3110227.012747" ZWR ^XTMP(G,*)
     46        S G="PXRM PXK EVENT27253 3110227.012746" ZWR ^XTMP(G,*)
     47        S G="PXRM PXK EVENT2559 3110115.170835" ZWR ^XTMP(G,*)
     48        S G="PXRM PXK EVENT25549 3110228.231135" ZWR ^XTMP(G,*)
     49        S G="PXRM PXK EVENT25549 3110228.231134" ZWR ^XTMP(G,*)
     50        S G="PXRM PXK EVENT2205 3101129.215343" ZWR ^XTMP(G,*)
     51        S G="PXRM PXK EVENT21092 3110114.195621" ZWR ^XTMP(G,*)
     52        S G="PXRM PXK EVENT21092 3110114.193803" ZWR ^XTMP(G,*)
     53        S G="PXRM PXK EVENT19640 3110226.032943" ZWR ^XTMP(G,*)
     54        S G="PXRM PXK EVENT19640 3110226.032941" ZWR ^XTMP(G,*)
     55        S G="PXRM PXK EVENT19353 3101212.162833" ZWR ^XTMP(G,*)
     56        S G="PXRM PXK EVENT18780 3110221.215603" ZWR ^XTMP(G,*)
     57        S G="PXRM PXK EVENT18156 3101212.152654" ZWR ^XTMP(G,*)
     58        S G="PXRM PXK EVENT17800 3110315.202432" ZWR ^XTMP(G,*)
     59        S G="PXRM PXK EVENT1650 3110220.192925" ZWR ^XTMP(G,*)
     60        S G="PXRM PXK EVENT16110 3110313.224636" ZWR ^XTMP(G,*)
     61        S G="PXRM PXK EVENT16004 3110317.151215" ZWR ^XTMP(G,*)
     62        S G="PXRM PXK EVENT16004 3110317.150834" ZWR ^XTMP(G,*)
     63        S G="PXRM PXK EVENT14955 3110315.165018" ZWR ^XTMP(G,*)
     64        S G="PXRM PXK EVENT14816 3110315.164839" ZWR ^XTMP(G,*)
     65        S G="PXRM PXK EVENT14816 3110315.164512" ZWR ^XTMP(G,*)
     66        S G="PXRM PXK EVENT12415 3110315.135514" ZWR ^XTMP(G,*)
     67        S G="PXRM PXK EVENT11797 3110315.131141" ZWR ^XTMP(G,*)
     68        S G="PXRM PXK EVENT11573 3110315.131811" ZWR ^XTMP(G,*)
     69        S G="PXRM PXK EVENT10728 3110114.025022" ZWR ^XTMP(G,*)
     70        S G="PXRM PXK EVENT10578 3110114.021524" ZWR ^XTMP(G,*)
     71        S G="PXRM PXK EVENT10243 3110114.020338" ZWR ^XTMP(G,*)
     72        S G="PXRM PXK EVENT10105 3101204.230554" ZWR ^XTMP(G,*)
     73        Q
     74        ;

  • ccr/branches/ohum/p/C0CQRY1.m

    r1342 r1428  
    1 LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99  13:48
    2         ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 2
    3         ;
    4         Q
    5         ;
    6 CHKSC   ; Check search NLT/LOINC codes
    7         ;
    8         N J
    9         ;
    10         S J=0
    11         F  S J=$O(LA7SC(J)) Q:'J  D
    12         . N X
    13         . S X=LA7SC(J)
    14         . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D  Q
    15         . . S ^TMP("LA7-NLT",$J,$P(X,"^"))=""
    16         . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D  Q
    17         . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))=""
    18         . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed"
    19         . K LA7SC(J)
    20         Q
    21         ;
    22         ;
    23 SPEC    ; Convert HL7 Specimen Codes to File #61, Topography codes
    24         ; Find all topographies that use this HL7 specimen code
    25         N J,K,L
    26         ;
    27         S J=0
    28         F  S J=$O(LA7SPEC(J)) Q:'J  D
    29         . S K=LA7SPEC(J),L=0
    30         . F  S L=$O(^LAB(61,"HL7",K,L)) Q:'L  S ^TMP("LA7-61",$J,L)=""
    31         Q
    32         ;
    33         ;
    34 BUILDMSG        ; Build HL7 message with result of query
    35         ;
    36         N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X
    37         ;
    38         I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&"
    39         S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5)
    40         S (HLQ,HL("Q"))=""""""
    41         ; Set flag to not send HL7 message
    42         S LA7NOMSG=1
    43         ; Create dummy MSH to pass HL7 delimiters
    44         S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS
    45         D FILESEG^LA7VHLU(GBL,.LA7MSH)
    46         ;
    47         F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)=""
    48         ;
    49         ; Take search results and put in HL7 message structure
    50         S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0
    51         ; F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT  D ;change per John M
    52         F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""  D  Q:LA7QUIT
    53         . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q
    54         . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0
    55         . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR
    56         . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR
    57         . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR
    58         . D OBX
    59         ;
    60         Q
    61         ;
    62         ;
    63 PID     ; Build PID segment
    64         ;
    65         N LA7PID
    66         ;
    67         S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3)
    68         S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
    69         D DEM^LRX
    70         D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL)
    71         D FILESEG^LA7VHLU(GBL,.LA7PID)
    72         S (LA("LRIDT"),LA("SUB"))=""
    73         Q
    74         ;
    75         ;
    76 ORC     ; Build ORC segment
    77         ;
    78         N X
    79         ;
    80         S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5)
    81         S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
    82         S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU"))
    83         S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4)
    84         I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6)
    85         S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0
    86         D ORC^LA7VORU
    87         S LA("NLT")=""
    88         ;
    89         Q
    90         ;
    91         ;
    92 OBR     ; Build OBR segment
    93         ;
    94         N LA764,LA7NLT
    95         ;
    96         S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))=""
    97         I $L(LA7NLT) D
    98         . S LA764=+$O(^LAM("E",LA7NLT,0))
    99         . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01)
    100         I LA("SUB")="CH" D
    101         . D OBR^LA7VORU
    102         . D NTE^LA7VORU
    103         . S LA7OBXSN=0
    104         ;
    105         Q
    106         ;
    107         ;
    108 OBX     ; Build OBX segment
    109         ;
    110         N LA7DATA,LA7VT
    111         ;
    112         S LA7NTESN=0
    113         I LA("SUB")="MI" D MI^LA7VORU1 Q
    114         I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q
    115         ;
    116         S LA7VT=$QS(LA7ROOT,7)
    117         D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH)
    118         I '$D(LA7DATA) Q
    119         D FILESEG^LA7VHLU(GBL,.LA7DATA)
    120         ; Send any test interpretation from file #60
    121         D INTRP^LA7VORUA
    122         ;
    123         Q
     1LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99  13:48
     2               ;;1.2;C0C;;May 11, 2012;Build 46
     3               ;
     4               Q
     5               ;
     6CHKSC     ; Check search NLT/LOINC codes
     7               ;
     8               N J
     9               ;
     10               S J=0
     11               F  S J=$O(LA7SC(J)) Q:'J  D
     12               . N X
     13               . S X=LA7SC(J)
     14               . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D  Q
     15               . . S ^TMP("LA7-NLT",$J,$P(X,"^"))=""
     16               . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D  Q
     17               . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))=""
     18               . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed"
     19               . K LA7SC(J)
     20               Q
     21               ;
     22               ;
     23SPEC       ; Convert HL7 Specimen Codes to File #61, Topography codes
     24               ; Find all topographies that use this HL7 specimen code
     25               N J,K,L
     26               ;
     27               S J=0
     28               F  S J=$O(LA7SPEC(J)) Q:'J  D
     29               . S K=LA7SPEC(J),L=0
     30               . F  S L=$O(^LAB(61,"HL7",K,L)) Q:'L  S ^TMP("LA7-61",$J,L)=""
     31               Q
     32               ;
     33               ;
     34BUILDMSG               ; Build HL7 message with result of query
     35               ;
     36               N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X
     37               ;
     38               I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&"
     39               S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5)
     40               S (HLQ,HL("Q"))=""""""
     41               ; Set flag to not send HL7 message
     42               S LA7NOMSG=1
     43               ; Create dummy MSH to pass HL7 delimiters
     44               S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS
     45               D FILESEG^LA7VHLU(GBL,.LA7MSH)
     46               ;
     47               F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)=""
     48               ;
     49               ; Take search results and put in HL7 message structure
     50               S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0
     51               ; F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT  D ;change per John M
     52               F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""  D  Q:LA7QUIT
     53               . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q
     54               . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0
     55               . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR
     56               . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR
     57               . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR
     58               . D OBX
     59               ;
     60               Q
     61               ;
     62               ;
     63PID         ; Build PID segment
     64               ;
     65               N LA7PID
     66               ;
     67               S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3)
     68               S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
     69               D DEM^LRX
     70               D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL)
     71               D FILESEG^LA7VHLU(GBL,.LA7PID)
     72               S (LA("LRIDT"),LA("SUB"))=""
     73               Q
     74               ;
     75               ;
     76ORC         ; Build ORC segment
     77               ;
     78               N X
     79               ;
     80               S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5)
     81               S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
     82               S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU"))
     83               S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4)
     84               I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6)
     85               S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0
     86               D ORC^LA7VORU
     87               S LA("NLT")=""
     88               ;
     89               Q
     90               ;
     91               ;
     92OBR         ; Build OBR segment
     93               ;
     94               N LA764,LA7NLT
     95               ;
     96               S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))=""
     97               I $L(LA7NLT) D
     98               . S LA764=+$O(^LAM("E",LA7NLT,0))
     99               . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01)
     100               I LA("SUB")="CH" D
     101               . D OBR^LA7VORU
     102               . D NTE^LA7VORU
     103               . S LA7OBXSN=0
     104               ;
     105               Q
     106               ;
     107               ;
     108OBX         ; Build OBX segment
     109               ;
     110               N LA7DATA,LA7VT
     111               ;
     112               S LA7NTESN=0
     113               I LA("SUB")="MI" D MI^LA7VORU1 Q
     114               I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q
     115               ;
     116               S LA7VT=$QS(LA7ROOT,7)
     117               D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH)
     118               I '$D(LA7DATA) Q
     119               D FILESEG^LA7VHLU(GBL,.LA7DATA)
     120               ; Send any test interpretation from file #60
     121               D INTRP^LA7VORUA
     122               ;
     123               Q

  • ccr/branches/ohum/p/C0CQRY2.m

    r1342 r1428  
    1 LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09
    2  ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994;Build 2
    3  ; JMC - mods to check for IHS V LAB file
    4  ;
    5  Q
    6  ;
    7 PATID ; Resolve patient id and establish patient environment
    8  ;
    9  N LA7X
    10  ;
    11  S (DFN,LRDFN)="",LA7PTYP=0
    12  ;
    13  ; SSN passed as patient identifier
    14  I LA7PTID?9N.1A D
    15  . S LA7PTYP=1
    16  . S LA7X=$O(^DPT("SSN",LA7PTID,0))
    17  . I LA7X>0 D SETDFN(LA7X)
    18  ;
    19  ; MPI/ICN (integration control number) passed as patient identifier
    20  I LA7PTID?10N1"V"6N D
    21  . S LA7PTYP=2
    22  . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V"))
    23  . I LA7X>0 D SETDFN(LA7X)
    24  ;
    25  ; If no patient identified/no laboratory record - return exception message
    26  I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed"
    27  I 'DFN S LA7ERR(2)="No patient found with requested identifier"
    28  I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient"
    29  I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient"
    30  Q
    31  ;
    32  ;
    33 BCD ; Search by specimen collection date.
    34  ;
    35  N LA763,LA7QUIT
    36  ;
    37  S (LA7SDT(0),LA7EDT(0))=0
    38  I LA7SDT S LA7SDT(0)=9999999-LA7SDT
    39  I LA7EDT S LA7EDT(0)=9999999-LA7EDT
    40  ;
    41  F LRSS="CH","MI","SP" D
    42  . S (LA7QUIT,LRIDT)=0
    43  . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1)
    44  . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT  D
    45  . . ; Quit if reached end of data or outside date criteria
    46  . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q
    47  . . D SEARCH
    48  ;
    49  Q
    50  ;
    51  ;
    52 BRAD ; Search by results available date (completion date).
    53  ; Assumes cross-references still exist for dates in LRO(69) global.
    54  ; Collects specimen date/time values for a given LRDFN and completion date.
    55  ; Cross-reference is by date only, time stripped from start date.
    56  ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)=""
    57  ;
    58  N LA763,LA7DT,LA7ROOT,LA7SRC,X
    59  ;
    60  ; Check if orders still exist Iin file #69 for search range
    61  S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0
    62  S X=$O(^LRO(69,LA7SDT(1)))
    63  I X,X<LA7EDT(1) S LA7SRC=1
    64  ;
    65  ; Search "AN" cross-reference in file #69.
    66  I LA7SRC D
    67  . S LA7DT=LA7SDT(1)
    68  . F  S LA7DT=$O(^LRO(69,LA7DT)) Q:'LA7DT!(LA7DT>LA7EDT(1))  D
    69  . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")"
    70  . . F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN")  D
    71  . . . I $QS(LA7ROOT,6)'=LRDFN Q
    72  . . . S LRIDT=$QS(LA7ROOT,7)
    73  . . . F LRSS="CH","MI","SP" D SEARCH
    74  ;
    75  ; If no orders in #69 then do long search through file #63.
    76  I 'LA7SRC D
    77  . F LRSS="CH","MI","SP" D
    78  . . S LRIDT=0
    79  . . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT  D
    80  . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
    81  . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)<LA7EDT(1) D SEARCH
    82  ;
    83  Q
    84  ;
    85  ;
    86 SEARCH ; Search subscript for a specific collection date/time
    87  ;
    88  K LA763
    89  S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
    90  ;
    91  ; Only CH, MI, and BB subscripts store pointer to file #61 in 5th piece of zeroth node.
    92  ; Quit if specific specimen codes and they do not match
    93  I "CHMIBB"[LRSS S LA761=+$P(LA763(0),"^",5)
    94  E  S LA761=0
    95  I LA761,$D(^TMP("LA7-61",$J)),'$D(^TMP("LA7-61",$J,LA761)) Q
    96  ;
    97  ; --- Chemistry
    98  I LRSS="CH" D CHSS Q
    99  ; --- Microbiology
    100  I LRSS="MI" D MISS Q
    101  ; --- Surgical pathology
    102  I LRSS="SP" D APSS Q
    103  ; --- Cytology
    104  I LRSS="CY" D APSS Q
    105  ; --- Electron Micrscopsy
    106  I LRSS="EM" D APSS Q
    107  ; --- Autopsy
    108  I LRSS="AU" D APSS Q
    109  ; --- Blood Bank
    110  I LRSS="BB" D BBSS Q
    111  Q
    112  ;
    113  ;
    114 CHSS ; Search "CH" datanames for matching codes
    115  ;
    116  N LA7X,LRSB
    117  ;
    118  S LRSB=1
    119  F  S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB  D
    120  . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
    121  . I $D(^AUPNVLAB) D LNCHK^C0CLA7Q ; WV check for IHS.
    122  . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761)
    123  . D CHECK
    124  ;
    125  Q
    126  ;
    127  ;
    128 MISS ; Search "MI" subscripts for matching codes
    129  ;
    130  N LA7ND,LRSB
    131  ;
    132  S LA7ND=0
    133  F LA7ND=1,5,8,11,16 I $D(^LR(LRDFN,LRSS,LRIDT,LA7ND)) D
    134  . S LRSB=$S(LA7ND=1:11,LA7ND=5:14,LA7ND=8:18,LA7ND=11:22,LA7ND=16:33,1:11)
    135  . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"",LA761)
    136  . D CHECK
    137  Q
    138  ;
    139  ;
    140 APSS ; Search AP subscripts for matching codes
    141  ; AP results are currently not coded - use defaults
    142  ;
    143  N LA7CODE,LRSB
    144  ;
    145  S LRSB=.012
    146  S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"","")
    147  D CHECK
    148  ;
    149  Q
    150  ;
    151  ;
    152 BBSS ; Search BB subscript for matching codes
    153  ; *** This subscript currently not supported ***
    154  Q
    155  ;
    156  ;
    157 CHECK ; Check NLT order/result and LOINC codes.
    158  ;
    159  N LA7QUIT
    160  ;
    161  ; If wildcard then store
    162  ; Otherwise check for specific NLT order/result and LOINC codes
    163  I LA7SC="*" D STORE Q
    164  S LA7QUIT=0
    165  F I=1:1:3 D  Q:LA7QUIT
    166  . ; If no test code then skip
    167  . I '$L($P(LA7CODE,"!",I)) Q
    168  . ; If test code does not match a search code then quit
    169  . I '$D(^TMP($S(I=3:"LA7-LN",1:"LA7-NLT"),$J,$P(LA7CODE,"!",I))) Q
    170  . D STORE S LA7QUIT=1
    171  ;
    172  Q
    173  ;
    174  ;
    175 STORE ; Store entry for building in HL7 message
    176  ;
    177  S ^TMP("LA7-QRY",$J,LRDFN,LRIDT,LRSS,LA7CODE,LRSB)=""
    178  Q
    179  ;
    180  ;
    181 SETDFN(LA7X) ; Setup DFN and other lab variables.
    182  ;
    183  S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^")
    184  Q
     1LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ; JMC - mods to check for IHS V LAB file
     4        ;
     5        Q
     6        ;
     7PATID   ; Resolve patient id and establish patient environment
     8        ;
     9        N LA7X
     10        ;
     11        S (DFN,LRDFN)="",LA7PTYP=0
     12        ;
     13        ; SSN passed as patient identifier
     14        I LA7PTID?9N.1A D
     15        . S LA7PTYP=1
     16        . S LA7X=$O(^DPT("SSN",LA7PTID,0))
     17        . I LA7X>0 D SETDFN(LA7X)
     18        ;
     19        ; MPI/ICN (integration control number) passed as patient identifier
     20        I LA7PTID?10N1"V"6N D
     21        . S LA7PTYP=2
     22        . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V"))
     23        . I LA7X>0 D SETDFN(LA7X)
     24        ;
     25        ; If no patient identified/no laboratory record - return exception message
     26        I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed"
     27        I 'DFN S LA7ERR(2)="No patient found with requested identifier"
     28        I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient"
     29        I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient"
     30        Q
     31        ;
     32        ;
     33BCD     ; Search by specimen collection date.
     34        ;
     35        N LA763,LA7QUIT
     36        ;
     37        S (LA7SDT(0),LA7EDT(0))=0
     38        I LA7SDT S LA7SDT(0)=9999999-LA7SDT
     39        I LA7EDT S LA7EDT(0)=9999999-LA7EDT
     40        ;
     41        F LRSS="CH","MI","SP" D
     42        . S (LA7QUIT,LRIDT)=0
     43        . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1)
     44        . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT  D
     45        . . ; Quit if reached end of data or outside date criteria
     46        . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q
     47        . . D SEARCH
     48        ;
     49        Q
     50        ;
     51        ;
     52BRAD    ; Search by results available date (completion date).
     53        ; Assumes cross-references still exist for dates in LRO(69) global.
     54        ; Collects specimen date/time values for a given LRDFN and completion date.
     55        ; Cross-reference is by date only, time stripped from start date.
     56        ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)=""
     57        ;
     58        N LA763,LA7DT,LA7ROOT,LA7SRC,X
     59        ;
     60        ; Check if orders still exist Iin file #69 for search range
     61        S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0
     62        S X=$O(^LRO(69,LA7SDT(1)))
     63        I X,X<LA7EDT(1) S LA7SRC=1
     64        ;
     65        ; Search "AN" cross-reference in file #69.
     66        I LA7SRC D
     67        . S LA7DT=LA7SDT(1)
     68        . F  S LA7DT=$O(^LRO(69,LA7DT)) Q:'LA7DT!(LA7DT>LA7EDT(1))  D
     69        . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")"
     70        . . F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN")  D
     71        . . . I $QS(LA7ROOT,6)'=LRDFN Q
     72        . . . S LRIDT=$QS(LA7ROOT,7)
     73        . . . F LRSS="CH","MI","SP" D SEARCH
     74        ;
     75        ; If no orders in #69 then do long search through file #63.
     76        I 'LA7SRC D
     77        . F LRSS="CH","MI","SP" D
     78        . . S LRIDT=0
     79        . . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT  D
     80        . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
     81        . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)<LA7EDT(1) D SEARCH
     82        ;
     83        Q
     84        ;
     85        ;
     86SEARCH  ; Search subscript for a specific collection date/time
     87        ;
     88        K LA763
     89        S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
     90        ;
     91        ; Only CH, MI, and BB subscripts store pointer to file #61 in 5th piece of zeroth node.
     92        ; Quit if specific specimen codes and they do not match
     93        I "CHMIBB"[LRSS S LA761=+$P(LA763(0),"^",5)
     94        E  S LA761=0
     95        I LA761,$D(^TMP("LA7-61",$J)),'$D(^TMP("LA7-61",$J,LA761)) Q
     96        ;
     97        ; --- Chemistry
     98        I LRSS="CH" D CHSS Q
     99        ; --- Microbiology
     100        I LRSS="MI" D MISS Q
     101        ; --- Surgical pathology
     102        I LRSS="SP" D APSS Q
     103        ; --- Cytology
     104        I LRSS="CY" D APSS Q
     105        ; --- Electron Micrscopsy
     106        I LRSS="EM" D APSS Q
     107        ; --- Autopsy
     108        I LRSS="AU" D APSS Q
     109        ; --- Blood Bank
     110        I LRSS="BB" D BBSS Q
     111        Q
     112        ;
     113        ;
     114CHSS    ; Search "CH" datanames for matching codes
     115        ;
     116        N LA7X,LRSB
     117        ;
     118        S LRSB=1
     119        F  S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB  D
     120        . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
     121        . I $D(^AUPNVLAB) D LNCHK^C0CLA7Q ; WV check for IHS.
     122        . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761)
     123        . D CHECK
     124        ;
     125        Q
     126        ;
     127        ;
     128MISS    ; Search "MI" subscripts for matching codes
     129        ;
     130        N LA7ND,LRSB
     131        ;
     132        S LA7ND=0
     133        F LA7ND=1,5,8,11,16 I $D(^LR(LRDFN,LRSS,LRIDT,LA7ND)) D
     134        . S LRSB=$S(LA7ND=1:11,LA7ND=5:14,LA7ND=8:18,LA7ND=11:22,LA7ND=16:33,1:11)
     135        . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"",LA761)
     136        . D CHECK
     137        Q
     138        ;
     139        ;
     140APSS    ; Search AP subscripts for matching codes
     141        ; AP results are currently not coded - use defaults
     142        ;
     143        N LA7CODE,LRSB
     144        ;
     145        S LRSB=.012
     146        S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"","")
     147        D CHECK
     148        ;
     149        Q
     150        ;
     151        ;
     152BBSS    ; Search BB subscript for matching codes
     153        ; *** This subscript currently not supported ***
     154        Q
     155        ;
     156        ;
     157CHECK   ; Check NLT order/result and LOINC codes.
     158        ;
     159        N LA7QUIT
     160        ;
     161        ; If wildcard then store
     162        ; Otherwise check for specific NLT order/result and LOINC codes
     163        I LA7SC="*" D STORE Q
     164        S LA7QUIT=0
     165        F I=1:1:3 D  Q:LA7QUIT
     166        . ; If no test code then skip
     167        . I '$L($P(LA7CODE,"!",I)) Q
     168        . ; If test code does not match a search code then quit
     169        . I '$D(^TMP($S(I=3:"LA7-LN",1:"LA7-NLT"),$J,$P(LA7CODE,"!",I))) Q
     170        . D STORE S LA7QUIT=1
     171        ;
     172        Q
     173        ;
     174        ;
     175STORE   ; Store entry for building in HL7 message
     176        ;
     177        S ^TMP("LA7-QRY",$J,LRDFN,LRIDT,LRSS,LA7CODE,LRSB)=""
     178        Q
     179        ;
     180        ;
     181SETDFN(LA7X)    ; Setup DFN and other lab variables.
     182        ;
     183        S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^")
     184        Q

  • ccr/branches/ohum/p/C0CRIMA.m

    r1342 r1428  
    1 C0CRIMA   ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  ; THESE ROUTINES EXAMINE ONE OR MORE, UP TO ALL, OF THE PATIENTS ON THE
    22  ; SYSTEM TO DETERMINE HOW COMPLETE THE RESULTING CCR OR CCD WOULD BE FOR
    23  ; THESE PATIENTS. IT BEGINS TO MEASURE "HL7 RIM COHERENCE" WHICH IS HOW USEFUL
    24  ; THE VARIABLES WILL BE TO A RIM-MODELED APPLICATION AFTER THEY ARE
    25  ; CONVEYED VIA THE CCR OR CCD.
    26  ; FACTORS THAT AFFECT RIM COHERENCE INCLUDE:
    27  ;    1. THE PRESENSE OF CLINICAL DATA IN A SECTION
    28  ;    2. ARE THE DATA ELEMENTS TIME-BOUND
    29  ;    3. ARE THE DATA ELEMENTS CODED WITH SNOMED OR LOINC ETC
    30  ;    4. ARE SOURCE ACTORS ASSOCIATED WITH THE DATA ELEMENTS
    31  ;    5. ARE ACTORS IDENTIFIED REGARDING THEIR ROLE
    32  ;    .. AND OTHER FACTORS YET TO BE DETERMINED
    33  ;
    34  ;    SINCE THESE MEASUREMENTS ARE DONE AT THE VARIABLE LEVEL, THEY
    35  ;    REFLECT ON RIM COHERENCE WHETHER THE CCR OR THE CCD IS USED FOR
    36  ;    CONVEYANCE TO THE RIM APPLICATION.
    37  ;
    38  ;
    39 ANALYZE(BEGDFN,DFNCNT,APARMS) ; RIM COHERANCE ANALYSIS ROUTINE
    40     ; BEGINS AT BEGDFN AND GOES FOR DFNCNT PATIENTS
    41     ; TO RESUME AT NEXT PATIENT, USE BEGDFN=""
    42     ; USE RESET^C0CRIMA TO RESET TO TOP OF PATIENT LIST
    43     ; APARMS ARE PARAMETERS TO BE USED IN THE EXTRACTION
    44     ; SEE C0CPARMS FOR SUPPORTED PARAMTERS
    45     ;
    46     N RIMARY,RIMTMP,RIMI,RIMDFN,RATTR
    47     N CCRGLO
    48     S C0CCHK=0 ; CHECKSUM FLAG
    49     D ASETUP ; SET UP VARIABLES AND GLOBALS
    50     D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE
    51     I '$D(@RIMBASE@("RESUME")) S @RIMBASE@("RESUME")=$O(^DPT(0)) ; FIRST TIME
    52     S RESUME=@RIMBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN
    53     S RIMDFN=BEGDFN ; BEGIN WITH THE BEGDFN PATIENT
    54     I RIMDFN="" S RIMDFN=RESUME
    55     I +RIMDFN=0 D  Q  ; AT THE END OF THE PATIENTS
    56     . W "END OF PATIENT LIST, CALL RESET^C0CRIMA",!
    57     I '$D(APARMS) S APARMS="" ; DEFAULT NO OVERRIDE PARMS
    58     F RIMI=1:1:DFNCNT  D  Q:+RIMDFN=0  ; FOR DFNCNT NUMBER OF PATIENTS OR END
    59     . K @RIMBASE@("VARS",RIMDFN) ; CLEAR OUT OLD VARS
    60     . D CCRRPC^C0CCCR(.CCRGLO,RIMDFN,APARMS,"CCR") ;PROCESS THE CCR
    61     . W RIMDFN,!
    62     . ;
    63     . ; COPY ALL THE VARIABLES TO THE RIM MAP AREA INDEXED BY PATIENT
    64     . ;
    65     . I $D(^TMP("C0CCCR",$J,"PROBVALS",1)) D  ; PROBLEM VARS EXISTS
    66     . . M @RIMBASE@("VARS",RIMDFN,"PROBLEMS")=^TMP("C0CCCR",$J,"PROBVALS")
    67     . . S @RIMBASE@("VARS",RIMDFN,"PROBLEMS",0)=$O(^TMP("C0CCCR",$J,"PROBVALS",""),-1)
    68     . I $D(^TMP("C0CCCR",$J,"VITALS",1)) D  ; VITALS VARS EXISTS
    69     . . M @RIMBASE@("VARS",RIMDFN,"VITALS")=^TMP("C0CCCR",$J,"VITALS")
    70     . I $D(^TMP("C0CCCR",$J,"MEDMAP",1)) D  ; MEDS VARS EXISTS
    71     . . M @RIMBASE@("VARS",RIMDFN,"MEDS")=^TMP("C0CCCR",$J,"MEDMAP")
    72     . I $D(^TMP("C0CCCR",$J,"ALERTS",1,"ALERTOBJECTID")) D  ; ALERTS EXIST
    73     . . W "FOUND ALERT VARS",!
    74     . . M @RIMBASE@("VARS",RIMDFN,"ALERTS")=^TMP("C0CCCR",$J,"ALERTS")
    75     . I $D(^TMP("C0CCCR",$J,"RESULTS",0)) D  ; RESULTS EXIST
    76     . . W "FOUND RESULTS VARS",!
    77     . . M @RIMBASE@("VARS",RIMDFN,"RESULTS")=^TMP("C0CCCR",$J,"RESULTS")
    78     . S C0CCHK=0
    79     . I $$CHKSUM(RIMDFN) D  ; CHECKSUM HAS CHANGED
    80     . . W "CHECKSUM IS NEW OR HAS CHANGED",!
    81     . . ;ZWR ^TMP("C0CRIM","CHKSUM",RIMDFN,*)
    82     . . S C0CCHK=1
    83     . K ^TMP("C0CCCR",$J) ; KILL WORK AREA FOR CCR BUILDING
    84     . ;
    85     . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP
    86     . ;
    87     . S RATTR=$$SETATTR(RIMDFN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS
    88     . S @RIMBASE@("ATTR",RIMDFN)=RATTR ; SAVE THE ATRIBUTES FOR THIS PAT
    89     . ;
    90     . ; INCREMENT THE COUNT OF PATIENTS WITH THESE ATTRIBUTES IN ATTRTBL
    91     . ;
    92     . ; I '$D(@RIMBASE@("ATTRTBL",RATTR)) D  ; IF FIRST PAT WITH THESE ATTRS
    93     . ; . S @RIMBASE@("ATTRTBL",RATTR)=0 ; DEFAULT VALUE TO BE INCREMENTED
    94     . ; S @RIMBASE@("ATTRTBL",RATTR)=@RIMBASE@("ATTRTBL",RATTR)+1 ; INCREMENT
    95     . ;
    96     . N CATNAME,CATTBL
    97     . ; S CATBASE=$NA(@RIMBASE@("ANALYSIS"))
    98     . S CATNAME=""
    99     . D CPUSH(.CATNAME,RIMBASE,"RIMTBL",RIMDFN,RATTR) ; ADD TO CATEGORY
    100     . W "CATEGORY NAME: ",CATNAME,!
    101     . ;
    102     . F  S RIMDFN=$O(^DPT(RIMDFN)) Q:'$$PTST^C0CSYS(RIMDFN) ; NEXT PATIENT
    103     . ; PTST TESTS TO SEE IF PATIENT WAS MERGED
    104     . ; IF CCRTEST=0, PTST WILL CHECK TO SEE IF THIS IS A TEST PATIENT
    105     . ; AND WE SKIP IT
    106     . S @RIMBASE@("RESUME")=RIMDFN ; WHERE WE ARE LEAVING OFF THIS RUN
    107     ; D PARY^C0CXPATH(@RIMBASE@("ATTRTBL"))
    108     Q
    109     ;
    110 SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS
    111     N SBASE,SATTR
    112     S SBASE=$NA(@RIMBASE@("VARS",SDFN))
    113     D APOST("SATTR","RIMTBL","HEADER")
    114     I $D(@SBASE@("PROBLEMS",1)) D  ;
    115     . D APOST("SATTR","RIMTBL","PROBLEMS")
    116     . ; W "POSTING PROBLEMS",!
    117     I $D(@SBASE@("VITALS",1)) D APOST("SATTR","RIMTBL","VITALS")
    118     I $D(@SBASE@("IMMUNE",1)) D  ;IMMUNIZATIONS PRESENT
    119     . D APOST("SATTR","RIMTBL","IMMUNE")
    120     . N ZR,ZI
    121     . D GETPA(.ZR,SDFN,"IMMUNE","IMMUNEPRODUCTCODE")
    122     . I ZR(0)>0 D APOST("SATTR","RIMTBL","IMMUNECODE") ;IMMUNIZATION CODES
    123     I $D(@SBASE@("MEDS",1)) D  ; IF THE PATIENT HAS MEDS VARIABLES
    124     . D APOST("SATTR","RIMTBL","MEDS")
    125     . N ZR,ZI
    126     . D GETPA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES
    127     . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
    128     . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
    129     . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","MEDSCODE") ;CODES
    130     . ; D PATD^C0CRIMA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES
    131     I $D(@SBASE@("ALERTS",1)) D  ; IF THE PATIENT HAS ALERTS
    132     . D APOST("SATTR","RIMTBL","ALERTS")
    133     . N ZR,ZI
    134     . D GETPA(.ZR,SDFN,"ALERTS","ALERTAGENTPRODUCTCODEVALUE") ;REACTANT CODES
    135     . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
    136     . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
    137     . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","ALERTSCODE") ;CODES
    138     I $D(@SBASE@("RESULTS",1)) D  ; IF THE PATIENT HAS LABS VARIABLES
    139     . D APOST("SATTR","RIMTBL","RESULTS")
    140     . N ZR,ZI
    141     . S ZR(0)=0 ; INITIALIZE TO NONE
    142     . D RPCGV(.ZR,SDFN,"RESULTS") ;CHECK FOR LABS CODES
    143     . ; D PARY^C0CXPATH("ZR") ;
    144     . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
    145     . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
    146     . . . I $P(ZR(ZI),"^",2)="RESULTTESTCODINGSYSTEM" D  ; LOINC CODE CHECK
    147     . . . . I $P(ZR(ZI),"^",3)="LOINC" D APOST("SATTR","RIMTBL","RESULTSLN") ;
    148     ; D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED
    149     I $D(@SBASE@("PROCEDURES",1)) D  ;
    150     . D APOST("SATTR","RIMTBL","PROCEDURES")
    151     W "ATTRIBUTES: ",SATTR,!
    152     Q SATTR
    153     ;
    154 RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES
    155     K ^TMP("C0CRIM","RESUME")
    156     K ^TMP("C0CRIM")
    157     Q
    158     ;
    159 CLIST ; LIST THE CATEGORIES
    160     ;
    161     I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
    162     N CLBASE,CLNUM,ZI,CLIDX
    163     S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS"))
    164     S CLNUM=@CLBASE@(0)
    165     F ZI=1:1:CLNUM D  ; LOOP THROUGH THE CATEGORIES
    166     . S CLIDX=@CLBASE@(ZI)
    167     . W "(",$P(@CLBASE@(CLIDX),"^",1)
    168     . W ":",$P(@CLBASE@(CLIDX),"^",2),") "
    169     . W CLIDX,!
    170     ; D PARY^C0CXPATH(CLBASE)
    171     Q
    172     ;
    173 CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES
    174     ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT
    175     ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE
    176     ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME
    177     ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES,
    178     ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X"
    179     ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES
    180     ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY
    181     ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING
    182     ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY
    183     ; NUMBER IE CTBL_X(CDFN)=""
    184     ;
    185     ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST
    186     S CCTBL=$NA(@CBASE@(CTBL,"CATS"))
    187     W "CBASE: ",CCTBL,!
    188     ;
    189     I '$D(@CCTBL@(CATTR)) D  ; FIRST PATIENT IN THIS CATEGORY
    190     . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY
    191     . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY
    192     . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT
    193     . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY
    194     . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME
    195     . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0
    196     ;
    197     S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY
    198     S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT
    199     S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK
    200     ;
    201     S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED
    202     ;
    203     S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT
    204     W "PATS BASE: ",CPATLIST,!
    205     S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST
    206     ;
    207     Q
    208     ;
    209 CHKSUM(CKDFN) ; DOES A CHECKSUM AND STORES IT IN MUMPS GLOBALS
    210  ;
    211  S C0CCKB=$NA(^TMP("C0CRIM","CHKSUM")) ;CHECKSUM BASE
    212  S C0CGLB=$NA(^TMP("C0CRIM","VARS")) ;CCR VARIABLE BASE
    213  S C0CI=""
    214  F  S C0CI=$O(@C0CGLB@(CKDFN,C0CI)) Q:C0CI=""  D  ;FOR EACH DOMAIN
    215  . ;W "DFN:",CKDFN," DOMAIN:",C0CI,!
    216  . S C0CJ=$NA(@C0CGLB@(CKDFN,C0CI))
    217  . I C0CI="HEADER" D  ; HAVE TO TAKE OUT THE "DATE GENERATED"
    218  . . S C0CDT=@C0CGLB@(CKDFN,C0CI,1,"DATETIME")
    219  . . K @C0CGLB@(CKDFN,C0CI,1,"DATETIME")
    220  . S C0CCK(C0CI)=$$CHKSUM^XUSESIG1(C0CJ)
    221  . I C0CI="HEADER" D  ; PUT IT BACK
    222  . . S @C0CGLB@(CKDFN,C0CI,1,"DATETIME")=C0CDT
    223  S C0CK="C0CCK" ;
    224  S C0CALL=$$CHKSUM^XUSESIG1(C0CK) ;CHECKSUM OF ALL DOMAIN CHECKSUMS
    225  S CHKR=0 ; RESULT DEFAULT
    226  I $D(^TMP("C0CRIM","CHKSUM",CKDFN,"ALL")) D  ; OLD CHECKSUM EXISTS
    227  . I @C0CCKB@(CKDFN,"ALL")'=C0CALL S CHKR=1
    228  E  S CHKR=1 ;CHECKSUM IS NEW
    229  S @C0CCKB@(CKDFN,"ALL")=C0CALL
    230  M @C0CCKB@(CKDFN,"DOMAIN")=C0CCK
    231  ;ZWR ^TMP("C0CRIM","CHKSUM",CKDFN,*)
    232  Q CHKR
    233  ;
    234 CCOUNT ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE
    235     ;
    236     I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
    237     N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT
    238     S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES
    239     S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS
    240     S ZTOT=0 ; INITIALIZE OVERALL TOTAL
    241     F ZI=1:1:@ZCBASE@(0) D  ; FOR ALL CATS
    242     . S ZCNT=0
    243     . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY
    244     . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME
    245     . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST
    246     . ; F ZJ=0:0 D  Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS
    247     . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT
    248     . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,!
    249     . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX))
    250     . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT)))
    251     . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD
    252     . S ZTOT=ZTOT+ZCNT
    253     W "TOTAL: ",ZTOT,!
    254     Q
    255     ;
    256 CNTLST(INLST) ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST
    257     ; INLST IS PASSED BY NAME
    258     N ZI,ZDX,ZCOUNT
    259     W INLST,!
    260     S ZCOUNT=0
    261     S ZDX=""
    262     F ZI=$O(@INLST@(ZDX)):0 D  Q:$O(@INLST@(ZDX))=""  ; LOOP UNTIL THE END
    263     . S ZCOUNT=ZCOUNT+1
    264     . S ZDX=$O(@INLST@(ZDX))
    265     . W "ZDX:",ZDX," ZCNT:",ZCOUNT,!
    266     Q ZCOUNT
    267     ;
    268 XCPAT(CPATCAT,CPATPARM) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT
    269     ;
    270     I '$D(CPATPARM) S CPATPARM=""
    271     I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
    272     N ZI,ZJ,ZC,ZPATBASE
    273     S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT))
    274     S ZI=""
    275     F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
    276     . S ZI=$O(@ZPATBASE@(ZI))
    277     . D XPAT^C0CCCR(ZI,CPATPARM) ; EXPORT THE PATIENT TO A FILE
    278     Q
    279     ;
    280 CPAT(CPATCAT) ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT
    281     ;
    282     I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
    283     N ZI,ZJ,ZC,ZPATBASE
    284     S ZC=0 ; COUNT FOR SPACING THE PRINTOUT
    285     S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT))
    286     S ZI=""
    287     F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
    288     . S ZI=$O(@ZPATBASE@(ZI))
    289     . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT
    290     . W ZI," "
    291     . I ZC=10 D  ; NEW LINE
    292     . . S ZC=0
    293     . . W !
    294     Q
    295     ;
    296 PATC(DFN) ; DISPLAY THE CATEGORY FOR THIS PATIENT
    297     ;
    298     N ATTR S ATTR=""
    299     I '$D(^TMP("C0CRIM","ATTR",DFN)) D  ; RIM VARS NOT PRESENT
    300     . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT
    301     S ATTR=^TMP("C0CRIM","ATTR",DFN)
    302     I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q  ;NO ATTRIBUTES FOUND
    303     I $D(^TMP("C0CRIM","RIMTBL","CATS",ATTR)) D  ; FOUND A CAT
    304     . N CAT
    305     . S CAT=$P(^TMP("C0CRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT
    306     . W CAT,": ",ATTR,!
    307     Q
    308     ;
    309 APUSH(AMAP,AVAL) ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME)
    310     ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT
    311     ; AND AMAP(N)=AVAL IS THE NTH AVAL
    312     ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE
    313     ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE
    314     ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED
    315     ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED
    316     ;
    317     I '$D(@AMAP) D  ; IF THE MAP DOES NOT EXIST
    318     . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS
    319     S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT
    320     S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY
    321     S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF
    322     Q
    323     ;
    324 ASETUP ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL
    325       I '$D(RIMBASE) S RIMBASE=$NA(^TMP("C0CRIM"))
    326       I '$D(@RIMBASE) S @RIMBASE=""
    327       I '$D(RIMTBL) S RIMTBL=$NA(^TMP("C0CRIM","RIMTBL","TABLE")) ; ATTR TABLE
    328       S ^TMP("C0CRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES
    329       Q
    330       ;
    331 AINIT ; INITIALIZE ATTRIBUTE TABLE
    332       I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
    333       K @RIMTBL
    334       D APUSH(RIMTBL,"EXTRACTED")
    335       D APUSH(RIMTBL,"NOTEXTRACTED")
    336       D APUSH(RIMTBL,"HEADER")
    337       D APUSH(RIMTBL,"NOPCP")
    338       D APUSH(RIMTBL,"PCP")
    339       D APUSH(RIMTBL,"PROBLEMS")
    340       D APUSH(RIMTBL,"PROBCODE")
    341       D APUSH(RIMTBL,"PROBNOCODE")
    342       D APUSH(RIMTBL,"PROBDATE")
    343       D APUSH(RIMTBL,"PROBNODATE")
    344       D APUSH(RIMTBL,"VITALS")
    345       D APUSH(RIMTBL,"VITALSCODE")
    346       D APUSH(RIMTBL,"VITALSNOCODE")
    347       D APUSH(RIMTBL,"VITALSDATE")
    348       D APUSH(RIMTBL,"VITALSNODATE")
    349       D APUSH(RIMTBL,"IMMUNE")
    350       D APUSH(RIMTBL,"IMMUNECODE")
    351       D APUSH(RIMTBL,"MEDS")
    352       D APUSH(RIMTBL,"MEDSCODE")
    353       D APUSH(RIMTBL,"MEDSNOCODE")
    354       D APUSH(RIMTBL,"MEDSDATE")
    355       D APUSH(RIMTBL,"MEDSNODATE")
    356       D APUSH(RIMTBL,"ALERTS")
    357       D APUSH(RIMTBL,"ALERTSCODE")
    358       D APUSH(RIMTBL,"RESULTS")
    359       D APUSH(RIMTBL,"RESULTSLN")
    360       D APUSH(RIMTBL,"PROCEDURES")
    361       D APUSH(RIMTBL,"ENCOUNTERS")
    362       D APUSH(RIMTBL,"NOTES")
    363       Q
    364       ;
    365 APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL
    366     ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING
    367     ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES
    368     ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL))
    369     I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING
    370     N USETBL
    371     I '$D(@RIMBASE@("TABLES",PTBL)) D  Q  ; NO TABLE
    372     . W "ERROR NO SUCH TABLE",!
    373     S USETBL=@RIMBASE@("TABLES",PTBL)
    374     S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL
    375     Q
    376 GETPA(RTN,DFN,ISEC,IVAR) ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN
    377     ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT")
    378     ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2
    379     ; IN SECTION "MEDS"
    380     ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS
    381     ; PENDING FOR MED 2 FOR PATIENT 2
    382     ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE
    383     ; RETURNED. RTN IS PASSED BY REFERENCE
    384     ;
    385     S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE
    386     I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES
    387     S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES
    388     I '$D(@ZVBASE@(DFN,ISEC,0)) D  Q ; NO VARIABLES IN SECTION
    389     . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,!
    390     N ZZI,ZZS
    391     S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT
    392     ; ZWR @ZZS@(1)
    393     S RTN(0)=@ZZS@(0)
    394     F ZZI=1:1:RTN(0) D  ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS)
    395     . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE
    396     . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE
    397     Q
    398     ;
    399 PATD(DFN,ISEC,IVAR) ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR
    400     ;
    401     N ZR
    402     D GETPA(.ZR,DFN,ISEC,IVAR)
    403     I $D(ZR(0)) D PARY^C0CXPATH("ZR")
    404     E  W "NOTHING RETURNED",!
    405     Q
    406     ;
    407 CAGET(RTN,IATTR) ;
    408     ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR
    409     ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE
    410     ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC
    411     Q
    412     ;
    413 PCLST(LSTRTN,IATTR) ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR
    414     ;
    415     I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES
    416     N ZLST
    417     S @LSTRTN@(0)=0 ; DEFAULT RETURN NONE
    418     S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES
    419     S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS
    420     N ZNC  ; ZNC IS NUMBER OF CATEGORIES
    421     S ZNC=@ZCBASE@(0)
    422     I ZNC=0 Q ; NO CATEGORIES TO SEARCH
    423     N ZAP  ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE
    424     S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR)
    425     N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT
    426     F ZI=1:1:ZNC D  ; FOR ALL CATEGORIES
    427     . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT
    428     . I $P(ZATBL,"^",ZAP)'="" D  ; CAT HAS ATTR
    429     . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL
    430     . . M @LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT
    431     S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS
    432     S ZPAT=0 ; START AT FIRST PATIENT IN LIST
    433     F  S ZPAT=$O(@LSTRTN@(ZPAT)) Q:ZPAT=""  D  ;
    434     . S ZCNT=ZCNT+1
    435     S @LSTRTN@(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY
    436     Q
    437     ;
    438 DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR
    439     ;
    440     ;N ZR
    441     D PCLST("ZR",CATTR)
    442     I ZR(0)=0 D  Q  ;
    443     . W "NO PATIENTS RETURNED",!
    444     E  D  ;
    445     . N ZI S ZI=0
    446     . F  S ZI=$O(ZR(ZI)) Q:ZI=""  D  ;
    447     . . W !,ZI
    448     . ;D PARY^C0CXPATH("ZR") ; PRINT ARRAY
    449     . W !,"COUNT=",ZR(0)
    450     Q
    451     ;
    452 RPCGV(RTN,DFN,WHICH) ; RPC GET VARS
    453  ; RETURNS IN RTN (PASSED BY REFERENCE) THE VARS AND VALUES
    454  ; FOUND AT INARY RTN(X)="VAR^VALUE" RTN(0) IS THE COUNT
    455  ; DFN IS THE PATIENT NUMBER.
    456  ; WHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","IMMUNE"
    457  ; OR OTHER SECTIONS AS THEY ARE ADDED
    458  ; THIS IS MEANT TO BE AVAILABLE AS AN RPC
    459  I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
    460  S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES
    461  S RTN(0)=0 ; DEFAULT NOTHING IS RETURNED
    462  N ZZGI
    463  I WHICH="ALL" D  ; VARIABLES FROM ALL SECTIONS
    464  . F ZZGI="HEADER","PROBLEMS","VITALS","MEDS","ALERTS","RESULTS","IMMUNE","PROCEDURES" D  ;
    465  . . D ZGVWRK(ZZGI) ; DO EACH SECTION
    466  . . I $G(DEBUG)'="" W "DID ",ZZGI,!
    467  E  D ZGVWRK(WHICH) ; ONLY ONE SECTION ASKED FOR
    468  Q
    469  ;
    470 ZGVWRK(ZWHICH) ; DO ONE SECTION FOR RPCGV
    471     ;
    472     N ZZGN ; NAME FOR SECTION VARIABLES
    473     S ZZGN=$NA(@ZVBASE@(DFN,ZWHICH)) ; BASE OF VARS FOR SECTION
    474     ;I '$D(@ZZGN@(0)) Q ; NO VARS FOR THIS SECTION
    475     I $O(@ZZGN@(""),-1)=""  D  ;
    476     E  D  ; VARS EXIST
    477     . N ZGVI,ZGVN
    478     . S ZGVN=$O(@ZZGN@(""),-1) ;COUNT OF VARS
    479     . F ZGVI=1:1:ZGVN D  ; FOR EACH MULTIPLE IN SECTION
    480     . . K ZZGA N ZZGA ; TEMP ARRAY FOR SECTION VARS
    481     . . K ZZGN2 N ZZGN2 ; NAME FOR MULTIPLE
    482     . . S ZZGN2=$NA(@ZZGN@(ZGVI))
    483     . . I $G(DEBUG)'="" W ZZGN2,!,$O(@ZZGN2@("")),!
    484     . . D H2ARY^C0CXPATH("ZZGA",ZZGN2,ZGVI) ; CONVERT HASH TO ARRAY
    485     . . ; D PARY^C0CXPATH("ZZGA")
    486     . . D PUSHA^C0CXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN
    487     Q
    488     ;
    489 DPATV(DFN,IWHICH) ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN C0CRIM
    490     ; ALONG WITH SAMPLE VALUES.
    491     ; IWHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","HEADER"
    492     N GTMP
    493     I '$D(^TMP("C0CRIM","ATTR",DFN)) D  ; RIM VARS NOT PRESENT
    494     . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES
    495     I '$D(IWHICH) S IWHICH="ALL"
    496     D RPCGV(.GTMP,DFN,IWHICH)
    497     D PARY^C0CXPATH("GTMP")
    498     Q
    499     ;
    500 RIM2RNF(R2RTN,DFN,RWHICH) ; CONVERTS RIM VARIABLES TO RNF2 FORMAT
    501  ; RETURN IN R2RTN, WHICH IS PASSED BY NAME
    502  ; RWHICH IS RIM SECTION TO RETURN, DEFAULTS TO "ALL"
    503  ;
    504  I '$D(RWHICH) S RWHICH="ALL"
    505  ;N R2TMP
    506  I '$D(^TMP("C0CRIM","ATTR",DFN)) D  ; RIM VARS NOT PRESENT
    507  . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES
    508  D RPCGV(.R2TMP,DFN,RWHICH) ; RETRIEVE ALL THE VARIABLES I AN ARRAY
    509  N R2I,R2J,R2X,R2X1,R2X2,R2Y,R2Z
    510  F R2I=1:1:R2TMP(0) D  ; FOR EVERY LINE OF THE ARRAY
    511  . S R2X=$P(R2TMP(R2I),"^",1) ; OCCURANCE
    512  . S R2Y=$P(R2TMP(R2I),"^",2) ; VARIABLE NAME
    513  . I $L(R2Y)<4 Q  ; SKIP SHORT VARIABLES (THEY ARE FOR DEBUGGING)
    514  . S R2Z=$P(R2TMP(R2I),"^",3) ; VALUE
    515  . I R2X[";" D  ; THERES MULTIPLES
    516  . . S R2X1=$P(R2X,";",1) ; FIRST INDEX
    517  . . S R2X2=$P(R2X,";",2) ; SECOND INDEX
    518  . . S R2J=R2Y_"["_R2X2_"]" ; BUILD THE VARIABLE NAME
    519  . . S @R2RTN@("F",R2J,1)="" ; PUT VARIABLE NAME IN FIELD MAP
    520  . . S @R2RTN@("V",R2X1,R2J,1)=R2Z ; PUT THE VALUE IN THE ARRAY
    521  . E  D  ; NO SUB-MULTIPLES
    522  . . S @R2RTN@("F",R2Y,1)="" ; PUT VARIABLE NAME IN FIELD MAP
    523  . . S @R2RTN@("V",R2X,R2Y,1)=R2Z ; PUT THE VALUE IN THE ARRAY
    524  Q
    525  ;
    526 RIM2CSV(DFN) ; WRITE THE RIM VARIABLES FOR A PATIENT TO A CSV FILE
    527  ;
    528  N R2CTMP,R2CARY
    529  D RIM2RNF("R2CTMP",DFN) ; CONVERT VARIABLES TO RNF FORMAT
    530  D RNF2CSV^C0CRNF("R2CARY","R2CTMP","NV") ; CONVERT RNF TO CSV FORMAT
    531  D FILEOUT^C0CRNF("R2CARY","VARS-"_DFN_".csv")
    532  Q
    533  ;
     1C0CRIMA   ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        ; THESE ROUTINES EXAMINE ONE OR MORE, UP TO ALL, OF THE PATIENTS ON THE
     22        ; SYSTEM TO DETERMINE HOW COMPLETE THE RESULTING CCR OR CCD WOULD BE FOR
     23        ; THESE PATIENTS. IT BEGINS TO MEASURE "HL7 RIM COHERENCE" WHICH IS HOW USEFUL
     24        ; THE VARIABLES WILL BE TO A RIM-MODELED APPLICATION AFTER THEY ARE
     25        ; CONVEYED VIA THE CCR OR CCD.
     26        ; FACTORS THAT AFFECT RIM COHERENCE INCLUDE:
     27        ;    1. THE PRESENSE OF CLINICAL DATA IN A SECTION
     28        ;    2. ARE THE DATA ELEMENTS TIME-BOUND
     29        ;    3. ARE THE DATA ELEMENTS CODED WITH SNOMED OR LOINC ETC
     30        ;    4. ARE SOURCE ACTORS ASSOCIATED WITH THE DATA ELEMENTS
     31        ;    5. ARE ACTORS IDENTIFIED REGARDING THEIR ROLE
     32        ;    .. AND OTHER FACTORS YET TO BE DETERMINED
     33        ;
     34        ;    SINCE THESE MEASUREMENTS ARE DONE AT THE VARIABLE LEVEL, THEY
     35        ;    REFLECT ON RIM COHERENCE WHETHER THE CCR OR THE CCD IS USED FOR
     36        ;    CONVEYANCE TO THE RIM APPLICATION.
     37        ;
     38        ;
     39ANALYZE(BEGDFN,DFNCNT,APARMS)   ; RIM COHERANCE ANALYSIS ROUTINE
     40           ; BEGINS AT BEGDFN AND GOES FOR DFNCNT PATIENTS
     41           ; TO RESUME AT NEXT PATIENT, USE BEGDFN=""
     42           ; USE RESET^C0CRIMA TO RESET TO TOP OF PATIENT LIST
     43           ; APARMS ARE PARAMETERS TO BE USED IN THE EXTRACTION
     44           ; SEE C0CPARMS FOR SUPPORTED PARAMTERS
     45           ;
     46           N RIMARY,RIMTMP,RIMI,RIMDFN,RATTR
     47           N CCRGLO
     48           S C0CCHK=0 ; CHECKSUM FLAG
     49           D ASETUP ; SET UP VARIABLES AND GLOBALS
     50           D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE
     51           I '$D(@RIMBASE@("RESUME")) S @RIMBASE@("RESUME")=$O(^DPT(0)) ; FIRST TIME
     52           S RESUME=@RIMBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN
     53           S RIMDFN=BEGDFN ; BEGIN WITH THE BEGDFN PATIENT
     54           I RIMDFN="" S RIMDFN=RESUME
     55           I +RIMDFN=0 D  Q  ; AT THE END OF THE PATIENTS
     56           . W "END OF PATIENT LIST, CALL RESET^C0CRIMA",!
     57           I '$D(APARMS) S APARMS="" ; DEFAULT NO OVERRIDE PARMS
     58           F RIMI=1:1:DFNCNT  D  Q:+RIMDFN=0  ; FOR DFNCNT NUMBER OF PATIENTS OR END
     59           . K @RIMBASE@("VARS",RIMDFN) ; CLEAR OUT OLD VARS
     60           . D CCRRPC^C0CCCR(.CCRGLO,RIMDFN,APARMS,"CCR") ;PROCESS THE CCR
     61           . W RIMDFN,!
     62           . ;
     63           . ; COPY ALL THE VARIABLES TO THE RIM MAP AREA INDEXED BY PATIENT
     64           . ;
     65           . I $D(^TMP("C0CCCR",$J,"PROBVALS",1)) D  ; PROBLEM VARS EXISTS
     66           . . M @RIMBASE@("VARS",RIMDFN,"PROBLEMS")=^TMP("C0CCCR",$J,"PROBVALS")
     67           . . S @RIMBASE@("VARS",RIMDFN,"PROBLEMS",0)=$O(^TMP("C0CCCR",$J,"PROBVALS",""),-1)
     68           . I $D(^TMP("C0CCCR",$J,"VITALS",1)) D  ; VITALS VARS EXISTS
     69           . . M @RIMBASE@("VARS",RIMDFN,"VITALS")=^TMP("C0CCCR",$J,"VITALS")
     70           . I $D(^TMP("C0CCCR",$J,"MEDMAP",1)) D  ; MEDS VARS EXISTS
     71           . . M @RIMBASE@("VARS",RIMDFN,"MEDS")=^TMP("C0CCCR",$J,"MEDMAP")
     72           . I $D(^TMP("C0CCCR",$J,"ALERTS",1,"ALERTOBJECTID")) D  ; ALERTS EXIST
     73           . . W "FOUND ALERT VARS",!
     74           . . M @RIMBASE@("VARS",RIMDFN,"ALERTS")=^TMP("C0CCCR",$J,"ALERTS")
     75           . I $D(^TMP("C0CCCR",$J,"RESULTS",0)) D  ; RESULTS EXIST
     76           . . W "FOUND RESULTS VARS",!
     77           . . M @RIMBASE@("VARS",RIMDFN,"RESULTS")=^TMP("C0CCCR",$J,"RESULTS")
     78           . S C0CCHK=0
     79           . I $$CHKSUM(RIMDFN) D  ; CHECKSUM HAS CHANGED
     80           . . W "CHECKSUM IS NEW OR HAS CHANGED",!
     81           . . ;ZWR ^TMP("C0CRIM","CHKSUM",RIMDFN,*)
     82           . . S C0CCHK=1
     83           . K ^TMP("C0CCCR",$J) ; KILL WORK AREA FOR CCR BUILDING
     84           . ;
     85           . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP
     86           . ;
     87           . S RATTR=$$SETATTR(RIMDFN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS
     88           . S @RIMBASE@("ATTR",RIMDFN)=RATTR ; SAVE THE ATRIBUTES FOR THIS PAT
     89           . ;
     90           . ; INCREMENT THE COUNT OF PATIENTS WITH THESE ATTRIBUTES IN ATTRTBL
     91           . ;
     92           . ; I '$D(@RIMBASE@("ATTRTBL",RATTR)) D  ; IF FIRST PAT WITH THESE ATTRS
     93           . ; . S @RIMBASE@("ATTRTBL",RATTR)=0 ; DEFAULT VALUE TO BE INCREMENTED
     94           . ; S @RIMBASE@("ATTRTBL",RATTR)=@RIMBASE@("ATTRTBL",RATTR)+1 ; INCREMENT
     95           . ;
     96           . N CATNAME,CATTBL
     97           . ; S CATBASE=$NA(@RIMBASE@("ANALYSIS"))
     98           . S CATNAME=""
     99           . D CPUSH(.CATNAME,RIMBASE,"RIMTBL",RIMDFN,RATTR) ; ADD TO CATEGORY
     100           . W "CATEGORY NAME: ",CATNAME,!
     101           . ;
     102           . F  S RIMDFN=$O(^DPT(RIMDFN)) Q:'$$PTST^C0CSYS(RIMDFN) ; NEXT PATIENT
     103           . ; PTST TESTS TO SEE IF PATIENT WAS MERGED
     104           . ; IF CCRTEST=0, PTST WILL CHECK TO SEE IF THIS IS A TEST PATIENT
     105           . ; AND WE SKIP IT
     106           . S @RIMBASE@("RESUME")=RIMDFN ; WHERE WE ARE LEAVING OFF THIS RUN
     107           ; D PARY^C0CXPATH(@RIMBASE@("ATTRTBL"))
     108           Q
     109           ;
     110SETATTR(SDFN)   ; SET ATTRIBUTES BASED ON VARS
     111           N SBASE,SATTR
     112           S SBASE=$NA(@RIMBASE@("VARS",SDFN))
     113           D APOST("SATTR","RIMTBL","HEADER")
     114           I $D(@SBASE@("PROBLEMS",1)) D  ;
     115           . D APOST("SATTR","RIMTBL","PROBLEMS")
     116           . ; W "POSTING PROBLEMS",!
     117           I $D(@SBASE@("VITALS",1)) D APOST("SATTR","RIMTBL","VITALS")
     118           I $D(@SBASE@("IMMUNE",1)) D  ;IMMUNIZATIONS PRESENT
     119           . D APOST("SATTR","RIMTBL","IMMUNE")
     120           . N ZR,ZI
     121           . D GETPA(.ZR,SDFN,"IMMUNE","IMMUNEPRODUCTCODE")
     122           . I ZR(0)>0 D APOST("SATTR","RIMTBL","IMMUNECODE") ;IMMUNIZATION CODES
     123           I $D(@SBASE@("MEDS",1)) D  ; IF THE PATIENT HAS MEDS VARIABLES
     124           . D APOST("SATTR","RIMTBL","MEDS")
     125           . N ZR,ZI
     126           . D GETPA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES
     127           . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
     128           . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
     129           . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","MEDSCODE") ;CODES
     130           . ; D PATD^C0CRIMA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES
     131           I $D(@SBASE@("ALERTS",1)) D  ; IF THE PATIENT HAS ALERTS
     132           . D APOST("SATTR","RIMTBL","ALERTS")
     133           . N ZR,ZI
     134           . D GETPA(.ZR,SDFN,"ALERTS","ALERTAGENTPRODUCTCODEVALUE") ;REACTANT CODES
     135           . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
     136           . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
     137           . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","ALERTSCODE") ;CODES
     138           I $D(@SBASE@("RESULTS",1)) D  ; IF THE PATIENT HAS LABS VARIABLES
     139           . D APOST("SATTR","RIMTBL","RESULTS")
     140           . N ZR,ZI
     141           . S ZR(0)=0 ; INITIALIZE TO NONE
     142           . D RPCGV(.ZR,SDFN,"RESULTS") ;CHECK FOR LABS CODES
     143           . ; D PARY^C0CXPATH("ZR") ;
     144           . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
     145           . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
     146           . . . I $P(ZR(ZI),"^",2)="RESULTTESTCODINGSYSTEM" D  ; LOINC CODE CHECK
     147           . . . . I $P(ZR(ZI),"^",3)="LOINC" D APOST("SATTR","RIMTBL","RESULTSLN") ;
     148           ; D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED
     149           I $D(@SBASE@("PROCEDURES",1)) D  ;
     150           . D APOST("SATTR","RIMTBL","PROCEDURES")
     151           W "ATTRIBUTES: ",SATTR,!
     152           Q SATTR
     153           ;
     154RESET   ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES
     155           K ^TMP("C0CRIM","RESUME")
     156           K ^TMP("C0CRIM")
     157           Q
     158           ;
     159CLIST   ; LIST THE CATEGORIES
     160           ;
     161           I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
     162           N CLBASE,CLNUM,ZI,CLIDX
     163           S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS"))
     164           S CLNUM=@CLBASE@(0)
     165           F ZI=1:1:CLNUM D  ; LOOP THROUGH THE CATEGORIES
     166           . S CLIDX=@CLBASE@(ZI)
     167           . W "(",$P(@CLBASE@(CLIDX),"^",1)
     168           . W ":",$P(@CLBASE@(CLIDX),"^",2),") "
     169           . W CLIDX,!
     170           ; D PARY^C0CXPATH(CLBASE)
     171           Q
     172           ;
     173CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR)     ; ADD PATIENTS TO CATEGORIES
     174           ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT
     175           ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE
     176           ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME
     177           ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES,
     178           ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X"
     179           ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES
     180           ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY
     181           ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING
     182           ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY
     183           ; NUMBER IE CTBL_X(CDFN)=""
     184           ;
     185           ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST
     186           S CCTBL=$NA(@CBASE@(CTBL,"CATS"))
     187           W "CBASE: ",CCTBL,!
     188           ;
     189           I '$D(@CCTBL@(CATTR)) D  ; FIRST PATIENT IN THIS CATEGORY
     190           . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY
     191           . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY
     192           . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT
     193           . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY
     194           . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME
     195           . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0
     196           ;
     197           S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY
     198           S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT
     199           S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK
     200           ;
     201           S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED
     202           ;
     203           S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT
     204           W "PATS BASE: ",CPATLIST,!
     205           S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST
     206           ;
     207           Q
     208           ;
     209CHKSUM(CKDFN)   ; DOES A CHECKSUM AND STORES IT IN MUMPS GLOBALS
     210        ;
     211        S C0CCKB=$NA(^TMP("C0CRIM","CHKSUM")) ;CHECKSUM BASE
     212        S C0CGLB=$NA(^TMP("C0CRIM","VARS")) ;CCR VARIABLE BASE
     213        S C0CI=""
     214        F  S C0CI=$O(@C0CGLB@(CKDFN,C0CI)) Q:C0CI=""  D  ;FOR EACH DOMAIN
     215        . ;W "DFN:",CKDFN," DOMAIN:",C0CI,!
     216        . S C0CJ=$NA(@C0CGLB@(CKDFN,C0CI))
     217        . I C0CI="HEADER" D  ; HAVE TO TAKE OUT THE "DATE GENERATED"
     218        . . S C0CDT=@C0CGLB@(CKDFN,C0CI,1,"DATETIME")
     219        . . K @C0CGLB@(CKDFN,C0CI,1,"DATETIME")
     220        . S C0CCK(C0CI)=$$CHKSUM^XUSESIG1(C0CJ)
     221        . I C0CI="HEADER" D  ; PUT IT BACK
     222        . . S @C0CGLB@(CKDFN,C0CI,1,"DATETIME")=C0CDT
     223        S C0CK="C0CCK" ;
     224        S C0CALL=$$CHKSUM^XUSESIG1(C0CK) ;CHECKSUM OF ALL DOMAIN CHECKSUMS
     225        S CHKR=0 ; RESULT DEFAULT
     226        I $D(^TMP("C0CRIM","CHKSUM",CKDFN,"ALL")) D  ; OLD CHECKSUM EXISTS
     227        . I @C0CCKB@(CKDFN,"ALL")'=C0CALL S CHKR=1
     228        E  S CHKR=1 ;CHECKSUM IS NEW
     229        S @C0CCKB@(CKDFN,"ALL")=C0CALL
     230        M @C0CCKB@(CKDFN,"DOMAIN")=C0CCK
     231        ;ZWR ^TMP("C0CRIM","CHKSUM",CKDFN,*)
     232        Q CHKR
     233        ;
     234CCOUNT  ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE
     235           ;
     236           I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
     237           N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT
     238           S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES
     239           S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS
     240           S ZTOT=0 ; INITIALIZE OVERALL TOTAL
     241           F ZI=1:1:@ZCBASE@(0) D  ; FOR ALL CATS
     242           . S ZCNT=0
     243           . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY
     244           . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME
     245           . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST
     246           . ; F ZJ=0:0 D  Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS
     247           . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT
     248           . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,!
     249           . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX))
     250           . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT)))
     251           . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD
     252           . S ZTOT=ZTOT+ZCNT
     253           W "TOTAL: ",ZTOT,!
     254           Q
     255           ;
     256CNTLST(INLST)   ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST
     257           ; INLST IS PASSED BY NAME
     258           N ZI,ZDX,ZCOUNT
     259           W INLST,!
     260           S ZCOUNT=0
     261           S ZDX=""
     262           F ZI=$O(@INLST@(ZDX)):0 D  Q:$O(@INLST@(ZDX))=""  ; LOOP UNTIL THE END
     263           . S ZCOUNT=ZCOUNT+1
     264           . S ZDX=$O(@INLST@(ZDX))
     265           . W "ZDX:",ZDX," ZCNT:",ZCOUNT,!
     266           Q ZCOUNT
     267           ;
     268XCPAT(CPATCAT,CPATPARM) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT
     269           ;
     270           I '$D(CPATPARM) S CPATPARM=""
     271           I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
     272           N ZI,ZJ,ZC,ZPATBASE
     273           S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT))
     274           S ZI=""
     275           F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
     276           . S ZI=$O(@ZPATBASE@(ZI))
     277           . D XPAT^C0CCCR(ZI,CPATPARM) ; EXPORT THE PATIENT TO A FILE
     278           Q
     279           ;
     280CPAT(CPATCAT)   ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT
     281           ;
     282           I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
     283           N ZI,ZJ,ZC,ZPATBASE
     284           S ZC=0 ; COUNT FOR SPACING THE PRINTOUT
     285           S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT))
     286           S ZI=""
     287           F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
     288           . S ZI=$O(@ZPATBASE@(ZI))
     289           . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT
     290           . W ZI," "
     291           . I ZC=10 D  ; NEW LINE
     292           . . S ZC=0
     293           . . W !
     294           Q
     295           ;
     296PATC(DFN)       ; DISPLAY THE CATEGORY FOR THIS PATIENT
     297           ;
     298           N ATTR S ATTR=""
     299           I '$D(^TMP("C0CRIM","ATTR",DFN)) D  ; RIM VARS NOT PRESENT
     300           . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT
     301           S ATTR=^TMP("C0CRIM","ATTR",DFN)
     302           I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q  ;NO ATTRIBUTES FOUND
     303           I $D(^TMP("C0CRIM","RIMTBL","CATS",ATTR)) D  ; FOUND A CAT
     304           . N CAT
     305           . S CAT=$P(^TMP("C0CRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT
     306           . W CAT,": ",ATTR,!
     307           Q
     308           ;
     309APUSH(AMAP,AVAL)        ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME)
     310           ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT
     311           ; AND AMAP(N)=AVAL IS THE NTH AVAL
     312           ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE
     313           ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE
     314           ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED
     315           ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED
     316           ;
     317           I '$D(@AMAP) D  ; IF THE MAP DOES NOT EXIST
     318           . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS
     319           S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT
     320           S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY
     321           S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF
     322           Q
     323           ;
     324ASETUP  ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL
     325             I '$D(RIMBASE) S RIMBASE=$NA(^TMP("C0CRIM"))
     326             I '$D(@RIMBASE) S @RIMBASE=""
     327             I '$D(RIMTBL) S RIMTBL=$NA(^TMP("C0CRIM","RIMTBL","TABLE")) ; ATTR TABLE
     328             S ^TMP("C0CRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES
     329             Q
     330             ;
     331AINIT   ; INITIALIZE ATTRIBUTE TABLE
     332             I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
     333             K @RIMTBL
     334             D APUSH(RIMTBL,"EXTRACTED")
     335             D APUSH(RIMTBL,"NOTEXTRACTED")
     336             D APUSH(RIMTBL,"HEADER")
     337             D APUSH(RIMTBL,"NOPCP")
     338             D APUSH(RIMTBL,"PCP")
     339             D APUSH(RIMTBL,"PROBLEMS")
     340             D APUSH(RIMTBL,"PROBCODE")
     341             D APUSH(RIMTBL,"PROBNOCODE")
     342             D APUSH(RIMTBL,"PROBDATE")
     343             D APUSH(RIMTBL,"PROBNODATE")
     344             D APUSH(RIMTBL,"VITALS")
     345             D APUSH(RIMTBL,"VITALSCODE")
     346             D APUSH(RIMTBL,"VITALSNOCODE")
     347             D APUSH(RIMTBL,"VITALSDATE")
     348             D APUSH(RIMTBL,"VITALSNODATE")
     349             D APUSH(RIMTBL,"IMMUNE")
     350             D APUSH(RIMTBL,"IMMUNECODE")
     351             D APUSH(RIMTBL,"MEDS")
     352             D APUSH(RIMTBL,"MEDSCODE")
     353             D APUSH(RIMTBL,"MEDSNOCODE")
     354             D APUSH(RIMTBL,"MEDSDATE")
     355             D APUSH(RIMTBL,"MEDSNODATE")
     356             D APUSH(RIMTBL,"ALERTS")
     357             D APUSH(RIMTBL,"ALERTSCODE")
     358             D APUSH(RIMTBL,"RESULTS")
     359             D APUSH(RIMTBL,"RESULTSLN")
     360             D APUSH(RIMTBL,"PROCEDURES")
     361             D APUSH(RIMTBL,"ENCOUNTERS")
     362             D APUSH(RIMTBL,"NOTES")
     363             Q
     364             ;
     365APOST(PRSLT,PTBL,PVAL)  ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL
     366           ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING
     367           ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES
     368           ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL))
     369           I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING
     370           N USETBL
     371           I '$D(@RIMBASE@("TABLES",PTBL)) D  Q  ; NO TABLE
     372           . W "ERROR NO SUCH TABLE",!
     373           S USETBL=@RIMBASE@("TABLES",PTBL)
     374           S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL
     375           Q
     376GETPA(RTN,DFN,ISEC,IVAR)        ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN
     377           ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT")
     378           ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2
     379           ; IN SECTION "MEDS"
     380           ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS
     381           ; PENDING FOR MED 2 FOR PATIENT 2
     382           ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE
     383           ; RETURNED. RTN IS PASSED BY REFERENCE
     384           ;
     385           S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE
     386           I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES
     387           S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES
     388           I '$D(@ZVBASE@(DFN,ISEC,0)) D  Q ; NO VARIABLES IN SECTION
     389           . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,!
     390           N ZZI,ZZS
     391           S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT
     392           ; ZWR @ZZS@(1)
     393           S RTN(0)=@ZZS@(0)
     394           F ZZI=1:1:RTN(0) D  ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS)
     395           . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE
     396           . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE
     397           Q
     398           ;
     399PATD(DFN,ISEC,IVAR)     ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR
     400           ;
     401           N ZR
     402           D GETPA(.ZR,DFN,ISEC,IVAR)
     403           I $D(ZR(0)) D PARY^C0CXPATH("ZR")
     404           E  W "NOTHING RETURNED",!
     405           Q
     406           ;
     407CAGET(RTN,IATTR)        ;
     408           ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR
     409           ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE
     410           ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC
     411           Q
     412           ;
     413PCLST(LSTRTN,IATTR)     ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR
     414           ;
     415           I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES
     416           N ZLST
     417           S @LSTRTN@(0)=0 ; DEFAULT RETURN NONE
     418           S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES
     419           S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS
     420           N ZNC  ; ZNC IS NUMBER OF CATEGORIES
     421           S ZNC=@ZCBASE@(0)
     422           I ZNC=0 Q ; NO CATEGORIES TO SEARCH
     423           N ZAP  ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE
     424           S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR)
     425           N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT
     426           F ZI=1:1:ZNC D  ; FOR ALL CATEGORIES
     427           . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT
     428           . I $P(ZATBL,"^",ZAP)'="" D  ; CAT HAS ATTR
     429           . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL
     430           . . M @LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT
     431           S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS
     432           S ZPAT=0 ; START AT FIRST PATIENT IN LIST
     433           F  S ZPAT=$O(@LSTRTN@(ZPAT)) Q:ZPAT=""  D  ;
     434           . S ZCNT=ZCNT+1
     435           S @LSTRTN@(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY
     436           Q
     437           ;
     438DCPAT(CATTR)    ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR
     439           ;
     440           ;N ZR
     441           D PCLST("ZR",CATTR)
     442           I ZR(0)=0 D  Q  ;
     443           . W "NO PATIENTS RETURNED",!
     444           E  D  ;
     445           . N ZI S ZI=0
     446           . F  S ZI=$O(ZR(ZI)) Q:ZI=""  D  ;
     447           . . W !,ZI
     448           . ;D PARY^C0CXPATH("ZR") ; PRINT ARRAY
     449           . W !,"COUNT=",ZR(0)
     450           Q
     451           ;
     452RPCGV(RTN,DFN,WHICH)    ; RPC GET VARS
     453        ; RETURNS IN RTN (PASSED BY REFERENCE) THE VARS AND VALUES
     454        ; FOUND AT INARY RTN(X)="VAR^VALUE" RTN(0) IS THE COUNT
     455        ; DFN IS THE PATIENT NUMBER.
     456        ; WHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","IMMUNE"
     457        ; OR OTHER SECTIONS AS THEY ARE ADDED
     458        ; THIS IS MEANT TO BE AVAILABLE AS AN RPC
     459        I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
     460        S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES
     461        S RTN(0)=0 ; DEFAULT NOTHING IS RETURNED
     462        N ZZGI
     463        I WHICH="ALL" D  ; VARIABLES FROM ALL SECTIONS
     464        . F ZZGI="HEADER","PROBLEMS","VITALS","MEDS","ALERTS","RESULTS","IMMUNE","PROCEDURES" D  ;
     465        . . D ZGVWRK(ZZGI) ; DO EACH SECTION
     466        . . I $G(DEBUG)'="" W "DID ",ZZGI,!
     467        E  D ZGVWRK(WHICH) ; ONLY ONE SECTION ASKED FOR
     468        Q
     469        ;
     470ZGVWRK(ZWHICH)  ; DO ONE SECTION FOR RPCGV
     471           ;
     472           N ZZGN ; NAME FOR SECTION VARIABLES
     473           S ZZGN=$NA(@ZVBASE@(DFN,ZWHICH)) ; BASE OF VARS FOR SECTION
     474           ;I '$D(@ZZGN@(0)) Q ; NO VARS FOR THIS SECTION
     475           I $O(@ZZGN@(""),-1)=""  D  ;
     476           E  D  ; VARS EXIST
     477           . N ZGVI,ZGVN
     478           . S ZGVN=$O(@ZZGN@(""),-1) ;COUNT OF VARS
     479           . F ZGVI=1:1:ZGVN D  ; FOR EACH MULTIPLE IN SECTION
     480           . . K ZZGA N ZZGA ; TEMP ARRAY FOR SECTION VARS
     481           . . K ZZGN2 N ZZGN2 ; NAME FOR MULTIPLE
     482           . . S ZZGN2=$NA(@ZZGN@(ZGVI))
     483           . . I $G(DEBUG)'="" W ZZGN2,!,$O(@ZZGN2@("")),!
     484           . . D H2ARY^C0CXPATH("ZZGA",ZZGN2,ZGVI) ; CONVERT HASH TO ARRAY
     485           . . ; D PARY^C0CXPATH("ZZGA")
     486           . . D PUSHA^C0CXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN
     487           Q
     488           ;
     489DPATV(DFN,IWHICH)       ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN C0CRIM
     490           ; ALONG WITH SAMPLE VALUES.
     491           ; IWHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","HEADER"
     492           N GTMP
     493           I '$D(^TMP("C0CRIM","ATTR",DFN)) D  ; RIM VARS NOT PRESENT
     494           . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES
     495           I '$D(IWHICH) S IWHICH="ALL"
     496           D RPCGV(.GTMP,DFN,IWHICH)
     497           D PARY^C0CXPATH("GTMP")
     498           Q
     499           ;
     500RIM2RNF(R2RTN,DFN,RWHICH)       ; CONVERTS RIM VARIABLES TO RNF2 FORMAT
     501        ; RETURN IN R2RTN, WHICH IS PASSED BY NAME
     502        ; RWHICH IS RIM SECTION TO RETURN, DEFAULTS TO "ALL"
     503        ;
     504        I '$D(RWHICH) S RWHICH="ALL"
     505        ;N R2TMP
     506        I '$D(^TMP("C0CRIM","ATTR",DFN)) D  ; RIM VARS NOT PRESENT
     507        . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES
     508        D RPCGV(.R2TMP,DFN,RWHICH) ; RETRIEVE ALL THE VARIABLES I AN ARRAY
     509        N R2I,R2J,R2X,R2X1,R2X2,R2Y,R2Z
     510        F R2I=1:1:R2TMP(0) D  ; FOR EVERY LINE OF THE ARRAY
     511        . S R2X=$P(R2TMP(R2I),"^",1) ; OCCURANCE
     512        . S R2Y=$P(R2TMP(R2I),"^",2) ; VARIABLE NAME
     513        . I $L(R2Y)<4 Q  ; SKIP SHORT VARIABLES (THEY ARE FOR DEBUGGING)
     514        . S R2Z=$P(R2TMP(R2I),"^",3) ; VALUE
     515        . I R2X[";" D  ; THERES MULTIPLES
     516        . . S R2X1=$P(R2X,";",1) ; FIRST INDEX
     517        . . S R2X2=$P(R2X,";",2) ; SECOND INDEX
     518        . . S R2J=R2Y_"["_R2X2_"]" ; BUILD THE VARIABLE NAME
     519        . . S @R2RTN@("F",R2J,1)="" ; PUT VARIABLE NAME IN FIELD MAP
     520        . . S @R2RTN@("V",R2X1,R2J,1)=R2Z ; PUT THE VALUE IN THE ARRAY
     521        . E  D  ; NO SUB-MULTIPLES
     522        . . S @R2RTN@("F",R2Y,1)="" ; PUT VARIABLE NAME IN FIELD MAP
     523        . . S @R2RTN@("V",R2X,R2Y,1)=R2Z ; PUT THE VALUE IN THE ARRAY
     524        Q
     525        ;
     526RIM2CSV(DFN)    ; WRITE THE RIM VARIABLES FOR A PATIENT TO A CSV FILE
     527        ;
     528        N R2CTMP,R2CARY
     529        D RIM2RNF("R2CTMP",DFN) ; CONVERT VARIABLES TO RNF FORMAT
     530        D RNF2CSV^C0CRNF("R2CARY","R2CTMP","NV") ; CONVERT RNF TO CSV FORMAT
     531        D FILEOUT^C0CRNF("R2CARY","VARS-"_DFN_".csv")
     532        Q
     533        ;

  • ccr/branches/ohum/p/C0CRNF.m

    r1342 r1428  
    1 C0CRNF   ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  W "This is the Reference Name Format (RNF) Utility Library ",!
    21  W !
    22  Q
    23  ;
    24 FIELDS(C0CFRTN,C0CF) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF,
    25  ; C0CFRTN IS PASSED BY NAME, C0CF IS PASSED BY VALUE
    26  ;
    27  N C0CFI,C0CFJ ;INNER LOOP, OUTER LOOP
    28  N C0CFN ; FIELD NAME
    29  S C0CFI=0 S C0CFJ=C0CF
    30  K @C0CFRTN ; CLEAR THE RETURN ARRAY
    31  F  Q:C0CFJ'[C0CF  D ; FOR THE C0CF FILE AND ALL SUBFILES INCLUSIVE
    32  . ;W "1: "_C0CFJ," ",C0CFI,!
    33  . F  S C0CFI=$O(^DD(C0CFJ,C0CFI)) Q:+C0CFI=0  D  ; EVERY FIELD
    34  . . ;W "2: "_C0CFJ," ",C0CFI,!
    35  . . S C0CFN=$P($G(^DD(C0CFJ,C0CFI,0)),"^",1) ;PULL FIELD NAME FROM ^DD
    36  . . ;W "N: ",C0CFN,!
    37  . . ;I C0CFN="STR" W C0CFN," ",C0CFJ,!
    38  . . I $D(@C0CFRTN@(C0CFN)) D  ; IS THIS A DUPLICATE?
    39  . . . I $G(DEBUG) D  ;
    40  . . . . W "DUPLICATE FOUND! ",C0CFJ," ",C0CFI," ",C0CFN,!,@C0CFRTN@(C0CFN),!
    41  . . . S @C0CFRTN@(C0CFN_"_"_C0CFJ)=C0CFJ_"^"_C0CFI
    42  . . E  S @C0CFRTN@(C0CFN)=C0CFJ_"^"_C0CFI
    43  . S C0CFJ=$O(^DD(C0CFJ)) ; NEXT SUBFILE
    44  Q
    45  ;
    46 TESTRNF ; TEST THE RNF1TO2 ROUTINE
    47  S G1("ONE")=1
    48  S G1("TWO")=2
    49  S G1("THREE")=3
    50  D RNF1TO2("GPL","G1")
    51  S G1("ONE")="NOT1"
    52  S G1("TWO")="STILL2"
    53  S G1("THREE")=3
    54  D RNF1TO2("GPL","G1")
    55  ZWR GPL
    56  Q
    57  ;
    58 RNF1TO2(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY
    59  ; (ZOUT) BOTH ARE PASSED BY NAME
    60  ; RNF1 IS OF THE FORM:
    61  ; @ZIN@("VAR1")=VAL1
    62  ; @ZIN@("VAR2")=VAL2
    63  ; RNF2 IS OF THE FORM:
    64  ; @ZOUT@("F","VAR1")=""
    65  ; @ZOUT@("F","VAR2")=""
    66  ; @ZOUT@("V",n,"VAR1")=VAL1
    67  ; @ZOUT@("V",n,"VAR2")=VAL2
    68  ; WHERE n IS THE "ROW" OF THE ARRAY
    69  N ZI S ZI=""
    70  N ZN
    71  I '$D(@ZOUT@("V",1)) S ZN=1
    72  E  S ZN=$O(@ZOUT@("V",""),-1)+1
    73  F  S ZI=$O(@ZIN@(ZI)) Q:ZI=""  D  ;
    74  . S @ZOUT@("F",ZI)=""
    75  . S @ZOUT@("V",ZN,ZI)=@ZIN@(ZI)
    76  Q
    77  ;
    78 RNF1TO2B(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY
    79  ; THE "B" ROUTINE SUPPORTS WP FIELDS IN THE ARRAY
    80  ; EVERY "V" VARIABLE IS FOLLOWED BY A "1"
    81  ; FOR EXAMPLE @G@("V",n,"VAR1",1)="VALUE1"
    82  ; USE THIS ROUTINE IF YOU WANT TO CONVERT THE RESULT TO A CSV
    83  ; WITH RNF2CSV
    84  ; (ZOUT) BOTH ARE PASSED BY NAME
    85  ; RNF1 IS OF THE FORM:
    86  ; @ZIN@("VAR1")=VAL1
    87  ; @ZIN@("VAR2")=VAL2
    88  ; RNF2 IS OF THE FORM:
    89  ; @ZOUT@("F","VAR1")=""
    90  ; @ZOUT@("F","VAR2")=""
    91  ; @ZOUT@("V",n,"VAR1",1)=VAL1
    92  ; @ZOUT@("V",n,"VAR2",1)=VAL2
    93  ; WHERE n IS THE "ROW" OF THE ARRAY
    94  N ZI S ZI=""
    95  N ZN
    96  I '$D(@ZOUT@("V",1)) S ZN=1
    97  E  S ZN=$O(@ZOUT@("V",""),-1)+1
    98  F  S ZI=$O(@ZIN@(ZI)) Q:ZI=""  D  ;
    99  . S @ZOUT@("F",ZI)=""
    100  . S @ZOUT@("V",ZN,ZI,1)=@ZIN@(ZI)
    101  Q
    102  ;
    103 GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME
    104  ; GRTN IS PASSED BY NAME
    105  ;
    106  N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
    107  I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
    108  E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
    109  S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
    110  D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
    111  D GETS^DIQ(GFILE,C0CREF,"**","I","C0CTMP")
    112  D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
    113  S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J ; STRUCTURE SIGNATURE
    114  S (C0CI,C0CJ)=""
    115  F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
    116  . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
    117  . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
    118  . . ;W C0CJ," ",C0CI,!
    119  . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
    120  . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI) ;
    121  . . I C0CVALUE["C0CTMP" S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,1) ;1ST LINE OF WP
    122  . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
    123  I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
    124  . S C0CI=""
    125  . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
    126  . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
    127  Q
    128  ;
    129 GETN(GRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP
    130  ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1
    131  ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
    132  ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN
    133  ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
    134  ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
    135  ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
    136  ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
    137  ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
    138  ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
    139  ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
    140  ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
    141  ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
    142  ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
    143  ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
    144  ; GREF IS THE VALUE FOR THE INDEX
    145  ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
    146  ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
    147  ;
    148  ;
    149  N GIEN,GF
    150  S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE
    151  I ('$D(GNDX))!($G(GNDX)="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN
    152  E  D  ; WE ARE USING AN INDEX
    153  . ;N ZG
    154  . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX
    155  . I ZG'="" D  ;
    156  . . I $QS(ZG,3)=GREF D  ; IS GREF IN INDEX?
    157  . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN
    158  . . E  S GIEN="" ; NOT FOUND IN INDEX
    159  . E  S GIEN="" ;
    160  ;W "IEN: ",GIEN,!
    161  ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
    162  I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
    163  E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
    164  S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
    165  D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
    166  K C0CTMP
    167  D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP")
    168  D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
    169  S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE
    170  S (C0CI,C0CJ)=""
    171  F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
    172  . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
    173  . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
    174  . . ;W C0CJ," ",C0CI,!
    175  . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
    176  . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ;
    177  . . I C0CVALUE["C0CTMP" D  ; WP FIELD
    178  . . . N ZT,ZWP S ZWP=0 ;ITERATOR
    179  . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE
    180  . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE
    181  . . . F  S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP  D  ;
    182  . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP
    183  . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT "
    184  . . . . S C0CVALUE=C0CVALUE_ZT ;
    185  . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
    186  . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I"))
    187  I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
    188  . S C0CI=""
    189  . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
    190  . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
    191  Q
    192  ;
    193 GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP
    194  ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1
    195  ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
    196  ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN
    197  ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
    198  ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
    199  ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
    200  ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
    201  ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
    202  ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
    203  ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
    204  ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
    205  ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
    206  ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
    207  ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
    208  ; GREF IS THE VALUE FOR THE INDEX
    209  ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
    210  ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
    211  ;
    212  ;
    213  N GIEN,GF
    214  S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE
    215  I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN
    216  E  D  ; WE ARE USING AN INDEX
    217  . ;N ZG
    218  . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX
    219  . I ZG'="" D  ;
    220  . . I $QS(ZG,3)=GREF D  ; IS GREF IN INDEX?
    221  . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN
    222  . . E  S GIEN="" ; NOT FOUND IN INDEX
    223  . E  S GIEN="" ;
    224  ;W "IEN: ",GIEN,!
    225  ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
    226  I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
    227  E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
    228  S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
    229  D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
    230  K C0CTMP
    231  D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP")
    232  D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
    233  S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE
    234  S (C0CI,C0CJ)=""
    235  F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
    236  . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
    237  . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
    238  . . ;W C0CJ," ",C0CI,!
    239  . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
    240  . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ;
    241  . . I C0CVALUE["C0CTMP" D  ; WP FIELD
    242  . . . N ZT,ZWP S ZWP=0 ;ITERATOR
    243  . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE
    244  . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE
    245  . . . F  S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP  D  ;
    246  . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP
    247  . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT "
    248  . . . . S C0CVALUE=C0CVALUE_ZT ;
    249  . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
    250  . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I"))
    251  I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
    252  . S C0CI=""
    253  . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
    254  . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
    255  Q
    256  ;
    257 GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES
    258  ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
    259  ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#"
    260  ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
    261  ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE
    262  ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES
    263  ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
    264  ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
    265  ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
    266  ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
    267  ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE
    268  ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN
    269  ; .. OF THE FILE WILL BE USED
    270  ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE
    271  ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED
    272  ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE
    273  ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD
    274  ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
    275  ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL
    276  ;N GATMP,GAI,GAF
    277  S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE
    278  I '$D(GAIDX) S GAIDX="" ;DEFAULT
    279  I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED
    280  I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX
    281  W GAF,!
    282  W $O(@GAF@(0)) ;
    283  S GAI=0 ;ITERATOR
    284  F  S GAI=$O(@GAF@(GAI)) Q:GAI=""  D  ;
    285  . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD
    286  . N GAX S GAX=0
    287  . F  S GAX=$O(GATMP(GAX)) Q:GAX=""  D  ;PULL OUT THE FIELDS
    288  . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN
    289  Q
    290  ;
    291 ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX
    292  ;
    293  S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD#
    294  S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE
    295  Q
    296  ;
    297 RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT
    298  ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES
    299  ; RNSTY IS STYLE OF THE OUTPUT -
    300  ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES
    301  ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES
    302  ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES
    303  N RNR,RNC ;ROW ROOT,COL ROOT
    304  N RNI,RNJ,RNX
    305  I '$D(RNSTY) S RNSTY="NV" ;DEFAULT
    306  I RNSTY="NV" D NV(RNRTN,RNIN)  ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION
    307  E  D VN(RNRTN,RNIN) ;
    308  Q
    309  ;
    310 NV(RNRTN,RNIN) ;
    311  S RNR=$NA(@RNIN@("F"))
    312  S RNC=$NA(@RNIN@("V"))
    313  ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
    314  S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD"
    315  S RNI=""
    316  F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
    317  . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
    318  S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
    319  D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
    320  S RNI=""
    321  F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
    322  . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
    323  . S RNJ=""
    324  . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
    325  . . I $D(@RNC@(RNJ,RNI,1)) D  ; THIS ROW HAS THIS COLUMN
    326  . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA
    327  . . E  S RNX=RNX_"," ; NUL COLUMN
    328  . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
    329  . D PUSH^C0CXPATH(RNRTN,RNX)
    330  Q
    331  ;
    332 VN(RNRTN,RNIN) ;
    333  S RNR=$NA(@RNIN@("V"))
    334  S RNC=$NA(@RNIN@("F"))
    335  ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
    336  S RNX="""ROW"""_"," ; FIRST COLUMN NAME IS "ROW"
    337  S RNI=""
    338  F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
    339  . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
    340  S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
    341  D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
    342  S RNI=""
    343  F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
    344  . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
    345  . S RNJ=""
    346  . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
    347  . . I $D(@RNR@(RNI,RNJ,1)) D  ; THIS ROW HAS THIS COLUMN
    348  . . . S RNV=$TR(@RNR@(RNI,RNJ,1),"""","")
    349  . . . S RNV=$TR(RNV,",","")
    350  . . . S RNX=RNX_""""_RNV_""""_"," ; ADD THE ELEMENT PLUS A COMMA
    351  . . E  S RNX=RNX_"," ; NUL COLUMN
    352  . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
    353  . D PUSH^C0CXPATH(RNRTN,RNX)
    354  Q
    355  ;
    356 READCSV(PATH,NAME,GLB) ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME
    357  ;
    358  Q $$FTG^%ZISH(PATH,NAME,GLB,1)
    359  ;
    360 FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV
    361  ;
    362  ;N G1,G2
    363  I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE
    364  S G1=$NA(^TMP($J,"C0CCSV",1))
    365  S G2=$NA(^TMP($J,"C0CCSV",2))
    366  D GETN2(G1,FNUM) ; GET THE MATRIX
    367  D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE
    368  K @G1
    369  D FILEOUT(G2,"FILE_"_FNUM_".csv")
    370  K @G2
    371  Q
    372  ;
    373 FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE
    374  ;
    375  W $$OUTPUT^C0CXPATH($NA(@FOARY@(1)),FONAM,^TMP("C0CCCR","ODIR"))
    376  Q
    377  ;
    378 FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM
    379  ;
    380  N C0CF
    381  S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE
    382  S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT
    383  I C0CF["()" S C0CF=$P(C0CF,"()",1)
    384  Q C0CF
    385  ;
    386 SKIP ;
    387  N TXT,DIERR
    388  S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT")
    389  I $D(DIERR) D CLEAN^DILF Q
    390  W "  report_text:",!  ;Progress Note Text
    391  N LN S LN=0
    392  F  S LN=$O(TXT(LN)) Q:'LN  D
    393  . W "    text"_LN_": "_TXT(LN),!
    394  . Q
    395  Q
    396  ;
    397 RNF2HNV(ZOUT,ZIN) ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME
    398  ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT
    399  ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END
    400  ; THE TABLE WILL BE IN NV FORMAT, ROWS ARE NAMES COLUMNS ARE VALUES
    401  D PUSH^C0CXPATH(ZOUT,"<table border=""1"">")
    402  N ZI,ZJ,ZV,ZN S ZI="" S ZJ=0
    403  D PUSH^C0CXPATH(ZOUT,"<tr><td></td>") ;begin row and leave a blank col
    404  F  S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0  D  ; FOR EACH OCCURANCE
    405  . S ZV="<td>"_ZJ_"</td>" ; OCCURANCE AS COLUMNS HEADER
    406  . D PUSH^C0CXPATH(ZOUT,ZV)
    407  D PUSH^C0CXPATH(ZOUT,"</tr>") ;end of first row
    408  S ZI=""
    409  F  S ZI=$O(@ZIN@("F",ZI)) Q:ZI=""  D  ; FOR EACH VARIABLE
    410  . S ZN="<tr><td>"_ZI_"</td>" ; VARIABLE NAME IN FIRST COLUMN
    411  . D PUSH^C0CXPATH(ZOUT,ZN)
    412  . S ZJ=0 ;RESET TO DO IT AGAIN
    413  . F  S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0  D  ; FOR EACH OCCURANCE
    414  . . S ZV="<td>"_$G(@ZIN@("V",ZJ,ZI,1))_"</td>"
    415  . . D PUSH^C0CXPATH(ZOUT,ZV)
    416  . D PUSH^C0CXPATH(ZOUT,"</tr>") ;END OF ROW
    417  D PUSH^C0CXPATH(ZOUT,"</table>") ; end of table
    418  Q
    419  ;
    420 RNF2HVN(ZOUT,ZIN) ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME
    421  ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT
    422  ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END
    423  ; THE TABLE WILL BE IN VN FORMAT, ROWS ARE VALUES COLUMNS ARE NAMES
    424  D PUSH^C0CXPATH(ZOUT,"<table border=""1"">")
    425  N ZI,ZJ S ZI="" S ZJ=0
    426  D PUSH^C0CXPATH(ZOUT,"<tr>") ;new row for column headers
    427  F  S ZI=$O(@ZIN@("F",ZI)) Q:ZI=""  D  ; FOR EACH VARIABLE
    428  . S ZV="<td>"_ZI_"</td>"
    429  . D PUSH^C0CXPATH(ZOUT,ZV) ; name
    430  D PUSH^C0CXPATH(ZOUT,"</tr>") ; end header row
    431  S ZI="" ;RESET TO DO AGAIN
    432  F  S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0  D  ; FOR EACH ROW OF VARIABLES
    433  . D PUSH^C0CXPATH(ZOUT,"<tr>") ;begin row
    434  . F  S ZI=$O(@ZIN@("F",ZI)) Q:ZI=""  D  ; FOR EACH VARIABLE
    435  . . S ZV="<td>"_$G(@ZIN@("V",ZJ,ZI,1))_"</td>" ; value
    436  . . D PUSH^C0CXPATH(ZOUT,ZV) ; value
    437  . D PUSH^C0CXPATH(ZOUT,"</tr>") ; end header
    438  D PUSH^C0CXPATH(ZOUT,"</table>") ;end of table
    439  Q
    440  ;
    441 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
    442  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN)
    443  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    444  I '$D(ZTAB) S ZTAB="C0CA"
    445  Q $P(@ZTAB@(ZFN),"^",1)
    446 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
    447  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN)
    448  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    449  I '$D(ZTAB) S ZTAB="C0CA"
    450  Q $P(@ZTAB@(ZFN),"^",2)
    451 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
    452  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
    453  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    454  I '$D(ZTAB) S ZTAB="C0CA"
    455  Q $P($G(@ZTAB@(ZFN)),"^",3)
    456  ;
    457 ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED
    458  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
    459  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    460  I '$D(ZTAB) S ZTAB="C0CA"
    461  Q $P($G(@ZTAB@(ZFN,"I")),"^",3)
    462  ;
     1C0CRNF    ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        W "This is the Reference Name Format (RNF) Utility Library ",!
     21        W !
     22        Q
     23        ;
     24FIELDS(C0CFRTN,C0CF)    ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF,
     25        ; C0CFRTN IS PASSED BY NAME, C0CF IS PASSED BY VALUE
     26        ;
     27        N C0CFI,C0CFJ ;INNER LOOP, OUTER LOOP
     28        N C0CFN ; FIELD NAME
     29        S C0CFI=0 S C0CFJ=C0CF
     30        K @C0CFRTN ; CLEAR THE RETURN ARRAY
     31        F  Q:C0CFJ'[C0CF  D ; FOR THE C0CF FILE AND ALL SUBFILES INCLUSIVE
     32        . ;W "1: "_C0CFJ," ",C0CFI,!
     33        . F  S C0CFI=$O(^DD(C0CFJ,C0CFI)) Q:+C0CFI=0  D  ; EVERY FIELD
     34        . . ;W "2: "_C0CFJ," ",C0CFI,!
     35        . . S C0CFN=$P($G(^DD(C0CFJ,C0CFI,0)),"^",1) ;PULL FIELD NAME FROM ^DD
     36        . . ;W "N: ",C0CFN,!
     37        . . ;I C0CFN="STR" W C0CFN," ",C0CFJ,!
     38        . . I $D(@C0CFRTN@(C0CFN)) D  ; IS THIS A DUPLICATE?
     39        . . . I $G(DEBUG) D  ;
     40        . . . . W "DUPLICATE FOUND! ",C0CFJ," ",C0CFI," ",C0CFN,!,@C0CFRTN@(C0CFN),!
     41        . . . S @C0CFRTN@(C0CFN_"_"_C0CFJ)=C0CFJ_"^"_C0CFI
     42        . . E  S @C0CFRTN@(C0CFN)=C0CFJ_"^"_C0CFI
     43        . S C0CFJ=$O(^DD(C0CFJ)) ; NEXT SUBFILE
     44        Q
     45        ;
     46TESTRNF ; TEST THE RNF1TO2 ROUTINE
     47        S G1("ONE")=1
     48        S G1("TWO")=2
     49        S G1("THREE")=3
     50        D RNF1TO2("GPL","G1")
     51        S G1("ONE")="NOT1"
     52        S G1("TWO")="STILL2"
     53        S G1("THREE")=3
     54        D RNF1TO2("GPL","G1")
     55        ZWR GPL
     56        Q
     57        ;
     58RNF1TO2(ZOUT,ZIN)       ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY
     59        ; (ZOUT) BOTH ARE PASSED BY NAME
     60        ; RNF1 IS OF THE FORM:
     61        ; @ZIN@("VAR1")=VAL1
     62        ; @ZIN@("VAR2")=VAL2
     63        ; RNF2 IS OF THE FORM:
     64        ; @ZOUT@("F","VAR1")=""
     65        ; @ZOUT@("F","VAR2")=""
     66        ; @ZOUT@("V",n,"VAR1")=VAL1
     67        ; @ZOUT@("V",n,"VAR2")=VAL2
     68        ; WHERE n IS THE "ROW" OF THE ARRAY
     69        N ZI S ZI=""
     70        N ZN
     71        I '$D(@ZOUT@("V",1)) S ZN=1
     72        E  S ZN=$O(@ZOUT@("V",""),-1)+1
     73        F  S ZI=$O(@ZIN@(ZI)) Q:ZI=""  D  ;
     74        . S @ZOUT@("F",ZI)=""
     75        . S @ZOUT@("V",ZN,ZI)=@ZIN@(ZI)
     76        Q
     77        ;
     78RNF1TO2B(ZOUT,ZIN)      ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY
     79        ; THE "B" ROUTINE SUPPORTS WP FIELDS IN THE ARRAY
     80        ; EVERY "V" VARIABLE IS FOLLOWED BY A "1"
     81        ; FOR EXAMPLE @G@("V",n,"VAR1",1)="VALUE1"
     82        ; USE THIS ROUTINE IF YOU WANT TO CONVERT THE RESULT TO A CSV
     83        ; WITH RNF2CSV
     84        ; (ZOUT) BOTH ARE PASSED BY NAME
     85        ; RNF1 IS OF THE FORM:
     86        ; @ZIN@("VAR1")=VAL1
     87        ; @ZIN@("VAR2")=VAL2
     88        ; RNF2 IS OF THE FORM:
     89        ; @ZOUT@("F","VAR1")=""
     90        ; @ZOUT@("F","VAR2")=""
     91        ; @ZOUT@("V",n,"VAR1",1)=VAL1
     92        ; @ZOUT@("V",n,"VAR2",1)=VAL2
     93        ; WHERE n IS THE "ROW" OF THE ARRAY
     94        N ZI S ZI=""
     95        N ZN
     96        I '$D(@ZOUT@("V",1)) S ZN=1
     97        E  S ZN=$O(@ZOUT@("V",""),-1)+1
     98        F  S ZI=$O(@ZIN@(ZI)) Q:ZI=""  D  ;
     99        . S @ZOUT@("F",ZI)=""
     100        . S @ZOUT@("V",ZN,ZI,1)=@ZIN@(ZI)
     101        Q
     102        ;
     103GETNOLD(GRTN,GFILE,GIEN,GNN)    ; GET FIELDS FOR ACCESS BY NAME
     104        ; GRTN IS PASSED BY NAME
     105        ;
     106        N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
     107        I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
     108        E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
     109        S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
     110        D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
     111        D GETS^DIQ(GFILE,C0CREF,"**","I","C0CTMP")
     112        D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
     113        S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J ; STRUCTURE SIGNATURE
     114        S (C0CI,C0CJ)=""
     115        F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
     116        . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
     117        . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
     118        . . ;W C0CJ," ",C0CI,!
     119        . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
     120        . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI) ;
     121        . . I C0CVALUE["C0CTMP" S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,1) ;1ST LINE OF WP
     122        . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
     123        I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
     124        . S C0CI=""
     125        . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
     126        . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
     127        Q
     128        ;
     129GETN(GRTN,GFILE,GREF,GNDX,GNN)  ; GET BY NAME ; RETURN A FIELD VALUE MAP
     130        ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1
     131        ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
     132        ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN
     133        ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
     134        ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
     135        ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
     136        ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
     137        ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
     138        ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
     139        ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
     140        ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
     141        ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
     142        ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
     143        ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
     144        ; GREF IS THE VALUE FOR THE INDEX
     145        ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
     146        ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
     147        ;
     148        ;
     149        N GIEN,GF
     150        S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE
     151        I ('$D(GNDX))!($G(GNDX)="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN
     152        E  D  ; WE ARE USING AN INDEX
     153        . ;N ZG
     154        . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX
     155        . I ZG'="" D  ;
     156        . . I $QS(ZG,3)=GREF D  ; IS GREF IN INDEX?
     157        . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN
     158        . . E  S GIEN="" ; NOT FOUND IN INDEX
     159        . E  S GIEN="" ;
     160        ;W "IEN: ",GIEN,!
     161        ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
     162        I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
     163        E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
     164        S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
     165        D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
     166        K C0CTMP
     167        D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP")
     168        D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
     169        S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE
     170        S (C0CI,C0CJ)=""
     171        F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
     172        . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
     173        . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
     174        . . ;W C0CJ," ",C0CI,!
     175        . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
     176        . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ;
     177        . . I C0CVALUE["C0CTMP" D  ; WP FIELD
     178        . . . N ZT,ZWP S ZWP=0 ;ITERATOR
     179        . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE
     180        . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE
     181        . . . F  S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP  D  ;
     182        . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP
     183        . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT "
     184        . . . . S C0CVALUE=C0CVALUE_ZT ;
     185        . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
     186        . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I"))
     187        I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
     188        . S C0CI=""
     189        . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
     190        . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
     191        Q
     192        ;
     193GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP
     194        ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1
     195        ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
     196        ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN
     197        ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
     198        ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
     199        ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
     200        ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
     201        ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
     202        ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
     203        ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
     204        ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
     205        ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
     206        ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
     207        ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
     208        ; GREF IS THE VALUE FOR THE INDEX
     209        ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
     210        ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
     211        ;
     212        ;
     213        N GIEN,GF
     214        S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE
     215        I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN
     216        E  D  ; WE ARE USING AN INDEX
     217        . ;N ZG
     218        . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX
     219        . I ZG'="" D  ;
     220        . . I $QS(ZG,3)=GREF D  ; IS GREF IN INDEX?
     221        . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN
     222        . . E  S GIEN="" ; NOT FOUND IN INDEX
     223        . E  S GIEN="" ;
     224        ;W "IEN: ",GIEN,!
     225        ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
     226        I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
     227        E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
     228        S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
     229        D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
     230        K C0CTMP
     231        D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP")
     232        D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
     233        S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE
     234        S (C0CI,C0CJ)=""
     235        F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
     236        . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
     237        . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
     238        . . ;W C0CJ," ",C0CI,!
     239        . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
     240        . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ;
     241        . . I C0CVALUE["C0CTMP" D  ; WP FIELD
     242        . . . N ZT,ZWP S ZWP=0 ;ITERATOR
     243        . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE
     244        . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE
     245        . . . F  S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP  D  ;
     246        . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP
     247        . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT "
     248        . . . . S C0CVALUE=C0CVALUE_ZT ;
     249        . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
     250        . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I"))
     251        I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
     252        . S C0CI=""
     253        . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
     254        . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
     255        Q
     256        ;
     257GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN)     ; RETURN FIELD MAP AND VALUES
     258        ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
     259        ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#"
     260        ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
     261        ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE
     262        ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES
     263        ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
     264        ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
     265        ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
     266        ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
     267        ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE
     268        ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN
     269        ; .. OF THE FILE WILL BE USED
     270        ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE
     271        ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED
     272        ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE
     273        ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD
     274        ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
     275        ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL
     276        ;N GATMP,GAI,GAF
     277        S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE
     278        I '$D(GAIDX) S GAIDX="" ;DEFAULT
     279        I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED
     280        I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX
     281        W GAF,!
     282        W $O(@GAF@(0)) ;
     283        S GAI=0 ;ITERATOR
     284        F  S GAI=$O(@GAF@(GAI)) Q:GAI=""  D  ;
     285        . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD
     286        . N GAX S GAX=0
     287        . F  S GAX=$O(GATMP(GAX)) Q:GAX=""  D  ;PULL OUT THE FIELDS
     288        . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN
     289        Q
     290        ;
     291ADDNV(GNV,GNVN,GNVF,GNVV)       ; CREATE AN ELEMENT OF THE MATRIX
     292        ;
     293        S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD#
     294        S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE
     295        Q
     296        ;
     297RNF2CSV(RNRTN,RNIN,RNSTY)       ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT
     298        ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES
     299        ; RNSTY IS STYLE OF THE OUTPUT -
     300        ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES
     301        ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES
     302        ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES
     303        N RNR,RNC ;ROW ROOT,COL ROOT
     304        N RNI,RNJ,RNX
     305        I '$D(RNSTY) S RNSTY="NV" ;DEFAULT
     306        I RNSTY="NV" D NV(RNRTN,RNIN)  ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION
     307        E  D VN(RNRTN,RNIN) ;
     308        Q
     309        ;
     310NV(RNRTN,RNIN)  ;
     311        S RNR=$NA(@RNIN@("F"))
     312        S RNC=$NA(@RNIN@("V"))
     313        ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
     314        S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD"
     315        S RNI=""
     316        F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
     317        . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
     318        S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
     319        D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
     320        S RNI=""
     321        F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
     322        . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
     323        . S RNJ=""
     324        . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
     325        . . I $D(@RNC@(RNJ,RNI,1)) D  ; THIS ROW HAS THIS COLUMN
     326        . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA
     327        . . E  S RNX=RNX_"," ; NUL COLUMN
     328        . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
     329        . D PUSH^C0CXPATH(RNRTN,RNX)
     330        Q
     331        ;
     332VN(RNRTN,RNIN)  ;
     333        S RNR=$NA(@RNIN@("V"))
     334        S RNC=$NA(@RNIN@("F"))
     335        ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
     336        S RNX="""ROW"""_"," ; FIRST COLUMN NAME IS "ROW"
     337        S RNI=""
     338        F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
     339        . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
     340        S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
     341        D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
     342        S RNI=""
     343        F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
     344        . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
     345        . S RNJ=""
     346        . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
     347        . . I $D(@RNR@(RNI,RNJ,1)) D  ; THIS ROW HAS THIS COLUMN
     348        . . . S RNV=$TR(@RNR@(RNI,RNJ,1),"""","")
     349        . . . S RNV=$TR(RNV,",","")
     350        . . . S RNX=RNX_""""_RNV_""""_"," ; ADD THE ELEMENT PLUS A COMMA
     351        . . E  S RNX=RNX_"," ; NUL COLUMN
     352        . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
     353        . D PUSH^C0CXPATH(RNRTN,RNX)
     354        Q
     355        ;
     356READCSV(PATH,NAME,GLB)  ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME
     357        ;
     358        Q $$FTG^%ZISH(PATH,NAME,GLB,1)
     359        ;
     360FILE2CSV(FNUM,FVN)      ; WRITES OUT A FILEMAN FILE TO CSV
     361        ;
     362        ;N G1,G2
     363        I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE
     364        S G1=$NA(^TMP($J,"C0CCSV",1))
     365        S G2=$NA(^TMP($J,"C0CCSV",2))
     366        D GETN2(G1,FNUM) ; GET THE MATRIX
     367        D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE
     368        K @G1
     369        D FILEOUT(G2,"FILE_"_FNUM_".csv")
     370        K @G2
     371        Q
     372        ;
     373FILEOUT(FOARY,FONAM)    ; WRITE OUT A FILE
     374        ;
     375        W $$OUTPUT^C0CXPATH($NA(@FOARY@(1)),FONAM,^TMP("C0CCCR","ODIR"))
     376        Q
     377        ;
     378FILEREF(FNUM)   ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM
     379        ;
     380        N C0CF
     381        S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE
     382        S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT
     383        I C0CF["()" S C0CF=$P(C0CF,"()",1)
     384        Q C0CF
     385        ;
     386SKIP    ;
     387        N TXT,DIERR
     388        S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT")
     389        I $D(DIERR) D CLEAN^DILF Q
     390        W "  report_text:",!  ;Progress Note Text
     391        N LN S LN=0
     392        F  S LN=$O(TXT(LN)) Q:'LN  D
     393        . W "    text"_LN_": "_TXT(LN),!
     394        . Q
     395        Q
     396        ;
     397RNF2HNV(ZOUT,ZIN)       ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME
     398        ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT
     399        ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END
     400        ; THE TABLE WILL BE IN NV FORMAT, ROWS ARE NAMES COLUMNS ARE VALUES
     401        D PUSH^C0CXPATH(ZOUT,"<table border=""1"">")
     402        N ZI,ZJ,ZV,ZN S ZI="" S ZJ=0
     403        D PUSH^C0CXPATH(ZOUT,"<tr><td></td>") ;begin row and leave a blank col
     404        F  S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0  D  ; FOR EACH OCCURANCE
     405        . S ZV="<td>"_ZJ_"</td>" ; OCCURANCE AS COLUMNS HEADER
     406        . D PUSH^C0CXPATH(ZOUT,ZV)
     407        D PUSH^C0CXPATH(ZOUT,"</tr>") ;end of first row
     408        S ZI=""
     409        F  S ZI=$O(@ZIN@("F",ZI)) Q:ZI=""  D  ; FOR EACH VARIABLE
     410        . S ZN="<tr><td>"_ZI_"</td>" ; VARIABLE NAME IN FIRST COLUMN
     411        . D PUSH^C0CXPATH(ZOUT,ZN)
     412        . S ZJ=0 ;RESET TO DO IT AGAIN
     413        . F  S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0  D  ; FOR EACH OCCURANCE
     414        . . S ZV="<td>"_$G(@ZIN@("V",ZJ,ZI,1))_"</td>"
     415        . . D PUSH^C0CXPATH(ZOUT,ZV)
     416        . D PUSH^C0CXPATH(ZOUT,"</tr>") ;END OF ROW
     417        D PUSH^C0CXPATH(ZOUT,"</table>") ; end of table
     418        Q
     419        ;
     420RNF2HVN(ZOUT,ZIN)       ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME
     421        ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT
     422        ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END
     423        ; THE TABLE WILL BE IN VN FORMAT, ROWS ARE VALUES COLUMNS ARE NAMES
     424        D PUSH^C0CXPATH(ZOUT,"<table border=""1"">")
     425        N ZI,ZJ S ZI="" S ZJ=0
     426        D PUSH^C0CXPATH(ZOUT,"<tr>") ;new row for column headers
     427        F  S ZI=$O(@ZIN@("F",ZI)) Q:ZI=""  D  ; FOR EACH VARIABLE
     428        . S ZV="<td>"_ZI_"</td>"
     429        . D PUSH^C0CXPATH(ZOUT,ZV) ; name
     430        D PUSH^C0CXPATH(ZOUT,"</tr>") ; end header row
     431        S ZI="" ;RESET TO DO AGAIN
     432        F  S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0  D  ; FOR EACH ROW OF VARIABLES
     433        . D PUSH^C0CXPATH(ZOUT,"<tr>") ;begin row
     434        . F  S ZI=$O(@ZIN@("F",ZI)) Q:ZI=""  D  ; FOR EACH VARIABLE
     435        . . S ZV="<td>"_$G(@ZIN@("V",ZJ,ZI,1))_"</td>" ; value
     436        . . D PUSH^C0CXPATH(ZOUT,ZV) ; value
     437        . D PUSH^C0CXPATH(ZOUT,"</tr>") ; end header
     438        D PUSH^C0CXPATH(ZOUT,"</table>") ;end of table
     439        Q
     440        ;
     441ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
     442        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN)
     443        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     444        I '$D(ZTAB) S ZTAB="C0CA"
     445        Q $P(@ZTAB@(ZFN),"^",1)
     446ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
     447        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN)
     448        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     449        I '$D(ZTAB) S ZTAB="C0CA"
     450        Q $P(@ZTAB@(ZFN),"^",2)
     451ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
     452        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
     453        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     454        I '$D(ZTAB) S ZTAB="C0CA"
     455        Q $P($G(@ZTAB@(ZFN)),"^",3)
     456        ;
     457ZVALUEI(ZFN,ZTAB)       ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED
     458        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
     459        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     460        I '$D(ZTAB) S ZTAB="C0CA"
     461        Q $P($G(@ZTAB@(ZFN,"I")),"^",3)
     462        ;

  • ccr/branches/ohum/p/C0CRNFRP.m

    r1342 r1428  
    1 C0CRNFRPC   ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09
    2  ;;1.0;C0C;;Dec 9, 2009;Build 2
    3  ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  W "This is the Reference Name Format (RNF) RPC Library ",!
    21  W !
    22  Q
    23  ;
    24  ;This routine will be mirroring C0CRNF and transform the output
    25  ;of the tags into an RPC friendly format
    26  ;The tags will be exactly as they are in C0CRNF
    27 FIELDS(C0CFRTN,C0CFILE) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF,
    28  ;C0CFRTN IS PASSED BY REFERENCE, C0CF IS PASSED BY VALUE
    29  ;RETURN FORMAT:
    30  ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS
    31  ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER"
    32  ;
    33  ;SAMPLE OUTPUT FROM FIELDS^C0CRNF:
    34  ;C0CRNFFIELDS("*AMOUNT OF MILITARY RETIREMENT")="2^.3625"
    35  ;
    36  ;FORMAT APPEARS TO BE:
    37  ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER"
    38  ;
    39  ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON
    40  S DEBUG=0
    41  ;SET RETURN VALUE
    42  S C0CFRTN=$NA(^TMP("C0CRNF",$J))
    43  K @C0CFRTN
    44  ;RUN WRAPPED CALL
    45  D FIELDS^C0CRNF("C0CRTN",C0CFILE)
    46  S J=""
    47  S I=1
    48  ;FORMAT RETURN
    49  F  S J=$O(C0CRTN(J)) Q:J=""  D  ; FOR EACH FIELD IN THE ARRAY
    50  . S @C0CFRTN@(I)=J_"^"_C0CRTN(J)
    51  . S I=I+1
    52  S @C0CFRTN@(0)=I-1
    53  ;CLEAN UP
    54  K J,I
    55  Q
    56  ;
    57 GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME
    58  ; GRTN IS PASSED BY NAME
    59  ;
    60  ; OLD TAG DO NOT USE!
    61  Q
    62  ;
    63 GETN(C0CGRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP
    64  ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
    65  ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
    66  ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
    67  ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
    68  ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
    69  ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
    70  ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
    71  ; .. NULL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
    72  ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
    73  ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
    74  ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
    75  ; GREF IS THE VALUE FOR THE INDEX
    76  ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
    77  ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
    78  ;
    79  ;
    80  ;RETURN FORMAT:
    81  ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS^FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ_$C(30)"
    82  ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER^VALUE^INTERNAL_VALUE_$C(30)"
    83  ;
    84  ;SAMPLE OUTPUT FROM FIELDS^C0CRNF:
    85  ;C0CRNFGETN(0)="2^RNF1^5095^3091209^2908^3268"
    86  ;C0CRNFGETN("1U4N")="2^.0905^H5369"
    87  ;C0CRNFGETN("1U4N","I")="^^H5369"
    88  ;C0CRNFGETN("ADDRESS CHANGE DT/TM")="2^.118^OCT 21,2009@08:03:26"
    89  ;C0CRNFGETN("ADDRESS CHANGE DT/TM","I")="^^3091021.080326"
    90  ;
    91  ;FORMAT APPEARS TO BE:
    92  ;VARIABLENAME(0)="FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ"
    93  ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER^VALUE"
    94  ;VARIABLENAME("FIELD_NAME","I")="^^INTERNAL_VALUE"
    95  ;
    96  ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON
    97  S DEBUG=0
    98  ;SET RETURN VALUE
    99  S C0CGRTN=$NA(^TMP("C0CRNF",$J))
    100  K @C0CGRTN
    101  ;RUN WRAPPED CALL
    102  D GETN^C0CRNF("C0CRTN",$G(GFILE),$G(GREF),$G(GNDX),$G(GNN))
    103  S J=""
    104  S I=1
    105  ;FORMAT RETURN
    106  F  S J=$O(C0CRTN(J)) Q:J=""  D  ; FOR EACH FIELD IN THE ARRAY
    107  . I J=0 S J=$O(C0CRTN(J)) ; SKIP THE 0 NODE
    108  . S @C0CGRTN@(I)=J_"^"_C0CRTN(J)_"^" ; GETS THE FIRST LINE
    109  . ;S J=$O(C0CRTN(J)) ; INCREMENT J SO WE CAN GET THE INTERNAL DATA
    110  . ;TEST TO SEE IF INTERNAL DATA EXISTS
    111  . I $D(C0CRTN(J,"I"))=1 D
    112  . . S @C0CGRTN@(I)=@C0CGRTN@(I)_$P(C0CRTN(J,"I"),U,3) ; GETS THE INTERNAL VALUE PIECE 3
    113  . S I=I+1
    114  S @C0CGRTN@(0)=I-1_"^"_C0CRTN(0)
    115  ;CLEAN UP
    116  K J,I
    117  Q
    118  ;
    119 GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP
    120  ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1
    121  ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
    122  ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN
    123  ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
    124  ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
    125  ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
    126  ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
    127  ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
    128  ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
    129  ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
    130  ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
    131  ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
    132  ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
    133  ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
    134  ; GREF IS THE VALUE FOR THE INDEX
    135  ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
    136  ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
    137  ;
    138  ;
    139  N GIEN,GF
    140  S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE
    141  I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN
    142  E  D  ; WE ARE USING AN INDEX
    143  . ;N ZG
    144  . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX
    145  . I ZG'="" D  ;
    146  . . I $QS(ZG,3)=GREF D  ; IS GREF IN INDEX?
    147  . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN
    148  . . E  S GIEN="" ; NOT FOUND IN INDEX
    149  . E  S GIEN="" ;
    150  ;W "IEN: ",GIEN,!
    151  ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
    152  I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
    153  E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
    154  S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
    155  D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
    156  K C0CTMP
    157  D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP")
    158  D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
    159  S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE
    160  S (C0CI,C0CJ)=""
    161  F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
    162  . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
    163  . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
    164  . . ;W C0CJ," ",C0CI,!
    165  . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
    166  . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ;
    167  . . I C0CVALUE["C0CTMP" D  ; WP FIELD
    168  . . . N ZT,ZWP S ZWP=0 ;ITERATOR
    169  . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE
    170  . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE
    171  . . . F  S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP  D  ;
    172  . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP
    173  . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT "
    174  . . . . S C0CVALUE=C0CVALUE_ZT ;
    175  . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
    176  . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I"))
    177  I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
    178  . S C0CI=""
    179  . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
    180  . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
    181  Q
    182  ;
    183 GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES
    184  ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
    185  ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#"
    186  ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
    187  ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE
    188  ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES
    189  ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
    190  ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
    191  ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
    192  ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
    193  ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE
    194  ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN
    195  ; .. OF THE FILE WILL BE USED
    196  ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE
    197  ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED
    198  ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE
    199  ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD
    200  ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
    201  ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL
    202  ;N GATMP,GAI,GAF
    203  S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE
    204  I '$D(GAIDX) S GAIDX="" ;DEFAULT
    205  I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED
    206  I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX
    207  W GAF,!
    208  W $O(@GAF@(0)) ;
    209  S GAI=0 ;ITERATOR
    210  F  S GAI=$O(@GAF@(GAI)) Q:GAI=""  D  ;
    211  . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD
    212  . N GAX S GAX=0
    213  . F  S GAX=$O(GATMP(GAX)) Q:GAX=""  D  ;PULL OUT THE FIELDS
    214  . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN
    215  Q
    216  ;
    217 ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX
    218  ;
    219  S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD#
    220  S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE
    221  Q
    222  ;
    223 RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT
    224  ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES
    225  ; RNSTY IS STYLE OF THE OUTPUT -
    226  ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES
    227  ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES
    228  ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES
    229  N RNR,RNC ;ROW ROOT,COL ROOT
    230  N RNI,RNJ,RNX
    231  I '$D(RNSTY) S RNSTY="NV" ;DEFAULT
    232  I RNSTY="NV" D NV(RNRTN,RNIN)  ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION
    233  E  D VN(RNRTN,RNIN) ;
    234  Q
    235  ;
    236 NV(RNRTN,RNIN) ;
    237  S RNR=$NA(@RNIN@("F"))
    238  S RNC=$NA(@RNIN@("V"))
    239  ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
    240  S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD"
    241  S RNI=""
    242  F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
    243  . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
    244  S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
    245  D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
    246  S RNI=""
    247  F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
    248  . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
    249  . S RNJ=""
    250  . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
    251  . . I $D(@RNC@(RNJ,RNI,1)) D  ; THIS ROW HAS THIS COLUMN
    252  . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA
    253  . . E  S RNX=RNX_"," ; NUL COLUMN
    254  . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
    255  . D PUSH^GPLXPATH(RNRTN,RNX)
    256  Q
    257  ;
    258 VN(RNRTN,RNIN) ;
    259  S RNR=$NA(@RNIN@("V"))
    260  S RNC=$NA(@RNIN@("F"))
    261  ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
    262  S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD"
    263  S RNI=""
    264  F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
    265  . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
    266  S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
    267  D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
    268  S RNI=""
    269  F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
    270  . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
    271  . S RNJ=""
    272  . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
    273  . . I $D(@RNR@(RNI,RNJ,1)) D  ; THIS ROW HAS THIS COLUMN
    274  . . . S RNX=RNX_""""_@RNR@(RNI,RNJ,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA
    275  . . E  S RNX=RNX_"," ; NUL COLUMN
    276  . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
    277  . D PUSH^GPLXPATH(RNRTN,RNX)
    278  Q
    279  ;
    280 READCSV(PATH,NAME,GLB) ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME
    281  ;
    282  Q $$FTG^%ZISH(PATH,NAME,GLB,1)
    283  ;
    284 FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV
    285  ;
    286  ;N G1,G2
    287  I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE
    288  S G1=$NA(^TMP($J,"C0CCSV",1))
    289  S G2=$NA(^TMP($J,"C0CCSV",2))
    290  D GETN2(G1,FNUM) ; GET THE MATRIX
    291  D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE
    292  K @G1
    293  D FILEOUT(G2,"FILE_"_FNUM_".csv")
    294  K @G2
    295  Q
    296  ;
    297 FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE
    298  ;
    299  W $$OUTPUT^GPLXPATH($NA(@FOARY@(1)),FONAM,^TMP("GPLCCR","ODIR"))
    300  Q
    301  ;
    302 FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM
    303  ;
    304  N C0CF
    305  S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE
    306  S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT
    307  I C0CF["()" S C0CF=$P(C0CF,"()",1)
    308  Q C0CF
    309  ;
    310 SKIP ;
    311  N TXT,DIERR
    312  S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT")
    313  I $D(DIERR) D CLEAN^DILF Q
    314  W "  report_text:",!  ;Progress Note Text
    315  N LN S LN=0
    316  F  S LN=$O(TXT(LN)) Q:'LN  D
    317  . W "    text"_LN_": "_TXT(LN),!
    318  . Q
    319  Q
    320  ;
    321 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
    322  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN)
    323  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    324  I '$D(ZTAB) S ZTAB="C0CA"
    325  Q $P(@ZTAB@(ZFN),"^",1)
    326 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
    327  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN)
    328  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    329  I '$D(ZTAB) S ZTAB="C0CA"
    330  Q $P(@ZTAB@(ZFN),"^",2)
    331 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
    332  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
    333  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    334  I '$D(ZTAB) S ZTAB="C0CA"
    335  Q $P($G(@ZTAB@(ZFN)),"^",3)
    336  ;
    337 ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED
    338  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
    339  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    340  I '$D(ZTAB) S ZTAB="C0CA"
    341  Q $P($G(@ZTAB@(ZFN,"I")),"^",3)
    342  ;
     1C0CRNFRP        ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09 ; 5/10/12 2:56pm
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        W "This is the Reference Name Format (RNF) RPC Library ",!
     21        W !
     22        Q
     23        ;
     24        ;This routine will be mirroring C0CRNF and transform the output
     25        ;of the tags into an RPC friendly format
     26        ;The tags will be exactly as they are in C0CRNF
     27FIELDS(C0CFRTN,C0CFILE) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF,
     28        ;C0CFRTN IS PASSED BY REFERENCE, C0CF IS PASSED BY VALUE
     29        ;RETURN FORMAT:
     30        ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS
     31        ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER"
     32        ;
     33        ;SAMPLE OUTPUT FROM FIELDS^C0CRNF:
     34        ;C0CRNFFIELDS("*AMOUNT OF MILITARY RETIREMENT")="2^.3625"
     35        ;
     36        ;FORMAT APPEARS TO BE:
     37        ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER"
     38        ;
     39        ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON
     40        S DEBUG=0
     41        ;SET RETURN VALUE
     42        S C0CFRTN=$NA(^TMP("C0CRNF",$J))
     43        K @C0CFRTN
     44        ;RUN WRAPPED CALL
     45        D FIELDS^C0CRNF("C0CRTN",C0CFILE)
     46        S J=""
     47        S I=1
     48        ;FORMAT RETURN
     49        F  S J=$O(C0CRTN(J)) Q:J=""  D  ; FOR EACH FIELD IN THE ARRAY
     50        . S @C0CFRTN@(I)=J_"^"_C0CRTN(J)
     51        . S I=I+1
     52        S @C0CFRTN@(0)=I-1
     53        ;CLEAN UP
     54        K J,I
     55        Q
     56        ;
     57GETNOLD(GRTN,GFILE,GIEN,GNN)    ; GET FIELDS FOR ACCESS BY NAME
     58        ; GRTN IS PASSED BY NAME
     59        ;
     60        ; OLD TAG DO NOT USE!
     61        Q
     62        ;
     63GETN(C0CGRTN,GFILE,GREF,GNDX,GNN)       ; GET BY NAME ; RETURN A FIELD VALUE MAP
     64        ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
     65        ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
     66        ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
     67        ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
     68        ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
     69        ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
     70        ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
     71        ; .. NULL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
     72        ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
     73        ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
     74        ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
     75        ; GREF IS THE VALUE FOR THE INDEX
     76        ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
     77        ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
     78        ;
     79        ;
     80        ;RETURN FORMAT:
     81        ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS^FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ_$C(30)"
     82        ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER^VALUE^INTERNAL_VALUE_$C(30)"
     83        ;
     84        ;SAMPLE OUTPUT FROM FIELDS^C0CRNF:
     85        ;C0CRNFGETN(0)="2^RNF1^5095^3091209^2908^3268"
     86        ;C0CRNFGETN("1U4N")="2^.0905^H5369"
     87        ;C0CRNFGETN("1U4N","I")="^^H5369"
     88        ;C0CRNFGETN("ADDRESS CHANGE DT/TM")="2^.118^OCT 21,2009@08:03:26"
     89        ;C0CRNFGETN("ADDRESS CHANGE DT/TM","I")="^^3091021.080326"
     90        ;
     91        ;FORMAT APPEARS TO BE:
     92        ;VARIABLENAME(0)="FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ"
     93        ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER^VALUE"
     94        ;VARIABLENAME("FIELD_NAME","I")="^^INTERNAL_VALUE"
     95        ;
     96        ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON
     97        S DEBUG=0
     98        ;SET RETURN VALUE
     99        S C0CGRTN=$NA(^TMP("C0CRNF",$J))
     100        K @C0CGRTN
     101        ;RUN WRAPPED CALL
     102        D GETN^C0CRNF("C0CRTN",$G(GFILE),$G(GREF),$G(GNDX),$G(GNN))
     103        S J=""
     104        S I=1
     105        ;FORMAT RETURN
     106        F  S J=$O(C0CRTN(J)) Q:J=""  D  ; FOR EACH FIELD IN THE ARRAY
     107        . I J=0 S J=$O(C0CRTN(J)) ; SKIP THE 0 NODE
     108        . S @C0CGRTN@(I)=J_"^"_C0CRTN(J)_"^" ; GETS THE FIRST LINE
     109        . ;S J=$O(C0CRTN(J)) ; INCREMENT J SO WE CAN GET THE INTERNAL DATA
     110        . ;TEST TO SEE IF INTERNAL DATA EXISTS
     111        . I $D(C0CRTN(J,"I"))=1 D
     112        . . S @C0CGRTN@(I)=@C0CGRTN@(I)_$P(C0CRTN(J,"I"),U,3) ; GETS THE INTERNAL VALUE PIECE 3
     113        . S I=I+1
     114        S @C0CGRTN@(0)=I-1_"^"_C0CRTN(0)
     115        ;CLEAN UP
     116        K J,I
     117        Q
     118        ;
     119GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP
     120        ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1
     121        ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
     122        ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN
     123        ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
     124        ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
     125        ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
     126        ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
     127        ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
     128        ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
     129        ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
     130        ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
     131        ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
     132        ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
     133        ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
     134        ; GREF IS THE VALUE FOR THE INDEX
     135        ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
     136        ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
     137        ;
     138        ;
     139        N GIEN,GF
     140        S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE
     141        I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN
     142        E  D  ; WE ARE USING AN INDEX
     143        . ;N ZG
     144        . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX
     145        . I ZG'="" D  ;
     146        . . I $QS(ZG,3)=GREF D  ; IS GREF IN INDEX?
     147        . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN
     148        . . E  S GIEN="" ; NOT FOUND IN INDEX
     149        . E  S GIEN="" ;
     150        ;W "IEN: ",GIEN,!
     151        ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
     152        I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
     153        E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
     154        S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
     155        D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
     156        K C0CTMP
     157        D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP")
     158        D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
     159        S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE
     160        S (C0CI,C0CJ)=""
     161        F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
     162        . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
     163        . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
     164        . . ;W C0CJ," ",C0CI,!
     165        . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
     166        . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ;
     167        . . I C0CVALUE["C0CTMP" D  ; WP FIELD
     168        . . . N ZT,ZWP S ZWP=0 ;ITERATOR
     169        . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE
     170        . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE
     171        . . . F  S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP  D  ;
     172        . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP
     173        . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT "
     174        . . . . S C0CVALUE=C0CVALUE_ZT ;
     175        . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
     176        . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I"))
     177        I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
     178        . S C0CI=""
     179        . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
     180        . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
     181        Q
     182        ;
     183GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN)     ; RETURN FIELD MAP AND VALUES
     184        ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
     185        ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#"
     186        ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
     187        ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE
     188        ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES
     189        ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
     190        ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
     191        ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
     192        ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
     193        ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE
     194        ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN
     195        ; .. OF THE FILE WILL BE USED
     196        ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE
     197        ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED
     198        ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE
     199        ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD
     200        ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
     201        ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL
     202        ;N GATMP,GAI,GAF
     203        S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE
     204        I '$D(GAIDX) S GAIDX="" ;DEFAULT
     205        I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED
     206        I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX
     207        W GAF,!
     208        W $O(@GAF@(0)) ;
     209        S GAI=0 ;ITERATOR
     210        F  S GAI=$O(@GAF@(GAI)) Q:GAI=""  D  ;
     211        . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD
     212        . N GAX S GAX=0
     213        . F  S GAX=$O(GATMP(GAX)) Q:GAX=""  D  ;PULL OUT THE FIELDS
     214        . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN
     215        Q
     216        ;
     217ADDNV(GNV,GNVN,GNVF,GNVV)       ; CREATE AN ELEMENT OF THE MATRIX
     218        ;
     219        S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD#
     220        S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE
     221        Q
     222        ;
     223RNF2CSV(RNRTN,RNIN,RNSTY)       ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT
     224        ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES
     225        ; RNSTY IS STYLE OF THE OUTPUT -
     226        ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES
     227        ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES
     228        ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES
     229        N RNR,RNC ;ROW ROOT,COL ROOT
     230        N RNI,RNJ,RNX
     231        I '$D(RNSTY) S RNSTY="NV" ;DEFAULT
     232        I RNSTY="NV" D NV(RNRTN,RNIN)  ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION
     233        E  D VN(RNRTN,RNIN) ;
     234        Q
     235        ;
     236NV(RNRTN,RNIN)  ;
     237        S RNR=$NA(@RNIN@("F"))
     238        S RNC=$NA(@RNIN@("V"))
     239        ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
     240        S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD"
     241        S RNI=""
     242        F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
     243        . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
     244        S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
     245        D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
     246        S RNI=""
     247        F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
     248        . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
     249        . S RNJ=""
     250        . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
     251        . . I $D(@RNC@(RNJ,RNI,1)) D  ; THIS ROW HAS THIS COLUMN
     252        . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA
     253        . . E  S RNX=RNX_"," ; NUL COLUMN
     254        . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
     255        . D PUSH^GPLXPATH(RNRTN,RNX)
     256        Q
     257        ;
     258VN(RNRTN,RNIN)  ;
     259        S RNR=$NA(@RNIN@("V"))
     260        S RNC=$NA(@RNIN@("F"))
     261        ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
     262        S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD"
     263        S RNI=""
     264        F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
     265        . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
     266        S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
     267        D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
     268        S RNI=""
     269        F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
     270        . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
     271        . S RNJ=""
     272        . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
     273        . . I $D(@RNR@(RNI,RNJ,1)) D  ; THIS ROW HAS THIS COLUMN
     274        . . . S RNX=RNX_""""_@RNR@(RNI,RNJ,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA
     275        . . E  S RNX=RNX_"," ; NUL COLUMN
     276        . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
     277        . D PUSH^GPLXPATH(RNRTN,RNX)
     278        Q
     279        ;
     280READCSV(PATH,NAME,GLB)  ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME
     281        ;
     282        Q $$FTG^%ZISH(PATH,NAME,GLB,1)
     283        ;
     284FILE2CSV(FNUM,FVN)      ; WRITES OUT A FILEMAN FILE TO CSV
     285        ;
     286        ;N G1,G2
     287        I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE
     288        S G1=$NA(^TMP($J,"C0CCSV",1))
     289        S G2=$NA(^TMP($J,"C0CCSV",2))
     290        D GETN2(G1,FNUM) ; GET THE MATRIX
     291        D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE
     292        K @G1
     293        D FILEOUT(G2,"FILE_"_FNUM_".csv")
     294        K @G2
     295        Q
     296        ;
     297FILEOUT(FOARY,FONAM)    ; WRITE OUT A FILE
     298        ;
     299        W $$OUTPUT^GPLXPATH($NA(@FOARY@(1)),FONAM,^TMP("GPLCCR","ODIR"))
     300        Q
     301        ;
     302FILEREF(FNUM)   ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM
     303        ;
     304        N C0CF
     305        S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE
     306        S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT
     307        I C0CF["()" S C0CF=$P(C0CF,"()",1)
     308        Q C0CF
     309        ;
     310SKIP    ;
     311        N TXT,DIERR
     312        S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT")
     313        I $D(DIERR) D CLEAN^DILF Q
     314        W "  report_text:",!  ;Progress Note Text
     315        N LN S LN=0
     316        F  S LN=$O(TXT(LN)) Q:'LN  D
     317        . W "    text"_LN_": "_TXT(LN),!
     318        . Q
     319        Q
     320        ;
     321ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
     322        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN)
     323        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     324        I '$D(ZTAB) S ZTAB="C0CA"
     325        Q $P(@ZTAB@(ZFN),"^",1)
     326ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
     327        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN)
     328        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     329        I '$D(ZTAB) S ZTAB="C0CA"
     330        Q $P(@ZTAB@(ZFN),"^",2)
     331ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
     332        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
     333        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     334        I '$D(ZTAB) S ZTAB="C0CA"
     335        Q $P($G(@ZTAB@(ZFN)),"^",3)
     336        ;
     337ZVALUEI(ZFN,ZTAB)       ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED
     338        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
     339        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     340        I '$D(ZTAB) S ZTAB="C0CA"
     341        Q $P($G(@ZTAB@(ZFN,"I")),"^",3)
     342        ;

  • ccr/branches/ohum/p/C0CRPMS.m

    r1342 r1428  
    1 C0CRPMS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR RPMS ;1/14/09  14:33
    2  ;;0.1;CCDCCR;;JUL 16,2008;Build 2
    3  ;Copyright 2008 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 "NO ENTRY FROM TOP",!
    21  Q
    22  ;
    23 DISPLAY ; RUN THE PCC DISPLAY ROUTINE
    24  D ^APCDDISP
    25  Q
    26  ;
    27 VTYPES ;
    28  D GETN2^C0CRNF("G1",9999999.07)
    29  ZWR G1
    30  Q
    31  ;
    32 VISITS(C0CDFN,C0CCNT) ;LIST VISIT DATES FOR PATIENT DFN
    33  ; C0CCNT IS A LIMIT ON HOW MANY VISITS TO DISPLAY ; DEFAULTS TO ALL
    34  I '$D(C0CCNT) S C0CCNT=999999999
    35  N G,GN
    36  S G="" S GN=0
    37  F  S G=$O(^AUPNVSIT("AA",C0CDFN,G)) Q:(G="")!(GN>C0CCNT)  D  ;
    38  . S GN=GN+1
    39  . W $$FMDTOUTC^C0CUTIL(9999999-G),!
    40  Q
    41  ;
    42 VISITS2(C0CDFN,C0CCNT) ;SECOND VERSION USING NEXTV
    43  ;
    44  N C0CG,GN
    45  S C0CG=""
    46  S GN=0
    47  I '$D(C0CCNT) S C0CCNT=99999999
    48  F  S C0CG=$$NEXTV(C0CDFN,C0CG) Q:(C0CG="")!(GN'<C0CCNT)  D  ;
    49  . S GN=GN+1
    50  . W $$FMDTOUTC^C0CUTIL(C0CG),!
    51  Q
    52  ;
    53 NEXTV(C0CDFN,C0CVDT) ;EXTRINSIC WHICH RETURNS THE NEXT VISIT DATE
    54  ;FOR PATIENT C0CDFN IN REVERSE TIME ORDER; PASS "" TO GET THE MOST
    55  ; RECENT VISIT
    56  N G
    57  S G=C0CVDT
    58  I G'="" S G=9999999-C0CVDT ;INVERT FOR INDEX
    59  S G=$O(^AUPNVSIT("AA",C0CDFN,G))
    60  I G="" Q ""
    61  E  Q 9999999-G
    62  ;
    63 GETV(C0CDFN,C0CVDT) ; GET VISIT USING DATE C0CVDT . IF C0CVDT IS NULL,
    64  ; GET MOST RECENT VISIT
    65  N C0CG
    66  I '$D(C0CVDT) S C0CVDT=$$NEXTV(C0CDFN,"")
    67  S APCDVLDT=C0CVDT
    68  S APCDPAT=C0CDFN
    69  D ^APCDVLK
    70  D ^APCDVD
    71  ;K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE
    72  Q
    73  ;
    74 GETNV(C0CDFN) ;GET MANY VISITS
    75  ;
    76  S APCDPAT=C0CDFN ;
    77  N C0CG S C0CG=""
    78  F  S C0CG=$$NEXTV(C0CDFN,C0CG) Q:C0CG=""  D  ; LOOP BACKWARD THROUGH VISITS
    79  . W C0CG,"    ",$$FMDTOUTC^C0CUTIL(C0CG),!
    80  . S APCDVLDT=C0CG
    81  . D ^APCDVLK
    82  . D ^APCDVD
    83  . K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE
    84  Q
    85  ;
    86 GETTBL(C0CTBL) ; SCAN FOR AND DISPLAY PATIENTS IN A RIMTBL, PASSED BY VALUE
    87  ;
    88  N ZG S ZG=$NA(^TMP("GPLRIM","RIMTBL","PATS",C0CTBL))
    89  N C0CG S C0CG=""
    90  N C0CQ S C0CQ=0
    91  F  S C0CG=$O(@ZG@(C0CG),-1) Q:(C0CG="")  D  ;
    92  . W "PAT: ",C0CG,!
    93  . D GETNV^C0CRPMS(C0CG)
    94  . K X R X
    95  . I X="Q" S C0CQ=1 ; QUIT IF Q
    96  Q
    97  ;
    98 CMPDRG ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES
    99  ;
    100  S C0CZI=0 ;
    101  F  S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI=""  D  ;ALL DRUGS IN RPMS DRUG FILE
    102  . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE
    103  . ;W "C0CZI:",C0CZI
    104  . F  S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ=""  D  ;
    105  . . ;W " C0CZJ:",C0CZJ
    106  . . N C0CZN,C0CZV ;
    107  . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE
    108  . . ;W " C0CZN:",C0CZN,!
    109  . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF
    110  . . I $D(C0CZV) D  ;FOUND A MATCH
    111  . . . S C0CVO="FOUND:^"_C0CZI_"^"_C0CZJ_"^"_C0CZN
    112  . . . S C0CVO=C0CVO_"^RXNORM:^"_$$ZVALUE^C0CRNF("MEDIATION CODE","C0CZV")
    113  . . . D PUSH^GPLXPATH("^C0CZRX",C0CVO)
    114  . . . W C0CVO,!
    115  Q
    116  ;
    117 CMPDRG2 ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES
    118  ;
    119  S C0CZI=0 ;
    120  F  S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI=""  D  ;ALL DRUGS IN RPMS DRUG FILE
    121  . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE
    122  . W "C0CZI:",C0CZI
    123  . F  S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ=""  D  ;
    124  . . W " C0CZJ:",C0CZJ
    125  . . N C0CZN,C0CZV ;
    126  . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE
    127  . . W " C0CZN:",C0CZN,!
    128  . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF
    129  . . I $D(C0CZV) D  ;FOUND A MATCH
    130  . . . W "FOUND: ",C0CZI," ",C0CZJ," ",C0CZN
    131  . . . W " VUID:",$$ZVALUE^C0CRNF("VUID","C0CZV"),!
    132  Q
    133  ;
     1C0CRPMS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR RPMS ;1/14/09  14:33
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008 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 "NO ENTRY FROM TOP",!
     21        Q
     22        ;
     23DISPLAY ; RUN THE PCC DISPLAY ROUTINE
     24        D ^APCDDISP
     25        Q
     26        ;
     27VTYPES  ;
     28        D GETN2^C0CRNF("G1",9999999.07)
     29        ZWR G1
     30        Q
     31        ;
     32VISITS(C0CDFN,C0CCNT)   ;LIST VISIT DATES FOR PATIENT DFN
     33        ; C0CCNT IS A LIMIT ON HOW MANY VISITS TO DISPLAY ; DEFAULTS TO ALL
     34        I '$D(C0CCNT) S C0CCNT=999999999
     35        N G,GN
     36        S G="" S GN=0
     37        F  S G=$O(^AUPNVSIT("AA",C0CDFN,G)) Q:(G="")!(GN>C0CCNT)  D  ;
     38        . S GN=GN+1
     39        . W $$FMDTOUTC^C0CUTIL(9999999-G),!
     40        Q
     41        ;
     42VISITS2(C0CDFN,C0CCNT)  ;SECOND VERSION USING NEXTV
     43        ;
     44        N C0CG,GN
     45        S C0CG=""
     46        S GN=0
     47        I '$D(C0CCNT) S C0CCNT=99999999
     48        F  S C0CG=$$NEXTV(C0CDFN,C0CG) Q:(C0CG="")!(GN'<C0CCNT)  D  ;
     49        . S GN=GN+1
     50        . W $$FMDTOUTC^C0CUTIL(C0CG),!
     51        Q
     52        ;
     53NEXTV(C0CDFN,C0CVDT)    ;EXTRINSIC WHICH RETURNS THE NEXT VISIT DATE
     54        ;FOR PATIENT C0CDFN IN REVERSE TIME ORDER; PASS "" TO GET THE MOST
     55        ; RECENT VISIT
     56        N G
     57        S G=C0CVDT
     58        I G'="" S G=9999999-C0CVDT ;INVERT FOR INDEX
     59        S G=$O(^AUPNVSIT("AA",C0CDFN,G))
     60        I G="" Q ""
     61        E  Q 9999999-G
     62        ;
     63GETV(C0CDFN,C0CVDT)     ; GET VISIT USING DATE C0CVDT . IF C0CVDT IS NULL,
     64        ; GET MOST RECENT VISIT
     65        N C0CG
     66        I '$D(C0CVDT) S C0CVDT=$$NEXTV(C0CDFN,"")
     67        S APCDVLDT=C0CVDT
     68        S APCDPAT=C0CDFN
     69        D ^APCDVLK
     70        D ^APCDVD
     71        ;K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE
     72        Q
     73        ;
     74GETNV(C0CDFN)   ;GET MANY VISITS
     75        ;
     76        S APCDPAT=C0CDFN ;
     77        N C0CG S C0CG=""
     78        F  S C0CG=$$NEXTV(C0CDFN,C0CG) Q:C0CG=""  D  ; LOOP BACKWARD THROUGH VISITS
     79        . W C0CG,"    ",$$FMDTOUTC^C0CUTIL(C0CG),!
     80        . S APCDVLDT=C0CG
     81        . D ^APCDVLK
     82        . D ^APCDVD
     83        . K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE
     84        Q
     85        ;
     86GETTBL(C0CTBL)  ; SCAN FOR AND DISPLAY PATIENTS IN A RIMTBL, PASSED BY VALUE
     87        ;
     88        N ZG S ZG=$NA(^TMP("GPLRIM","RIMTBL","PATS",C0CTBL))
     89        N C0CG S C0CG=""
     90        N C0CQ S C0CQ=0
     91        F  S C0CG=$O(@ZG@(C0CG),-1) Q:(C0CG="")  D  ;
     92        . W "PAT: ",C0CG,!
     93        . D GETNV^C0CRPMS(C0CG)
     94        . K X R X
     95        . I X="Q" S C0CQ=1 ; QUIT IF Q
     96        Q
     97        ;
     98CMPDRG  ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES
     99        ;
     100        S C0CZI=0 ;
     101        F  S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI=""  D  ;ALL DRUGS IN RPMS DRUG FILE
     102        . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE
     103        . ;W "C0CZI:",C0CZI
     104        . F  S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ=""  D  ;
     105        . . ;W " C0CZJ:",C0CZJ
     106        . . N C0CZN,C0CZV ;
     107        . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE
     108        . . ;W " C0CZN:",C0CZN,!
     109        . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF
     110        . . I $D(C0CZV) D  ;FOUND A MATCH
     111        . . . S C0CVO="FOUND:^"_C0CZI_"^"_C0CZJ_"^"_C0CZN
     112        . . . S C0CVO=C0CVO_"^RXNORM:^"_$$ZVALUE^C0CRNF("MEDIATION CODE","C0CZV")
     113        . . . D PUSH^GPLXPATH("^C0CZRX",C0CVO)
     114        . . . W C0CVO,!
     115        Q
     116        ;
     117CMPDRG2 ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES
     118        ;
     119        S C0CZI=0 ;
     120        F  S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI=""  D  ;ALL DRUGS IN RPMS DRUG FILE
     121        . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE
     122        . W "C0CZI:",C0CZI
     123        . F  S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ=""  D  ;
     124        . . W " C0CZJ:",C0CZJ
     125        . . N C0CZN,C0CZV ;
     126        . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE
     127        . . W " C0CZN:",C0CZN,!
     128        . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF
     129        . . I $D(C0CZV) D  ;FOUND A MATCH
     130        . . . W "FOUND: ",C0CZI," ",C0CZJ," ",C0CZN
     131        . . . W " VUID:",$$ZVALUE^C0CRNF("VUID","C0CZV"),!
     132        Q
     133        ;

  • ccr/branches/ohum/p/C0CRXN.m

    r1342 r1428  
    1 C0CRXN   ; CCDCCR/GPL - CCR RXN utilities; 12/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  W "This is the CCR RXNORM Utility Library ",!
    21  W !
    22  Q
    23  ;
    24 EXPAND ; MAIN ROUTINE TO CREATE THE C0C RXNORM VUID EXPANSION FILE (176.112)
    25  ; READ EACH RECORD FROM 176.111 AND USE THE VUID TO LOOK UP THE RXNORM
    26  ; CODE FROM 176.001 (RXNORM CONCEPTS)
    27  ; POPULATE ALL FIELDS IN 176.112 AND SET "NEW" TO "Y" IF 176.111 DOES NOT
    28  ; ALREADY HAVE AN RXNORM CODE.
    29  ; ADD THE RXNORM TEXT FIELD TO EVERY RECORD (NOT PRESENT IN 176.111)
    30  ; AND COMPARE THE RXNORM TEXT FIELD WITH THE VUID TEXT FIELD, SETTING THE
    31  ; "DIFFERENT TEXT" FIELD TO "Y" IF THERE ARE DIFFERENCES
    32  ; USES SUPPORT ROUTINES FROM C0CRNF.m
    33  N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR
    34  N C0CFVA,C0CFRXN ; CLOSED ROOTS FOR SOURCE FILES
    35  N C0CF ; CLOSED ROOT FOR DESTINATION FILE
    36  S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE
    37  S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE
    38  S C0CF=$$FILEREF^C0CRNF(176.112) ; C0C RXNORM VUID MAPPING EXPANSION FILE
    39  W C0CVA,C0CFRXN,C0CF,!
    40  S C0CZX=0
    41  S (HASRXN,NORXN,NOVUID,RXFOUND,RXMATCH,TXTMATCH)=0 ; INITIALIZE COUNTERS
    42  F  S C0CZX=$O(^C0CCODES(176.111,C0CZX)) Q:+C0CZX=0  D  ; FOR EVERY RECORD
    43  . K C0CA,C0CB,C0CC ; CLEAR ARRAYS
    44  . D FIELDS^C0CRNF("C0CC",176.112) ;GET FIELD NAMES FOR OUTPUT FILE
    45  . D GETN1^C0CRNF("C0CA",176.111,C0CZX,"","ALL") ;GET THE FIELDS
    46  . I $$ZVALUE("MEDIATION CODE")="" D
    47  . . S NORXN=NORXN+1 ;
    48  . E  D  ; PROCESS MEDIATION CODE
    49  . . S HASRXN=HASRXN+1
    50  . . D SETFDA("MEDIATION CODE",$$ZVALUE("MEDIATION CODE")) ;
    51  . I $$ZVALUE("VUID")="" D  ; BAD RECORD
    52  . . S NOVUID=NOVUID+1
    53  . . ;D SETFDA("VUID",$$ZVALUE("VUID"))
    54  . E  D SETFDA("VUID TEXT",$$ZVALUE("VUID TEXT"))
    55  . . ;ZWR C0CA
    56  . D GETN1^C0CRNF("C0CB",176.001,$$ZVALUE("VUID"),"VUID","ALL")
    57  . I $$ZVALUE("RXCUI","C0CB")'="" D  ; RXNORM FOUND
    58  . . S RXFOUND=RXFOUND+1
    59  . . I $$ZVALUE("MEDIATION CODE")="" D  ; THIS IS A NEW CODE
    60  . . . D SETFDA("MEDIATION CODE",$$ZVALUE("RXCUI","C0CB"))
    61  . . . D SETFDA("NEW","Y") ;FLAG RECORD HAS HAVING NEW RXNORM
    62  . . W "RXNORM=",$$ZVALUE("RXCUI","C0CB")," ",$$ZVALUE("STR","C0CB"),!
    63  . . W "VUID TEXT: ",$$ZVALUE("VUID TEXT"),!
    64  . . I $$ZVALUE("VUID TEXT")=$$ZVALUE("STR","C0CB") S TXTMATCH=TXTMATCH+1
    65  . . E  D  ;
    66  . . . S ZZ=$$ZVALUE("VUID TEXT")_"^"_$$ZVALUE("STR","C0CB")
    67  . . . D PUSH^GPLXPATH("NOMATCH",ZZ)
    68  . . . D SETFDA("RXNORM TEXT",$$ZVALUE("STR","C0CB")) ;
    69  . . . D SETFDA("DIFFERENT TEXT","Y") ;FLAG RECORD FOR DIFFERENT TEXT
    70  . I $$ZVALUE("MEDIATION CODE")=$$ZVALUE("RXCUI","C0CB") D  ;
    71  . . S RXMATCH=RXMATCH+1
    72  . . W "VUID=",$$ZVALUE("VUID")," MATCH RXNORM=",$$ZVALUE("MEDIATION CODE"),!
    73  . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
    74  . S C0CFDA(176.112,"+"_C0CZX_",",.01)=$$ZVALUE("VUID") ; NEW VUID RECORD
    75  . D UPDATE^DIE("","C0CFDA")
    76  . I $D(^TMP("DIERR",$J)) U $P BREAK
    77  W "HAS RXN=",HASRXN,!
    78  W "NO RXN=",NORXN,!
    79  W "NO VUID=",NOVUID,!
    80  W "RXNORM FOUND=",RXFOUND,!
    81  W "RXNORM MATCHES:",RXMATCH,!
    82  W "TEXT MATCHES:",TXTMATCH,!
    83  Q
    84  ;
    85 EXP2 ; ROUTINE TO CREATE 176.113 C0C RXNORM VUID MAPPING DISCREPANCIES FILE
    86  ; CROSS CHECKS THE NATIONAL DRUG FILE AND THE VA MAPPING FILE AGAINST
    87  ; THE UMLS RXNORM DATABASE
    88  ; THIS ROUTINE HAS BEEN ENHANCED TO ALSO CHECK THE 50.416 DRUG INGREDIENT
    89  ; FILE AND TREAT VUIDS FOUND THERE LIKE THE ONES BEING FOUND IN THE NDF
    90  ; IF THE VUID EXISISTS IN ALL THREE FILES, THE RXNORM CODE MATCHES IN
    91  ; THE VA MAPPING FILE AND THE TEXT STRINGS ARE THE SAME, THE VUID IS INCLUDED
    92  ; IN THE FILE BUT NO FLAGS ARE SET
    93  ; IF THE VUID IS MISSING FROM THE NATIONAL DRUG FILE NDF=N
    94  ; (IF THE VUID IS MISSING FROM THE NDF, IT IS CHECKED IN THE DRUG INGREDIENT
    95  ; FILE, AND IF FOUND, THE FLAG IS NOT SET. IN THIS CASE THE TEXT FROM THE
    96  ; DRUG INGREDIENT FILE IS USED FOR COMPARISONS)
    97  ; IF THE VUID IS MISSING FROM THE VA MAPPING FILE VAMAP=N
    98  ; IF THE VUID IS PRESENT IN THE VA MAPPING FILE, BUT THE RXNORM
    99  ; CODE IS MISSING IN THAT FILE, VARXN=N
    100  ; IF THE TEXT STRINGS DO NOT MATCH EXACTLY, TXTM=N AND ALL THREE STRINGS
    101  ; ARE SHOWN; NDF TEXT=NDF TEXT STRING, VA MAP TEXT=VA MAPPING TEXT STRING
    102  ; RXNORM TEXT=RXNORM TEXT STRING
    103  ; THE FILE IS KEYED ON VUID AND WOULD USUALLY BE SORTED BY VUID
    104  ; THE OBJECTIVE IS TO SEE IF NDF (50.68) AND VA MAPPING (176.111) HAVE
    105  ; ALL THE VUID CODES THAT ARE IN THE UMLS RXNORM DATABASE
    106  N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR
    107  N C0CFVA,C0CFRXN ; CLOSED ROOTS FOR SOURCE FILES
    108  N C0CF ; CLOSED ROOT FOR DESTINATION FILE
    109  S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE
    110  S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE
    111  ;S C0CF=$$FILEREF^C0CRNF(176.113) ; C0C RXNORM VUID MAPPING ADDITIONAL FILE
    112  W C0CVA,C0CFRXN,! ;C0CF,!
    113  S C0CZX=0
    114  S (NDFVCNT,NDFTCNT,NDFNO)=0 ; COUNTERS FOR NDF TESTS
    115  S (VAVCNT,VATCNT,VARCNT,VANO)=0 ; COUNTERS FOR VA MAPPING FILE TESTS
    116  F  S C0CZX=$O(^C0CRXN(176.001,"VUID",C0CZX)) Q:+C0CZX=0  D  ; FOR EVERY VUID
    117  . K C0CA,C0CB,C0CC,C0CD ; CLEAR ARRAYS
    118  . D FIELDS^C0CRNF("C0CC",176.113) ;GET FIELD NAMES FOR OUTPUT FILE
    119  . D GETN1^C0CRNF("C0CA",176.001,C0CZX,"VUID","ALL") ;GET FROM RXNORM FILE
    120  . D GETN1^C0CRNF("C0CB",176.111,C0CZX,"B","ALL") ;GET FROM VA MAPPING FILE
    121  . D GETN1^C0CRNF("C0CD",50.68,C0CZX,"AVUID","ALL") ;GET FROM NDF
    122  . D GETN1^C0CRNF("C0CE",50.416,C0CZX,"AVUID","ALL") ;GET FROM DRUG INGREDIENTS
    123  . ;D SETFDA("VUID",$$ZVALUE("CODE")) ;SET THE VUID CODE
    124  . D SETFDA("RXNORM",$$ZVALUE("RXCUI")) ;SET THE RXNORM CODE
    125  . D SETFDA("RXNORM TEXT",$$ZVALUE("STR")) ;SET THE RXNORM TEXT
    126  . ;VA MAPPING FILE TESTS
    127  . I $$ZVALUE("VUID","C0CB")=C0CZX D  ; VUID FOUND
    128  . . S VAVCNT=VAVCNT+1 ;INCREMENT COUNT
    129  . . I $$ZVALUE("STR")'=$$ZVALUE("VUID TEXT","C0CB") D  ;TEXT MISMATCH
    130  . . . S VATCNT=VATCNT+1 ; INCREMENT VA TEXT MISMATCH COUNT
    131  . . . D SETFDA("TXTM","N") ;MARK THAT TEXT DOESN'T MATCH
    132  . . . D SETFDA("VA MAP TEXT",$$ZVALUE("VUID TEXT","C0CB")) ; SET VA MAP TEXT
    133  . E  D  ; VUID NOT FOUND
    134  . . S VANO=VANO+1
    135  . . D SETFDA("VAMAP","N") ;MARK AS MISSING FROM VA MAPPING FILE
    136  . ; NATIONAL DRUG FILE TESTS
    137  . I ($$ZVALUE("VUID","C0CD")=C0CZX)!($$ZVALUE("VUID","C0CE")=C0CZX) D  ;
    138  . . ;FOUND IN NATIONAL DRUG FILE OR DRUG INGREDIENT FILE
    139  . . S NDFVCNT=NDFVCNT+1 ;INCREMENT VUID FOUND COUNT
    140  . . I $$ZVALUE("NAME","C0CD")'=$$ZVALUE("STR") D  ;NDF TEXT DOESN'T MATCH
    141  . . . I $$ZVALUE("NAME","C0CE")'=$$ZVALUE("STR") D  ;DRUG ING FILE ALSO
    142  . . . . S NDFTCNT=NDFTCNT+1 ; INCREMENT MISMATCHED NDF TEXT COUNT
    143  . . . . D SETFDA("TXTM","N") ; SET TEXT MATCH FLAG TO N
    144  . . . . D SETFDA("NDF TEXT",$$ZVALUE("NAME","C0CD")) ;POST THE TEXT
    145  . . . . D SETFDA("NAT DRUG TEXT",$$ZVALUE("NAME","C0CE")) ;POST TEXT
    146  . E  D  ;
    147  . . D SETFDA("NDF","N") ;MARK AS MISSING
    148  . . S NDFNO=NDFNO+1 ;INCREMENT MISSING COUNT
    149  . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
    150  . S C0CFDA(176.113,"+"_C0CZX_",",.01)=C0CZX ; NEW VUID RECORD
    151  . D UPDATE^DIE("","C0CFDA")
    152  . I $D(^TMP("DIERR",$J)) U $P BREAK
    153  W "VA MAPPING VUID COUNT: ",VAVCNT,!
    154  W "VA MAPPING MISSING: ",VANO,!
    155  W "VA MAPPING TEXT MISMATCH: ",VATCNT,!
    156  W "NDF VUID COUNT: ",NDFVCNT,!
    157  W "NDF MISSING: ",NDFNO,!
    158  W "NDF TEXT MISMATCH: ",NDFTCNT,!
    159  Q
    160 CHKNDF ; ROUTINE TO CHECK THE NATIONAL DRUG FILE WITH THE UMLS RXNORM DB
    161  ; USING THE AVUID INDEX, READS ALL VUID CODES IN ^PSNDF(50.68),
    162  ; CHECKS TO SEE IF THE CODE IS IN 176.001, AND CREATES A RECORD
    163  ; IN 176.114
    164  ; THE OBJECTIVE IS TO SEE IF ^PSNDF(50.68) HAS ALL THE VUID CODES IN THE
    165  ; UMLS RXNORM DATABASE AND IF THE TEXT FIELDS MATCH
    166  ; ALSO CAPTURES THE RXNORM CODE MAPPING
    167  ; CHKNDF2 WILL CHECK THE OTHER DIRECTION, STARTING WITH THE 176.001 VUID INDEX
    168  ; THIS ROUTINE ALSO CHECKS IF THE VUID CODE IS IN 176.111 AND IF NOT
    169  ; SETS NOTMAPPED=Y
    170  N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR
    171  N C0CFVA,C0CFRXN,C0CPSNDF ; CLOSED ROOTS FOR SOURCE FILES
    172  N C0CF ; CLOSED ROOT FOR DESTINATION FILE
    173  S C0CPSNDF=$$FILEREF^C0CRNF(50.68) ; NDF CLOSED ROOT REFERENCE
    174  S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE
    175  S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE
    176  ;S C0CF=$$FILEREF^C0CRNF(176.113) ; C0C RXNORM VUID MAPPING ADDITIONAL FILE
    177  W C0CVA,C0CFRXN,! ;C0CF,!
    178  S C0CZX=0
    179  S (FOUND,MISSING)=0
    180  S (NOVUID,VMATCH,NOMATCH,MISSING,FOUND,TXTMATCH,NOTM,NVAM)=0 ; COUNTERS
    181  F  S C0CZX=$O(^PSNDF(50.68,"AVUID",C0CZX)) Q:+C0CZX=0  D  ; FOR EVERY VUID
    182  . K C0CA,C0CB,C0CC,C0CD ; CLEAR ARRAYS
    183  . ;D FIELDS^C0CRNF("C0CC",176.113) ;GET FIELD NAMES FOR OUTPUT FILE
    184  . D GETN1^C0CRNF("C0CA",50.68,C0CZX,"AVUID","ALL") ;GET THE FIELDS
    185  . I $$ZVALUE("VUID")="" D  ; ERROR, SHOULD NOT HAPPEN
    186  . . S NOVUID=NOVUID+1 ; FLAG THE ERROR
    187  . . D PUSH^GPLXPATH("NOVUID",C0CZX) ; RECORD THE VUID
    188  . D GETN1^C0CRNF("C0CD",176.001,C0CZX,"VUID","ALL") ;TRY RXNORM DB
    189  . I $$ZVALUE("CODE","C0CD")=C0CZX D  ; FOUND IN RXNORM
    190  . . S VMATCH=VMATCH+1 ; COUNT OF PSNDF VUIDS FOUND IN RXNORM
    191  . . I $$ZVALUE("NAME")=$$ZVALUE("STR","C0CD") D  ;TEXT MATCHES
    192  . . . S TXTMATCH=TXTMATCH+1 ; COUNT IT
    193  . . E  D  ; TEXT DOESN'T MATCH
    194  . . . S NOTM=NOTM+1 ;NO TEXT MATCH COUNTER
    195  . . . S ZV=$$ZVALUE("NAME")_"^"_$$ZVALUE("STR","C0CD")
    196  . . . W ZV,!
    197  . . . D PUSH^GPLXPATH("TXTNM",ZV) ; RECORD THE TXT MISMATCH
    198  . E  S NOMATCH=NOMATCH+1 ; NOT FOUND IN RXNORM
    199  . D GETN1^C0CRNF("C0CB",176.111,C0CZX,"B","ALL") ;TRY TO GET FROM 176.111
    200  . I $$ZVALUE("VUID","C0CB")="" D  ; VUID NOT FOUND
    201  . . ;W "NOT FOUND: ",C0CZX," ",$$ZVALUE("STR")," ",$$ZVALUE("RXCUI"),!
    202  . . S MISSING=MISSING+1
    203  . . D PUSH^GPLXPATH("MISSING",C0CZX) ;MISSING FROM MAPPING FILE
    204  . E  D  ; FOUND IN VA MAPPING FILE
    205  . . S FOUND=FOUND+1
    206  . . I $$ZVALUE("VUID TEXT","C0CB")'=$$ZVALUE("NAME") D  ; TEXT DOESN'T MATCH
    207  . . . S NVAM=NVAM+1 ; MAPPING FILE TEXT IS DIFFERENT THAN NDF
    208  . . . S ZY=$$ZVALUE("VUID TEXT","C0CB")_"^"_$$ZVALUE("NAME") ;BOTH STRINGS
    209  . . . W "VA: ",ZY,!
    210  . . . D PUSH^GPLXPATH("NVAM",ZY) ;SAVE IT
    211  W "MISSING IN MAPPING FILE: ",MISSING,!
    212  W "FOUND IN MAPPING FILE: ",FOUND,!
    213  W "FOUND IN RXNORM: ",VMATCH,!
    214  W "NOT FOUND IN RXNORM: ",NOMATCH,!
    215  W "ERRORS: ",NOVUID,!
    216  Q
    217  ;
    218  . I $$ZVALUE("MEDIATION CODE")="" D
    219  . . S NORXN=NORXN+1 ;
    220  . E  D  ; PROCESS MEDIATION CODE
    221  . . S HASRXN=HASRXN+1
    222  . . D SETFDA("MEDIATION CODE",$$ZVALUE("MEDIATION CODE")) ;
    223  . I $$ZVALUE("VUID")="" D  ; BAD RECORD
    224  . . S NOVUID=NOVUID+1
    225  . . ;D SETFDA("VUID",$$ZVALUE("VUID"))
    226  . E  D SETFDA("VUID TEXT",$$ZVALUE("VUID TEXT"))
    227  . . ;ZWR C0CA
    228  . D GETN1^C0CRNF("C0CB",176.001,$$ZVALUE("VUID"),"VUID","ALL")
    229  . I $$ZVALUE("RXCUI","C0CB")'="" D  ; RXNORM FOUND
    230  . . S RXFOUND=RXFOUND+1
    231  . . I $$ZVALUE("MEDIATION CODE")="" D  ; THIS IS A NEW CODE
    232  . . . D SETFDA("MEDIATION CODE",$$ZVALUE("RXCUI","C0CB"))
    233  . . . D SETFDA("NEW","Y") ;FLAG RECORD HAS HAVING NEW RXNORM
    234  . . W "RXNORM=",$$ZVALUE("RXCUI","C0CB")," ",$$ZVALUE("STR","C0CB"),!
    235  . . W "VUID TEXT: ",$$ZVALUE("VUID TEXT"),!
    236  . . I $$ZVALUE("VUID TEXT")=$$ZVALUE("STR","C0CB") S TXTMATCH=TXTMATCH+1
    237  . . E  D  ;
    238  . . . D PUSH^GPLXPATH("NOMATCH",$$ZVALUE("VUID TEXT")_"^"_$$ZVALUE("STR","C0CB"))
    239  . . . D SETFDA("RXNORM TEXT",$$ZVALUE("STR","C0CB")) ;
    240  . . . D SETFDA("DIFFERENT TEXT","Y") ;FLAG RECORD FOR DIFFERENT TEXT
    241  . I $$ZVALUE("MEDIATION CODE")=$$ZVALUE("RXCUI","C0CB") D  ;
    242  . . S RXMATCH=RXMATCH+1
    243  . . W "VUID=",$$ZVALUE("VUID")," MATCH RXNORM=",$$ZVALUE("MEDIATION CODE"),!
    244  . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
    245  . S C0CFDA(176.112,"+"_C0CZX_",",.01)=$$ZVALUE("VUID") ; NEW VUID RECORD
    246  . D UPDATE^DIE("","C0CFDA")
    247  . I $D(^TMP("DIERR",$J)) U $P BREAK
    248  W "HAS RXN=",HASRXN,!
    249  W "NO RXN=",NORXN,!
    250  W "NO VUID=",NOVUID,!
    251  W "RXNORM FOUND=",RXFOUND,!
    252  W "RXNORM MATCHES:",RXMATCH,!
    253  W "TEXT MATCHES:",TXTMATCH,!
    254  Q
    255 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
    256  ; TO SET TO VALUE C0CSV.
    257  ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
    258  ; C0CSN,C0CSV ARE PASSED BY VALUE
    259  ;
    260  N C0CSI,C0CSJ
    261  S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
    262  S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
    263  S C0CFDA(C0CSI,"+"_C0CZX_",",C0CSJ)=C0CSV
    264  Q
    265 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
    266  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
    267  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    268  I '$D(ZTAB) S ZTAB="C0CA"
    269  N ZR
    270  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
    271  E  S ZR=""
    272  Q ZR
    273 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
    274  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
    275  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    276  I '$D(ZTAB) S ZTAB="C0CA"
    277  N ZR
    278  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
    279  E  S ZR=""
    280  Q ZR
    281  ;
    282 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
    283  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
    284  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    285  I '$D(ZTAB) S ZTAB="C0CA"
    286  N ZR
    287  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
    288  E  S ZR=""
    289  Q ZR
    290  ;
     1C0CRXN    ; CCDCCR/GPL - CCR RXN utilities; 12/6/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        W "This is the CCR RXNORM Utility Library ",!
     21        W !
     22        Q
     23        ;
     24EXPAND  ; MAIN ROUTINE TO CREATE THE C0C RXNORM VUID EXPANSION FILE (176.112)
     25        ; READ EACH RECORD FROM 176.111 AND USE THE VUID TO LOOK UP THE RXNORM
     26        ; CODE FROM 176.001 (RXNORM CONCEPTS)
     27        ; POPULATE ALL FIELDS IN 176.112 AND SET "NEW" TO "Y" IF 176.111 DOES NOT
     28        ; ALREADY HAVE AN RXNORM CODE.
     29        ; ADD THE RXNORM TEXT FIELD TO EVERY RECORD (NOT PRESENT IN 176.111)
     30        ; AND COMPARE THE RXNORM TEXT FIELD WITH THE VUID TEXT FIELD, SETTING THE
     31        ; "DIFFERENT TEXT" FIELD TO "Y" IF THERE ARE DIFFERENCES
     32        ; USES SUPPORT ROUTINES FROM C0CRNF.m
     33        N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR
     34        N C0CFVA,C0CFRXN ; CLOSED ROOTS FOR SOURCE FILES
     35        N C0CF ; CLOSED ROOT FOR DESTINATION FILE
     36        S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE
     37        S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE
     38        S C0CF=$$FILEREF^C0CRNF(176.112) ; C0C RXNORM VUID MAPPING EXPANSION FILE
     39        W C0CVA,C0CFRXN,C0CF,!
     40        S C0CZX=0
     41        S (HASRXN,NORXN,NOVUID,RXFOUND,RXMATCH,TXTMATCH)=0 ; INITIALIZE COUNTERS
     42        F  S C0CZX=$O(^C0CCODES(176.111,C0CZX)) Q:+C0CZX=0  D  ; FOR EVERY RECORD
     43        . K C0CA,C0CB,C0CC ; CLEAR ARRAYS
     44        . D FIELDS^C0CRNF("C0CC",176.112) ;GET FIELD NAMES FOR OUTPUT FILE
     45        . D GETN1^C0CRNF("C0CA",176.111,C0CZX,"","ALL") ;GET THE FIELDS
     46        . I $$ZVALUE("MEDIATION CODE")="" D
     47        . . S NORXN=NORXN+1 ;
     48        . E  D  ; PROCESS MEDIATION CODE
     49        . . S HASRXN=HASRXN+1
     50        . . D SETFDA("MEDIATION CODE",$$ZVALUE("MEDIATION CODE")) ;
     51        . I $$ZVALUE("VUID")="" D  ; BAD RECORD
     52        . . S NOVUID=NOVUID+1
     53        . . ;D SETFDA("VUID",$$ZVALUE("VUID"))
     54        . E  D SETFDA("VUID TEXT",$$ZVALUE("VUID TEXT"))
     55        . . ;ZWR C0CA
     56        . D GETN1^C0CRNF("C0CB",176.001,$$ZVALUE("VUID"),"VUID","ALL")
     57        . I $$ZVALUE("RXCUI","C0CB")'="" D  ; RXNORM FOUND
     58        . . S RXFOUND=RXFOUND+1
     59        . . I $$ZVALUE("MEDIATION CODE")="" D  ; THIS IS A NEW CODE
     60        . . . D SETFDA("MEDIATION CODE",$$ZVALUE("RXCUI","C0CB"))
     61        . . . D SETFDA("NEW","Y") ;FLAG RECORD HAS HAVING NEW RXNORM
     62        . . W "RXNORM=",$$ZVALUE("RXCUI","C0CB")," ",$$ZVALUE("STR","C0CB"),!
     63        . . W "VUID TEXT: ",$$ZVALUE("VUID TEXT"),!
     64        . . I $$ZVALUE("VUID TEXT")=$$ZVALUE("STR","C0CB") S TXTMATCH=TXTMATCH+1
     65        . . E  D  ;
     66        . . . S ZZ=$$ZVALUE("VUID TEXT")_"^"_$$ZVALUE("STR","C0CB")
     67        . . . D PUSH^GPLXPATH("NOMATCH",ZZ)
     68        . . . D SETFDA("RXNORM TEXT",$$ZVALUE("STR","C0CB")) ;
     69        . . . D SETFDA("DIFFERENT TEXT","Y") ;FLAG RECORD FOR DIFFERENT TEXT
     70        . I $$ZVALUE("MEDIATION CODE")=$$ZVALUE("RXCUI","C0CB") D  ;
     71        . . S RXMATCH=RXMATCH+1
     72        . . W "VUID=",$$ZVALUE("VUID")," MATCH RXNORM=",$$ZVALUE("MEDIATION CODE"),!
     73        . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
     74        . S C0CFDA(176.112,"+"_C0CZX_",",.01)=$$ZVALUE("VUID") ; NEW VUID RECORD
     75        . D UPDATE^DIE("","C0CFDA")
     76        . I $D(^TMP("DIERR",$J)) U $P BREAK
     77        W "HAS RXN=",HASRXN,!
     78        W "NO RXN=",NORXN,!
     79        W "NO VUID=",NOVUID,!
     80        W "RXNORM FOUND=",RXFOUND,!
     81        W "RXNORM MATCHES:",RXMATCH,!
     82        W "TEXT MATCHES:",TXTMATCH,!
     83        Q
     84        ;
     85EXP2    ; ROUTINE TO CREATE 176.113 C0C RXNORM VUID MAPPING DISCREPANCIES FILE
     86        ; CROSS CHECKS THE NATIONAL DRUG FILE AND THE VA MAPPING FILE AGAINST
     87        ; THE UMLS RXNORM DATABASE
     88        ; THIS ROUTINE HAS BEEN ENHANCED TO ALSO CHECK THE 50.416 DRUG INGREDIENT
     89        ; FILE AND TREAT VUIDS FOUND THERE LIKE THE ONES BEING FOUND IN THE NDF
     90        ; IF THE VUID EXISISTS IN ALL THREE FILES, THE RXNORM CODE MATCHES IN
     91        ; THE VA MAPPING FILE AND THE TEXT STRINGS ARE THE SAME, THE VUID IS INCLUDED
     92        ; IN THE FILE BUT NO FLAGS ARE SET
     93        ; IF THE VUID IS MISSING FROM THE NATIONAL DRUG FILE NDF=N
     94        ; (IF THE VUID IS MISSING FROM THE NDF, IT IS CHECKED IN THE DRUG INGREDIENT
     95        ; FILE, AND IF FOUND, THE FLAG IS NOT SET. IN THIS CASE THE TEXT FROM THE
     96        ; DRUG INGREDIENT FILE IS USED FOR COMPARISONS)
     97        ; IF THE VUID IS MISSING FROM THE VA MAPPING FILE VAMAP=N
     98        ; IF THE VUID IS PRESENT IN THE VA MAPPING FILE, BUT THE RXNORM
     99        ; CODE IS MISSING IN THAT FILE, VARXN=N
     100        ; IF THE TEXT STRINGS DO NOT MATCH EXACTLY, TXTM=N AND ALL THREE STRINGS
     101        ; ARE SHOWN; NDF TEXT=NDF TEXT STRING, VA MAP TEXT=VA MAPPING TEXT STRING
     102        ; RXNORM TEXT=RXNORM TEXT STRING
     103        ; THE FILE IS KEYED ON VUID AND WOULD USUALLY BE SORTED BY VUID
     104        ; THE OBJECTIVE IS TO SEE IF NDF (50.68) AND VA MAPPING (176.111) HAVE
     105        ; ALL THE VUID CODES THAT ARE IN THE UMLS RXNORM DATABASE
     106        N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR
     107        N C0CFVA,C0CFRXN ; CLOSED ROOTS FOR SOURCE FILES
     108        N C0CF ; CLOSED ROOT FOR DESTINATION FILE
     109        S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE
     110        S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE
     111        ;S C0CF=$$FILEREF^C0CRNF(176.113) ; C0C RXNORM VUID MAPPING ADDITIONAL FILE
     112        W C0CVA,C0CFRXN,! ;C0CF,!
     113        S C0CZX=0
     114        S (NDFVCNT,NDFTCNT,NDFNO)=0 ; COUNTERS FOR NDF TESTS
     115        S (VAVCNT,VATCNT,VARCNT,VANO)=0 ; COUNTERS FOR VA MAPPING FILE TESTS
     116        F  S C0CZX=$O(^C0CRXN(176.001,"VUID",C0CZX)) Q:+C0CZX=0  D  ; FOR EVERY VUID
     117        . K C0CA,C0CB,C0CC,C0CD ; CLEAR ARRAYS
     118        . D FIELDS^C0CRNF("C0CC",176.113) ;GET FIELD NAMES FOR OUTPUT FILE
     119        . D GETN1^C0CRNF("C0CA",176.001,C0CZX,"VUID","ALL") ;GET FROM RXNORM FILE
     120        . D GETN1^C0CRNF("C0CB",176.111,C0CZX,"B","ALL") ;GET FROM VA MAPPING FILE
     121        . D GETN1^C0CRNF("C0CD",50.68,C0CZX,"AVUID","ALL") ;GET FROM NDF
     122        . D GETN1^C0CRNF("C0CE",50.416,C0CZX,"AVUID","ALL") ;GET FROM DRUG INGREDIENTS
     123        . ;D SETFDA("VUID",$$ZVALUE("CODE")) ;SET THE VUID CODE
     124        . D SETFDA("RXNORM",$$ZVALUE("RXCUI")) ;SET THE RXNORM CODE
     125        . D SETFDA("RXNORM TEXT",$$ZVALUE("STR")) ;SET THE RXNORM TEXT
     126        . ;VA MAPPING FILE TESTS
     127        . I $$ZVALUE("VUID","C0CB")=C0CZX D  ; VUID FOUND
     128        . . S VAVCNT=VAVCNT+1 ;INCREMENT COUNT
     129        . . I $$ZVALUE("STR")'=$$ZVALUE("VUID TEXT","C0CB") D  ;TEXT MISMATCH
     130        . . . S VATCNT=VATCNT+1 ; INCREMENT VA TEXT MISMATCH COUNT
     131        . . . D SETFDA("TXTM","N") ;MARK THAT TEXT DOESN'T MATCH
     132        . . . D SETFDA("VA MAP TEXT",$$ZVALUE("VUID TEXT","C0CB")) ; SET VA MAP TEXT
     133        . E  D  ; VUID NOT FOUND
     134        . . S VANO=VANO+1
     135        . . D SETFDA("VAMAP","N") ;MARK AS MISSING FROM VA MAPPING FILE
     136        . ; NATIONAL DRUG FILE TESTS
     137        . I ($$ZVALUE("VUID","C0CD")=C0CZX)!($$ZVALUE("VUID","C0CE")=C0CZX) D  ;
     138        . . ;FOUND IN NATIONAL DRUG FILE OR DRUG INGREDIENT FILE
     139        . . S NDFVCNT=NDFVCNT+1 ;INCREMENT VUID FOUND COUNT
     140        . . I $$ZVALUE("NAME","C0CD")'=$$ZVALUE("STR") D  ;NDF TEXT DOESN'T MATCH
     141        . . . I $$ZVALUE("NAME","C0CE")'=$$ZVALUE("STR") D  ;DRUG ING FILE ALSO
     142        . . . . S NDFTCNT=NDFTCNT+1 ; INCREMENT MISMATCHED NDF TEXT COUNT
     143        . . . . D SETFDA("TXTM","N") ; SET TEXT MATCH FLAG TO N
     144        . . . . D SETFDA("NDF TEXT",$$ZVALUE("NAME","C0CD")) ;POST THE TEXT
     145        . . . . D SETFDA("NAT DRUG TEXT",$$ZVALUE("NAME","C0CE")) ;POST TEXT
     146        . E  D  ;
     147        . . D SETFDA("NDF","N") ;MARK AS MISSING
     148        . . S NDFNO=NDFNO+1 ;INCREMENT MISSING COUNT
     149        . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
     150        . S C0CFDA(176.113,"+"_C0CZX_",",.01)=C0CZX ; NEW VUID RECORD
     151        . D UPDATE^DIE("","C0CFDA")
     152        . I $D(^TMP("DIERR",$J)) U $P BREAK
     153        W "VA MAPPING VUID COUNT: ",VAVCNT,!
     154        W "VA MAPPING MISSING: ",VANO,!
     155        W "VA MAPPING TEXT MISMATCH: ",VATCNT,!
     156        W "NDF VUID COUNT: ",NDFVCNT,!
     157        W "NDF MISSING: ",NDFNO,!
     158        W "NDF TEXT MISMATCH: ",NDFTCNT,!
     159        Q
     160CHKNDF  ; ROUTINE TO CHECK THE NATIONAL DRUG FILE WITH THE UMLS RXNORM DB
     161        ; USING THE AVUID INDEX, READS ALL VUID CODES IN ^PSNDF(50.68),
     162        ; CHECKS TO SEE IF THE CODE IS IN 176.001, AND CREATES A RECORD
     163        ; IN 176.114
     164        ; THE OBJECTIVE IS TO SEE IF ^PSNDF(50.68) HAS ALL THE VUID CODES IN THE
     165        ; UMLS RXNORM DATABASE AND IF THE TEXT FIELDS MATCH
     166        ; ALSO CAPTURES THE RXNORM CODE MAPPING
     167        ; CHKNDF2 WILL CHECK THE OTHER DIRECTION, STARTING WITH THE 176.001 VUID INDEX
     168        ; THIS ROUTINE ALSO CHECKS IF THE VUID CODE IS IN 176.111 AND IF NOT
     169        ; SETS NOTMAPPED=Y
     170        N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR
     171        N C0CFVA,C0CFRXN,C0CPSNDF ; CLOSED ROOTS FOR SOURCE FILES
     172        N C0CF ; CLOSED ROOT FOR DESTINATION FILE
     173        S C0CPSNDF=$$FILEREF^C0CRNF(50.68) ; NDF CLOSED ROOT REFERENCE
     174        S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE
     175        S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE
     176        ;S C0CF=$$FILEREF^C0CRNF(176.113) ; C0C RXNORM VUID MAPPING ADDITIONAL FILE
     177        W C0CVA,C0CFRXN,! ;C0CF,!
     178        S C0CZX=0
     179        S (FOUND,MISSING)=0
     180        S (NOVUID,VMATCH,NOMATCH,MISSING,FOUND,TXTMATCH,NOTM,NVAM)=0 ; COUNTERS
     181        F  S C0CZX=$O(^PSNDF(50.68,"AVUID",C0CZX)) Q:+C0CZX=0  D  ; FOR EVERY VUID
     182        . K C0CA,C0CB,C0CC,C0CD ; CLEAR ARRAYS
     183        . ;D FIELDS^C0CRNF("C0CC",176.113) ;GET FIELD NAMES FOR OUTPUT FILE
     184        . D GETN1^C0CRNF("C0CA",50.68,C0CZX,"AVUID","ALL") ;GET THE FIELDS
     185        . I $$ZVALUE("VUID")="" D  ; ERROR, SHOULD NOT HAPPEN
     186        . . S NOVUID=NOVUID+1 ; FLAG THE ERROR
     187        . . D PUSH^GPLXPATH("NOVUID",C0CZX) ; RECORD THE VUID
     188        . D GETN1^C0CRNF("C0CD",176.001,C0CZX,"VUID","ALL") ;TRY RXNORM DB
     189        . I $$ZVALUE("CODE","C0CD")=C0CZX D  ; FOUND IN RXNORM
     190        . . S VMATCH=VMATCH+1 ; COUNT OF PSNDF VUIDS FOUND IN RXNORM
     191        . . I $$ZVALUE("NAME")=$$ZVALUE("STR","C0CD") D  ;TEXT MATCHES
     192        . . . S TXTMATCH=TXTMATCH+1 ; COUNT IT
     193        . . E  D  ; TEXT DOESN'T MATCH
     194        . . . S NOTM=NOTM+1 ;NO TEXT MATCH COUNTER
     195        . . . S ZV=$$ZVALUE("NAME")_"^"_$$ZVALUE("STR","C0CD")
     196        . . . W ZV,!
     197        . . . D PUSH^GPLXPATH("TXTNM",ZV) ; RECORD THE TXT MISMATCH
     198        . E  S NOMATCH=NOMATCH+1 ; NOT FOUND IN RXNORM
     199        . D GETN1^C0CRNF("C0CB",176.111,C0CZX,"B","ALL") ;TRY TO GET FROM 176.111
     200        . I $$ZVALUE("VUID","C0CB")="" D  ; VUID NOT FOUND
     201        . . ;W "NOT FOUND: ",C0CZX," ",$$ZVALUE("STR")," ",$$ZVALUE("RXCUI"),!
     202        . . S MISSING=MISSING+1
     203        . . D PUSH^GPLXPATH("MISSING",C0CZX) ;MISSING FROM MAPPING FILE
     204        . E  D  ; FOUND IN VA MAPPING FILE
     205        . . S FOUND=FOUND+1
     206        . . I $$ZVALUE("VUID TEXT","C0CB")'=$$ZVALUE("NAME") D  ; TEXT DOESN'T MATCH
     207        . . . S NVAM=NVAM+1 ; MAPPING FILE TEXT IS DIFFERENT THAN NDF
     208        . . . S ZY=$$ZVALUE("VUID TEXT","C0CB")_"^"_$$ZVALUE("NAME") ;BOTH STRINGS
     209        . . . W "VA: ",ZY,!
     210        . . . D PUSH^GPLXPATH("NVAM",ZY) ;SAVE IT
     211        W "MISSING IN MAPPING FILE: ",MISSING,!
     212        W "FOUND IN MAPPING FILE: ",FOUND,!
     213        W "FOUND IN RXNORM: ",VMATCH,!
     214        W "NOT FOUND IN RXNORM: ",NOMATCH,!
     215        W "ERRORS: ",NOVUID,!
     216        Q
     217        ;
     218        . I $$ZVALUE("MEDIATION CODE")="" D
     219        . . S NORXN=NORXN+1 ;
     220        . E  D  ; PROCESS MEDIATION CODE
     221        . . S HASRXN=HASRXN+1
     222        . . D SETFDA("MEDIATION CODE",$$ZVALUE("MEDIATION CODE")) ;
     223        . I $$ZVALUE("VUID")="" D  ; BAD RECORD
     224        . . S NOVUID=NOVUID+1
     225        . . ;D SETFDA("VUID",$$ZVALUE("VUID"))
     226        . E  D SETFDA("VUID TEXT",$$ZVALUE("VUID TEXT"))
     227        . . ;ZWR C0CA
     228        . D GETN1^C0CRNF("C0CB",176.001,$$ZVALUE("VUID"),"VUID","ALL")
     229        . I $$ZVALUE("RXCUI","C0CB")'="" D  ; RXNORM FOUND
     230        . . S RXFOUND=RXFOUND+1
     231        . . I $$ZVALUE("MEDIATION CODE")="" D  ; THIS IS A NEW CODE
     232        . . . D SETFDA("MEDIATION CODE",$$ZVALUE("RXCUI","C0CB"))
     233        . . . D SETFDA("NEW","Y") ;FLAG RECORD HAS HAVING NEW RXNORM
     234        . . W "RXNORM=",$$ZVALUE("RXCUI","C0CB")," ",$$ZVALUE("STR","C0CB"),!
     235        . . W "VUID TEXT: ",$$ZVALUE("VUID TEXT"),!
     236        . . I $$ZVALUE("VUID TEXT")=$$ZVALUE("STR","C0CB") S TXTMATCH=TXTMATCH+1
     237        . . E  D  ;
     238        . . . D PUSH^GPLXPATH("NOMATCH",$$ZVALUE("VUID TEXT")_"^"_$$ZVALUE("STR","C0CB"))
     239        . . . D SETFDA("RXNORM TEXT",$$ZVALUE("STR","C0CB")) ;
     240        . . . D SETFDA("DIFFERENT TEXT","Y") ;FLAG RECORD FOR DIFFERENT TEXT
     241        . I $$ZVALUE("MEDIATION CODE")=$$ZVALUE("RXCUI","C0CB") D  ;
     242        . . S RXMATCH=RXMATCH+1
     243        . . W "VUID=",$$ZVALUE("VUID")," MATCH RXNORM=",$$ZVALUE("MEDIATION CODE"),!
     244        . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
     245        . S C0CFDA(176.112,"+"_C0CZX_",",.01)=$$ZVALUE("VUID") ; NEW VUID RECORD
     246        . D UPDATE^DIE("","C0CFDA")
     247        . I $D(^TMP("DIERR",$J)) U $P BREAK
     248        W "HAS RXN=",HASRXN,!
     249        W "NO RXN=",NORXN,!
     250        W "NO VUID=",NOVUID,!
     251        W "RXNORM FOUND=",RXFOUND,!
     252        W "RXNORM MATCHES:",RXMATCH,!
     253        W "TEXT MATCHES:",TXTMATCH,!
     254        Q
     255SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
     256        ; TO SET TO VALUE C0CSV.
     257        ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
     258        ; C0CSN,C0CSV ARE PASSED BY VALUE
     259        ;
     260        N C0CSI,C0CSJ
     261        S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
     262        S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
     263        S C0CFDA(C0CSI,"+"_C0CZX_",",C0CSJ)=C0CSV
     264        Q
     265ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
     266        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
     267        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     268        I '$D(ZTAB) S ZTAB="C0CA"
     269        N ZR
     270        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
     271        E  S ZR=""
     272        Q ZR
     273ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
     274        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
     275        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     276        I '$D(ZTAB) S ZTAB="C0CA"
     277        N ZR
     278        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
     279        E  S ZR=""
     280        Q ZR
     281        ;
     282ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
     283        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
     284        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     285        I '$D(ZTAB) S ZTAB="C0CA"
     286        N ZR
     287        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
     288        E  S ZR=""
     289        Q ZR
     290        ;

  • ccr/branches/ohum/p/C0CRXNRD.m

    r1342 r1428  
    1 C0CRXNRD ; WV/SMH - CCR/CCD PROJECT: Routine to Read RxNorm files;11/15/08
    2  ;;0.1;C0C;nopatch;noreleasedate;Build 2
    3  W "No entry from top" Q
    4 IMPORT(PATH) 
    5  I PATH="" QUIT
    6  D READSRC(PATH),READCON(PATH),READNDC(PATH)
    7  QUIT
    8  ;
    9 DELFILED(FN) ; Delete file data; PEP procedure; only for RxNorm files
    10  ; FN is Filenumber passed by Value
    11  QUIT:$E(FN,1,3)'=176  ; Quit if not RxNorm files
    12  D CLEAN^DILF ; Clean FM variables
    13  N ROOT S ROOT=$$ROOT^DILFD(FN,"",1) ; global root
    14  N ZERO S ZERO=@ROOT@(0) ; Save zero node
    15  S $P(ZERO,U,3,9999)="" ; Remove entry # and last edited
    16  K @ROOT ; Kill the file -- so sad!
    17  S @ROOT@(0)=ZERO ; It riseth again!
    18  QUIT
    19 GETLINES(PATH,FILENAME) ; Get number of lines in a file
    20  D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
    21  U IO
    22  N I
    23  F I=1:1 R LINE Q:$$STATUS^%ZISH
    24  D CLOSE^%ZISH("FILE")
    25  Q I-1
    26 READCON(PATH,INCRES) ; Open and read concepts file: RXNCONSO.RRF; EP
    27  ; PATH ByVal, path of RxNorm files
    28  ; INCRES ByVal, include restricted sources. 1 for yes, 0 for no
    29  I PATH="" QUIT
    30  S INCRES=+$G(INCRES) ; if not passed, becomes zero.
    31  N FILENAME S FILENAME="RXNCONSO.RRF"
    32  D DELFILED(176.001) ; delete data
    33  N LINES S LINES=$$GETLINES(PATH,FILENAME)
    34  D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
    35  IF POP D EN^DDIOL("Error reading file..., Please check...") G EX
    36  N C0CCOUNT
    37  F C0CCOUNT=1:1 D  Q:$$STATUS^%ZISH
    38  . U IO
    39  . N LINE R LINE
    40  . IF $$STATUS^%ZISH QUIT
    41  . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
    42  . N RXCUI,RXAUI,SAB,TTY,CODE,STR  ; Fileman fields numbers below
    43  . S RXCUI=$P(LINE,"|",1) ; .01
    44  . S RXAUI=$P(LINE,"|",8) ; 1
    45  . S SAB=$P(LINE,"|",12) ; 2
    46  . ; If the source is a restricted source, decide what to do based on what's asked.
    47  . N SRCIEN S SRCIEN=$$FIND1^DIC(176.003,"","QX",SAB,"B") ; SrcIEN in RXNORM SOURCES file
    48  . N RESTRIC S RESTRIC=$$GET1^DIQ(176.003,SRCIEN,14,"I") ; 14 is restriction field; values 0-4
    49  . ; If RESTRIC is zero, then it's unrestricted. Everything else is restricted.
    50  . ; If user didn't ask to include restricted sources, and the source is restricted, then quit
    51  . I 'INCRES,RESTRIC QUIT
    52  . S TTY=$P(LINE,"|",13) ; 3
    53  . S CODE=$P(LINE,"|",14) ; 4
    54  . S STR=$P(LINE,"|",15) ; 5
    55  . ; Remove embedded "^"
    56  . S STR=$TR(STR,"^")
    57  . ; Convert STR into an array of 80 characters on each line
    58  . N STRLINE S STRLINE=$L(STR)\80+1
    59  . ; In each line, chop 80 characters off, reset STR to be the rest
    60  . N J F J=1:1:STRLINE S STR(J)=$E(STR,1,80) S STR=$E(STR,81,$L(STR))
    61  . ; Now, construct the FDA array
    62  . N RXNFDA
    63  . S RXNFDA(176.001,"+1,",.01)=RXCUI
    64  . S RXNFDA(176.001,"+1,",1)=RXAUI
    65  . S RXNFDA(176.001,"+1,",2)=SAB
    66  . S RXNFDA(176.001,"+1,",3)=TTY
    67  . S RXNFDA(176.001,"+1,",4)=CODE
    68  . N RXNIEN S RXNIEN(1)=C0CCOUNT
    69  . D UPDATE^DIE("","RXNFDA","RXNIEN")
    70  . I $D(^TMP("DIERR",$J)) D EN^DDIOL("ERROR") G EX
    71  . ; Now, file WP field STR
    72  . D WP^DIE(176.001,C0CCOUNT_",",5,,$NA(STR))
    73 EX D CLOSE^%ZISH("FILE")
    74  QUIT
    75 READNDC(PATH) ; Open and read NDC/RxNorm/VANDF relationship file: RXNSAT.RRF
    76  I PATH="" QUIT
    77  N FILENAME S FILENAME="RXNSAT.RRF"
    78  D DELFILED(176.002) ; delete data
    79  N LINES S LINES=$$GETLINES(PATH,FILENAME)
    80  D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
    81  IF POP W "Error reading file..., Please check...",! G EX2
    82  F C0CCOUNT=1:1 Q:$$STATUS^%ZISH  D
    83  . U IO
    84  . N LINE R LINE
    85  . IF $$STATUS^%ZISH QUIT
    86  . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
    87  . IF LINE'["NDC|RXNORM"  QUIT
    88  . ; Otherwise, we are good to go
    89  . N RXCUI,NDC ; Fileman fields below
    90  . S RXCUI=$P(LINE,"|",1) ; .01
    91  . S NDC=$P(LINE,"|",11) ; 2
    92  . ; Using classic call to update.
    93  . N DIC,X,DA,DR
    94  . K DO
    95  . S DIC="^C0CRXN(176.002,",DIC(0)="F",X=RXCUI,DIC("DR")="2////"_NDC
    96  . D FILE^DICN
    97  . I Y<1 U $P W !,"THERE IS TROUBLE IN RIVER CITY",! G EX2
    98 EX2 D CLOSE^%ZISH("FILE")
    99  QUIT
    100 READSRC(PATH) ; Open the read RxNorm Sources file: RXNSAB.RRF
    101  I PATH="" QUIT
    102  N FILENAME S FILENAME="RXNSAB.RRF"
    103  D DELFILED(176.003) ; delete data
    104  D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
    105  IF POP W "Error reading file..., Please check...",! G EX3
    106  F I=1:1 Q:$$STATUS^%ZISH  D
    107  . U IO
    108  . N LINE R LINE
    109  . IF $$STATUS^%ZISH QUIT
    110  . U $P W I,! U IO  ; Write I to the screen, then go back to reading the file
    111  . N VCUI,RCUI,VSAB,RSAB,SON,SF,SVER,SRL,SCIT ; Fileman fields numbers below
    112  . S VCUI=$P(LINE,"|",1)        ; .01
    113  . S RCUI=$P(LINE,"|",2)        ; 2
    114  . S VSAB=$P(LINE,"|",3)        ; 3
    115  . S RSAB=$P(LINE,"|",4)        ; 4
    116  . S SON=$P(LINE,"|",5)         ; 5
    117  . S SF=$P(LINE,"|",6)          ; 6
    118  . S SVER=$P(LINE,"|",7)        ; 7
    119  . S SRL=$P(LINE,"|",14)  ; 14
    120  . S SCIT=$P(LINE,"|",25)       ; 25
    121  . ; Remove embedded "^"
    122  . S SCIT=$TR(SCIT,"^")
    123  . ; Convert SCIT into an array of 80 characters on each line
    124  . ; In each line, chop 80 characters off, reset SCIT to be the rest
    125  . N SCITLINE S SCITLINE=$L(SCIT)\80+1
    126  . F J=1:1:SCITLINE S SCIT(J)=$E(SCIT,1,80) S SCIT=$E(SCIT,81,$L(SCIT))
    127  . ; Now, construct the FDA array
    128  . N RXNFDA
    129  . S RXNFDA(176.003,"+"_I_",",.01)=VCUI
    130  . S RXNFDA(176.003,"+"_I_",",2)=RCUI
    131  . S RXNFDA(176.003,"+"_I_",",3)=VSAB
    132  . S RXNFDA(176.003,"+"_I_",",4)=RSAB
    133  . S RXNFDA(176.003,"+"_I_",",5)=SON
    134  . S RXNFDA(176.003,"+"_I_",",6)=SF
    135  . S RXNFDA(176.003,"+"_I_",",7)=SVER
    136  . S RXNFDA(176.003,"+"_I_",",14)=SRL
    137  . D UPDATE^DIE("","RXNFDA")
    138  . I $D(^TMP("DIERR",$J)) U $P W "ERR" G EX
    139  . ; Now, file WP field SCIT
    140  . D WP^DIE(176.003,I_",",25,,$NA(SCIT))
    141 EX3 D CLOSE^%ZISH("FILE")
    142  Q
    143  
     1C0CRXNRD        ; WV/SMH - CCR/CCD PROJECT: Routine to Read RxNorm files;11/15/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        W "No entry from top" Q
     4IMPORT(PATH)   
     5        I PATH="" QUIT
     6        D READSRC(PATH),READCON(PATH),READNDC(PATH)
     7        QUIT
     8        ;
     9DELFILED(FN)    ; Delete file data; PEP procedure; only for RxNorm files
     10        ; FN is Filenumber passed by Value
     11        QUIT:$E(FN,1,3)'=176  ; Quit if not RxNorm files
     12        D CLEAN^DILF ; Clean FM variables
     13        N ROOT S ROOT=$$ROOT^DILFD(FN,"",1) ; global root
     14        N ZERO S ZERO=@ROOT@(0) ; Save zero node
     15        S $P(ZERO,U,3,9999)="" ; Remove entry # and last edited
     16        K @ROOT ; Kill the file -- so sad!
     17        S @ROOT@(0)=ZERO ; It riseth again!
     18        QUIT
     19GETLINES(PATH,FILENAME) ; Get number of lines in a file
     20        D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
     21        U IO
     22        N I
     23        F I=1:1 R LINE Q:$$STATUS^%ZISH
     24        D CLOSE^%ZISH("FILE")
     25        Q I-1
     26READCON(PATH,INCRES)    ; Open and read concepts file: RXNCONSO.RRF; EP
     27        ; PATH ByVal, path of RxNorm files
     28        ; INCRES ByVal, include restricted sources. 1 for yes, 0 for no
     29        I PATH="" QUIT
     30        S INCRES=+$G(INCRES) ; if not passed, becomes zero.
     31        N FILENAME S FILENAME="RXNCONSO.RRF"
     32        D DELFILED(176.001) ; delete data
     33        N LINES S LINES=$$GETLINES(PATH,FILENAME)
     34        D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
     35        IF POP D EN^DDIOL("Error reading file..., Please check...") G EX
     36        N C0CCOUNT
     37        F C0CCOUNT=1:1 D  Q:$$STATUS^%ZISH
     38        . U IO
     39        . N LINE R LINE
     40        . IF $$STATUS^%ZISH QUIT
     41        . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
     42        . N RXCUI,RXAUI,SAB,TTY,CODE,STR  ; Fileman fields numbers below
     43        . S RXCUI=$P(LINE,"|",1) ; .01
     44        . S RXAUI=$P(LINE,"|",8) ; 1
     45        . S SAB=$P(LINE,"|",12) ; 2
     46        . ; If the source is a restricted source, decide what to do based on what's asked.
     47        . N SRCIEN S SRCIEN=$$FIND1^DIC(176.003,"","QX",SAB,"B") ; SrcIEN in RXNORM SOURCES file
     48        . N RESTRIC S RESTRIC=$$GET1^DIQ(176.003,SRCIEN,14,"I") ; 14 is restriction field; values 0-4
     49        . ; If RESTRIC is zero, then it's unrestricted. Everything else is restricted.
     50        . ; If user didn't ask to include restricted sources, and the source is restricted, then quit
     51        . I 'INCRES,RESTRIC QUIT
     52        . S TTY=$P(LINE,"|",13) ; 3
     53        . S CODE=$P(LINE,"|",14) ; 4
     54        . S STR=$P(LINE,"|",15) ; 5
     55        . ; Remove embedded "^"
     56        . S STR=$TR(STR,"^")
     57        . ; Convert STR into an array of 80 characters on each line
     58        . N STRLINE S STRLINE=$L(STR)\80+1
     59        . ; In each line, chop 80 characters off, reset STR to be the rest
     60        . N J F J=1:1:STRLINE S STR(J)=$E(STR,1,80) S STR=$E(STR,81,$L(STR))
     61        . ; Now, construct the FDA array
     62        . N RXNFDA
     63        . S RXNFDA(176.001,"+1,",.01)=RXCUI
     64        . S RXNFDA(176.001,"+1,",1)=RXAUI
     65        . S RXNFDA(176.001,"+1,",2)=SAB
     66        . S RXNFDA(176.001,"+1,",3)=TTY
     67        . S RXNFDA(176.001,"+1,",4)=CODE
     68        . N RXNIEN S RXNIEN(1)=C0CCOUNT
     69        . D UPDATE^DIE("","RXNFDA","RXNIEN")
     70        . I $D(^TMP("DIERR",$J)) D EN^DDIOL("ERROR") G EX
     71        . ; Now, file WP field STR
     72        . D WP^DIE(176.001,C0CCOUNT_",",5,,$NA(STR))
     73EX      D CLOSE^%ZISH("FILE")
     74        QUIT
     75READNDC(PATH)   ; Open and read NDC/RxNorm/VANDF relationship file: RXNSAT.RRF
     76        I PATH="" QUIT
     77        N FILENAME S FILENAME="RXNSAT.RRF"
     78        D DELFILED(176.002) ; delete data
     79        N LINES S LINES=$$GETLINES(PATH,FILENAME)
     80        D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
     81        IF POP W "Error reading file..., Please check...",! G EX2
     82        F C0CCOUNT=1:1 Q:$$STATUS^%ZISH  D
     83        . U IO
     84        . N LINE R LINE
     85        . IF $$STATUS^%ZISH QUIT
     86        . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
     87        . IF LINE'["NDC|RXNORM"  QUIT
     88        . ; Otherwise, we are good to go
     89        . N RXCUI,NDC ; Fileman fields below
     90        . S RXCUI=$P(LINE,"|",1) ; .01
     91        . S NDC=$P(LINE,"|",11) ; 2
     92        . ; Using classic call to update.
     93        . N DIC,X,DA,DR
     94        . K DO
     95        . S DIC="^C0CRXN(176.002,",DIC(0)="F",X=RXCUI,DIC("DR")="2////"_NDC
     96        . D FILE^DICN
     97        . I Y<1 U $P W !,"THERE IS TROUBLE IN RIVER CITY",! G EX2
     98EX2     D CLOSE^%ZISH("FILE")
     99        QUIT
     100READSRC(PATH)   ; Open the read RxNorm Sources file: RXNSAB.RRF
     101        I PATH="" QUIT
     102        N FILENAME S FILENAME="RXNSAB.RRF"
     103        D DELFILED(176.003) ; delete data
     104        D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
     105        IF POP W "Error reading file..., Please check...",! G EX3
     106        F I=1:1 Q:$$STATUS^%ZISH  D
     107        . U IO
     108        . N LINE R LINE
     109        . IF $$STATUS^%ZISH QUIT
     110        . U $P W I,! U IO  ; Write I to the screen, then go back to reading the file
     111        . N VCUI,RCUI,VSAB,RSAB,SON,SF,SVER,SRL,SCIT ; Fileman fields numbers below
     112        . S VCUI=$P(LINE,"|",1)        ; .01
     113        . S RCUI=$P(LINE,"|",2)        ; 2
     114        . S VSAB=$P(LINE,"|",3)        ; 3
     115        . S RSAB=$P(LINE,"|",4)        ; 4
     116        . S SON=$P(LINE,"|",5)         ; 5
     117        . S SF=$P(LINE,"|",6)          ; 6
     118        . S SVER=$P(LINE,"|",7)        ; 7
     119        . S SRL=$P(LINE,"|",14)  ; 14
     120        . S SCIT=$P(LINE,"|",25)       ; 25
     121        . ; Remove embedded "^"
     122        . S SCIT=$TR(SCIT,"^")
     123        . ; Convert SCIT into an array of 80 characters on each line
     124        . ; In each line, chop 80 characters off, reset SCIT to be the rest
     125        . N SCITLINE S SCITLINE=$L(SCIT)\80+1
     126        . F J=1:1:SCITLINE S SCIT(J)=$E(SCIT,1,80) S SCIT=$E(SCIT,81,$L(SCIT))
     127        . ; Now, construct the FDA array
     128        . N RXNFDA
     129        . S RXNFDA(176.003,"+"_I_",",.01)=VCUI
     130        . S RXNFDA(176.003,"+"_I_",",2)=RCUI
     131        . S RXNFDA(176.003,"+"_I_",",3)=VSAB
     132        . S RXNFDA(176.003,"+"_I_",",4)=RSAB
     133        . S RXNFDA(176.003,"+"_I_",",5)=SON
     134        . S RXNFDA(176.003,"+"_I_",",6)=SF
     135        . S RXNFDA(176.003,"+"_I_",",7)=SVER
     136        . S RXNFDA(176.003,"+"_I_",",14)=SRL
     137        . D UPDATE^DIE("","RXNFDA")
     138        . I $D(^TMP("DIERR",$J)) U $P W "ERR" G EX
     139        . ; Now, file WP field SCIT
     140        . D WP^DIE(176.003,I_",",25,,$NA(SCIT))
     141EX3     D CLOSE^%ZISH("FILE")
     142        Q
     143       

  • ccr/branches/ohum/p/C0CSNOA.m

    r1342 r1428  
    1 C0CSNOA   ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/08
    2  ;;0.1;CCDCCR;nopatch;noreleasedate;Build 2
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  ; THESE ROUTINES ANALYZE THE POTENTIAL RETRIEVAL OF SNOMED CT CODES
    22  ; FOR PATIENT DRUG ALLERGIES FOR INCLUSION IN THE CCR OR CCD
    23  ; USING THE VISTA LEXICON ^LEX
    24  ;
    25 ANALYZE(BEGIEN,IENCNT) ; SNOMED RETRIEVAL ANALYSIS ROUTINE
    26     ; BEGINS AT BEGIEN AND GOES FOR IENCNT DRUGS IN GMRD
    27     ; TO RESUME AT NEXT DRUG, USE BEGIEN=""
    28     ; USE RESET^C0CSNOA TO RESET TO TOP OF DRUG LIST
    29     ;
    30     N SNOARY,SNOTMP,SNOI,SNOIEN,RATTR
    31     N CCRGLO
    32     D ASETUP ; SET UP VARIABLES AND GLOBALS
    33     D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE
    34     I '$D(@SNOBASE@("RESUME")) S @SNOBASE@("RESUME")=$O(@GMRBASE@(1)) ;1ST TME
    35     S RESUME=@SNOBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN
    36     S SNOIEN=BEGIEN ; BEGIN WITH THE BEGIEN RECORD
    37     I SNOIEN="" S SNOIEN=RESUME
    38     I +SNOIEN=0 D  Q  ; AT THE END OF THE ALLERGY LIST
    39     . W "END OF DRUG LIST, CALL RESET^C0CSNOA",!
    40     F SNOI=1:1:IENCNT  D  Q:+SNOIEN=0  ; FOR IENCNT NUMBER OF PATIENTS OR END
    41     . ;D CCRRPC^C0CCCR(.CCRGLO,SNOIEN,"CCR","","","") ;PROCESS THE CCR
    42     . W SNOIEN,@GMRBASE@(SNOIEN,0),!
    43     . N SNORTN,TTERM ; RETURN ARRAY
    44     . S TTERM=$P(@GMRBASE@(SNOIEN,0),"^",1)_" ALLERGY"
    45     . D TEXTRPC(.SNORTN,TTERM)
    46     . I $D(SNORTN) ZWR SNORTN
    47     . K @SNOBASE@("VARS",SNOIEN) ; CLEAR OUT OLD VARS
    48     . I $P(TTMP,"^",1)=1 S @SNOBASE@("VARS",SNOIEN)=TTERM_"^"_TTMP_"^"_SNORTN(0)
    49     . ;
    50     . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP
    51     . ;
    52     . S RATTR=$$SETATTR(SNOIEN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS
    53     . S @SNOBASE@("ATTR",SNOIEN)=RATTR ; SAVE THE ATRIBUTES FOR THIS DRUG
    54     . ;
    55     . N CATNAME,CATTBL
    56     . S CATNAME=""
    57     . D CPUSH(.CATNAME,SNOBASE,"SNOTBL",SNOIEN,RATTR) ; ADD TO CATEGORY
    58     . ; W "CATEGORY NAME: ",CATNAME,!
    59     . ;
    60     . S SNOIEN=$O(@GMRBASE@(SNOIEN)) ; NEXT RECORD
    61     . S @SNOBASE@("RESUME")=SNOIEN ; WHERE WE ARE LEAVING OFF THIS RUN
    62     ; D PARY^C0CXPATH(@SNOBASE@("ATTRTBL"))
    63     Q
    64     ;
    65 TEXTRPC(ORTN,ITEXT) ; CALL THE LEXICON WITH ITEXT AND RETURN RESULTS IN ORTN
    66  ;
    67  ;N TTMP
    68  W ITEXT,!
    69  S TTMP=$$TEXT^LEXTRAN(ITEXT,"","","SCT","ORTN")
    70  Q
    71  ;
    72 ASETUP ; SET UP GLOBALS AND VARS SNOBASE AND SNOTBL
    73       I '$D(SNOBASE) S SNOBASE=$NA(^TMP("C0CSNO"))
    74       I '$D(@SNOBASE) S @SNOBASE=""
    75       I '$D(GMRBASE) S GMRBASE=$NA(^GMRD(120.82))
    76       I '$D(SNOTBL) S SNOTBL=$NA(^TMP("C0CSNO","SNOTBL","TABLE")) ; ATTR TABLE
    77       S ^TMP("C0CSNO","TABLES","SNOTBL")=SNOTBL ; TABLE OF TABLES
    78       Q
    79       ;
    80 AINIT ; INITIALIZE ATTRIBUTE TABLE
    81       I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS
    82       K @SNOTBL
    83       D APUSH^C0CRIMA(SNOTBL,"CODE")
    84       D APUSH^C0CRIMA(SNOTBL,"NOCODE")
    85       D APUSH^C0CRIMA(SNOTBL,"MULTICODE")
    86       D APUSH^C0CRIMA(SNOTBL,"SUBMULTI")
    87       D APUSH^C0CRIMA(SNOTBL,"DONE")
    88       Q
    89 APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL
    90     ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING
    91     ; PTBL IS THE NAME OF A TABLE IN @SNOBASE@("TABLES") - "SNOTBL"=ALL VALUES
    92     ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL))
    93     I '$D(SNOBASE) D ASETUP ; FOR COMMANDLINE PROCESSING
    94     N USETBL
    95     I '$D(@SNOBASE@("TABLES",PTBL)) D  Q  ; NO TABLE
    96     . W "ERROR NO SUCH TABLE",!
    97     S USETBL=@SNOBASE@("TABLES",PTBL)
    98     S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL
    99     Q
    100 SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS
    101     N SBASE,SATTR
    102     S SBASE=$NA(@SNOBASE@("VARS",SDFN))
    103     D APOST("SATTR","SNOTBL","DONE")
    104     I $P(TTMP,"^",1)=1 D APOST("SATTR","SNOTBL","CODE")
    105     I $P(TTMP,"^",1)=-1 D APOST("SATTR","SNOTBL","NOCODE")
    106     Q SATTR  ; C0C
    107     I $D(@SBASE@("PROBLEMS",1)) D  ;
    108     . D APOST("SATTR","SNOTBL","PROBLEMS")
    109     . ; W "POSTING PROBLEMS",!
    110     I $D(@SBASE@("VITALS",1)) D APOST("SATTR","SNOTBL","VITALS")
    111     I $D(@SBASE@("MEDS",1)) D  ; IF THE PATIENT HAS MEDS VARIABLES
    112     . D APOST("SATTR","SNOTBL","MEDS")
    113     . N ZR,ZI
    114     . D GETPA^C0CRIMA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES
    115     . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
    116     . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
    117     . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","SNOTBL","MEDSCODE") ;CODES
    118     . ; D PATD^C0CSNOA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES
    119     D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED
    120     ; W "ATTRIBUTES: ",SATTR,!
    121     Q SATTR
    122     ;
    123 RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES
    124     K ^TMP("C0CSNO","RESUME")
    125     K ^TMP("C0CSNO")
    126     Q
    127     ;
    128 CLIST ; LIST THE CATEGORIES
    129     ;
    130     I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS
    131     N CLBASE,CLNUM,ZI,CLIDX
    132     S CLBASE=$NA(@SNOBASE@("SNOTBL","CATS"))
    133     S CLNUM=@CLBASE@(0)
    134     F ZI=1:1:CLNUM D  ; LOOP THROUGH THE CATEGORIES
    135     . S CLIDX=@CLBASE@(ZI)
    136     . W "(",$P(@CLBASE@(CLIDX),"^",1)
    137     . W ":",$P(@CLBASE@(CLIDX),"^",2),") "
    138     . W CLIDX,!
    139     ; D PARY^C0CXPATH(CLBASE)
    140     Q
    141     ;
    142 CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES
    143     ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT
    144     ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE
    145     ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME
    146     ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES,
    147     ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X"
    148     ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES
    149     ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY
    150     ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING
    151     ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY
    152     ; NUMBER IE CTBL_X(CDFN)=""
    153     ;
    154     ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST
    155     S CCTBL=$NA(@CBASE@(CTBL,"CATS"))
    156     ; W "CBASE: ",CCTBL,!
    157     ;
    158     I '$D(@CCTBL@(CATTR)) D  ; FIRST PATIENT IN THIS CATEGORY
    159     . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY
    160     . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY
    161     . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT
    162     . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY
    163     . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME
    164     . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0
    165     ;
    166     S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY
    167     S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT
    168     S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK
    169     ;
    170     S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED
    171     ;
    172     S CPATLIST=$NA(@CBASE@(CTBL,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT
    173     ; W "IENS BASE: ",CPATLIST,!
    174     S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST
    175     ;
    176     Q
    177     ;
    178 REUSE ; GET SAVED VALUES FROM ^TMP("C0CSAV") AND PUT THEM IN A DATABASE
    179  ;
    180  D ASETUP
    181  D AINIT
    182  N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH
    183  S SAVBASE=$NA(^TMP("C0CSAV","VARS"))
    184  S SNOI=""
    185  F  D  Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST
    186  . S SNOI=$O(@SAVBASE@(SNOI))
    187  . S SNOJ=@SAVBASE@(SNOI)
    188  . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1)
    189  . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE
    190  . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON
    191  . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE
    192  . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE
    193  . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE
    194  . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,!
    195  . W SNOK,!
    196  . W SNOJ,!
    197  Q
    198  ;
     1C0CSNOA   ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        ; THESE ROUTINES ANALYZE THE POTENTIAL RETRIEVAL OF SNOMED CT CODES
     22        ; FOR PATIENT DRUG ALLERGIES FOR INCLUSION IN THE CCR OR CCD
     23        ; USING THE VISTA LEXICON ^LEX
     24        ;
     25ANALYZE(BEGIEN,IENCNT)  ; SNOMED RETRIEVAL ANALYSIS ROUTINE
     26           ; BEGINS AT BEGIEN AND GOES FOR IENCNT DRUGS IN GMRD
     27           ; TO RESUME AT NEXT DRUG, USE BEGIEN=""
     28           ; USE RESET^C0CSNOA TO RESET TO TOP OF DRUG LIST
     29           ;
     30           N SNOARY,SNOTMP,SNOI,SNOIEN,RATTR
     31           N CCRGLO
     32           D ASETUP ; SET UP VARIABLES AND GLOBALS
     33           D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE
     34           I '$D(@SNOBASE@("RESUME")) S @SNOBASE@("RESUME")=$O(@GMRBASE@(1)) ;1ST TME
     35           S RESUME=@SNOBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN
     36           S SNOIEN=BEGIEN ; BEGIN WITH THE BEGIEN RECORD
     37           I SNOIEN="" S SNOIEN=RESUME
     38           I +SNOIEN=0 D  Q  ; AT THE END OF THE ALLERGY LIST
     39           . W "END OF DRUG LIST, CALL RESET^C0CSNOA",!
     40           F SNOI=1:1:IENCNT  D  Q:+SNOIEN=0  ; FOR IENCNT NUMBER OF PATIENTS OR END
     41           . ;D CCRRPC^C0CCCR(.CCRGLO,SNOIEN,"CCR","","","") ;PROCESS THE CCR
     42           . W SNOIEN,@GMRBASE@(SNOIEN,0),!
     43           . N SNORTN,TTERM ; RETURN ARRAY
     44           . S TTERM=$P(@GMRBASE@(SNOIEN,0),"^",1)_" ALLERGY"
     45           . D TEXTRPC(.SNORTN,TTERM)
     46           . I $D(SNORTN) ZWR SNORTN
     47           . K @SNOBASE@("VARS",SNOIEN) ; CLEAR OUT OLD VARS
     48           . I $P(TTMP,"^",1)=1 S @SNOBASE@("VARS",SNOIEN)=TTERM_"^"_TTMP_"^"_SNORTN(0)
     49           . ;
     50           . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP
     51           . ;
     52           . S RATTR=$$SETATTR(SNOIEN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS
     53           . S @SNOBASE@("ATTR",SNOIEN)=RATTR ; SAVE THE ATRIBUTES FOR THIS DRUG
     54           . ;
     55           . N CATNAME,CATTBL
     56           . S CATNAME=""
     57           . D CPUSH(.CATNAME,SNOBASE,"SNOTBL",SNOIEN,RATTR) ; ADD TO CATEGORY
     58           . ; W "CATEGORY NAME: ",CATNAME,!
     59           . ;
     60           . S SNOIEN=$O(@GMRBASE@(SNOIEN)) ; NEXT RECORD
     61           . S @SNOBASE@("RESUME")=SNOIEN ; WHERE WE ARE LEAVING OFF THIS RUN
     62           ; D PARY^C0CXPATH(@SNOBASE@("ATTRTBL"))
     63           Q
     64           ;
     65TEXTRPC(ORTN,ITEXT)     ; CALL THE LEXICON WITH ITEXT AND RETURN RESULTS IN ORTN
     66        ;
     67        ;N TTMP
     68        W ITEXT,!
     69        S TTMP=$$TEXT^LEXTRAN(ITEXT,"","","SCT","ORTN")
     70        Q
     71        ;
     72ASETUP  ; SET UP GLOBALS AND VARS SNOBASE AND SNOTBL
     73             I '$D(SNOBASE) S SNOBASE=$NA(^TMP("C0CSNO"))
     74             I '$D(@SNOBASE) S @SNOBASE=""
     75             I '$D(GMRBASE) S GMRBASE=$NA(^GMRD(120.82))
     76             I '$D(SNOTBL) S SNOTBL=$NA(^TMP("C0CSNO","SNOTBL","TABLE")) ; ATTR TABLE
     77             S ^TMP("C0CSNO","TABLES","SNOTBL")=SNOTBL ; TABLE OF TABLES
     78             Q
     79             ;
     80AINIT   ; INITIALIZE ATTRIBUTE TABLE
     81             I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS
     82             K @SNOTBL
     83             D APUSH^C0CRIMA(SNOTBL,"CODE")
     84             D APUSH^C0CRIMA(SNOTBL,"NOCODE")
     85             D APUSH^C0CRIMA(SNOTBL,"MULTICODE")
     86             D APUSH^C0CRIMA(SNOTBL,"SUBMULTI")
     87             D APUSH^C0CRIMA(SNOTBL,"DONE")
     88             Q
     89APOST(PRSLT,PTBL,PVAL)  ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL
     90           ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING
     91           ; PTBL IS THE NAME OF A TABLE IN @SNOBASE@("TABLES") - "SNOTBL"=ALL VALUES
     92           ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL))
     93           I '$D(SNOBASE) D ASETUP ; FOR COMMANDLINE PROCESSING
     94           N USETBL
     95           I '$D(@SNOBASE@("TABLES",PTBL)) D  Q  ; NO TABLE
     96           . W "ERROR NO SUCH TABLE",!
     97           S USETBL=@SNOBASE@("TABLES",PTBL)
     98           S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL
     99           Q
     100SETATTR(SDFN)   ; SET ATTRIBUTES BASED ON VARS
     101           N SBASE,SATTR
     102           S SBASE=$NA(@SNOBASE@("VARS",SDFN))
     103           D APOST("SATTR","SNOTBL","DONE")
     104           I $P(TTMP,"^",1)=1 D APOST("SATTR","SNOTBL","CODE")
     105           I $P(TTMP,"^",1)=-1 D APOST("SATTR","SNOTBL","NOCODE")
     106           Q SATTR  ; C0C
     107           I $D(@SBASE@("PROBLEMS",1)) D  ;
     108           . D APOST("SATTR","SNOTBL","PROBLEMS")
     109           . ; W "POSTING PROBLEMS",!
     110           I $D(@SBASE@("VITALS",1)) D APOST("SATTR","SNOTBL","VITALS")
     111           I $D(@SBASE@("MEDS",1)) D  ; IF THE PATIENT HAS MEDS VARIABLES
     112           . D APOST("SATTR","SNOTBL","MEDS")
     113           . N ZR,ZI
     114           . D GETPA^C0CRIMA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES
     115           . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
     116           . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
     117           . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","SNOTBL","MEDSCODE") ;CODES
     118           . ; D PATD^C0CSNOA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES
     119           D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED
     120           ; W "ATTRIBUTES: ",SATTR,!
     121           Q SATTR
     122           ;
     123RESET   ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES
     124           K ^TMP("C0CSNO","RESUME")
     125           K ^TMP("C0CSNO")
     126           Q
     127           ;
     128CLIST   ; LIST THE CATEGORIES
     129           ;
     130           I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS
     131           N CLBASE,CLNUM,ZI,CLIDX
     132           S CLBASE=$NA(@SNOBASE@("SNOTBL","CATS"))
     133           S CLNUM=@CLBASE@(0)
     134           F ZI=1:1:CLNUM D  ; LOOP THROUGH THE CATEGORIES
     135           . S CLIDX=@CLBASE@(ZI)
     136           . W "(",$P(@CLBASE@(CLIDX),"^",1)
     137           . W ":",$P(@CLBASE@(CLIDX),"^",2),") "
     138           . W CLIDX,!
     139           ; D PARY^C0CXPATH(CLBASE)
     140           Q
     141           ;
     142CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR)     ; ADD PATIENTS TO CATEGORIES
     143           ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT
     144           ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE
     145           ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME
     146           ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES,
     147           ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X"
     148           ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES
     149           ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY
     150           ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING
     151           ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY
     152           ; NUMBER IE CTBL_X(CDFN)=""
     153           ;
     154           ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST
     155           S CCTBL=$NA(@CBASE@(CTBL,"CATS"))
     156           ; W "CBASE: ",CCTBL,!
     157           ;
     158           I '$D(@CCTBL@(CATTR)) D  ; FIRST PATIENT IN THIS CATEGORY
     159           . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY
     160           . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY
     161           . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT
     162           . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY
     163           . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME
     164           . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0
     165           ;
     166           S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY
     167           S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT
     168           S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK
     169           ;
     170           S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED
     171           ;
     172           S CPATLIST=$NA(@CBASE@(CTBL,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT
     173           ; W "IENS BASE: ",CPATLIST,!
     174           S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST
     175           ;
     176           Q
     177           ;
     178REUSE   ; GET SAVED VALUES FROM ^TMP("C0CSAV") AND PUT THEM IN A DATABASE
     179        ;
     180        D ASETUP
     181        D AINIT
     182        N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH
     183        S SAVBASE=$NA(^TMP("C0CSAV","VARS"))
     184        S SNOI=""
     185        F  D  Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST
     186        . S SNOI=$O(@SAVBASE@(SNOI))
     187        . S SNOJ=@SAVBASE@(SNOI)
     188        . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1)
     189        . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE
     190        . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON
     191        . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE
     192        . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE
     193        . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE
     194        . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,!
     195        . W SNOK,!
     196        . W SNOJ,!
     197        Q
     198        ;

  • ccr/branches/ohum/p/C0CSOAP.m

    r1342 r1428  
    1 C0CSOAP  ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008 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 SOAP utility library",!
    21  W !
    22  Q
    23  ;
    24 TEST1 
    25  S url="https://ec2-75-101-247-83.compute-1.amazonaws.com:8181/ccr/CCRService?wsdl"
    26  D GET1URL^C0CEWD2(url)
    27  Q
    28  ;
    29 INITFARY(ARY) ;initialize the Fileman Field array for SOAP processing
    30  ; ARY is passed by name
    31  S @ARY@("XML FILE NUMBER")="178.301"
    32  S @ARY@("BINDING SUBFILE NUMBER")="178.3014"
    33  S @ARY@("MIME TYPE")="2.3"
    34  S @ARY@("PROXY SERVER")="2.4"
    35  S @ARY@("REPLY TEMPLATE")=".03"
    36  S @ARY@("TEMPLATE NAME")=".01"
    37  S @ARY@("TEMPLATE XML")="3"
    38  S @ARY@("URL")="1"
    39  S @ARY@("WSDL URL")="2"
    40  S @ARY@("XML")="2.1"
    41  S @ARY@("XML HEADER")="2.2"
    42  S @ARY@("XPATH REDUCTION STRING")="2.5"
    43  S @ARY@("CCR VARIABLE")="4"
    44  S @ARY@("FILEMAN FIELD NAME")="1"
    45  S @ARY@("FILEMAN FIELD NUMBER")="1.2"
    46  S @ARY@("FILEMAN FILE POINTER")="1.1"
    47  S @ARY@("INDEXED BY")=".05"
    48  S @ARY@("SQLI FIELD NAME")="3"
    49  S @ARY@("VARIABLE NAME")="2"
    50  Q
    51  ;
    52 RESTID(INNAM,INFARY) ;EXTRINSIC TO RESOLVE TEMPLATE PASSED BY NAME
    53  ; FILE IS IDENTIFIED IN FARY, PASSED BY NAME
    54  I '$D(INFARY) D  ; NO FILE ARRAY PASSED
    55  . S INFARY="FARY"
    56  . D INITFARY(INFARY)
    57  N ZN,ZREF,ZR
    58  S ZN=@INFARY@("XML FILE NUMBER")
    59  S ZREF=$$FILEREF^C0CRNF(ZN)
    60  S ZR=$O(@ZREF@("B",INNAM,""))
    61  Q ZR
    62  ;
    63 TESTSOAP ;
    64  ; USING ICD9 WEB SERVICE TO TEST SOAP
    65  S G("CODE")="E*"
    66  S G("CODELN")=3
    67  D SOAP("GPL","ICD9","G")
    68  Q
    69  ;
    70 SOAP(C0CRTN,C0CTID,C0CVA,C0CVOR,ALTXML,IFARY) ; MAKES A SOAP CALL FOR
    71  ; TEMPLATE ID C0CTID
    72  ; RETURNS THE XML RESULT IN C0CRTN, PASSED BY NAME
    73  ; C0CVA IS PASSED BY NAME AND IS THE VARIABLE ARRAY TO PASS TO BIND
    74  ; C0CVOR IS THE NAME OF A VARIABLE OVERRIDE ARRAY, WHICH IS APPLIED
    75  ; BEFORE MAPPING
    76  ; IF ALTXML IS PASSED, BIND AND MAP WILL BE SKIPPED AND
    77  ; ALTXML WILL BE USED INSTEAD
    78  ;
    79  ; ARTIFACTS SECTION
    80  ; THE FOLLOWING WILL SET UP DEBUGGING ARTIFACTS FOR A POSSIBLE FUTURE
    81  ; ONLINE DEBUGGER. IF DEBUG=1, VARIABLES CONTAINING INTERMEDIATE RESULTS
    82  ; WILL NOT BE NEWED.
    83  I $G(WSDEBUG)="" N C0CV ; CATALOG OF ARTIFACT VARIABLES AND ARRAYS
    84  S C0CV(100,"C0CXF","XML TEMPLATE FILE NUMBER")=""
    85  S C0CV(200,"C0CHEAD","SOAP HEADER VARIABLE NAME")=""
    86  S C0CV(300,"HEADER","SOAP HEADER")=""
    87  S C0CV(400,"C0CMIME","MIME TYPE")=""
    88  S C0CV(500,"C0CURL","WS URL")=""
    89  S C0CV(550,"C0CPURL","PROXY URL")=""
    90  S C0CV(600,"C0CXML","XML VARIABLE NAME")=""
    91  S C0CV(700,"XML","OUTBOUND XML")=""
    92  S C0CV(800,"C0CRSLT","RAW XML RESULT RETURNED FROM WEB SERVICE")=""
    93  S C0CV(900,"C0CRHDR","RETURNED HEADER")=""
    94  S C0CV(1000,"C0CRXML","XML RESULT NORMALIZED")=""
    95  S C0CV(1100,"C0CR","REPLY TEMPLATE")=""
    96  S C0CV(1200,"C0CREDUX","REDUX STRING")=""
    97  S C0CV(1300,"C0CIDX","RESULT XPATH INDEX")=""
    98  S C0CV(1400,"C0CARY","RESULT XPATH ARRAY")=""
    99  S C0CV(1500,"C0CNOM","RESULT DOM DOCUMENT NAME")=""
    100  S C0CV(1600,"C0CID","RESULT DOM ID")=""
    101  I $G(DEBUG)'="" G NOTNEW ; SKIP NEWING THE VARIABLES IF IN DEBUG
    102  N ZI,ZJ S ZI=""
    103 NEW 
    104  S ZI=$O(C0CV(ZI))
    105  S ZJ=$O(C0CV(ZI,"")) ; SET UP NEW COMMAND
    106  ;W ZJ,!
    107  N @ZJ ; NEW THE VARIABLE
    108  I $O(C0CV(ZI))'="" G NEW ;LOOP TO GET NEW IN CONTEXT
    109 NOTNEW 
    110  ; END ARTIFACTS
    111  ;
    112  I '$D(IFARY) D INITFARY("C0CF") ; SET FILE NUMBER AND PARAMATERS
    113  E  D  ;
    114  . K C0CF
    115  . M C0CF=@IFARY
    116  S C0CXF=C0CF("XML FILE NUMBER") ; FILE NUMBER FOR THE XML TEMPLATE FILE
    117  I +C0CTID=0 D  ; A STRING WAS PASSED FOR THE TEMPLATE NAME
    118  . S C0CUTID=$$RESTID(C0CTID,"C0CF") ;RESOLVE TEMPLATE IEN FROM NAME
    119  E  S C0CUTID=C0CTID ; AN IEN WAS PASSED
    120  N XML,TEMPLATE,HEADER
    121  N C0CFH S C0CFH=C0CF("XML HEADER")
    122  S C0CHEAD=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFH,,"HEADER")
    123  N C0CFM S C0CFM=C0CF("MIME TYPE")
    124  S C0CMIME=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFM)
    125  N C0CFP S C0CFP=C0CF("PROXY SERVER")
    126  S C0CPURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFP)
    127  N C0CFU S C0CFU=C0CF("URL")
    128  S C0CURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFU)
    129  N C0CFX S C0CFX=C0CF("XML")
    130  S C0CXML=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFX,,"XML")
    131  N C0CFT S C0CFT=C0CF("TEMPLATE XML")
    132  S C0CTMPL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFT,,"TEMPLATE")
    133  I C0CTMPL="TEMPLATE" D  ; there is a template to process
    134  . K XML ; going to replace the xml array
    135  . N VARS
    136  . I $D(C0CVOR) M @C0CVA=@C0CVOR ; merge in varible overrides
    137  . I '$D(ALTXML) D  ; if ALTXML is passed in, don't bind
    138  . . D BIND("VARS",C0CVA,C0CUTID,"C0CF")
    139  . . D MAP("XML","VARS",TPTR,"C0CF")
    140  . . K XML(0)
    141  . E  M XML=@ALTXML ; use ALTXML instead
    142  I $G(C0CPROXY) S C0CURL=C0CPURL
    143  K C0CRSLT,C0CRHDR
    144  B
    145  S ok=$$httpPOST^%zewdGTM(C0CURL,.XML,C0CMIME,.C0CRSLT,.HEADER,"",.gpl5,.C0CRHDR)
    146  K C0CRXML
    147  D NORMAL("C0CRXML","C0CRSLT(1)") ;RETURN XML IN AN ARRAY
    148  N C0CFR S C0CFR=$G(C0CF("REPLY TEMPLATE"))
    149  S C0CR=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFR,"I") ; REPLY TEMPLATE
    150  ; reply templates are optional and are specified by populating a
    151  ; template pointer in field 2.5 of the request template
    152  ; if specified, the reply template is the source of the REDUX string
    153  ; used for XPath on the reply, and for UNBIND processing
    154  ; if no reply template is specified, REDUX is obtained from the request
    155  ; template and no UNBIND processing is performed. The XPath array is
    156  ; returned without variable bindings
    157  I C0CR'="" D  ; REPLY TEMPLATE EXISTS
    158  . I +$G(DEBUG)'=0 W "REPLY TEMPLATE:",C0CR,!
    159  . S C0CTID=C0CR ;
    160  N C0CFRDX S C0CFRDX=C0CF("XPATH REDUCTION STRING")
    161  S C0CREDUX=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFRDX) ;XPATH REDUCTION STRING
    162  K C0CIDX,C0CARY ; XPATH INDEX AND ARRAY VARS
    163  S C0CNOM="C0CWS"_$J ; DOCUMENT NAME FOR THE DOM
    164  S C0CID=$$PARSE^C0CXEWD("C0CRXML",C0CNOM) ;CALL THE PARSER
    165  S C0CID=$$FIRST^C0CXEWD($$ID^C0CXEWD(C0CNOM)) ;ID OF FIRST NODE
    166  D XPATH^C0CXEWD(C0CID,"/","C0CIDX","C0CARY","",C0CREDUX) ;XPATH GENERATOR
    167  ; Next, call UNBIND to map the reply XPath array to variables
    168  ; This is only done if a Reply Template is provided
    169  D DEMUXARY(C0CRTN,"C0CARY")
    170  ; M @C0CRTN=C0CARY
    171  Q
    172  ;
    173 DEMUXARY(OARY,IARY) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
    174  ; FORMAT @OARY@(x,xpath) where x is the first multiple
    175  N ZI,ZJ,ZK,ZL S ZI=""
    176  F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ;
    177  . D DEMUX^C0CMXP("ZJ",ZI)
    178  . S ZK=$P(ZJ,"^",3)
    179  . S ZK=$RE($P($RE(ZK),"/",1))
    180  . S ZL=$P(ZJ,"^",1)
    181  . I ZL="" S ZL=1
    182  . S @OARY@(ZL,ZK)=@IARY@(ZI)
    183  Q
    184  ;
    185 NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
    186  ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
    187  ;
    188  N ZI,ZN,ZTMP
    189  S ZN=1
    190  S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">"
    191  S ZN=ZN+1
    192  F  S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)=""  D  ;
    193  . S @OUTXML@(ZN)=@OUTXML@(ZN)_">"
    194  . S ZN=ZN+1
    195  Q
    196  ;
    197 MAP(RARY,IVARS,TPTR,INFARY) ;RETURNS MAPPED XML IN RARY PASSED BY NAME
    198  ; IVARS IS AN XPATH ARRAY PASSED BY NAME
    199  ; TPTR IS A POINT TO THE C0C XML TEMPLATE FILE USED TO RETRIEVE THE TEMPLATE
    200  ;
    201  N ZT ;THE TEMPLATE
    202  K ZT,@RARY
    203  I '$D(INFARY) D  ;
    204  . S INFARY="FARY"
    205  . D INITFARY(INFARY)
    206  N ZF,ZFT
    207  S ZF=@INFARY@("XML FILE NUMBER")
    208  S ZFT=@INFARY@("TEMPLATE XML")
    209  I $$GET1^DIQ(ZF,TPTR_",",ZFT,,"ZT")'="ZT" D  Q  ; ERROR GETTING TEMPLATE
    210  . W "ERROR RETRIEVING TEMPLATE",!
    211  D MAP^C0CXPATH("ZT",IVARS,RARY) ;DO THE MAPPING
    212  Q
    213  ;
    214 TESTBIND ;
    215  S G1("TESTONE")=1
    216  S G1("TESTTWO")=2
    217  D BIND("G","G1","TEST")
    218  W !
    219  ZWR G
    220  Q
    221  ;
    222 BIND(RARY,IVARS,INTPTR,INFARY) ;RETURNS AN XPATH ARRAY IN RARY FOR USE WITH MAP
    223  ; TO BUILD AN INSTANTIATED TEMPLATE
    224  ; TPTR IS THE IEN OF THE XML TEMPATE IN THE C0C XML TEMPLATE FILE
    225  ; LOOPS THROUGHT THE BINDING SUBFILE TO PULL OUT XPATHS AND
    226  ; EITHER ASSIGNS VARIABLES OR DOES A FILEMAN CALL TO GET VALUES
    227  ; VARIABLES ARE IN IVARS WHICH IS PASSED BY NAME
    228  I '$D(INFARY) D  ;
    229  . S INFARY="FARY"
    230  . D INITFARY(INFARY) ;INITIALIZE FILE ARRAY IF NOT PASSED
    231  I +INTPTR>0 S TPTR=INTPTR
    232  E  S TPTR=$$RESTID(INTPTR,INFARY)
    233  N C0CFF,C0CBF,C0CXI,C0CFREF,C0CXREF
    234  S C0CFF=@INFARY@("XML FILE NUMBER") ;fileman file number of XML file
    235  S C0CFREF=$$FILEREF^C0CRNF(C0CFF) ; closed file reference to the file
    236  S C0CBF=@INFARY@("BINDING SUBFILE NUMBER") ; BINDING SUBFILE NUMBER
    237  S C0CXI=$G(@INFARY@("XPATH INDEX")) ; index to the XPath bindings
    238  I C0CXI="" S C0CXI="XPATH" ; default is the XPATH index
    239  ; this needs to be a whole file index on the XPath subfile with
    240  ; the Template IEN perceding the XPath in the index
    241  N ZI
    242  S ZI=""
    243  S C0CXREF=$NA(@C0CFREF@(C0CXI,TPTR)) ; where the xref is
    244  ;F  S ZI=$O(^C0CX(TPTR,5,"B",ZI)) Q:ZI=""  D  ; FOR EACH XPATH
    245  F  S ZI=$O(@C0CXREF@(ZI)) Q:ZI=""  D  ; for each XPath in this template
    246  . ;W !,ZI," ",$O(@C0CXREF@(ZI,TPTR,""))
    247  . N ZIEN,ZFILE,ZFIELD,ZVAR,ZIDX,ZINDEX ;
    248  . S ZIEN=$O(@C0CXREF@(ZI,TPTR,"")) ; IEN OF THE BINDING RECORD
    249  . N ZFF S ZFF=@INFARY@("FILEMAN FILE POINTER")
    250  . S ZFILE=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFF,"I")
    251  . N ZFFLD S ZFFLD=@INFARY@("FILEMAN FIELD NUMBER")
    252  . S ZFIELD=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFFLD,"I")
    253  . N ZFV S ZFV=@INFARY@("VARIABLE NAME")
    254  . S ZVAR=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFV,"E")
    255  . N ZFX S ZFX=("INDEXED BY")
    256  . S ZIDX=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFX,"I")
    257  . S ZINDEX=""
    258  . I ZIDX="DUZ" S ZINDEX=$G(DUZ) ; FILE IS INDEXED BY DUZ
    259  . I ZIDX="DFN" S ZINDEX=$G(DFN) ; BY DFN
    260  . E  I ZIDX'="" S ZINDEX=$G(@ZIDX) ; index variable
    261  . ;I ZIDX="ACCT" S ZINDEX=C0CACCT ; BY ACCOUNT RECORD POINT TO C0C WS ACCT
    262  . ;I ZIDX="LOC" S ZINDEX=C0CLOC ; BY LOCATION
    263  . I ZVAR'="" D  ; VARIABLES TAKE PRESCIDENCE OVER FILEMAN FIELDS
    264  . . S @RARY@(ZI)=@IVARS@(ZVAR) ;
    265  . E  D  ; IF NO VARIABLE, TRY ACCESSING FROM FILEMAN
    266  . . I (ZFILE="")!(ZFIELD="") Q  ;QUIT IF FILE OR FIELD NOT THERE
    267  . . D CLEAN^DILF
    268  . . S @RARY@(ZI)=$$GET1^DIQ(ZFILE,ZINDEX_",",ZFIELD) ;GET THE VALUE
    269  . . I $D(^TMP("DIERR",$J,1)) D  B ;
    270  . . . W "ERROR!",!
    271  . . . ZWR ^TMP("DIERR",$J,*)
    272  Q
    273  ;
     1C0CSOAP  ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008 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 SOAP utility library",!
     21        W !
     22        Q
     23        ;
     24TEST1   
     25        S url="https://ec2-75-101-247-83.compute-1.amazonaws.com:8181/ccr/CCRService?wsdl"
     26        D GET1URL^C0CEWD2(url)
     27        Q
     28        ;
     29INITFARY(ARY)   ;initialize the Fileman Field array for SOAP processing
     30        ; ARY is passed by name
     31        S @ARY@("XML FILE NUMBER")="178.301"
     32        S @ARY@("BINDING SUBFILE NUMBER")="178.3014"
     33        S @ARY@("MIME TYPE")="2.3"
     34        S @ARY@("PROXY SERVER")="2.4"
     35        S @ARY@("REPLY TEMPLATE")=".03"
     36        S @ARY@("TEMPLATE NAME")=".01"
     37        S @ARY@("TEMPLATE XML")="3"
     38        S @ARY@("URL")="1"
     39        S @ARY@("WSDL URL")="2"
     40        S @ARY@("XML")="2.1"
     41        S @ARY@("XML HEADER")="2.2"
     42        S @ARY@("XPATH REDUCTION STRING")="2.5"
     43        S @ARY@("CCR VARIABLE")="4"
     44        S @ARY@("FILEMAN FIELD NAME")="1"
     45        S @ARY@("FILEMAN FIELD NUMBER")="1.2"
     46        S @ARY@("FILEMAN FILE POINTER")="1.1"
     47        S @ARY@("INDEXED BY")=".05"
     48        S @ARY@("SQLI FIELD NAME")="3"
     49        S @ARY@("VARIABLE NAME")="2"
     50        Q
     51        ;
     52RESTID(INNAM,INFARY)    ;EXTRINSIC TO RESOLVE TEMPLATE PASSED BY NAME
     53        ; FILE IS IDENTIFIED IN FARY, PASSED BY NAME
     54        I '$D(INFARY) D  ; NO FILE ARRAY PASSED
     55        . S INFARY="FARY"
     56        . D INITFARY(INFARY)
     57        N ZN,ZREF,ZR
     58        S ZN=@INFARY@("XML FILE NUMBER")
     59        S ZREF=$$FILEREF^C0CRNF(ZN)
     60        S ZR=$O(@ZREF@("B",INNAM,""))
     61        Q ZR
     62        ;
     63TESTSOAP        ;
     64        ; USING ICD9 WEB SERVICE TO TEST SOAP
     65        S G("CODE")="E*"
     66        S G("CODELN")=3
     67        D SOAP("GPL","ICD9","G")
     68        Q
     69        ;
     70SOAP(C0CRTN,C0CTID,C0CVA,C0CVOR,ALTXML,IFARY)   ; MAKES A SOAP CALL FOR
     71        ; TEMPLATE ID C0CTID
     72        ; RETURNS THE XML RESULT IN C0CRTN, PASSED BY NAME
     73        ; C0CVA IS PASSED BY NAME AND IS THE VARIABLE ARRAY TO PASS TO BIND
     74        ; C0CVOR IS THE NAME OF A VARIABLE OVERRIDE ARRAY, WHICH IS APPLIED
     75        ; BEFORE MAPPING
     76        ; IF ALTXML IS PASSED, BIND AND MAP WILL BE SKIPPED AND
     77        ; ALTXML WILL BE USED INSTEAD
     78        ;
     79        ; ARTIFACTS SECTION
     80        ; THE FOLLOWING WILL SET UP DEBUGGING ARTIFACTS FOR A POSSIBLE FUTURE
     81        ; ONLINE DEBUGGER. IF DEBUG=1, VARIABLES CONTAINING INTERMEDIATE RESULTS
     82        ; WILL NOT BE NEWED.
     83        I $G(WSDEBUG)="" N C0CV ; CATALOG OF ARTIFACT VARIABLES AND ARRAYS
     84        S C0CV(100,"C0CXF","XML TEMPLATE FILE NUMBER")=""
     85        S C0CV(200,"C0CHEAD","SOAP HEADER VARIABLE NAME")=""
     86        S C0CV(300,"HEADER","SOAP HEADER")=""
     87        S C0CV(400,"C0CMIME","MIME TYPE")=""
     88        S C0CV(500,"C0CURL","WS URL")=""
     89        S C0CV(550,"C0CPURL","PROXY URL")=""
     90        S C0CV(600,"C0CXML","XML VARIABLE NAME")=""
     91        S C0CV(700,"XML","OUTBOUND XML")=""
     92        S C0CV(800,"C0CRSLT","RAW XML RESULT RETURNED FROM WEB SERVICE")=""
     93        S C0CV(900,"C0CRHDR","RETURNED HEADER")=""
     94        S C0CV(1000,"C0CRXML","XML RESULT NORMALIZED")=""
     95        S C0CV(1100,"C0CR","REPLY TEMPLATE")=""
     96        S C0CV(1200,"C0CREDUX","REDUX STRING")=""
     97        S C0CV(1300,"C0CIDX","RESULT XPATH INDEX")=""
     98        S C0CV(1400,"C0CARY","RESULT XPATH ARRAY")=""
     99        S C0CV(1500,"C0CNOM","RESULT DOM DOCUMENT NAME")=""
     100        S C0CV(1600,"C0CID","RESULT DOM ID")=""
     101        I $G(DEBUG)'="" G NOTNEW ; SKIP NEWING THE VARIABLES IF IN DEBUG
     102        N ZI,ZJ S ZI=""
     103NEW     
     104        S ZI=$O(C0CV(ZI))
     105        S ZJ=$O(C0CV(ZI,"")) ; SET UP NEW COMMAND
     106        ;W ZJ,!
     107        N @ZJ ; NEW THE VARIABLE
     108        I $O(C0CV(ZI))'="" G NEW ;LOOP TO GET NEW IN CONTEXT
     109NOTNEW 
     110        ; END ARTIFACTS
     111        ;
     112        I '$D(IFARY) D INITFARY("C0CF") ; SET FILE NUMBER AND PARAMATERS
     113        E  D  ;
     114        . K C0CF
     115        . M C0CF=@IFARY
     116        S C0CXF=C0CF("XML FILE NUMBER") ; FILE NUMBER FOR THE XML TEMPLATE FILE
     117        I +C0CTID=0 D  ; A STRING WAS PASSED FOR THE TEMPLATE NAME
     118        . S C0CUTID=$$RESTID(C0CTID,"C0CF") ;RESOLVE TEMPLATE IEN FROM NAME
     119        E  S C0CUTID=C0CTID ; AN IEN WAS PASSED
     120        N XML,TEMPLATE,HEADER
     121        N C0CFH S C0CFH=C0CF("XML HEADER")
     122        S C0CHEAD=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFH,,"HEADER")
     123        N C0CFM S C0CFM=C0CF("MIME TYPE")
     124        S C0CMIME=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFM)
     125        N C0CFP S C0CFP=C0CF("PROXY SERVER")
     126        S C0CPURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFP)
     127        N C0CFU S C0CFU=C0CF("URL")
     128        S C0CURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFU)
     129        N C0CFX S C0CFX=C0CF("XML")
     130        S C0CXML=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFX,,"XML")
     131        N C0CFT S C0CFT=C0CF("TEMPLATE XML")
     132        S C0CTMPL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFT,,"TEMPLATE")
     133        I C0CTMPL="TEMPLATE" D  ; there is a template to process
     134        . K XML ; going to replace the xml array
     135        . N VARS
     136        . I $D(C0CVOR) M @C0CVA=@C0CVOR ; merge in varible overrides
     137        . I '$D(ALTXML) D  ; if ALTXML is passed in, don't bind
     138        . . D BIND("VARS",C0CVA,C0CUTID,"C0CF")
     139        . . D MAP("XML","VARS",TPTR,"C0CF")
     140        . . K XML(0)
     141        . E  M XML=@ALTXML ; use ALTXML instead
     142        I $G(C0CPROXY) S C0CURL=C0CPURL
     143        K C0CRSLT,C0CRHDR
     144        B
     145        S ok=$$httpPOST^%zewdGTM(C0CURL,.XML,C0CMIME,.C0CRSLT,.HEADER,"",.gpl5,.C0CRHDR)
     146        K C0CRXML
     147        D NORMAL("C0CRXML","C0CRSLT(1)") ;RETURN XML IN AN ARRAY
     148        N C0CFR S C0CFR=$G(C0CF("REPLY TEMPLATE"))
     149        S C0CR=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFR,"I") ; REPLY TEMPLATE
     150        ; reply templates are optional and are specified by populating a
     151        ; template pointer in field 2.5 of the request template
     152        ; if specified, the reply template is the source of the REDUX string
     153        ; used for XPath on the reply, and for UNBIND processing
     154        ; if no reply template is specified, REDUX is obtained from the request
     155        ; template and no UNBIND processing is performed. The XPath array is
     156        ; returned without variable bindings
     157        I C0CR'="" D  ; REPLY TEMPLATE EXISTS
     158        . I +$G(DEBUG)'=0 W "REPLY TEMPLATE:",C0CR,!
     159        . S C0CTID=C0CR ;
     160        N C0CFRDX S C0CFRDX=C0CF("XPATH REDUCTION STRING")
     161        S C0CREDUX=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFRDX) ;XPATH REDUCTION STRING
     162        K C0CIDX,C0CARY ; XPATH INDEX AND ARRAY VARS
     163        S C0CNOM="C0CWS"_$J ; DOCUMENT NAME FOR THE DOM
     164        S C0CID=$$PARSE^C0CXEWD("C0CRXML",C0CNOM) ;CALL THE PARSER
     165        S C0CID=$$FIRST^C0CXEWD($$ID^C0CXEWD(C0CNOM)) ;ID OF FIRST NODE
     166        D XPATH^C0CXEWD(C0CID,"/","C0CIDX","C0CARY","",C0CREDUX) ;XPATH GENERATOR
     167        ; Next, call UNBIND to map the reply XPath array to variables
     168        ; This is only done if a Reply Template is provided
     169        D DEMUXARY(C0CRTN,"C0CARY")
     170        ; M @C0CRTN=C0CARY
     171        Q
     172        ;
     173DEMUXARY(OARY,IARY)     ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
     174        ; FORMAT @OARY@(x,xpath) where x is the first multiple
     175        N ZI,ZJ,ZK,ZL S ZI=""
     176        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ;
     177        . D DEMUX^C0CMXP("ZJ",ZI)
     178        . S ZK=$P(ZJ,"^",3)
     179        . S ZK=$RE($P($RE(ZK),"/",1))
     180        . S ZL=$P(ZJ,"^",1)
     181        . I ZL="" S ZL=1
     182        . S @OARY@(ZL,ZK)=@IARY@(ZI)
     183        Q
     184        ;
     185NORMAL(OUTXML,INXML)    ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
     186        ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
     187        ;
     188        N ZI,ZN,ZTMP
     189        S ZN=1
     190        S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">"
     191        S ZN=ZN+1
     192        F  S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)=""  D  ;
     193        . S @OUTXML@(ZN)=@OUTXML@(ZN)_">"
     194        . S ZN=ZN+1
     195        Q
     196        ;
     197MAP(RARY,IVARS,TPTR,INFARY)     ;RETURNS MAPPED XML IN RARY PASSED BY NAME
     198        ; IVARS IS AN XPATH ARRAY PASSED BY NAME
     199        ; TPTR IS A POINT TO THE C0C XML TEMPLATE FILE USED TO RETRIEVE THE TEMPLATE
     200        ;
     201        N ZT ;THE TEMPLATE
     202        K ZT,@RARY
     203        I '$D(INFARY) D  ;
     204        . S INFARY="FARY"
     205        . D INITFARY(INFARY)
     206        N ZF,ZFT
     207        S ZF=@INFARY@("XML FILE NUMBER")
     208        S ZFT=@INFARY@("TEMPLATE XML")
     209        I $$GET1^DIQ(ZF,TPTR_",",ZFT,,"ZT")'="ZT" D  Q  ; ERROR GETTING TEMPLATE
     210        . W "ERROR RETRIEVING TEMPLATE",!
     211        D MAP^C0CXPATH("ZT",IVARS,RARY) ;DO THE MAPPING
     212        Q
     213        ;
     214TESTBIND        ;
     215        S G1("TESTONE")=1
     216        S G1("TESTTWO")=2
     217        D BIND("G","G1","TEST")
     218        W !
     219        ZWR G
     220        Q
     221        ;
     222BIND(RARY,IVARS,INTPTR,INFARY)  ;RETURNS AN XPATH ARRAY IN RARY FOR USE WITH MAP
     223        ; TO BUILD AN INSTANTIATED TEMPLATE
     224        ; TPTR IS THE IEN OF THE XML TEMPATE IN THE C0C XML TEMPLATE FILE
     225        ; LOOPS THROUGHT THE BINDING SUBFILE TO PULL OUT XPATHS AND
     226        ; EITHER ASSIGNS VARIABLES OR DOES A FILEMAN CALL TO GET VALUES
     227        ; VARIABLES ARE IN IVARS WHICH IS PASSED BY NAME
     228        I '$D(INFARY) D  ;
     229        . S INFARY="FARY"
     230        . D INITFARY(INFARY) ;INITIALIZE FILE ARRAY IF NOT PASSED
     231        I +INTPTR>0 S TPTR=INTPTR
     232        E  S TPTR=$$RESTID(INTPTR,INFARY)
     233        N C0CFF,C0CBF,C0CXI,C0CFREF,C0CXREF
     234        S C0CFF=@INFARY@("XML FILE NUMBER") ;fileman file number of XML file
     235        S C0CFREF=$$FILEREF^C0CRNF(C0CFF) ; closed file reference to the file
     236        S C0CBF=@INFARY@("BINDING SUBFILE NUMBER") ; BINDING SUBFILE NUMBER
     237        S C0CXI=$G(@INFARY@("XPATH INDEX")) ; index to the XPath bindings
     238        I C0CXI="" S C0CXI="XPATH" ; default is the XPATH index
     239        ; this needs to be a whole file index on the XPath subfile with
     240        ; the Template IEN perceding the XPath in the index
     241        N ZI
     242        S ZI=""
     243        S C0CXREF=$NA(@C0CFREF@(C0CXI,TPTR)) ; where the xref is
     244        ;F  S ZI=$O(^C0CX(TPTR,5,"B",ZI)) Q:ZI=""  D  ; FOR EACH XPATH
     245        F  S ZI=$O(@C0CXREF@(ZI)) Q:ZI=""  D  ; for each XPath in this template
     246        . ;W !,ZI," ",$O(@C0CXREF@(ZI,TPTR,""))
     247        . N ZIEN,ZFILE,ZFIELD,ZVAR,ZIDX,ZINDEX ;
     248        . S ZIEN=$O(@C0CXREF@(ZI,TPTR,"")) ; IEN OF THE BINDING RECORD
     249        . N ZFF S ZFF=@INFARY@("FILEMAN FILE POINTER")
     250        . S ZFILE=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFF,"I")
     251        . N ZFFLD S ZFFLD=@INFARY@("FILEMAN FIELD NUMBER")
     252        . S ZFIELD=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFFLD,"I")
     253        . N ZFV S ZFV=@INFARY@("VARIABLE NAME")
     254        . S ZVAR=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFV,"E")
     255        . N ZFX S ZFX=("INDEXED BY")
     256        . S ZIDX=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFX,"I")
     257        . S ZINDEX=""
     258        . I ZIDX="DUZ" S ZINDEX=$G(DUZ) ; FILE IS INDEXED BY DUZ
     259        . I ZIDX="DFN" S ZINDEX=$G(DFN) ; BY DFN
     260        . E  I ZIDX'="" S ZINDEX=$G(@ZIDX) ; index variable
     261        . ;I ZIDX="ACCT" S ZINDEX=C0CACCT ; BY ACCOUNT RECORD POINT TO C0C WS ACCT
     262        . ;I ZIDX="LOC" S ZINDEX=C0CLOC ; BY LOCATION
     263        . I ZVAR'="" D  ; VARIABLES TAKE PRESCIDENCE OVER FILEMAN FIELDS
     264        . . S @RARY@(ZI)=@IVARS@(ZVAR) ;
     265        . E  D  ; IF NO VARIABLE, TRY ACCESSING FROM FILEMAN
     266        . . I (ZFILE="")!(ZFIELD="") Q  ;QUIT IF FILE OR FIELD NOT THERE
     267        . . D CLEAN^DILF
     268        . . S @RARY@(ZI)=$$GET1^DIQ(ZFILE,ZINDEX_",",ZFIELD) ;GET THE VALUE
     269        . . I $D(^TMP("DIERR",$J,1)) D  B ;
     270        . . . W "ERROR!",!
     271        . . . ZWR ^TMP("DIERR",$J,*)
     272        Q
     273        ;

  • ccr/branches/ohum/p/C0CSUB1.m

    r1342 r1428  
    1 C0CSUB1   ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  W "This is the CCR SUBSCRIPTIONN Utility Library ",!
    21  Q
    22  ;
    23 CHK1(DFN) ; ADD THE CHECKSUM FOR ONE PATIENT
    24  ;
    25  S C0CCHK=$NA(^TMP("C0CRIM","CHKSUM"))
    26  S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE
    27  S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE
    28  S C0CSFC=177.1012 ; FILE NUMBER FOR CHECKSUM SUBFILE
    29  S C0CSFDC=177.10121 ; FILE NUMBER FOR DOMAIN CHECKSUMS
    30  S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT
    31  K C0CFDA
    32  S C0CALL=$G(@C0CCHK@(DFN,"ALL"))
    33  I C0CALL'="" S C0CFDA(C0CSFC,"?+1,"_C0CPAT_",",.01)=C0CALL
    34  E  Q ; NO CHECKSUMS FOR THISPATIENT
    35  D UPDIE
    36  N C0CJ S C0CJ=""
    37  F  S C0CJ=$O(@C0CCHK@(DFN,"DOMAIN",C0CJ)) Q:C0CJ=""  D  ; FOR EACH DOMAIN
    38  . S C0CD=$O(^C0CDIC(170.101,"B",C0CJ,""))
    39  . W C0CJ," ",C0CD,!
    40  . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",.01)=C0CD
    41  . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",1)=@C0CCHK@(DFN,"DOMAIN",C0CJ)
    42  . D UPDIE
    43  Q
    44  ;
    45 SUBALL ; SUBSCRIBE ALL PATIENTS IN CCR GLOBALS TO SUBCRIBER 1
    46  ;
    47  S C0CGLB=$NA(^TMP("C0CRIM","VARS"))
    48  S C0CI=""
    49  F  S C0CI=$O(@C0CGLB@(C0CI)) Q:C0CI=""  D  ; FOR EACH PATIENT
    50  . D SUB1(C0CI,1) ;SUBSCIRBE THEM TO EPCRN
    51  Q
    52  ;
    53 SUB1(DFN,C0CSS) ; SUBSCRIBE ONE PATIENT TO SUBSCRIBER C0CSS
    54  ;
    55  S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE
    56  S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE
    57  S C0CSFC=177.10121 ; FILE NUMBER FOR CHECKSUMS
    58  S C0CSSF=177.201 ; FILE NUMBER FOR SUBSCRIBER FILE
    59  K C0CFDA
    60  S C0CFDA(C0CSF,"+1,",.01)=DFN
    61  D UPDIE ; ADD THE PATIENT
    62  S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT
    63  S C0CFDA(C0CSFS,"+1,"_C0CPAT_",",.01)=C0CSS ; C0CSS IS A POINTER
    64  D UPDIE ; ADD THE SUBSCRIPTION
    65  D CHK1(DFN) ; ADD THE CHECKSUMS
    66  Q
    67  ;
    68 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
    69  K ZERR
    70  D CLEAN^DILF
    71  D UPDATE^DIE("","C0CFDA","","ZERR")
    72  I $D(ZERR) D  ;
    73  . W "ERROR",!
    74  . ZWR ZERR
    75  . B
    76  K C0CFDA
    77  Q
    78  ;
    79 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
    80  ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
    81  ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
    82  ;
    83  N ZCCRD,ZVARN,C0CFDA2
    84  S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
    85  S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    86  I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
    87  . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
    88  . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
    89  . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
    90  . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
    91  . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
    92  . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
    93  . I $D(ZERR) D  ; LAYGO ERROR
    94  . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
    95  . E  D  ;
    96  . . D CLEAN^DILF ; CLEAN UP
    97  . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
    98  . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
    99  Q ZVARN
    100  ;
    101 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
    102  ; TO SET TO VALUE C0CSV.
    103  ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
    104  ; C0CSN,C0CSV ARE PASSED BY VALUE
    105  ;
    106  N C0CSI,C0CSJ
    107  S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
    108  S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
    109  S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
    110  Q
    111 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
    112  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
    113  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    114  I '$D(ZTAB) S ZTAB="C0CA"
    115  N ZR
    116  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
    117  E  S ZR=""
    118  Q ZR
    119 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
    120  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
    121  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    122  I '$D(ZTAB) S ZTAB="C0CA"
    123  N ZR
    124  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
    125  E  S ZR=""
    126  Q ZR
    127  ;
    128 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
    129  ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
    130  ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
    131  I '$D(ZTAB) S ZTAB="C0CA"
    132  N ZR
    133  I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
    134  E  S ZR=""
    135  Q ZR
    136  ;
     1C0CSUB1   ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        W "This is the CCR SUBSCRIPTIONN Utility Library ",!
     21        Q
     22        ;
     23CHK1(DFN)       ; ADD THE CHECKSUM FOR ONE PATIENT
     24        ;
     25        S C0CCHK=$NA(^TMP("C0CRIM","CHKSUM"))
     26        S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE
     27        S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE
     28        S C0CSFC=177.1012 ; FILE NUMBER FOR CHECKSUM SUBFILE
     29        S C0CSFDC=177.10121 ; FILE NUMBER FOR DOMAIN CHECKSUMS
     30        S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT
     31        K C0CFDA
     32        S C0CALL=$G(@C0CCHK@(DFN,"ALL"))
     33        I C0CALL'="" S C0CFDA(C0CSFC,"?+1,"_C0CPAT_",",.01)=C0CALL
     34        E  Q ; NO CHECKSUMS FOR THISPATIENT
     35        D UPDIE
     36        N C0CJ S C0CJ=""
     37        F  S C0CJ=$O(@C0CCHK@(DFN,"DOMAIN",C0CJ)) Q:C0CJ=""  D  ; FOR EACH DOMAIN
     38        . S C0CD=$O(^C0CDIC(170.101,"B",C0CJ,""))
     39        . W C0CJ," ",C0CD,!
     40        . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",.01)=C0CD
     41        . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",1)=@C0CCHK@(DFN,"DOMAIN",C0CJ)
     42        . D UPDIE
     43        Q
     44        ;
     45SUBALL  ; SUBSCRIBE ALL PATIENTS IN CCR GLOBALS TO SUBCRIBER 1
     46        ;
     47        S C0CGLB=$NA(^TMP("C0CRIM","VARS"))
     48        S C0CI=""
     49        F  S C0CI=$O(@C0CGLB@(C0CI)) Q:C0CI=""  D  ; FOR EACH PATIENT
     50        . D SUB1(C0CI,1) ;SUBSCIRBE THEM TO EPCRN
     51        Q
     52        ;
     53SUB1(DFN,C0CSS) ; SUBSCRIBE ONE PATIENT TO SUBSCRIBER C0CSS
     54        ;
     55        S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE
     56        S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE
     57        S C0CSFC=177.10121 ; FILE NUMBER FOR CHECKSUMS
     58        S C0CSSF=177.201 ; FILE NUMBER FOR SUBSCRIBER FILE
     59        K C0CFDA
     60        S C0CFDA(C0CSF,"+1,",.01)=DFN
     61        D UPDIE ; ADD THE PATIENT
     62        S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT
     63        S C0CFDA(C0CSFS,"+1,"_C0CPAT_",",.01)=C0CSS ; C0CSS IS A POINTER
     64        D UPDIE ; ADD THE SUBSCRIPTION
     65        D CHK1(DFN) ; ADD THE CHECKSUMS
     66        Q
     67        ;
     68UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
     69        K ZERR
     70        D CLEAN^DILF
     71        D UPDATE^DIE("","C0CFDA","","ZERR")
     72        I $D(ZERR) D  ;
     73        . W "ERROR",!
     74        . ZWR ZERR
     75        . B
     76        K C0CFDA
     77        Q
     78        ;
     79VARPTR(ZVAR,ZTYP)       ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
     80        ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
     81        ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
     82        ;
     83        N ZCCRD,ZVARN,C0CFDA2
     84        S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
     85        S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     86        I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
     87        . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
     88        . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
     89        . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
     90        . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
     91        . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
     92        . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
     93        . I $D(ZERR) D  ; LAYGO ERROR
     94        . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
     95        . E  D  ;
     96        . . D CLEAN^DILF ; CLEAN UP
     97        . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
     98        . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
     99        Q ZVARN
     100        ;
     101SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
     102        ; TO SET TO VALUE C0CSV.
     103        ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
     104        ; C0CSN,C0CSV ARE PASSED BY VALUE
     105        ;
     106        N C0CSI,C0CSJ
     107        S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
     108        S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
     109        S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
     110        Q
     111ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
     112        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
     113        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     114        I '$D(ZTAB) S ZTAB="C0CA"
     115        N ZR
     116        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
     117        E  S ZR=""
     118        Q ZR
     119ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
     120        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
     121        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     122        I '$D(ZTAB) S ZTAB="C0CA"
     123        N ZR
     124        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
     125        E  S ZR=""
     126        Q ZR
     127        ;
     128ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
     129        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
     130        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
     131        I '$D(ZTAB) S ZTAB="C0CA"
     132        N ZR
     133        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
     134        E  S ZR=""
     135        Q ZR
     136        ;

  • ccr/branches/ohum/p/C0CSYS.m

    r1342 r1428  
    1 C0CSYS ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4  ; General Public License See attached copy of the License.
    5  ;
    6  ; This program is free software; you can redistribute it and/or modify
    7  ; it under the terms of the GNU General Public License as published by
    8  ; the Free Software Foundation; either version 2 of the License, or
    9  ; (at your option) any later version.
    10  ;
    11  ; This program is distributed in the hope that it will be useful,
    12  ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ; GNU General Public License for more details.
    15  ;
    16  ; You should have received a copy of the GNU General Public License along
    17  ; with this program; if not, write to the Free Software Foundation, Inc.,
    18  ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  W "Enter at appropriate points." Q
    21  ;
    22  ; Originally, I was going to use VEPERVER, but VEPERVER
    23  ; actually kills ^TMP($J), outputs it to the screen in a user-friendly
    24  ; manner (press any key to continue),
    25  ; and is really a very half finished routine
    26  ;
    27  ; So for now, I am hard-coding the values.
    28  ;
    29 SYSNAME() ;Get EHR System Name; PUBLIC; Extrinsic
    30  Q:$G(DUZ("AG"))="I" "RPMS"
    31  Q "WorldVistA EHR/VOE"
    32  ;
    33 SYSVER() ;Get EHR System Version; PUBLIC; Extrinsic
    34  Q "1.0"
    35  ;
    36 PTST(DFN) ;TEST TO SEE IF PATIENT MERGED OR A TEST PATIENT
    37   ; DFN = IEN of the Patient to be tested
    38   ; 1 = Merged or Test Patient
    39   ; 0 = Non-test Patient
    40   ;
    41   I DFN="" Q 0  ; BAD DFN PASSED
    42   I $D(^DPT(DFN,-9)) Q 1  ;This patient has been merged
    43   I $G(^DPT(DFN,0))="" Q 1  ;Missing zeroth node <---add
    44   ;
    45   I '$D(CCRTEST) S CCRTEST=1 ; DEFAULT IS THAT WE ARE TESTING
    46   I CCRTEST Q 0  ; IF WE ARE TESTING, DON'T REJECT TEST PATIENTS
    47   N DIERR,DATA
    48   I $$TESTPAT^VADPT(DFN) Q 1 ; QUIT IF IT'S A VA TEST PATIENT
    49   S DATA=+$$GET1^DIQ(2,DFN_",",.6,"I") ;Test Patient Indicator
    50   ; 1 = Test Patient
    51   ; 0 = Non-test Patient
    52   I DATA Q DATA
    53   S DATA=$$GET1^DIQ(2,DFN_",",.09,"I") ;SSN test
    54   D CLEAN^DILF
    55   I "Pp"[$E(DATA,$L(DATA),$L(DATA)) Q 0  ;Allow Pseudo SSN
    56   I $E(DATA,1,3)="000" Q 1
    57   I $E(DATA,1,3)="666" Q 1
    58   Q 0
    59   ;
     1C0CSYS  ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     4        ; General Public License See attached copy of the License.
     5        ;
     6        ; This program is free software; you can redistribute it and/or modify
     7        ; it under the terms of the GNU General Public License as published by
     8        ; the Free Software Foundation; either version 2 of the License, or
     9        ; (at your option) any later version.
     10        ;
     11        ; This program is distributed in the hope that it will be useful,
     12        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ; GNU General Public License for more details.
     15        ;
     16        ; You should have received a copy of the GNU General Public License along
     17        ; with this program; if not, write to the Free Software Foundation, Inc.,
     18        ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        W "Enter at appropriate points." Q
     21        ;
     22        ; Originally, I was going to use VEPERVER, but VEPERVER
     23        ; actually kills ^TMP($J), outputs it to the screen in a user-friendly
     24        ; manner (press any key to continue),
     25        ; and is really a very half finished routine
     26        ;
     27        ; So for now, I am hard-coding the values.
     28        ;
     29SYSNAME()       ;Get EHR System Name; PUBLIC; Extrinsic
     30        Q:$G(DUZ("AG"))="I" "RPMS"
     31        Q "WorldVistA EHR/VOE"
     32        ;
     33SYSVER()        ;Get EHR System Version; PUBLIC; Extrinsic
     34        Q "1.0"
     35        ;
     36PTST(DFN)       ;TEST TO SEE IF PATIENT MERGED OR A TEST PATIENT
     37        ; DFN = IEN of the Patient to be tested
     38        ; 1 = Merged or Test Patient
     39        ; 0 = Non-test Patient
     40        ;
     41        I DFN="" Q 0  ; BAD DFN PASSED
     42        I $D(^DPT(DFN,-9)) Q 1  ;This patient has been merged
     43        I $G(^DPT(DFN,0))="" Q 1  ;Missing zeroth node <---add
     44        ;
     45        I '$D(CCRTEST) S CCRTEST=1 ; DEFAULT IS THAT WE ARE TESTING
     46        I CCRTEST Q 0  ; IF WE ARE TESTING, DON'T REJECT TEST PATIENTS
     47        N DIERR,DATA
     48        I $$TESTPAT^VADPT(DFN) Q 1 ; QUIT IF IT'S A VA TEST PATIENT
     49        S DATA=+$$GET1^DIQ(2,DFN_",",.6,"I") ;Test Patient Indicator
     50        ; 1 = Test Patient
     51        ; 0 = Non-test Patient
     52        I DATA Q DATA
     53        S DATA=$$GET1^DIQ(2,DFN_",",.09,"I") ;SSN test
     54        D CLEAN^DILF
     55        I "Pp"[$E(DATA,$L(DATA),$L(DATA)) Q 0  ;Allow Pseudo SSN
     56        I $E(DATA,1,3)="000" Q 1
     57        I $E(DATA,1,3)="666" Q 1
     58        Q 0
     59        ;

  • ccr/branches/ohum/p/C0CUNIT.m

    r1342 r1428  
    1 C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008 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 a unit testing library",!
    21           W !
    22           Q
    23           ;
    24 ZT(ZARY,BAT,TST) ; private routine to add a test case to the ZARY array
    25           ; ZARY IS PASSED BY REFERENCE
    26           ; BAT is a string identifying the test battery
    27           ; TST is a test which will evaluate to true or false
    28           ; I '$G(ZARY) D
    29           ; . S ZARY(0)=0 ; initially there are no elements
    30           ; W "GOT HERE LOADING "_TST,!
    31           N CNT ; count of array elements
    32           S CNT=ZARY(0) ; contains array count
    33           S CNT=CNT+1 ; increment count
    34           S ZARY(CNT)=TST ; put the test in the array
    35           I $D(ZARY(BAT))  D  ; NOT THE FIRST TEST IN BATTERY
    36           . N II,TN ; TEMP FOR ENDING TEST IN BATTERY
    37           . S II=$P(ZARY(BAT),"^",2)
    38           . S $P(ZARY(BAT),"^",2)=II+1
    39           I '$D(ZARY(BAT))  D  ; FIRST TEST IN THIS BATTERY
    40           . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY
    41           . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX
    42           . ; S TN=$NA(ZARY("TESTS"))
    43           . ; D PUSH^C0CXPATH(TN,BAT)
    44           S ZARY(0)=CNT ; update the array counter
    45           Q
    46           ;
    47 ZLOAD(ZARY,ROUTINE)  ; load tests into ZARY which is passed by reference
    48           ; ZARY IS PASSED BY NAME
    49           ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
    50           ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
    51           K @ZARY
    52           S @ZARY@(0)=0 ; initialize array count
    53           N LINE,LABEL,BODY
    54           N INTEST S INTEST=0 ; switch for in the test case section
    55           N SECTION S SECTION="[anonymous]" ; test case section
    56           ;
    57           N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
    58           . I LINE?." "1";;><TEST>".E S INTEST=1 ; entering test section
    59           . I LINE?." "1";;><TEMPLATE>".E S INTEST=1 ; entering TEMPLATE section
    60           . I LINE?." "1";;></TEST>".E S INTEST=0 ; leaving test section
    61           . I LINE?." "1";;></TEMPLATE>".E S INTEST=0 ; leaving TEMPLATE section
    62           . I INTEST  D  ; within the testing section
    63           . . I LINE?." "1";;><".E  D  ; section name found
    64           . . . S SECTION=$P($P(LINE,";;><",2),">",1) ; pull out name
    65           . . I LINE?." "1";;>>".E  D  ; test case found
    66           . . . D ZT(.@ZARY,SECTION,$P(LINE,";;>>",2)) ; put the test in the array
    67           S @ZARY@("ALL")="1"_"^"_@ZARY@(0) ; MAKE A BATTERY FOR ALL
    68           Q
    69           ;
    70 ZTEST(ZARY,WHICH)   ; try out the tests using a passed array ZTEST
    71           N ZI,ZX,ZR,ZP
    72           S DEBUG=0
    73           ; I WHICH="ALL" D  Q ; RUN ALL THE TESTS
    74           ; . W "DOING ALL",!
    75           ; . N J,NT
    76           ; . S NT=$NA(ZARY("TESTS"))
    77           ; . W NT,@NT@(0),!
    78           ; . F J=1:1:@NT@(0) D  ;
    79           ; . . W @NT@(J),!
    80           ; . . D ZTEST^C0CUNIT(@ZARY,@NT@(J))
    81           I '$D(ZARY(WHICH))  D  Q ; TEST SECTION DOESN'T EXIST
    82           . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,!
    83           N FIRST,LAST
    84           S FIRST=$P(ZARY(WHICH),"^",1)
    85           S LAST=$P(ZARY(WHICH),"^",2)
    86           F ZI=FIRST:1:LAST  D
    87           . I ZARY(ZI)?1">"1.E  D  ; NOT A TEST, JUST RUN THE STATEMENT
    88           . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI)))
    89           . . ;  W ZP,!
    90           . . S ZX=ZP
    91           . . W "RUNNING: "_ZP
    92           . . X ZX
    93           . . W "..SUCCESS: ",WHICH,!
    94           . I ZARY(ZI)?1"?"1.E  D  ; THIS IS A TEST
    95           . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI)))
    96           . . S ZX="S ZR="_ZP
    97           . . W "TRYING: "_ZP
    98           . . X ZX
    99           . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),!
    100           . . I '$D(TPASSED) D  ; NOT INITIALIZED YET
    101           . . . S TPASSED=0 S TFAILED=0
    102           . . I ZR S TPASSED=TPASSED+1
    103           . . I 'ZR S TFAILED=TFAILED+1
    104           Q
    105           ;
    106 TEST   ; RUN ALL THE TEST CASES
    107           N ZTMP
    108           D ZLOAD(.ZTMP)
    109           D ZTEST(.ZTMP,"ALL")
    110           W "PASSED: ",TPASSED,!
    111           W "FAILED: ",TFAILED,!
    112           W !
    113           W "THE TESTS!",!
    114           ; I DEBUG ZWR ZTMP
    115           Q
    116           ;
    117 GTSTS(GTZARY,RTN) ; return an array of test names
    118           N I,J S I="" S I=$O(GTZARY("TESTS",I))
    119           F J=0:0  Q:I=""  D
    120           . D PUSH^C0CXPATH(RTN,I)
    121           . S I=$O(GTZARY("TESTS",I))
    122           Q
    123           ;
    124 TESTALL(RNM) ; RUN ALL THE TESTS
    125           N ZI,J,TZTMP,TSTS,TOTP,TOTF
    126           S TOTP=0 S TOTF=0
    127           D ZLOAD^C0CUNIT("TZTMP",RNM)
    128           D GTSTS(.TZTMP,"TSTS")
    129           F ZI=1:1:TSTS(0) D  ;
    130           . S TPASSED=0 S TFAILED=0
    131           . D ZTEST^C0CUNIT(.TZTMP,TSTS(ZI))
    132           . S TOTP=TOTP+TPASSED
    133           . S TOTF=TOTF+TFAILED
    134           . S $P(TSTS(ZI),"^",2)=TPASSED
    135           . S $P(TSTS(ZI),"^",3)=TFAILED
    136           F ZI=1:1:TSTS(0) D  ;
    137           . W "TEST=> ",$P(TSTS(ZI),"^",1)
    138           . W " PASSED=>",$P(TSTS(ZI),"^",2)
    139           . W " FAILED=>",$P(TSTS(ZI),"^",3),!
    140           W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,!
    141           Q
    142           ;
    143 TLIST(ZARY) ; LIST ALL THE TESTS
    144           ; THEY ARE MARKED AS ;;><TESTNAME> IN THE TEST CASES
    145           ; ZARY IS PASSED BY REFERENCE
    146           N I,J,K S I="" S I=$O(ZARY("TESTS",I))
    147           S K=1
    148           F J=0:0  Q:I=""  D
    149           . ; W "I IS NOW=",I,!
    150           . W I," "
    151           . S I=$O(ZARY("TESTS",I))
    152           . S K=K+1 I K=6  D
    153           . . W !
    154           . . S K=1
    155           Q
    156           ;
    157 MEDS 
    158  N DEBUG S DEBUG=0
    159  N DFN S DFN=5685
    160  K ^TMP($J)
    161  W "Loading CCR Template into T using LOAD^GPLCCR0($NA(^TMP($J,""CCR"")))",!!
    162  N T S T=$NA(^TMP($J,"CCR"))     D LOAD^GPLCCR0(T)
    163  N XPATH S XPATH="//ContinuityOfCareRecord/Body/Medications"
    164  W "XPATH is: "_XPATH,!
    165  W "Getting Med Template into INXML using",!
    166  W "QUERY^GPLXPATH(T,XPATH,""INXML"")",!!
    167  D QUERY^GPLXPATH(T,XPATH,"INXML")
    168  W "Executing EXTRACT^C0CMED(INXML,DFN,OUTXML)",!
    169  W "OUTXML will be ^TMP($J,""OUT"")",!
    170  N OUTXML S OUTXML=$NA(^TMP($J,"OUT"))
    171  D EXTRACT^C0CMED6("INXML",DFN,OUTXML)
    172  D FILEOUT^C0CRNF(OUTXML,"TESTMEDS.xml")
    173  Q
    174 PAT 
    175  D ANALYZE^ARJTXRD("C0CDPT",.OUT) ; Analyze a routine in the directory
    176  N X,Y
    177  ; Select Patient
    178  S DIC=2,DIC(0)="AEMQ" D ^DIC
    179  ;
    180  W "You have selected patient "_Y,!!
    181  N I S I=89 F  S I=$O(OUT(I)) Q:I="ALINE"  D
    182  . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" "
    183  . W "valued at "
    184  . W @("$$"_$P(OUT(I,0),"(DFN)")_"^"_"C0CDPT"_"("_$P(Y,"^")_")")
    185  . W !
    186  Q
     1C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008 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 a unit testing library",!
     21                 W !
     22                 Q
     23                 ;
     24ZT(ZARY,BAT,TST)        ; private routine to add a test case to the ZARY array
     25                 ; ZARY IS PASSED BY REFERENCE
     26                 ; BAT is a string identifying the test battery
     27                 ; TST is a test which will evaluate to true or false
     28                 ; I '$G(ZARY) D
     29                 ; . S ZARY(0)=0 ; initially there are no elements
     30                 ; W "GOT HERE LOADING "_TST,!
     31                 N CNT ; count of array elements
     32                 S CNT=ZARY(0) ; contains array count
     33                 S CNT=CNT+1 ; increment count
     34                 S ZARY(CNT)=TST ; put the test in the array
     35                 I $D(ZARY(BAT))  D  ; NOT THE FIRST TEST IN BATTERY
     36                 . N II,TN ; TEMP FOR ENDING TEST IN BATTERY
     37                 . S II=$P(ZARY(BAT),"^",2)
     38                 . S $P(ZARY(BAT),"^",2)=II+1
     39                 I '$D(ZARY(BAT))  D  ; FIRST TEST IN THIS BATTERY
     40                 . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY
     41                 . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX
     42                 . ; S TN=$NA(ZARY("TESTS"))
     43                 . ; D PUSH^C0CXPATH(TN,BAT)
     44                 S ZARY(0)=CNT ; update the array counter
     45                 Q
     46                 ;
     47ZLOAD(ZARY,ROUTINE)      ; load tests into ZARY which is passed by reference
     48                 ; ZARY IS PASSED BY NAME
     49                 ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
     50                 ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
     51                 K @ZARY
     52                 S @ZARY@(0)=0 ; initialize array count
     53                 N LINE,LABEL,BODY
     54                 N INTEST S INTEST=0 ; switch for in the test case section
     55                 N SECTION S SECTION="[anonymous]" ; test case section
     56                 ;
     57                 N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
     58                 . I LINE?." "1";;><TEST>".E S INTEST=1 ; entering test section
     59                 . I LINE?." "1";;><TEMPLATE>".E S INTEST=1 ; entering TEMPLATE section
     60                 . I LINE?." "1";;></TEST>".E S INTEST=0 ; leaving test section
     61                 . I LINE?." "1";;></TEMPLATE>".E S INTEST=0 ; leaving TEMPLATE section
     62                 . I INTEST  D  ; within the testing section
     63                 . . I LINE?." "1";;><".E  D  ; section name found
     64                 . . . S SECTION=$P($P(LINE,";;><",2),">",1) ; pull out name
     65                 . . I LINE?." "1";;>>".E  D  ; test case found
     66                 . . . D ZT(.@ZARY,SECTION,$P(LINE,";;>>",2)) ; put the test in the array
     67                 S @ZARY@("ALL")="1"_"^"_@ZARY@(0) ; MAKE A BATTERY FOR ALL
     68                 Q
     69                 ;
     70ZTEST(ZARY,WHICH)         ; try out the tests using a passed array ZTEST
     71                 N ZI,ZX,ZR,ZP
     72                 S DEBUG=0
     73                 ; I WHICH="ALL" D  Q ; RUN ALL THE TESTS
     74                 ; . W "DOING ALL",!
     75                 ; . N J,NT
     76                 ; . S NT=$NA(ZARY("TESTS"))
     77                 ; . W NT,@NT@(0),!
     78                 ; . F J=1:1:@NT@(0) D  ;
     79                 ; . . W @NT@(J),!
     80                 ; . . D ZTEST^C0CUNIT(@ZARY,@NT@(J))
     81                 I '$D(ZARY(WHICH))  D  Q ; TEST SECTION DOESN'T EXIST
     82                 . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,!
     83                 N FIRST,LAST
     84                 S FIRST=$P(ZARY(WHICH),"^",1)
     85                 S LAST=$P(ZARY(WHICH),"^",2)
     86                 F ZI=FIRST:1:LAST  D
     87                 . I ZARY(ZI)?1">"1.E  D  ; NOT A TEST, JUST RUN THE STATEMENT
     88                 . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI)))
     89                 . . ;  W ZP,!
     90                 . . S ZX=ZP
     91                 . . W "RUNNING: "_ZP
     92                 . . X ZX
     93                 . . W "..SUCCESS: ",WHICH,!
     94                 . I ZARY(ZI)?1"?"1.E  D  ; THIS IS A TEST
     95                 . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI)))
     96                 . . S ZX="S ZR="_ZP
     97                 . . W "TRYING: "_ZP
     98                 . . X ZX
     99                 . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),!
     100                 . . I '$D(TPASSED) D  ; NOT INITIALIZED YET
     101                 . . . S TPASSED=0 S TFAILED=0
     102                 . . I ZR S TPASSED=TPASSED+1
     103                 . . I 'ZR S TFAILED=TFAILED+1
     104                 Q
     105                 ;
     106TEST      ; RUN ALL THE TEST CASES
     107                 N ZTMP
     108                 D ZLOAD(.ZTMP)
     109                 D ZTEST(.ZTMP,"ALL")
     110                 W "PASSED: ",TPASSED,!
     111                 W "FAILED: ",TFAILED,!
     112                 W !
     113                 W "THE TESTS!",!
     114                 ; I DEBUG ZWR ZTMP
     115                 Q
     116                 ;
     117GTSTS(GTZARY,RTN)       ; return an array of test names
     118                 N I,J S I="" S I=$O(GTZARY("TESTS",I))
     119                 F J=0:0  Q:I=""  D
     120                 . D PUSH^C0CXPATH(RTN,I)
     121                 . S I=$O(GTZARY("TESTS",I))
     122                 Q
     123                 ;
     124TESTALL(RNM)    ; RUN ALL THE TESTS
     125                 N ZI,J,TZTMP,TSTS,TOTP,TOTF
     126                 S TOTP=0 S TOTF=0
     127                 D ZLOAD^C0CUNIT("TZTMP",RNM)
     128                 D GTSTS(.TZTMP,"TSTS")
     129                 F ZI=1:1:TSTS(0) D  ;
     130                 . S TPASSED=0 S TFAILED=0
     131                 . D ZTEST^C0CUNIT(.TZTMP,TSTS(ZI))
     132                 . S TOTP=TOTP+TPASSED
     133                 . S TOTF=TOTF+TFAILED
     134                 . S $P(TSTS(ZI),"^",2)=TPASSED
     135                 . S $P(TSTS(ZI),"^",3)=TFAILED
     136                 F ZI=1:1:TSTS(0) D  ;
     137                 . W "TEST=> ",$P(TSTS(ZI),"^",1)
     138                 . W " PASSED=>",$P(TSTS(ZI),"^",2)
     139                 . W " FAILED=>",$P(TSTS(ZI),"^",3),!
     140                 W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,!
     141                 Q
     142                 ;
     143TLIST(ZARY)     ; LIST ALL THE TESTS
     144                 ; THEY ARE MARKED AS ;;><TESTNAME> IN THE TEST CASES
     145                 ; ZARY IS PASSED BY REFERENCE
     146                 N I,J,K S I="" S I=$O(ZARY("TESTS",I))
     147                 S K=1
     148                 F J=0:0  Q:I=""  D
     149                 . ; W "I IS NOW=",I,!
     150                 . W I," "
     151                 . S I=$O(ZARY("TESTS",I))
     152                 . S K=K+1 I K=6  D
     153                 . . W !
     154                 . . S K=1
     155                 Q
     156                 ;
     157MEDS   
     158        N DEBUG S DEBUG=0
     159        N DFN S DFN=5685
     160        K ^TMP($J)
     161        W "Loading CCR Template into T using LOAD^GPLCCR0($NA(^TMP($J,""CCR"")))",!!
     162        N T S T=$NA(^TMP($J,"CCR"))     D LOAD^GPLCCR0(T)
     163        N XPATH S XPATH="//ContinuityOfCareRecord/Body/Medications"
     164        W "XPATH is: "_XPATH,!
     165        W "Getting Med Template into INXML using",!
     166        W "QUERY^GPLXPATH(T,XPATH,""INXML"")",!!
     167        D QUERY^GPLXPATH(T,XPATH,"INXML")
     168        W "Executing EXTRACT^C0CMED(INXML,DFN,OUTXML)",!
     169        W "OUTXML will be ^TMP($J,""OUT"")",!
     170        N OUTXML S OUTXML=$NA(^TMP($J,"OUT"))
     171        D EXTRACT^C0CMED6("INXML",DFN,OUTXML)
     172        D FILEOUT^C0CRNF(OUTXML,"TESTMEDS.xml")
     173        Q
     174PAT     
     175        D ANALYZE^ARJTXRD("C0CDPT",.OUT) ; Analyze a routine in the directory
     176        N X,Y
     177        ; Select Patient
     178        S DIC=2,DIC(0)="AEMQ" D ^DIC
     179        ;
     180        W "You have selected patient "_Y,!!
     181        N I S I=89 F  S I=$O(OUT(I)) Q:I="ALINE"  D
     182        . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" "
     183        . W "valued at "
     184        . W @("$$"_$P(OUT(I,0),"(DFN)")_"^"_"C0CDPT"_"("_$P(Y,"^")_")")
     185        . W !
     186        Q

  • ccr/branches/ohum/p/C0CUTIL.m

    r1342 r1428  
    1 C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08
    2  ;;0.1;C0C;;Jun 15, 2008;Build 2
    3  ;Copyright 2008-2009 Sam Habiel & George Lilly. 
    4  ;Licensed under the terms of the GNU
    5  ;General Public License See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  W "No Entry at Top!"
    22  Q
    23  ;
    24 UUID()  ; thanks to Wally for this.
    25         N R,I,J,N
    26         S N="",R="" F  S N=N_$R(100000) Q:$L(N)>64
    27         F I=1:2:64 S R=R_$E("0123456789abcdef",($E(N,I,I+1)#16+1))
    28         Q $E(R,1,8)_"-"_$E(R,9,12)_"-4"_$E(R,14,16)_"-"_$E("89ab",$E(N,17)#4+1)_$E(R,18,20)_"-"_$E(R,21,32)
    29  ;
    30 OLDUUID() ; GENERATE A RANDOM UUID (Version 4)
    31  N I,J,ZS
    32  S ZS="0123456789abcdef" S J=""
    33  F I=1:1:36 S J=J_$S((I=9)!(I=14)!(I=19)!(I=24):"-",I=15:4,I=20:"a",1:$E(ZS,$R(16)+1))
    34  Q J
    35  ;
    36 FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic
    37  ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time)
    38  ; If not passed, or passed incorrectly, it's assumed that it is D.
    39  ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied.
    40  ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC
    41  ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters)
    42  N UTC,Y,M,D,H,MM,S,OFF
    43  S Y=1700+$E(DATE,1,3)
    44  S M=$E(DATE,4,5)
    45  S D=$E(DATE,6,7)
    46  S H=$E(DATE,9,10)
    47  I $L(H)=1 S H="0"_H
    48  S MM=$E(DATE,11,12)
    49  I $L(MM)=1 S MM="0"_MM
    50  S S=$E(DATE,13,14)
    51  I $L(S)=1 S S="0"_S
    52  S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation.
    53  S OFFS=$E(OFF,1,1)
    54  S OFF0=$TR(OFF,"+-")
    55  S OFF1=$E(OFF0+10000,2,3)
    56  S OFF2=$E(OFF0+10000,4,5)
    57  S OFF=OFFS_OFF1_":"_OFF2
    58  ;S OFF2=$E(OFF,1,2) ;
    59  ;S OFF2=$E(100+OFF2,2,3) ; GPL 11/08 CHANGED TO -05:00 FORMAT
    60  ;S OFF3=$E(OFF,3,4) ;MINUTES
    61  ;S OFF=$S(OFF2="":"00",0:"00",1:OFF2)_"."_$S(OFF3="":"00",1:OFF3)
    62  ; If H, MM and S are empty, it means that the FM date didn't supply the time.
    63  ; In this case, set H, MM and S to "00"
    64  ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING?
    65  S:'$L(H) H="00"
    66  S:'$L(MM) MM="00"
    67  S:'$L(S) S="00"
    68  S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds
    69  I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time.
    70  E  Q $P(UTC,"T")
    71  ;
    72 SORTDT(V1,V2,ORDR) ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT
    73  ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE
    74  ; DATE AND TIME ORDER. DEFAULT IS FORWARD
    75  ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT
    76  ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER
    77  ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER
    78  ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC
    79  ; BOTH V1 AND V2 ARE PASSED BY REFERENCE
    80  N VSRT ; TEMP FOR HASHING DATES
    81  N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2
    82  S ZCNT=V2(0) ; COUNTING NUMBER OF DATES
    83  F ZI=1:1:ZCNT D  ; FOR EACH DATE IN THE ARRAY
    84  . I $D(V2(ZI)) D  ; IF THE DATE EXISTS
    85  . . S ZP1=$P(V2(ZI),".",1) ; THE DATE PIECE
    86  . . S ZP2=$P(V2(ZI),".",2) ; THE TIME PIECE
    87  . . ; W "DATE: ",ZP1," TIME: ",ZP2,!
    88  . . S VSRT(ZP1,ZP2,ZI)=ZI ; INDEX OF DATE, TIME AND COUNT
    89  N ZG
    90  S ZG=$Q(VSRT(""))
    91  F  D  Q:ZG=""  ;
    92  . ; W ZG,!
    93  . D PUSH^C0CXPATH("V1",@ZG)
    94  . S ZG=$Q(@ZG)
    95  I ORDR=-1 D  ; HAVE TO REVERSE ORDER
    96  . N ZG2
    97  . F ZI=1:1:V1(0) D  ; FOR EACH ELELMENT
    98  . . S ZG2(V1(0)-ZI+1)=V1(ZI) ; SET IN REVERSE ORDER
    99  . S ZG2(0)=V1(0)
    100  . D CP^C0CXPATH("ZG2","V1") ; COPY OVER THE NEW ARRAY
    101  Q ZCNT
    102  ;
    103 DA2SNO(RTN,DNAME) ; LOOK UP DRUG ALLERGY CODE IN ^LEX
    104  ; RETURNS AN ARRAY RTN PASSED BY REFERENCE
    105  ; THIS ROUTINE CAN BE USED AS AN RPC
    106  ; RTN(0) IS THE NUMBER OF ELEMENTS IN THE ARRAY
    107  ; RTN(1) IS THE SNOMED CODE FOR THE DRUG ALLERGY
    108  ;
    109  N LEXIEN
    110  I $O(^LEX(757.21,"ADIS",DNAME,""))'="" D  ; IEN FOUND FOR THIS DRUG
    111  . S LEXIEN=$O(^LEX(757.21,"ADIS",DNAME,"")) ; GET THE IEN IN THE LEXICON
    112  . W LEXIEN,!
    113  . S RTN(1)=$P(^LEX(757.02,LEXIEN,0),"^",2) ; SNOMED CODE IN P2
    114  . S RTN(0)=1 ; ONE THING RETURNED
    115  E  S RTN(0)=0 ; NOT FOUND
    116  Q
    117  ;
    118 DASNO(DANAME) ; PRINTS THE SNOMED CODE FOR ALLERGY TO DRUG DANAME
    119  ;
    120  N DARTN
    121  D DA2SNO(.DARTN,DANAME) ; CALL THE LOOKUP ROUTINE
    122  I DARTN(0)>0 D  ; GOT RESULTS
    123  . W !,DARTN(1) ;PRINT THE SNOMED CODE
    124  E  W !,"NOT FOUND",!
    125  Q
    126  ;
    127 DASNALL(WHICH) ; ROUTINE TO EXAMINE THE ADIS INDEX IN LEX AND RETRIEVE ALL
    128  ; ASSOCIATED SNOMED CODES
    129  N DASTMP,DASIEN,DASNO
    130  S DASTMP=""
    131  F  S DASTMP=$O(^LEX(757.21,WHICH,DASTMP)) Q:DASTMP=""  D  ; NAME OF MED
    132  . S DASIEN=$O(^LEX(757.21,WHICH,DASTMP,"")) ; IEN OF MED
    133  . S DASNO=$P(^LEX(757.02,DASIEN,0),"^",2) ; SNOMED CODE FOR ENTRY
    134  . W DASTMP,"=",DASNO,! ; PRINT IT OUT
    135  Q
    136  ;
    137 RXNFN() Q 1130590011.001 ; RxNorm Concepts file number
    138  ;
    139 CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF
    140  ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR
    141  N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT
    142  I $G(ZVUID)="" Q ""
    143  I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED
    144  N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID")
    145  S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES
    146  N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01)
    147  S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED
    148  I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F"
    149  Q ZRSLT
    150  ;
    151 NISTMAP(ZRXN) ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO
    152  ; CONFORM TO NIST REQUIREMENTS
    153  ;INPATIENT CERTIFICATION
    154  I ZRXN=309362 S ZRXN=213169
    155  I ZRXN=855318 S ZRXN=855320
    156  I ZRXN=197361 S ZRXN=212549
    157  ;OUTPATIENT CERTIFICATION
    158  I ZRXN=310534 S ZRXN=205875
    159  I ZRXN=617312 S ZRXN=617314
    160  I ZRXN=310429 S ZRXN=200801
    161  I ZRXN=628953 S ZRXN=628958
    162  I ZRXN=745679 S ZRXN=630208
    163  I ZRXN=311564 S ZRXN=979334
    164  I ZRXN=836343 S ZRXN=836370
    165  Q ZRXN
    166  ;
    167 RPMS() ; Are we running on an RPMS system rather than Vista?
    168  Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service
    169 VISTA() ; Are we running on Vanilla Vista?
    170  Q $G(DUZ("AG"))="V" ; If User Agency is VA
    171 WV() ; Are we running on WorldVista?
    172  Q $G(DUZ("AG"))="E" ; Code for WV.
    173 OV() ; Are we running on OpenVista?
    174  Q $G(DUZ("AG"))="O" ; Code for OpenVista
    175  
     1C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008-2009 Sam Habiel & George Lilly. 
     4        ;Licensed under the terms of the GNU
     5        ;General Public License See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        W "No Entry at Top!"
     22        Q
     23        ;
     24UUID()  ; thanks to Wally for this.
     25               N R,I,J,N
     26               S N="",R="" F  S N=N_$R(100000) Q:$L(N)>64
     27               F I=1:2:64 S R=R_$E("0123456789abcdef",($E(N,I,I+1)#16+1))
     28               Q $E(R,1,8)_"-"_$E(R,9,12)_"-4"_$E(R,14,16)_"-"_$E("89ab",$E(N,17)#4+1)_$E(R,18,20)_"-"_$E(R,21,32)
     29        ;
     30OLDUUID()       ; GENERATE A RANDOM UUID (Version 4)
     31        N I,J,ZS
     32        S ZS="0123456789abcdef" S J=""
     33        F I=1:1:36 S J=J_$S((I=9)!(I=14)!(I=19)!(I=24):"-",I=15:4,I=20:"a",1:$E(ZS,$R(16)+1))
     34        Q J
     35        ;
     36FMDTOUTC(DATE,FORMAT)   ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic
     37        ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time)
     38        ; If not passed, or passed incorrectly, it's assumed that it is D.
     39        ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied.
     40        ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC
     41        ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters)
     42        N UTC,Y,M,D,H,MM,S,OFF
     43        S Y=1700+$E(DATE,1,3)
     44        S M=$E(DATE,4,5)
     45        S D=$E(DATE,6,7)
     46        S H=$E(DATE,9,10)
     47        I $L(H)=1 S H="0"_H
     48        S MM=$E(DATE,11,12)
     49        I $L(MM)=1 S MM="0"_MM
     50        S S=$E(DATE,13,14)
     51        I $L(S)=1 S S="0"_S
     52        S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation.
     53        S OFFS=$E(OFF,1,1)
     54        S OFF0=$TR(OFF,"+-")
     55        S OFF1=$E(OFF0+10000,2,3)
     56        S OFF2=$E(OFF0+10000,4,5)
     57        S OFF=OFFS_OFF1_":"_OFF2
     58        ;S OFF2=$E(OFF,1,2) ;
     59        ;S OFF2=$E(100+OFF2,2,3) ; GPL 11/08 CHANGED TO -05:00 FORMAT
     60        ;S OFF3=$E(OFF,3,4) ;MINUTES
     61        ;S OFF=$S(OFF2="":"00",0:"00",1:OFF2)_"."_$S(OFF3="":"00",1:OFF3)
     62        ; If H, MM and S are empty, it means that the FM date didn't supply the time.
     63        ; In this case, set H, MM and S to "00"
     64        ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING?
     65        S:'$L(H) H="00"
     66        S:'$L(MM) MM="00"
     67        S:'$L(S) S="00"
     68        S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds
     69        I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time.
     70        E  Q $P(UTC,"T")
     71        ;
     72SORTDT(V1,V2,ORDR)      ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT
     73        ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE
     74        ; DATE AND TIME ORDER. DEFAULT IS FORWARD
     75        ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT
     76        ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER
     77        ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER
     78        ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC
     79        ; BOTH V1 AND V2 ARE PASSED BY REFERENCE
     80        N VSRT ; TEMP FOR HASHING DATES
     81        N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2
     82        S ZCNT=V2(0) ; COUNTING NUMBER OF DATES
     83        F ZI=1:1:ZCNT D  ; FOR EACH DATE IN THE ARRAY
     84        . I $D(V2(ZI)) D  ; IF THE DATE EXISTS
     85        . . S ZP1=$P(V2(ZI),".",1) ; THE DATE PIECE
     86        . . S ZP2=$P(V2(ZI),".",2) ; THE TIME PIECE
     87        . . ; W "DATE: ",ZP1," TIME: ",ZP2,!
     88        . . S VSRT(ZP1,ZP2,ZI)=ZI ; INDEX OF DATE, TIME AND COUNT
     89        N ZG
     90        S ZG=$Q(VSRT(""))
     91        F  D  Q:ZG=""  ;
     92        . ; W ZG,!
     93        . D PUSH^C0CXPATH("V1",@ZG)
     94        . S ZG=$Q(@ZG)
     95        I ORDR=-1 D  ; HAVE TO REVERSE ORDER
     96        . N ZG2
     97        . F ZI=1:1:V1(0) D  ; FOR EACH ELELMENT
     98        . . S ZG2(V1(0)-ZI+1)=V1(ZI) ; SET IN REVERSE ORDER
     99        . S ZG2(0)=V1(0)
     100        . D CP^C0CXPATH("ZG2","V1") ; COPY OVER THE NEW ARRAY
     101        Q ZCNT
     102        ;
     103DA2SNO(RTN,DNAME)       ; LOOK UP DRUG ALLERGY CODE IN ^LEX
     104        ; RETURNS AN ARRAY RTN PASSED BY REFERENCE
     105        ; THIS ROUTINE CAN BE USED AS AN RPC
     106        ; RTN(0) IS THE NUMBER OF ELEMENTS IN THE ARRAY
     107        ; RTN(1) IS THE SNOMED CODE FOR THE DRUG ALLERGY
     108        ;
     109        N LEXIEN
     110        I $O(^LEX(757.21,"ADIS",DNAME,""))'="" D  ; IEN FOUND FOR THIS DRUG
     111        . S LEXIEN=$O(^LEX(757.21,"ADIS",DNAME,"")) ; GET THE IEN IN THE LEXICON
     112        . W LEXIEN,!
     113        . S RTN(1)=$P(^LEX(757.02,LEXIEN,0),"^",2) ; SNOMED CODE IN P2
     114        . S RTN(0)=1 ; ONE THING RETURNED
     115        E  S RTN(0)=0 ; NOT FOUND
     116        Q
     117        ;
     118DASNO(DANAME)   ; PRINTS THE SNOMED CODE FOR ALLERGY TO DRUG DANAME
     119        ;
     120        N DARTN
     121        D DA2SNO(.DARTN,DANAME) ; CALL THE LOOKUP ROUTINE
     122        I DARTN(0)>0 D  ; GOT RESULTS
     123        . W !,DARTN(1) ;PRINT THE SNOMED CODE
     124        E  W !,"NOT FOUND",!
     125        Q
     126        ;
     127DASNALL(WHICH)  ; ROUTINE TO EXAMINE THE ADIS INDEX IN LEX AND RETRIEVE ALL
     128        ; ASSOCIATED SNOMED CODES
     129        N DASTMP,DASIEN,DASNO
     130        S DASTMP=""
     131        F  S DASTMP=$O(^LEX(757.21,WHICH,DASTMP)) Q:DASTMP=""  D  ; NAME OF MED
     132        . S DASIEN=$O(^LEX(757.21,WHICH,DASTMP,"")) ; IEN OF MED
     133        . S DASNO=$P(^LEX(757.02,DASIEN,0),"^",2) ; SNOMED CODE FOR ENTRY
     134        . W DASTMP,"=",DASNO,! ; PRINT IT OUT
     135        Q
     136        ;
     137RXNFN() Q 1130590011.001 ; RxNorm Concepts file number
     138        ;
     139CODE(ZVUID)     ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF
     140        ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR
     141        N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT
     142        I $G(ZVUID)="" Q ""
     143        I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED
     144        N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID")
     145        S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES
     146        N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01)
     147        S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED
     148        I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F"
     149        Q ZRSLT
     150        ;
     151NISTMAP(ZRXN)   ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO
     152        ; CONFORM TO NIST REQUIREMENTS
     153        ;INPATIENT CERTIFICATION
     154        I ZRXN=309362 S ZRXN=213169
     155        I ZRXN=855318 S ZRXN=855320
     156        I ZRXN=197361 S ZRXN=212549
     157        ;OUTPATIENT CERTIFICATION
     158        I ZRXN=310534 S ZRXN=205875
     159        I ZRXN=617312 S ZRXN=617314
     160        I ZRXN=310429 S ZRXN=200801
     161        I ZRXN=628953 S ZRXN=628958
     162        I ZRXN=745679 S ZRXN=630208
     163        I ZRXN=311564 S ZRXN=979334
     164        I ZRXN=836343 S ZRXN=836370
     165        Q ZRXN
     166        ;
     167RPMS()  ; Are we running on an RPMS system rather than Vista?
     168        Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service
     169VISTA() ; Are we running on Vanilla Vista?
     170        Q $G(DUZ("AG"))="V" ; If User Agency is VA
     171WV()    ; Are we running on WorldVista?
     172        Q $G(DUZ("AG"))="E" ; Code for WV.
     173OV()    ; Are we running on OpenVista?
     174        Q $G(DUZ("AG"))="O" ; Code for OpenVista
     175       

  • ccr/branches/ohum/p/C0CVA200.m

    r1342 r1428  
    1 C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008 Sam Habiel.  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  Q
    20  ; This routine uses Kernel APIs and Direct Global Access to get
    21  ; Proivder Data from File 200.
    22  ;
    23   ; The Global is VA(200,*)
    24   ;
    25 FAMILY(DUZ) ; Get Family Name; PUBLIC; EXTRINSIC
    26   ; INPUT: DUZ (i.e. File 200 IEN) ByVal
    27   ; OUTPUT: String
    28   N NAME S NAME=$P(^VA(200,DUZ,0),U)
    29   D NAMECOMP^XLFNAME(.NAME)
    30   Q NAME("FAMILY")
    31   ;
    32 GIVEN(DUZ) ; Get Given Name; PUBLIC; EXTRINSIC
    33   ; INPUT: DUZ ByVal
    34   ; OUTPUT: String
    35   N NAME S NAME=$P(^VA(200,DUZ,0),U)
    36   D NAMECOMP^XLFNAME(.NAME)
    37   Q NAME("GIVEN")
    38   ;
    39 MIDDLE(DUZ) ; Get Middle Name, PUBLIC; EXTRINSIC
    40   ; INPUT: DUZ ByVal
    41   ; OUTPUT: String
    42   N NAME S NAME=$P(^VA(200,DUZ,0),U)
    43   D NAMECOMP^XLFNAME(.NAME)
    44   Q NAME("MIDDLE")
    45   ;
    46 SUFFIX(DUZ) ; Get Suffix Name, PUBLIC; EXTRINSIC
    47   ; INPUT: DUZ ByVal
    48   ; OUTPUT: String
    49   N NAME S NAME=$P(^VA(200,DUZ,0),U)
    50   D NAMECOMP^XLFNAME(.NAME)
    51   Q NAME("SUFFIX")
    52   ;
    53 TITLE(DUZ) ; Get Title for Proivder, PUBLIC; EXTRINSIC
    54   ; INPUT: DUZ ByVal
    55   ; OUTPUT: String
    56   ; Gets External Value of Title field in New Person File.
    57   ; It's actually a pointer to file 3.1
    58   ; 200=New Person File; 8 is Title Field
    59   Q $$GET1^DIQ(200,DUZ_",",8)
    60   ;
    61 NPI(DUZ) ; Get NPI Number, PUBLIC; EXTRINSIC
    62   ; INPUT: DUZ ByVal
    63   ; OUTPUT: Delimited String in format:
    64   ; IDType^ID^IDDescription
    65   ; If the NPI doesn't exist, "" is returned.
    66   ; This routine uses a call documented in the Kernel dev guide
    67   ; This call returns as "NPI^TimeEntered^ActiveInactive"
    68   ; It returns -1 for NPI if NPI doesn't exist.
    69   N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U)
    70   Q:NPI=-1 ""
    71   Q "NPI^"_NPI_"^HHS"
    72   ;
    73 SPEC(DUZ) ; Get Provider Specialty, PUBLIC; EXTRINSIC
    74   ; INPUT: DUZ ByVal
    75   ; OUTPUT: String: ProviderType/Specialty/Subspecialty OR ""
    76   ; Uses a Kernel API. Returns -1 if a specialty is not specified
    77   ; in file 200.
    78   ; Otherwise, returns IEN^Profession^Specialty^Sub­specialty^Effect date^Expired date^VA code
    79   N STR S STR=$$GET^XUA4A72(DUZ)
    80   Q:+STR<0 ""
    81   ; Sometimes we have 3 pieces, or 2. Deal with that.
    82   Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4)
    83   Q $P(STR,U,2)_"-"_$P(STR,U,3)
    84   ;
    85 ADDTYPE(DUZ) ; Get Address Type, PUBLIC; EXTRINSIC
    86   ; INPUT: DUZ, but not needed really... here for future expansion
    87   ; OUTPUT: At this point "Work"
    88   Q "Work"
    89   ;
    90 ADDLINE1(ADUZ) ; Get Address associated with this instituation; PUBLIC; EXTRINSIC ; CHANGED PARAMETER TO ADUZ TO KEEP FROM CRASHING GPL 1/09
    91   ; INPUT: DUZ ByVal
    92   ; Output: String.
    93   ;
    94   ; First, get site number from the institution file.
    95   ; 1st piece returned by $$SITE^VASITE, which gets the system institution
    96   N INST S INST=$P($$SITE^VASITE(),U)
    97   ;
    98   ; Second, get mailing address
    99   ; There are two APIs to get the address, one for physical and one for
    100   ; mailing. We will check if mailing exists first, since that's the
    101   ; one we want to use; then check for physical. If neither exists,
    102   ; then we return nothing. We check for the existence of an address
    103   ; by the length of the returned string.
    104   ; NOTE: API doesn't support Address 2, so I won't even include it
    105   ; in the template.
    106   N ADD
    107   S ADD=$$MADD^XUAF4(INST) ; mailing address
    108   Q:$L(ADD) $P(ADD,U)
    109   S ADD=$$PADD^XUAF4(INST) ; physical address
    110   Q:$L(ADD) $P(ADD,U)
    111   Q ""
    112   ;
    113 CITY(ADUZ) ; Get City for Institution. PUBLIC; EXTRINSIC
    114     ;GPL CHANGED PARAMETER TO ADUZ TO KEEP $$SITE^VASITE FROM CRASHING
    115   ; INPUT: DUZ ByVal
    116   ; Output: String.
    117   ; See ADD1 for comments
    118   N INST S INST=$P($$SITE^VASITE(),U)
    119   N ADD
    120   S ADD=$$MADD^XUAF4(INST) ; mailing address
    121   Q:$L(ADD) $P(ADD,U,2)
    122   S ADD=$$PADD^XUAF4(INST) ; physical address
    123   Q:$L(ADD) $P(ADD,U,2)
    124   Q ""
    125   ;
    126 STATE(ADUZ) ; Get State for Institution. PUBLIC; EXTRINSIC
    127   ; INPUT: DUZ ByVal
    128   ; Output: String.
    129   ; See ADD1 for comments
    130   N INST S INST=$P($$SITE^VASITE(),U)
    131   N ADD
    132   S ADD=$$MADD^XUAF4(INST) ; mailing address
    133   Q:$L(ADD) $P(ADD,U,3)
    134   S ADD=$$PADD^XUAF4(INST) ; physical address
    135   Q:$L(ADD) $P(ADD,U,3)
    136   Q ""
    137   ;
    138 POSTCODE(ADUZ) ; Get Postal Code for Institution. PUBLIC; EXTRINSIC
    139   ; INPUT: DUZ ByVal
    140   ; OUTPUT: String.
    141   ; See ADD1 for comments
    142   N INST S INST=$P($$SITE^VASITE(),U)
    143   N ADD
    144   S ADD=$$MADD^XUAF4(INST) ; mailing address
    145   Q:$L(ADD) $P(ADD,U,4)
    146   S ADD=$$PADD^XUAF4(INST) ; physical address
    147   Q:$L(ADD) $P(ADD,U,4)
    148   Q ""
    149   ;
    150 TEL(DUZ) ; Get Office Phone number. PUBLIC; EXTRINSIC
    151   ; INPUT: DUZ ByVal
    152   ; OUTPUT: String.
    153   ; Direct global access
    154   N TEL S TEL=$G(^VA(200,DUZ,.13))
    155   Q $P(TEL,U,2)
    156   ;
    157 TELTYPE(DUZ) ; Get Telephone Type. PUBLIC; EXTRINSIC
    158   ; INPUT: DUZ ByVal
    159   ; OUTPUT: String.
    160   Q "Office"
    161   ;
    162 EMAIL(DUZ) ; Get Provider's Email. PUBLIC; EXTRINSIC
    163   ; INPUT: DUZ ByVal
    164   ; OUTPUT: String
    165   ; Direct global access
    166   N EMAIL S EMAIL=$G(^VA(200,DUZ,.15))
    167   Q $P(EMAIL,U)
    168   ;
     1C0CVA200        ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008 Sam Habiel.  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        Q
     20        ; This routine uses Kernel APIs and Direct Global Access to get
     21        ; Proivder Data from File 200.
     22        ;
     23        ; The Global is VA(200,*)
     24        ;
     25FAMILY(DUZ)     ; Get Family Name; PUBLIC; EXTRINSIC
     26        ; INPUT: DUZ (i.e. File 200 IEN) ByVal
     27        ; OUTPUT: String
     28        N NAME S NAME=$P(^VA(200,DUZ,0),U)
     29        D NAMECOMP^XLFNAME(.NAME)
     30        Q NAME("FAMILY")
     31        ;
     32GIVEN(DUZ)      ; Get Given Name; PUBLIC; EXTRINSIC
     33        ; INPUT: DUZ ByVal
     34        ; OUTPUT: String
     35        N NAME S NAME=$P(^VA(200,DUZ,0),U)
     36        D NAMECOMP^XLFNAME(.NAME)
     37        Q NAME("GIVEN")
     38        ;
     39MIDDLE(DUZ)     ; Get Middle Name, PUBLIC; EXTRINSIC
     40        ; INPUT: DUZ ByVal
     41        ; OUTPUT: String
     42        N NAME S NAME=$P(^VA(200,DUZ,0),U)
     43        D NAMECOMP^XLFNAME(.NAME)
     44        Q NAME("MIDDLE")
     45        ;
     46SUFFIX(DUZ)     ; Get Suffix Name, PUBLIC; EXTRINSIC
     47        ; INPUT: DUZ ByVal
     48        ; OUTPUT: String
     49        N NAME S NAME=$P(^VA(200,DUZ,0),U)
     50        D NAMECOMP^XLFNAME(.NAME)
     51        Q NAME("SUFFIX")
     52        ;
     53TITLE(DUZ)      ; Get Title for Proivder, PUBLIC; EXTRINSIC
     54        ; INPUT: DUZ ByVal
     55        ; OUTPUT: String
     56        ; Gets External Value of Title field in New Person File.
     57        ; It's actually a pointer to file 3.1
     58        ; 200=New Person File; 8 is Title Field
     59        Q $$GET1^DIQ(200,DUZ_",",8)
     60        ;
     61NPI(DUZ)        ; Get NPI Number, PUBLIC; EXTRINSIC
     62        ; INPUT: DUZ ByVal
     63        ; OUTPUT: Delimited String in format:
     64        ; IDType^ID^IDDescription
     65        ; If the NPI doesn't exist, "" is returned.
     66        ; This routine uses a call documented in the Kernel dev guide
     67        ; This call returns as "NPI^TimeEntered^ActiveInactive"
     68        ; It returns -1 for NPI if NPI doesn't exist.
     69        N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U)
     70        Q:NPI=-1 ""
     71        Q "NPI^"_NPI_"^HHS"
     72        ;
     73SPEC(DUZ)       ; Get Provider Specialty, PUBLIC; EXTRINSIC
     74        ; INPUT: DUZ ByVal
     75        ; OUTPUT: String: ProviderType/Specialty/Subspecialty OR ""
     76        ; Uses a Kernel API. Returns -1 if a specialty is not specified
     77        ; in file 200.
     78        ; Otherwise, returns IEN^Profession^Specialty^Sub­specialty^Effect date^Expired date^VA code
     79        N STR S STR=$$GET^XUA4A72(DUZ)
     80        Q:+STR<0 ""
     81        ; Sometimes we have 3 pieces, or 2. Deal with that.
     82        Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4)
     83        Q $P(STR,U,2)_"-"_$P(STR,U,3)
     84        ;
     85ADDTYPE(DUZ)    ; Get Address Type, PUBLIC; EXTRINSIC
     86        ; INPUT: DUZ, but not needed really... here for future expansion
     87        ; OUTPUT: At this point "Work"
     88        Q "Work"
     89        ;
     90ADDLINE1(ADUZ)  ; Get Address associated with this instituation; PUBLIC; EXTRINSIC ; CHANGED PARAMETER TO ADUZ TO KEEP FROM CRASHING GPL 1/09
     91        ; INPUT: DUZ ByVal
     92        ; Output: String.
     93        ;
     94        ; First, get site number from the institution file.
     95        ; 1st piece returned by $$SITE^VASITE, which gets the system institution
     96        N INST S INST=$P($$SITE^VASITE(),U)
     97        ;
     98        ; Second, get mailing address
     99        ; There are two APIs to get the address, one for physical and one for
     100        ; mailing. We will check if mailing exists first, since that's the
     101        ; one we want to use; then check for physical. If neither exists,
     102        ; then we return nothing. We check for the existence of an address
     103        ; by the length of the returned string.
     104        ; NOTE: API doesn't support Address 2, so I won't even include it
     105        ; in the template.
     106        N ADD
     107        S ADD=$$MADD^XUAF4(INST) ; mailing address
     108        Q:$L(ADD) $P(ADD,U)
     109        S ADD=$$PADD^XUAF4(INST) ; physical address
     110        Q:$L(ADD) $P(ADD,U)
     111        Q ""
     112        ;
     113CITY(ADUZ)      ; Get City for Institution. PUBLIC; EXTRINSIC
     114           ;GPL CHANGED PARAMETER TO ADUZ TO KEEP $$SITE^VASITE FROM CRASHING
     115        ; INPUT: DUZ ByVal
     116        ; Output: String.
     117        ; See ADD1 for comments
     118        N INST S INST=$P($$SITE^VASITE(),U)
     119        N ADD
     120        S ADD=$$MADD^XUAF4(INST) ; mailing address
     121        Q:$L(ADD) $P(ADD,U,2)
     122        S ADD=$$PADD^XUAF4(INST) ; physical address
     123        Q:$L(ADD) $P(ADD,U,2)
     124        Q ""
     125        ;
     126STATE(ADUZ)     ; Get State for Institution. PUBLIC; EXTRINSIC
     127        ; INPUT: DUZ ByVal
     128        ; Output: String.
     129        ; See ADD1 for comments
     130        N INST S INST=$P($$SITE^VASITE(),U)
     131        N ADD
     132        S ADD=$$MADD^XUAF4(INST) ; mailing address
     133        Q:$L(ADD) $P(ADD,U,3)
     134        S ADD=$$PADD^XUAF4(INST) ; physical address
     135        Q:$L(ADD) $P(ADD,U,3)
     136        Q ""
     137        ;
     138POSTCODE(ADUZ)  ; Get Postal Code for Institution. PUBLIC; EXTRINSIC
     139        ; INPUT: DUZ ByVal
     140        ; OUTPUT: String.
     141        ; See ADD1 for comments
     142        N INST S INST=$P($$SITE^VASITE(),U)
     143        N ADD
     144        S ADD=$$MADD^XUAF4(INST) ; mailing address
     145        Q:$L(ADD) $P(ADD,U,4)
     146        S ADD=$$PADD^XUAF4(INST) ; physical address
     147        Q:$L(ADD) $P(ADD,U,4)
     148        Q ""
     149        ;
     150TEL(DUZ)        ; Get Office Phone number. PUBLIC; EXTRINSIC
     151        ; INPUT: DUZ ByVal
     152        ; OUTPUT: String.
     153        ; Direct global access
     154        N TEL S TEL=$G(^VA(200,DUZ,.13))
     155        Q $P(TEL,U,2)
     156        ;
     157TELTYPE(DUZ)    ; Get Telephone Type. PUBLIC; EXTRINSIC
     158        ; INPUT: DUZ ByVal
     159        ; OUTPUT: String.
     160        Q "Office"
     161        ;
     162EMAIL(DUZ)      ; Get Provider's Email. PUBLIC; EXTRINSIC
     163        ; INPUT: DUZ ByVal
     164        ; OUTPUT: String
     165        ; Direct global access
     166        N EMAIL S EMAIL=$G(^VA(200,DUZ,.15))
     167        Q $P(EMAIL,U)
     168        ;

  • ccr/branches/ohum/p/C0CVIT2.m

    r1342 r1428  
    1 C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
    2  ;;1.0;C0C;;Feb 16, 2010;Build 2
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  W "NO ENTRY FROM TOP",!
    22  Q
    23  ;
    24 EXTRACT(VITXML,DFN,VITOUT) ; EXTRACT VITAL SIGNS INTO XML TEMPLATE
    25  ; VITXML AND VITOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
    26  ;
    27  ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS
    28  ; THAT GET PASSED TO *GET ROUTINES
    29  ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME))
    30  N C0CVIT
    31  S C0CVIT=$NA(^TMP("C0CCCR",$J,DFN,"C0CVIT"))
    32  ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS
    33  ; THAT GET INSERTED INTO THE XML TEMPLATE
    34  ; D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS
    35  I $$RPMS^C0CUTIL() D GETRPMS(DFN,C0CVIT) ; GET VARS
    36  I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D GETVISTA(DFN,C0CVIT)
    37  ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE
    38  ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES
    39  D MAP(VITXML,C0CVIT,VITOUT) ;MAP RESULTS FOR PROCEDURES
    40  Q
    41  ;
    42 GETVISTA(DFN,C0CVIT) ; CALLS VITALS^ORQQVI TO GET VITAL SIGNS.
    43  ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
    44  ; C0CVIT: VITAL SIGNS
    45  ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2
    46  ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY
    47  ; EXIST.
    48  ;
    49  ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J))
    50  ;
    51  ; SETUP RPC/API CALL HERE
    52  ; USE START AND END DATES FROM PARAMETERS IF REQUIRED
    53  ;
    54  N VIT,DATA,START,END
    55  ; RPC REQUIRES FM DATES NOT T-* DATES
    56  D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM
    57  D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM
    58  ; RPC CALL (ORY,DFN,ORSDT,OREDT):
    59  ;ORY: return variable
    60  ;DFN: patient identifier from Patient File [#2]
    61  ;ORSDT: start date/time in Fileman format
    62  ;OREDT: end date/time in Fileman format
    63  ; OUTPUT FORMAT:
    64  ;vital measurement ien^vital type^rate^date/time taken
    65  D VITALS^ORQQVI(.VIT,DFN,START,END) ; RUN QUERY VITALS CALL
    66  I '$D(VIT) S @VITOUT@(0)=0 K VIT Q  ; RETURN NOT FOUND, KILL ARRAY AND QUIT
    67  I $P(VIT(1),U,2)="No vitals found." D  Q  ; signal no vitals and quit
    68  . I $D(VITOUT) S @VITOUT@(0)=0
    69  . K VIT
    70  ;
    71  ; PREFORM SORT HERE IF NEEDED
    72  ;
    73  ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST
    74  ; COPIED SORT LOGIC:
    75  N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
    76  D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
    77  S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
    78  ; VSORT IS VITALS IN REVERSE ORDER
    79  ;
    80  ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY
    81  ; RNF1 ARRAY FORMAT:
    82  ; VAR("NAME_OF_RIM_VARIABLE")=VALUE
    83  ;
    84  ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS
    85  ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD
    86  ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS
    87  N C0CVI,C0CC,ZRNF
    88  ;S C0CVI="" ; INITIALIZE FOR $O
    89  F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D  ; FOR EACH VITAL SIGN IN THE LIST
    90  . I DEBUG W VIT(C0CVI),!
    91  . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER)
    92  . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"in")
    93  . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"lbs")
    94  . D:$P(VIT(C0CVI),U,3)="BP" BP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"")
    95  . D:$P(VIT(C0CVI),U,3)="T" TMP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"F")
    96  . D:$P(VIT(C0CVI),U,3)="R" RESP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"")
    97  . D:$P(VIT(C0CVI),U,3)="P" PULSE1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"")
    98  . D:$P(VIT(C0CVI),U,3)="PN" PAIN1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"")
    99  . D:'$D(ZRNF) OTHER1($$FMDTOUTC^C0CUTIL($P(C0CVI,U,4),"DT"),"OTHER VITAL",$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"UNKNOWN") ;IF THE VITAL ISN'T DEFINED IT IS OTHER
    100  . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY
    101  . K ZRNF
    102  ; SAVE RIM VARIABLES SEE C0CRIMA
    103  N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS"))
    104  M @ZRIM=@C0CVIT@("V")
    105  Q
    106  ;
    107 GETRPMS(DFN,C0CVIT) ; CALLS QUERY^BEHOVM TO GET VITAL SIGNS.
    108  ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
    109  ; C0CVIT: VITAL SIGNS
    110  ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2
    111  ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY
    112  ; EXIST.
    113  ;
    114  ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J))
    115  ;
    116  ; SETUP RPC/API CALL HERE
    117  ; USE START AND END DATES FROM PARAMETERS IF REQUIRED
    118  ;
    119  ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE
    120  ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE
    121  N C0CEDT,C0CSDT,VIT,DATA,START,END
    122  ; RPC REQUIRES FM DATES NOT T-* DATES
    123  D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM
    124  D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM
    125  ; RPC OUTPUT FORMAT:
    126  ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric)
    127  D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL
    128  I '$D(^TMP("CIAVMRPC",$J)) S @VITOUT@(0)=0 K ^TMP("CIAVMRPC",$J) Q  ; RETURN NOT FOUND, KILL ARRAY AND QUIT
    129  ; MOVE THE ARRAY TO LOCAL VARIABLE
    130  M VIT=^TMP("CIAVMRPC",$J,0)
    131  ; RPC CLEANUP
    132  K ^TMP("CIAVMRPC",$J),VITS,RMAX,START,END,DATA,METRIC,VSTR,VUNT
    133  ;
    134  ; PREFORM SORT HERE IF NEEDED
    135  ;
    136  ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST
    137  ; COPIED SORT LOGIC:
    138  N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
    139  D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
    140  S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
    141  ; VSORT IS VITALS IN REVERSE ORDER
    142  ;
    143  ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY
    144  ; RNF1 ARRAY FORMAT:
    145  ; VAR("NAME_OF_RIM_VARIABLE")=VALUE
    146  ;
    147  ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS
    148  ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD
    149  ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS
    150  N C0CVI,C0CC,ZRNF
    151  ;S C0CVI="" ; INITIALIZE FOR $O
    152  F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D  ; FOR EACH VITAL SIGN IN THE LIST
    153  . I DEBUG W VIT(C0CVI),!
    154  . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER)
    155  . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT
    156  . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT
    157  . D:$P(VIT(C0CVI),U,3)="BP" BP
    158  . D:$P(VIT(C0CVI),U,3)="TMP" TMP
    159  . D:$P(VIT(C0CVI),U,3)="RS" RESP
    160  . D:$P(VIT(C0CVI),U,3)="PU" PULSE
    161  . D:$P(VIT(C0CVI),U,3)="PA" PAIN
    162  . D:'$D(ZRNF) OTHER ;IF THE VITAL ISN'T DEFINED IT IS OTHER
    163  . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY
    164  . K ZRNF
    165  ; SAVE RIM VARIABLES SEE C0CRIMA
    166  N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS"))
    167  M @ZRIM=@C0CVIT@("V")
    168  Q
    169  ;
    170 HEIGHT 
    171  I DEBUG W "IN VITAL:  HEIGHT",!
    172  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID
    173  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    174  S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
    175  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
    176  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    177  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    178  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    179  S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008"
    180  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    181  S ZRNF("VITALSIGNSCODEVERSION")=""
    182  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
    183  S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
    184  S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
    185  Q
    186  ;
    187 WEIGHT 
    188  I DEBUG W "IN VITAL:  WEIGHT",!
    189  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    190  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    191  S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
    192  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
    193  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    194  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    195  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    196  S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005"
    197  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    198  S ZRNF("VITALSIGNSCODEVERSION")=""
    199  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
    200  S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
    201  S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
    202  Q
    203  ;
    204 BP 
    205  I DEBUG W "IN VITAL:  BLOOD PRESSURE",!
    206  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    207  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    208  S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
    209  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
    210  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    211  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    212  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    213  S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002"
    214  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    215  S ZRNF("VITALSIGNSCODEVERSION")=""
    216  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
    217  S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
    218  S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
    219  Q
    220  ;
    221 TMP 
    222  I DEBUG W "IN VITAL:  TEMPERATURE",!
    223  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    224  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    225  S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
    226  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
    227  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    228  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    229  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    230  S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008"
    231  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    232  S ZRNF("VITALSIGNSCODEVERSION")=""
    233  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
    234  S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
    235  S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
    236  Q
    237  ;
    238 RESP 
    239  I DEBUG W "IN VITAL:  RESPIRATION",!
    240  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    241  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    242  S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
    243  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
    244  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    245  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    246  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    247  S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009"
    248  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    249  S ZRNF("VITALSIGNSCODEVERSION")=""
    250  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
    251  S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
    252  S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
    253  Q
    254  ;
    255 PULSE 
    256  I DEBUG W "IN VITAL:  PULSE",!
    257  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    258  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    259  S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
    260  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
    261  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    262  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    263  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    264  S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006"
    265  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    266  S ZRNF("VITALSIGNSCODEVERSION")=""
    267  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
    268  S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
    269  S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
    270  Q
    271  ;
    272 PAIN 
    273  I DEBUG W "IN VITAL:  PAIN",!
    274  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    275  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    276  S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
    277  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
    278  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    279  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    280  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    281  S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000"
    282  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    283  S ZRNF("VITALSIGNSCODEVERSION")=""
    284  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
    285  S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
    286  S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
    287  Q
    288  ;
    289 OTHER 
    290  I DEBUG W "IN VITAL:  OTHER",!
    291  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    292  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    293  S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
    294  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=$P(VIT(C0CVI),U,2)
    295  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    296  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    297  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    298  S ZRNF("VITALSIGNSDESCCODEVALUE")=""
    299  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")=""
    300  S ZRNF("VITALSIGNSCODEVERSION")=""
    301  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
    302  S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
    303  S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
    304  Q
    305  ;
    306  ;TEMPORARY, THINKING ON HOW TO REFACTOR (CJE)
    307 HEIGHT1(DT,ACTOR,VALUE,UNIT) 
    308  I DEBUG W "IN VITAL:  HEIGHT",!
    309  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID
    310  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    311  S ZRNF("VITALSIGNSEXACTDATETIME")=DT
    312  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
    313  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    314  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    315  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    316  S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008"
    317  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    318  S ZRNF("VITALSIGNSCODEVERSION")=""
    319  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
    320  S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
    321  S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
    322  Q
    323  ;
    324 WEIGHT1(DT,ACTOR,VALUE,UNIT) 
    325  I DEBUG W "IN VITAL:  WEIGHT",!
    326  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    327  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    328  S ZRNF("VITALSIGNSEXACTDATETIME")=DT
    329  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
    330  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    331  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    332  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    333  S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005"
    334  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    335  S ZRNF("VITALSIGNSCODEVERSION")=""
    336  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
    337  S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
    338  S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
    339  Q
    340  ;
    341 BP1(DT,ACTOR,VALUE,UNIT) 
    342  I DEBUG W "IN VITAL:  BLOOD PRESSURE",!
    343  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    344  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    345  S ZRNF("VITALSIGNSEXACTDATETIME")=DT
    346  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
    347  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    348  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    349  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    350  S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002"
    351  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    352  S ZRNF("VITALSIGNSCODEVERSION")=""
    353  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
    354  S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
    355  S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
    356  Q
    357  ;
    358 TMP1(DT,ACTOR,VALUE,UNIT) 
    359  I DEBUG W "IN VITAL:  TEMPERATURE",!
    360  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    361  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    362  S ZRNF("VITALSIGNSEXACTDATETIME")=DT
    363  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
    364  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    365  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    366  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    367  S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008"
    368  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    369  S ZRNF("VITALSIGNSCODEVERSION")=""
    370  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
    371  S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
    372  S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
    373  Q
    374  ;
    375 RESP1(DT,ACTOR,VALUE,UNIT) 
    376  I DEBUG W "IN VITAL:  RESPIRATION",!
    377  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    378  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    379  S ZRNF("VITALSIGNSEXACTDATETIME")=DT
    380  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
    381  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    382  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    383  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    384  S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009"
    385  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    386  S ZRNF("VITALSIGNSCODEVERSION")=""
    387  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
    388  S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
    389  S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
    390  Q
    391  ;
    392 PULSE1(DT,ACTOR,VALUE,UNIT) 
    393  I DEBUG W "IN VITAL:  PULSE",!
    394  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    395  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    396  S ZRNF("VITALSIGNSEXACTDATETIME")=DT
    397  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
    398  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    399  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    400  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    401  S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006"
    402  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    403  S ZRNF("VITALSIGNSCODEVERSION")=""
    404  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
    405  S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
    406  S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
    407  Q
    408  ;
    409 PAIN1(DT,ACTOR,VALUE,UNIT) 
    410  I DEBUG W "IN VITAL:  PAIN",!
    411  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    412  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    413  S ZRNF("VITALSIGNSEXACTDATETIME")=DT
    414  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
    415  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    416  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    417  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    418  S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000"
    419  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    420  S ZRNF("VITALSIGNSCODEVERSION")=""
    421  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
    422  S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
    423  S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
    424  Q
    425  ;
    426 OTHER1(DT,TEXT,ACTOR,VALUE,UNIT) 
    427  I DEBUG W "IN VITAL:  OTHER",!
    428  S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
    429  S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    430  S ZRNF("VITALSIGNSEXACTDATETIME")=DT
    431  S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=TEXT
    432  S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    433  S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
    434  S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    435  S ZRNF("VITALSIGNSDESCCODEVALUE")=""
    436  S ZRNF("VITALSIGNSDESCCODINGSYSTEM")=""
    437  S ZRNF("VITALSIGNSCODEVERSION")=""
    438  S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
    439  S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
    440  S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
    441  Q
    442  ;
    443 VITSORT(VDT) ; RUN DATE SORTING ALGORITHM
    444  ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY
    445  ; OF DATES IN THE VITALS RESULTS
    446  N VDTI,VDTJ,VTDCNT
    447  S VTDCNT=0 ; COUNT TO BUILD ARRAY
    448  S VDTJ="" ; USED TO VISIT THE RESULTS
    449  F VDTI=0:0 D  Q:$O(VIT(VDTJ))=""  ; VISIT ALL RESULTS
    450  . S VDTJ=$O(VIT(VDTJ)) ; NEXT RESULT
    451  . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER
    452  . S VDT(VTDCNT)=$P(VIT(VDTJ),U,4) ; PULL OUT THE DATE
    453  S VDT(0)=VTDCNT
    454  Q
    455  ;
    456 MAP(VITXML,C0CVIT,VITOUT) ; MAP VITAL SIGNS XML
    457  ;
    458  N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"VITTEMP")) ;WORK AREA FOR TEMPLATE
    459  K @ZTEMP
    460  N ZBLD
    461  S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"VITBLD")) ; BUILD LIST AREA
    462  D QUEUE^C0CXPATH(ZBLD,VITXML,1,1) ; FIRST LINE
    463  N ZINNER
    464  ; XPATH NEEDS TO MATCH YOUR SECTION
    465  D QUERY^C0CXPATH(VITXML,"//VitalSigns/Result","ZINNER") ;ONE VITAL SIGN
    466  N ZTMP,ZVAR,ZI
    467  S ZI=""
    468  F  S ZI=$O(@C0CVIT@("V",ZI)) Q:ZI=""  D  ;FOR EACH VITAL SIGN
    469  . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS VITAL SIGN XML
    470  . S ZVAR=$NA(@C0CVIT@("V",ZI)) ;THIS VITAL SIGN VARIABLES
    471  . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE VITAL SIGN
    472  . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD
    473  D QUEUE^C0CXPATH(ZBLD,VITXML,@VITXML@(0),@VITXML@(0))
    474  N ZZTMP ; IS THIS NEEDED?
    475  D BUILD^C0CXPATH(ZBLD,VITOUT) ;BUILD FINAL XML
    476  K @ZTEMP,@ZBLD
    477  Q
    478  ; 
     1C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        W "NO ENTRY FROM TOP",!
     22        Q
     23        ;
     24EXTRACT(VITXML,DFN,VITOUT)      ; EXTRACT VITAL SIGNS INTO XML TEMPLATE
     25        ; VITXML AND VITOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
     26        ;
     27        ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS
     28        ; THAT GET PASSED TO *GET ROUTINES
     29        ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME))
     30        N C0CVIT
     31        S C0CVIT=$NA(^TMP("C0CCCR",$J,DFN,"C0CVIT"))
     32        ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS
     33        ; THAT GET INSERTED INTO THE XML TEMPLATE
     34        ; D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS
     35        I $$RPMS^C0CUTIL() D GETRPMS(DFN,C0CVIT) ; GET VARS
     36        I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D GETVISTA(DFN,C0CVIT)
     37        ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE
     38        ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES
     39        D MAP(VITXML,C0CVIT,VITOUT) ;MAP RESULTS FOR PROCEDURES
     40        Q
     41        ;
     42GETVISTA(DFN,C0CVIT)    ; CALLS VITALS^ORQQVI TO GET VITAL SIGNS.
     43        ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
     44        ; C0CVIT: VITAL SIGNS
     45        ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2
     46        ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY
     47        ; EXIST.
     48        ;
     49        ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J))
     50        ;
     51        ; SETUP RPC/API CALL HERE
     52        ; USE START AND END DATES FROM PARAMETERS IF REQUIRED
     53        ;
     54        N VIT,DATA,START,END
     55        ; RPC REQUIRES FM DATES NOT T-* DATES
     56        D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM
     57        D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM
     58        ; RPC CALL (ORY,DFN,ORSDT,OREDT):
     59        ;ORY: return variable
     60        ;DFN: patient identifier from Patient File [#2]
     61        ;ORSDT: start date/time in Fileman format
     62        ;OREDT: end date/time in Fileman format
     63        ; OUTPUT FORMAT:
     64        ;vital measurement ien^vital type^rate^date/time taken
     65        D VITALS^ORQQVI(.VIT,DFN,START,END) ; RUN QUERY VITALS CALL
     66        I '$D(VIT) S @VITOUT@(0)=0 K VIT Q  ; RETURN NOT FOUND, KILL ARRAY AND QUIT
     67        I $P(VIT(1),U,2)="No vitals found." D  Q  ; signal no vitals and quit
     68        . I $D(VITOUT) S @VITOUT@(0)=0
     69        . K VIT
     70        ;
     71        ; PREFORM SORT HERE IF NEEDED
     72        ;
     73        ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST
     74        ; COPIED SORT LOGIC:
     75        N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
     76        D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
     77        S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
     78        ; VSORT IS VITALS IN REVERSE ORDER
     79        ;
     80        ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY
     81        ; RNF1 ARRAY FORMAT:
     82        ; VAR("NAME_OF_RIM_VARIABLE")=VALUE
     83        ;
     84        ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS
     85        ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD
     86        ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS
     87        N C0CVI,C0CC,ZRNF
     88        ;S C0CVI="" ; INITIALIZE FOR $O
     89        F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D  ; FOR EACH VITAL SIGN IN THE LIST
     90        . I DEBUG W VIT(C0CVI),!
     91        . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER)
     92        . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"in")
     93        . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"lbs")
     94        . D:$P(VIT(C0CVI),U,3)="BP" BP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"")
     95        . D:$P(VIT(C0CVI),U,3)="T" TMP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"F")
     96        . D:$P(VIT(C0CVI),U,3)="R" RESP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"")
     97        . D:$P(VIT(C0CVI),U,3)="P" PULSE1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"")
     98        . D:$P(VIT(C0CVI),U,3)="PN" PAIN1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"")
     99        . D:'$D(ZRNF) OTHER1($$FMDTOUTC^C0CUTIL($P(C0CVI,U,4),"DT"),"OTHER VITAL",$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"UNKNOWN") ;IF THE VITAL ISN'T DEFINED IT IS OTHER
     100        . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY
     101        . K ZRNF
     102        ; SAVE RIM VARIABLES SEE C0CRIMA
     103        N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS"))
     104        M @ZRIM=@C0CVIT@("V")
     105        Q
     106        ;
     107GETRPMS(DFN,C0CVIT)     ; CALLS QUERY^BEHOVM TO GET VITAL SIGNS.
     108        ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
     109        ; C0CVIT: VITAL SIGNS
     110        ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2
     111        ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY
     112        ; EXIST.
     113        ;
     114        ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J))
     115        ;
     116        ; SETUP RPC/API CALL HERE
     117        ; USE START AND END DATES FROM PARAMETERS IF REQUIRED
     118        ;
     119        ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE
     120        ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE
     121        N C0CEDT,C0CSDT,VIT,DATA,START,END
     122        ; RPC REQUIRES FM DATES NOT T-* DATES
     123        D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM
     124        D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM
     125        ; RPC OUTPUT FORMAT:
     126        ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric)
     127        D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL
     128        I '$D(^TMP("CIAVMRPC",$J)) S @VITOUT@(0)=0 K ^TMP("CIAVMRPC",$J) Q  ; RETURN NOT FOUND, KILL ARRAY AND QUIT
     129        ; MOVE THE ARRAY TO LOCAL VARIABLE
     130        M VIT=^TMP("CIAVMRPC",$J,0)
     131        ; RPC CLEANUP
     132        K ^TMP("CIAVMRPC",$J),VITS,RMAX,START,END,DATA,METRIC,VSTR,VUNT
     133        ;
     134        ; PREFORM SORT HERE IF NEEDED
     135        ;
     136        ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST
     137        ; COPIED SORT LOGIC:
     138        N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
     139        D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
     140        S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
     141        ; VSORT IS VITALS IN REVERSE ORDER
     142        ;
     143        ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY
     144        ; RNF1 ARRAY FORMAT:
     145        ; VAR("NAME_OF_RIM_VARIABLE")=VALUE
     146        ;
     147        ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS
     148        ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD
     149        ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS
     150        N C0CVI,C0CC,ZRNF
     151        ;S C0CVI="" ; INITIALIZE FOR $O
     152        F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D  ; FOR EACH VITAL SIGN IN THE LIST
     153        . I DEBUG W VIT(C0CVI),!
     154        . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER)
     155        . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT
     156        . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT
     157        . D:$P(VIT(C0CVI),U,3)="BP" BP
     158        . D:$P(VIT(C0CVI),U,3)="TMP" TMP
     159        . D:$P(VIT(C0CVI),U,3)="RS" RESP
     160        . D:$P(VIT(C0CVI),U,3)="PU" PULSE
     161        . D:$P(VIT(C0CVI),U,3)="PA" PAIN
     162        . D:'$D(ZRNF) OTHER ;IF THE VITAL ISN'T DEFINED IT IS OTHER
     163        . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY
     164        . K ZRNF
     165        ; SAVE RIM VARIABLES SEE C0CRIMA
     166        N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS"))
     167        M @ZRIM=@C0CVIT@("V")
     168        Q
     169        ;
     170HEIGHT 
     171        I DEBUG W "IN VITAL:  HEIGHT",!
     172        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID
     173        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     174        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
     175        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
     176        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     177        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     178        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     179        S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008"
     180        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     181        S ZRNF("VITALSIGNSCODEVERSION")=""
     182        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
     183        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
     184        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
     185        Q
     186        ;
     187WEIGHT 
     188        I DEBUG W "IN VITAL:  WEIGHT",!
     189        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     190        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     191        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
     192        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
     193        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     194        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     195        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     196        S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005"
     197        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     198        S ZRNF("VITALSIGNSCODEVERSION")=""
     199        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
     200        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
     201        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
     202        Q
     203        ;
     204BP     
     205        I DEBUG W "IN VITAL:  BLOOD PRESSURE",!
     206        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     207        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     208        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
     209        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
     210        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     211        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     212        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     213        S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002"
     214        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     215        S ZRNF("VITALSIGNSCODEVERSION")=""
     216        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
     217        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
     218        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
     219        Q
     220        ;
     221TMP     
     222        I DEBUG W "IN VITAL:  TEMPERATURE",!
     223        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     224        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     225        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
     226        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
     227        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     228        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     229        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     230        S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008"
     231        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     232        S ZRNF("VITALSIGNSCODEVERSION")=""
     233        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
     234        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
     235        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
     236        Q
     237        ;
     238RESP   
     239        I DEBUG W "IN VITAL:  RESPIRATION",!
     240        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     241        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     242        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
     243        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
     244        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     245        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     246        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     247        S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009"
     248        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     249        S ZRNF("VITALSIGNSCODEVERSION")=""
     250        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
     251        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
     252        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
     253        Q
     254        ;
     255PULSE   
     256        I DEBUG W "IN VITAL:  PULSE",!
     257        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     258        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     259        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
     260        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
     261        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     262        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     263        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     264        S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006"
     265        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     266        S ZRNF("VITALSIGNSCODEVERSION")=""
     267        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
     268        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
     269        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
     270        Q
     271        ;
     272PAIN   
     273        I DEBUG W "IN VITAL:  PAIN",!
     274        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     275        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     276        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
     277        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
     278        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     279        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     280        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     281        S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000"
     282        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     283        S ZRNF("VITALSIGNSCODEVERSION")=""
     284        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
     285        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
     286        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
     287        Q
     288        ;
     289OTHER   
     290        I DEBUG W "IN VITAL:  OTHER",!
     291        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     292        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     293        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
     294        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=$P(VIT(C0CVI),U,2)
     295        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     296        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     297        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     298        S ZRNF("VITALSIGNSDESCCODEVALUE")=""
     299        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")=""
     300        S ZRNF("VITALSIGNSCODEVERSION")=""
     301        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
     302        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
     303        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
     304        Q
     305        ;
     306        ;TEMPORARY, THINKING ON HOW TO REFACTOR (CJE)
     307HEIGHT1(DT,ACTOR,VALUE,UNIT)   
     308        I DEBUG W "IN VITAL:  HEIGHT",!
     309        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID
     310        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     311        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
     312        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
     313        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     314        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     315        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     316        S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008"
     317        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     318        S ZRNF("VITALSIGNSCODEVERSION")=""
     319        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
     320        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
     321        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
     322        Q
     323        ;
     324WEIGHT1(DT,ACTOR,VALUE,UNIT)   
     325        I DEBUG W "IN VITAL:  WEIGHT",!
     326        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     327        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     328        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
     329        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
     330        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     331        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     332        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     333        S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005"
     334        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     335        S ZRNF("VITALSIGNSCODEVERSION")=""
     336        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
     337        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
     338        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
     339        Q
     340        ;
     341BP1(DT,ACTOR,VALUE,UNIT)       
     342        I DEBUG W "IN VITAL:  BLOOD PRESSURE",!
     343        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     344        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     345        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
     346        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
     347        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     348        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     349        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     350        S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002"
     351        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     352        S ZRNF("VITALSIGNSCODEVERSION")=""
     353        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
     354        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
     355        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
     356        Q
     357        ;
     358TMP1(DT,ACTOR,VALUE,UNIT)       
     359        I DEBUG W "IN VITAL:  TEMPERATURE",!
     360        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     361        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     362        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
     363        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
     364        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     365        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     366        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     367        S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008"
     368        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     369        S ZRNF("VITALSIGNSCODEVERSION")=""
     370        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
     371        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
     372        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
     373        Q
     374        ;
     375RESP1(DT,ACTOR,VALUE,UNIT)     
     376        I DEBUG W "IN VITAL:  RESPIRATION",!
     377        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     378        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     379        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
     380        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
     381        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     382        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     383        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     384        S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009"
     385        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     386        S ZRNF("VITALSIGNSCODEVERSION")=""
     387        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
     388        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
     389        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
     390        Q
     391        ;
     392PULSE1(DT,ACTOR,VALUE,UNIT)     
     393        I DEBUG W "IN VITAL:  PULSE",!
     394        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     395        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     396        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
     397        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
     398        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     399        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     400        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     401        S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006"
     402        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     403        S ZRNF("VITALSIGNSCODEVERSION")=""
     404        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
     405        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
     406        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
     407        Q
     408        ;
     409PAIN1(DT,ACTOR,VALUE,UNIT)     
     410        I DEBUG W "IN VITAL:  PAIN",!
     411        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     412        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     413        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
     414        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
     415        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     416        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     417        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     418        S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000"
     419        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     420        S ZRNF("VITALSIGNSCODEVERSION")=""
     421        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
     422        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
     423        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
     424        Q
     425        ;
     426OTHER1(DT,TEXT,ACTOR,VALUE,UNIT)       
     427        I DEBUG W "IN VITAL:  OTHER",!
     428        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
     429        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     430        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
     431        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=TEXT
     432        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     433        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
     434        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     435        S ZRNF("VITALSIGNSDESCCODEVALUE")=""
     436        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")=""
     437        S ZRNF("VITALSIGNSCODEVERSION")=""
     438        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
     439        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
     440        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
     441        Q
     442        ;
     443VITSORT(VDT)    ; RUN DATE SORTING ALGORITHM
     444        ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY
     445        ; OF DATES IN THE VITALS RESULTS
     446        N VDTI,VDTJ,VTDCNT
     447        S VTDCNT=0 ; COUNT TO BUILD ARRAY
     448        S VDTJ="" ; USED TO VISIT THE RESULTS
     449        F VDTI=0:0 D  Q:$O(VIT(VDTJ))=""  ; VISIT ALL RESULTS
     450        . S VDTJ=$O(VIT(VDTJ)) ; NEXT RESULT
     451        . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER
     452        . S VDT(VTDCNT)=$P(VIT(VDTJ),U,4) ; PULL OUT THE DATE
     453        S VDT(0)=VTDCNT
     454        Q
     455        ;
     456MAP(VITXML,C0CVIT,VITOUT)       ; MAP VITAL SIGNS XML
     457        ;
     458        N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"VITTEMP")) ;WORK AREA FOR TEMPLATE
     459        K @ZTEMP
     460        N ZBLD
     461        S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"VITBLD")) ; BUILD LIST AREA
     462        D QUEUE^C0CXPATH(ZBLD,VITXML,1,1) ; FIRST LINE
     463        N ZINNER
     464        ; XPATH NEEDS TO MATCH YOUR SECTION
     465        D QUERY^C0CXPATH(VITXML,"//VitalSigns/Result","ZINNER") ;ONE VITAL SIGN
     466        N ZTMP,ZVAR,ZI
     467        S ZI=""
     468        F  S ZI=$O(@C0CVIT@("V",ZI)) Q:ZI=""  D  ;FOR EACH VITAL SIGN
     469        . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS VITAL SIGN XML
     470        . S ZVAR=$NA(@C0CVIT@("V",ZI)) ;THIS VITAL SIGN VARIABLES
     471        . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE VITAL SIGN
     472        . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD
     473        D QUEUE^C0CXPATH(ZBLD,VITXML,@VITXML@(0),@VITXML@(0))
     474        N ZZTMP ; IS THIS NEEDED?
     475        D BUILD^C0CXPATH(ZBLD,VITOUT) ;BUILD FINAL XML
     476        K @ZTEMP,@ZBLD
     477        Q
     478        ; 

  • ccr/branches/ohum/p/C0CVITAL.m

    r1342 r1428  
    1 C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
    4  ;Licensed under the terms of the GNU General Public License.
    5  ;See attached copy of the License.
    6  ;
    7  ;This program is free software; you can redistribute it and/or modify
    8  ;it under the terms of the GNU General Public License as published by
    9  ;the Free Software Foundation; either version 2 of the License, or
    10  ;(at your option) any later version.
    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  W "NO ENTRY FROM TOP",!
    22  Q
    23  ;
    24 EXTRACT(VITXML,DFN,VITOUTXML) ; EXTRACT VITALS INTO PROVIDED XML TEMPLATE
    25  ;
    26  ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
    27  ; IVITXML CONTAINS ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE
    28  ;
    29  N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF,VORDR
    30  S C0CVLMT=$$GET^C0CPARMS("VITLIMIT") ; GET THE LIMIT PARM
    31  S C0CVSTRT=$$GET^C0CPARMS("VITSTART") ; GET START PARM
    32  D DT^DILF(,C0CVLMT,.C0CEDT) ;
    33  D DT^DILF(,C0CVSTRT,.C0CSDT) ;
    34  ;D DT^DILF(,C0CVLMT,.C0CSDT) ; GPL TESTING
    35  ;D DT^DILF(,C0CVSTRT,.C0CEDT) ;
    36  W "VITALS START: ",C0CVSTRT," LIMIT: ",C0CVLMT,!
    37  I $$RPMS^C0CUTIL() D VITRPMS QUIT
    38  I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VITVISTA QUIT
    39  ;I $$SYSNAME^C0CSYS()="RPMS" D VITRPMS
    40  ;E  D VITVISTA
    41  Q
    42  ;
    43 VITVISTA ; EXTRACT VITALS FROM VISTA INTO PROVIDED XML TEMPLATE
    44  D FASTVIT^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) ; GPL THIS ONE WORKS FOR AT
    45  ; LEAST ONE SET OF VITALS - TO DO, CALL IT REPETIVELY TO GET EARLIER VITALS
    46  ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT)
    47  ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CSDT,C0CEDT)
    48  ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CVSTRT,C0CVLMT) ; GPL LET GMR HANDLE THE DATES
    49  I '$D(VITRSLT(1)) S @VITOUTXML@(0)=0 Q  ; RETURN NOT FOUND AND QUIT
    50  I $P(VITRSLT(1),U,2)="No vitals found." D  Q  ; NULL RESULT FROM RPC
    51  . I DEBUG W "NO VITALS FOUND FROM VITALS RPC",!
    52  . S @VITOUTXML@(0)=0
    53  I $P(VITRSLT(1),U,2)="No vitals found." Q  ; QUIT
    54  ; ZWR RPCRSLT
    55  S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS"))
    56  S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP"))
    57  K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES
    58  N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
    59  D VITDVISTA(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
    60  I DEBUG ZWR VDATES ;DEBUG
    61  S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
    62  ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY
    63  S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS
    64  F J=1:1:VCNT  D  ; FOR EACH VITAL IN THE LIST
    65  . I $D(VITRSLT(VSORT(J))) D
    66  . . S VITVMAP=$NA(@VITTVMAP@(J))
    67  . . K @VITVMAP
    68  . . I DEBUG W "VMAP= ",VITVMAP,!
    69  . . S VITPTMP=VITRSLT(VSORT(J)) ; DATE SORTED VITAL FROM RETURN ARRAY
    70  . . I DEBUG W "VITAL ",VSORT(J),!
    71  . . I DEBUG W VITRSLT(VSORT(J))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),!
    72  . . I DEBUG W $P(VITPTMP,U,4),!
    73  . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID
    74         . . ;B  ;gpl
    75         . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6)
    76         . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D  ;
    77         . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1"
    78  . . I $P(VITPTMP,U,2)="HT" D
    79  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    80  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    81  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
    82  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    83  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    84  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    85  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
    86  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008"
    87  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    88  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    89  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    90  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    91  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in"
    92  . . E  I $P(VITPTMP,U,2)="WT" D
    93  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    94  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    95  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
    96  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    97  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    98  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    99  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
    100  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005"
    101  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    102  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    103  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    104  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    105  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs"
    106  . . E  I $P(VITPTMP,U,2)="BP" D
    107  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    108  . . . ;S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    109  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
    110  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    111  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    112  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    113  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
    114  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002"
    115  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    116  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    117  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    118  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    119  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
    120  . . E  I $P(VITPTMP,U,2)="T" D
    121  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    122  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    123  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
    124  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    125  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    126  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    127  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
    128  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008"
    129  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    130  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    131  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    132  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    133  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F"
    134  . . E  I $P(VITPTMP,U,2)="R" D
    135  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    136  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    137  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
    138  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    139  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    140  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    141  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
    142  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009"
    143  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    144  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    145  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    146  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    147  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
    148  . . E  I $P(VITPTMP,U,2)="P" D
    149  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    150  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    151  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
    152  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    153  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    154  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    155  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
    156  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006"
    157  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    158  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    159  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    160  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    161  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
    162  . . E  I $P(VITPTMP,U,2)="PN" D
    163  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    164  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    165  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
    166  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    167  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    168  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    169  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
    170  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000"
    171  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    172  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    173  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    174  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    175  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
    176  . . E  I $P(VITPTMP,U,2)="BMI" D
    177  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    178  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    179  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI"
    180  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    181  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    182  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    183  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI"
    184  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="60621009"
    185  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    186  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    187  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
    188  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    189  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
    190  . . E  D
    191  . . . ;W "IN VITAL:  OTHER",!
    192  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    193  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    194  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER VITAL"
    195  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    196  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    197  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="UNKNOWN"
    198  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER"
    199  . . . ;S @VITVMAP@("VITALSIGNSDESCCODEVALUE")=""
    200  . . . ;S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")=""
    201  . . . ;S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    202  . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6)
    203  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    204  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN"
    205         . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D  ;
    206         . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ;
    207  . . S VITARYTMP=$NA(@VITTARYTMP@(J))
    208  . . K @VITARYTMP
    209  . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP)
    210  . . I J=1 D  ; FIRST ONE IS JUST A COPY
    211  . . . ; W "FIRST ONE",!
    212  . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML)
    213  . . . I DEBUG W "VITOUTXML ",VITOUTXML,!
    214  . . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
    215  . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP)
    216  ; ZWR ^TMP($J,"VITALS",*)
    217  ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS
    218  I DEBUG D PARY^C0CXPATH(VITOUTXML)
    219  N VITTMP,I
    220  D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS
    221  I VITTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
    222  . W "VITALS MISSING ",!
    223  . F I=1:1:VITTMP(0) W VITTMP(I),!
    224  Q
    225  ;
    226 VITRPMS ; EXTRACT VITALS FROM RPMS INTO PROVIDED XML TEMPLATE
    227  ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE
    228  ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE
    229  N END,START,DATA
    230  D DT^DILF("",C0CVLMT,.END)
    231  D DT^DILF("",C0CVSTRT,.START)
    232  ; RPC OUTPUT FORMAT:
    233  ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric)
    234  D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL
    235  I '$D(^TMP("CIAVMRPC",$J)) S @VITOUTXML@(0)=0 Q  ; RETURN NOT FOUND AND QUIT
    236  ;ZW ^TMP("CIAVMRPC",$J)
    237  S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS"))
    238  S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP"))
    239  K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES
    240  N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
    241  D VITDRPMS(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
    242  S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
    243  ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY
    244  S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS
    245  F J=1:1:VCNT  D  ; FOR EACH VITAL IN THE LIST
    246  . I $D(^TMP("CIAVMRPC",$J,0,(VSORT(J)))) D
    247  . . S VITVMAP=$NA(@VITTVMAP@(J))
    248  . . K @VITVMAP
    249  . . I DEBUG W "VMAP= ",VITVMAP,!
    250  . . S VITPTMP=^TMP("CIAVMRPC",$J,0,(VSORT(J))) ; DATE SORTED VITAL FROM RETURN ARRAY
    251  . . I DEBUG W "VITAL ",VSORT(J),!
    252  . . I DEBUG W ^TMP("CIAVMRPC",$J,0,(VSORT(J)))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),!
    253  . . I DEBUG W $P(VITPTMP,U,4),!
    254  . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID
    255  . . I $P(VITPTMP,U,3)="HT" D
    256  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    257  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    258  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
    259  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    260  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    261  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    262  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
    263  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008"
    264  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    265  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    266  . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
    267  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
    268  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
    269  . . E  I $P(VITPTMP,U,3)="WT" D
    270  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    271  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    272  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
    273  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    274  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    275  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    276  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
    277  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005"
    278  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    279  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    280  . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
    281  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
    282  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
    283  . . E  I $P(VITPTMP,U,3)="BP" D
    284  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    285  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    286  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
    287  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    288  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    289  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    290  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
    291  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002"
    292  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    293  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    294  . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
    295  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
    296  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
    297  . . E  I $P(VITPTMP,U,3)="TMP" D
    298  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    299  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    300  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
    301  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    302  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    303  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    304  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
    305  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008"
    306  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    307  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    308  . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
    309  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
    310  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
    311  . . E  I $P(VITPTMP,U,3)="RS" D
    312  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    313  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    314  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
    315  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    316  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    317  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    318  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
    319  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009"
    320  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    321  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    322  . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
    323  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
    324  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
    325  . . E  I $P(VITPTMP,U,3)="PU" D
    326  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    327  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    328  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
    329  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    330  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    331  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    332  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
    333  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006"
    334  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    335  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    336  . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
    337  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
    338  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
    339  . . E  I $P(VITPTMP,U,3)="PA" D
    340  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    341  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    342  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
    343  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    344  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    345  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    346  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
    347  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000"
    348  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
    349  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    350  . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
    351  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
    352  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
    353  . . E  D
    354  . . . ;W "IN VITAL:  OTHER",!
    355  . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    356  . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
    357  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2)
    358  . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
    359  . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    360  . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    361  . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2)
    362  . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")=""
    363  . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")=""
    364  . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
    365  . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
    366  . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
    367  . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
    368  . . S VITARYTMP=$NA(@VITTARYTMP@(J))
    369  . . K @VITARYTMP
    370  . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP)
    371  . . I J=1 D  ; FIRST ONE IS JUST A COPY
    372  . . . ; W "FIRST ONE",!
    373  . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML)
    374  . . . I DEBUG W "VITOUTXML ",VITOUTXML,!
    375  . . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
    376  . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP)
    377  ; ZWR ^TMP($J,"VITALS",*)
    378  ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS
    379  I DEBUG D PARY^C0CXPATH(VITOUTXML)
    380  N VITTMP,I
    381  D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS
    382  I VITTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
    383  . W "VITALS MISSING ",!
    384  . F I=1:1:VITTMP(0) W VITTMP(I),!
    385  K ^TMP("CIAVMRPC",$J)
    386  Q
    387  ;
    388 VITDRPMS(VDT) ; RUN DATE SORTING ALGORITHM FOR RPMS
    389  ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY
    390  ; OF DATES IN THE VITALS RESULTS
    391  N VDTI,VDTJ,VTDCNT
    392  S VTDCNT=0 ; COUNT TO BUILD ARRAY
    393  S VDTJ="" ; USED TO VISIT THE RESULTS
    394  F VDTI=0:0 D  Q:$O(^TMP("CIAVMRPC",$J,0,VDTJ))=""  ; VISIT ALL RESULTS
    395  . S VDTJ=$O(^TMP("CIAVMRPC",$J,0,VDTJ)) ; NEXT RESULT
    396  . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER
    397  . S VDT(VTDCNT)=$P(^TMP("CIAVMRPC",$J,0,VDTJ),U,4) ; PULL OUT THE DATE
    398  S VDT(0)=VTDCNT
    399  Q
    400  ;
    401 VITDVISTA(VDT) ; RUN DATE SORTING ALGORITHM FOR VISTA
    402  ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY
    403  ; OF DATES IN THE VITALS RESULTS
    404  N VDTI,VDTJ,VTDCNT
    405  S VTDCNT=0 ; COUNT TO BUILD ARRAY
    406  S VDTJ="" ; USED TO VISIT THE RESULTS
    407  F VDTI=0:0 D  Q:$O(VITRSLT(VDTJ))=""  ; VISIT ALL RESULTS
    408  . S VDTJ=$O(VITRSLT(VDTJ)) ; NEXT RESULT
    409  . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER
    410  . S VDT(VTDCNT)=$P(VITRSLT(VDTJ),U,4) ; PULL OUT THE DATE
    411  S VDT(0)=VTDCNT
    412  Q
    413  ;
     1C0CVITAL        ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
     4        ;Licensed under the terms of the GNU General Public License.
     5        ;See attached copy of the License.
     6        ;
     7        ;This program is free software; you can redistribute it and/or modify
     8        ;it under the terms of the GNU General Public License as published by
     9        ;the Free Software Foundation; either version 2 of the License, or
     10        ;(at your option) any later version.
     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        W "NO ENTRY FROM TOP",!
     22        Q
     23        ;
     24EXTRACT(VITXML,DFN,VITOUTXML)   ; EXTRACT VITALS INTO PROVIDED XML TEMPLATE
     25        ;
     26        ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
     27        ; IVITXML CONTAINS ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE
     28        ;
     29        N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF,VORDR
     30        S C0CVLMT=$$GET^C0CPARMS("VITLIMIT") ; GET THE LIMIT PARM
     31        S C0CVSTRT=$$GET^C0CPARMS("VITSTART") ; GET START PARM
     32        D DT^DILF(,C0CVLMT,.C0CEDT) ;
     33        D DT^DILF(,C0CVSTRT,.C0CSDT) ;
     34        ;D DT^DILF(,C0CVLMT,.C0CSDT) ; GPL TESTING
     35        ;D DT^DILF(,C0CVSTRT,.C0CEDT) ;
     36        W "VITALS START: ",C0CVSTRT," LIMIT: ",C0CVLMT,!
     37        I $$RPMS^C0CUTIL() D VITRPMS QUIT
     38        I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VITVISTA QUIT
     39        ;I $$SYSNAME^C0CSYS()="RPMS" D VITRPMS
     40        ;E  D VITVISTA
     41        Q
     42        ;
     43VITVISTA        ; EXTRACT VITALS FROM VISTA INTO PROVIDED XML TEMPLATE
     44        D FASTVIT^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) ; GPL THIS ONE WORKS FOR AT
     45        ; LEAST ONE SET OF VITALS - TO DO, CALL IT REPETIVELY TO GET EARLIER VITALS
     46        ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT)
     47        ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CSDT,C0CEDT)
     48        ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CVSTRT,C0CVLMT) ; GPL LET GMR HANDLE THE DATES
     49        I '$D(VITRSLT(1)) S @VITOUTXML@(0)=0 Q  ; RETURN NOT FOUND AND QUIT
     50        I $P(VITRSLT(1),U,2)="No vitals found." D  Q  ; NULL RESULT FROM RPC
     51        . I DEBUG W "NO VITALS FOUND FROM VITALS RPC",!
     52        . S @VITOUTXML@(0)=0
     53        I $P(VITRSLT(1),U,2)="No vitals found." Q  ; QUIT
     54        ; ZWR RPCRSLT
     55        S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS"))
     56        S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP"))
     57        K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES
     58        N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
     59        D VITDVISTA(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
     60        I DEBUG ZWR VDATES ;DEBUG
     61        S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
     62        ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY
     63        S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS
     64        F J=1:1:VCNT  D  ; FOR EACH VITAL IN THE LIST
     65        . I $D(VITRSLT(VSORT(J))) D
     66        . . S VITVMAP=$NA(@VITTVMAP@(J))
     67        . . K @VITVMAP
     68        . . I DEBUG W "VMAP= ",VITVMAP,!
     69        . . S VITPTMP=VITRSLT(VSORT(J)) ; DATE SORTED VITAL FROM RETURN ARRAY
     70        . . I DEBUG W "VITAL ",VSORT(J),!
     71        . . I DEBUG W VITRSLT(VSORT(J))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),!
     72        . . I DEBUG W $P(VITPTMP,U,4),!
     73        . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID
     74               . . ;B  ;gpl
     75               . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6)
     76               . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D  ;
     77               . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1"
     78        . . I $P(VITPTMP,U,2)="HT" D
     79        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     80        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     81        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
     82        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     83        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     84        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     85        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
     86        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008"
     87        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     88        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     89        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     90        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
     91        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in"
     92        . . E  I $P(VITPTMP,U,2)="WT" D
     93        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     94        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     95        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
     96        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     97        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     98        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     99        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
     100        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005"
     101        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     102        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     103        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     104        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
     105        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs"
     106        . . E  I $P(VITPTMP,U,2)="BP" D
     107        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     108        . . . ;S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     109        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
     110        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     111        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     112        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     113        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
     114        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002"
     115        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     116        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     117        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     118        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
     119        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
     120        . . E  I $P(VITPTMP,U,2)="T" D
     121        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     122        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     123        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
     124        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     125        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     126        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     127        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
     128        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008"
     129        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     130        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     131        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     132        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
     133        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F"
     134        . . E  I $P(VITPTMP,U,2)="R" D
     135        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     136        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     137        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
     138        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     139        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     140        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     141        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
     142        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009"
     143        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     144        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     145        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     146        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
     147        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
     148        . . E  I $P(VITPTMP,U,2)="P" D
     149        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     150        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     151        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
     152        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     153        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     154        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     155        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
     156        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006"
     157        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     158        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     159        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     160        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
     161        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
     162        . . E  I $P(VITPTMP,U,2)="PN" D
     163        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     164        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     165        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
     166        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     167        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     168        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     169        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
     170        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000"
     171        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     172        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     173        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     174        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
     175        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
     176        . . E  I $P(VITPTMP,U,2)="BMI" D
     177        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     178        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     179        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI"
     180        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     181        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     182        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     183        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI"
     184        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="60621009"
     185        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     186        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     187        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
     188        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
     189        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
     190        . . E  D
     191        . . . ;W "IN VITAL:  OTHER",!
     192        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     193        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     194        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER VITAL"
     195        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     196        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     197        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="UNKNOWN"
     198        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER"
     199        . . . ;S @VITVMAP@("VITALSIGNSDESCCODEVALUE")=""
     200        . . . ;S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")=""
     201        . . . ;S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     202        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6)
     203        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
     204        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN"
     205               . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D  ;
     206               . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ;
     207        . . S VITARYTMP=$NA(@VITTARYTMP@(J))
     208        . . K @VITARYTMP
     209        . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP)
     210        . . I J=1 D  ; FIRST ONE IS JUST A COPY
     211        . . . ; W "FIRST ONE",!
     212        . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML)
     213        . . . I DEBUG W "VITOUTXML ",VITOUTXML,!
     214        . . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
     215        . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP)
     216        ; ZWR ^TMP($J,"VITALS",*)
     217        ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS
     218        I DEBUG D PARY^C0CXPATH(VITOUTXML)
     219        N VITTMP,I
     220        D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS
     221        I VITTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
     222        . W "VITALS MISSING ",!
     223        . F I=1:1:VITTMP(0) W VITTMP(I),!
     224        Q
     225        ;
     226VITRPMS ; EXTRACT VITALS FROM RPMS INTO PROVIDED XML TEMPLATE
     227        ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE
     228        ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE
     229        N END,START,DATA
     230        D DT^DILF("",C0CVLMT,.END)
     231        D DT^DILF("",C0CVSTRT,.START)
     232        ; RPC OUTPUT FORMAT:
     233        ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric)
     234        D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL
     235        I '$D(^TMP("CIAVMRPC",$J)) S @VITOUTXML@(0)=0 Q  ; RETURN NOT FOUND AND QUIT
     236        ;ZW ^TMP("CIAVMRPC",$J)
     237        S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS"))
     238        S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP"))
     239        K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES
     240        N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
     241        D VITDRPMS(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
     242        S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
     243        ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY
     244        S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS
     245        F J=1:1:VCNT  D  ; FOR EACH VITAL IN THE LIST
     246        . I $D(^TMP("CIAVMRPC",$J,0,(VSORT(J)))) D
     247        . . S VITVMAP=$NA(@VITTVMAP@(J))
     248        . . K @VITVMAP
     249        . . I DEBUG W "VMAP= ",VITVMAP,!
     250        . . S VITPTMP=^TMP("CIAVMRPC",$J,0,(VSORT(J))) ; DATE SORTED VITAL FROM RETURN ARRAY
     251        . . I DEBUG W "VITAL ",VSORT(J),!
     252        . . I DEBUG W ^TMP("CIAVMRPC",$J,0,(VSORT(J)))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),!
     253        . . I DEBUG W $P(VITPTMP,U,4),!
     254        . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID
     255        . . I $P(VITPTMP,U,3)="HT" D
     256        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     257        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     258        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
     259        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     260        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     261        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     262        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
     263        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008"
     264        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     265        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     266        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
     267        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
     268        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
     269        . . E  I $P(VITPTMP,U,3)="WT" D
     270        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     271        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     272        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
     273        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     274        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     275        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     276        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
     277        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005"
     278        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     279        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     280        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
     281        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
     282        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
     283        . . E  I $P(VITPTMP,U,3)="BP" D
     284        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     285        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     286        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
     287        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     288        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     289        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     290        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
     291        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002"
     292        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     293        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     294        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
     295        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
     296        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
     297        . . E  I $P(VITPTMP,U,3)="TMP" D
     298        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     299        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     300        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
     301        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     302        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     303        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     304        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
     305        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008"
     306        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     307        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     308        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
     309        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
     310        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
     311        . . E  I $P(VITPTMP,U,3)="RS" D
     312        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     313        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     314        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
     315        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     316        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     317        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     318        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
     319        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009"
     320        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     321        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     322        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
     323        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
     324        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
     325        . . E  I $P(VITPTMP,U,3)="PU" D
     326        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     327        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     328        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
     329        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     330        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     331        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     332        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
     333        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006"
     334        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     335        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     336        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
     337        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
     338        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
     339        . . E  I $P(VITPTMP,U,3)="PA" D
     340        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     341        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     342        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
     343        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     344        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     345        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     346        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
     347        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000"
     348        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
     349        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     350        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
     351        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
     352        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
     353        . . E  D
     354        . . . ;W "IN VITAL:  OTHER",!
     355        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     356        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
     357        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2)
     358        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
     359        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     360        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     361        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2)
     362        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")=""
     363        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")=""
     364        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
     365        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
     366        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
     367        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
     368        . . S VITARYTMP=$NA(@VITTARYTMP@(J))
     369        . . K @VITARYTMP
     370        . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP)
     371        . . I J=1 D  ; FIRST ONE IS JUST A COPY
     372        . . . ; W "FIRST ONE",!
     373        . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML)
     374        . . . I DEBUG W "VITOUTXML ",VITOUTXML,!
     375        . . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
     376        . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP)
     377        ; ZWR ^TMP($J,"VITALS",*)
     378        ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS
     379        I DEBUG D PARY^C0CXPATH(VITOUTXML)
     380        N VITTMP,I
     381        D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS
     382        I VITTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
     383        . W "VITALS MISSING ",!
     384        . F I=1:1:VITTMP(0) W VITTMP(I),!
     385        K ^TMP("CIAVMRPC",$J)
     386        Q
     387        ;
     388VITDRPMS(VDT)   ; RUN DATE SORTING ALGORITHM FOR RPMS
     389        ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY
     390        ; OF DATES IN THE VITALS RESULTS
     391        N VDTI,VDTJ,VTDCNT
     392        S VTDCNT=0 ; COUNT TO BUILD ARRAY
     393        S VDTJ="" ; USED TO VISIT THE RESULTS
     394        F VDTI=0:0 D  Q:$O(^TMP("CIAVMRPC",$J,0,VDTJ))=""  ; VISIT ALL RESULTS
     395        . S VDTJ=$O(^TMP("CIAVMRPC",$J,0,VDTJ)) ; NEXT RESULT
     396        . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER
     397        . S VDT(VTDCNT)=$P(^TMP("CIAVMRPC",$J,0,VDTJ),U,4) ; PULL OUT THE DATE
     398        S VDT(0)=VTDCNT
     399        Q
     400        ;
     401VITDVISTA(VDT)  ; RUN DATE SORTING ALGORITHM FOR VISTA
     402        ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY
     403        ; OF DATES IN THE VITALS RESULTS
     404        N VDTI,VDTJ,VTDCNT
     405        S VTDCNT=0 ; COUNT TO BUILD ARRAY
     406        S VDTJ="" ; USED TO VISIT THE RESULTS
     407        F VDTI=0:0 D  Q:$O(VITRSLT(VDTJ))=""  ; VISIT ALL RESULTS
     408        . S VDTJ=$O(VITRSLT(VDTJ)) ; NEXT RESULT
     409        . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER
     410        . S VDT(VTDCNT)=$P(VITRSLT(VDTJ),U,4) ; PULL OUT THE DATE
     411        S VDT(0)=VTDCNT
     412        Q
     413        ;

  • ccr/branches/ohum/p/C0CVOBX1.m

    r1342 r1428  
    1 LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09
    2  ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994;Build 2
    3  ; JMC - mods to check for IHS V LAB file
    4  ;
    5 CH ; Observation/Result segment for "CH" subscript results.
    6  ; Called by LA7VOBX
    7  ;
    8  N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X
    9  ;
    10  ; "CH" subscript requires a dataname
    11  I '$G(LRSB) Q
    12  ;
    13  ; get result node from LR global.
    14  S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
    15  S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
    16  ;
    17  ; Check if test is OK to send - (O)utput or (B)oth
    18  S LA7X=$P(LA7VAL,"^",12)
    19  I LA7X]"","BO"'[LA7X Q
    20  I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q
    21  ;
    22  ; If no result NLT or LOINC try to determine from file #60
    23  S LA7X=$P(LA7VAL,"^",3)
    24  ; WV check for IHS - NLT/LN codes from V LAB file
    25  I $D(^AUPNVLAB) D TMPCHK^C0CLA7Q
    26  ;
    27  I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5))
    28  ; No result NLT code - log error
    29  I $P($P(LA7VAL,"^",3),"!",2)="" D
    30  . N LA7X
    31  . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL")
    32  . D CREATE^LA7LOG(36)
    33  ;
    34  ; something missing - No NLT code, etc.
    35  I LA7VAL="" Q
    36  ;
    37  ; Check for missing units/reference ranges
    38  S LA7X=$P(LA7VAL,"^",5)
    39  ;
    40  ; Results missing units, lookup in file #60
    41  I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3)
    42  ;
    43  ; If results missing reference ranges, use values from file #60.
    44  I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D
    45  . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5))
    46  . S $P(LA7X,"!",2)=$P(LA7Y,"^")
    47  . S $P(LA7X,"!",3)=$P(LA7Y,"^",2)
    48  . S $P(LA7X,"!",11)=$P(LA7Y,"^",6)
    49  . S $P(LA7X,"!",12)=$P(LA7Y,"^",7)
    50  ; Use therapeutic low/high if low/high missing.
    51  I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D
    52  . S $P(LA7X,"!",2)=$P(LA7X,"!",11)
    53  . S $P(LA7X,"!",3)=$P(LA7X,"!",12)
    54  ;
    55  ; Evaluate low/high reference ranges in case M code in these fields.
    56  S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99
    57  F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D
    58  . S @("X="_$P(LA7X,"!",LA7I))
    59  . S $P(LA7X,"!",LA7I)=X
    60  ;
    61  ; Put units/reference ranges back in variable LA7VAL
    62  S $P(LA7VAL,"^",5)=LA7X
    63  ;
    64  ; Initialize OBX segment
    65  S LA7OBX(0)="OBX"
    66  S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
    67  ;
    68  ; Value type
    69  S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB)
    70  ;
    71  ; Observation identifer
    72  ; build alternate code based on dataname from file #63 in case it's needed
    73  S LA7X=$P(LA7VAL,"^",3)
    74  S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63"
    75  S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH)
    76  ;
    77  ; Test value
    78  S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH)
    79  ;
    80  ; Units - remove leading and trailing spaces
    81  S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ")
    82  S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH)
    83  ;
    84  ; Reference range
    85  S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH)
    86  ;
    87  ; Abnormal flags
    88  S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2))
    89  ;
    90  ; "P"artial or "F"inal results
    91  S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F"))
    92  ;
    93  ; Observation date/time - collection date/time per HL7 standard
    94  I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^"))
    95  ;
    96  S LA7DIV=$P(LA7VAL,"^",9)
    97  I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0))
    98  ;
    99  ; Facility that performed the testing
    100  S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH)
    101  ;
    102  ; Person that verified the test
    103  S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH)
    104  ;
    105  ; Observation method
    106  S LA7X=$P($P(LA7VAL,"^",3),"!",4)
    107  I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH)
    108  ;
    109  ; Equipment entity identifier
    110  I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH)
    111  ;
    112  D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS)
    113  ;
    114  Q
     1LA7VOBX1        ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ; JMC - mods to check for IHS V LAB file
     4        ;
     5CH      ; Observation/Result segment for "CH" subscript results.
     6        ; Called by LA7VOBX
     7        ;
     8        N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X
     9        ;
     10        ; "CH" subscript requires a dataname
     11        I '$G(LRSB) Q
     12        ;
     13        ; get result node from LR global.
     14        S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
     15        S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
     16        ;
     17        ; Check if test is OK to send - (O)utput or (B)oth
     18        S LA7X=$P(LA7VAL,"^",12)
     19        I LA7X]"","BO"'[LA7X Q
     20        I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q
     21        ;
     22        ; If no result NLT or LOINC try to determine from file #60
     23        S LA7X=$P(LA7VAL,"^",3)
     24        ; WV check for IHS - NLT/LN codes from V LAB file
     25        I $D(^AUPNVLAB) D TMPCHK^C0CLA7Q
     26        ;
     27        I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5))
     28        ; No result NLT code - log error
     29        I $P($P(LA7VAL,"^",3),"!",2)="" D
     30        . N LA7X
     31        . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL")
     32        . D CREATE^LA7LOG(36)
     33        ;
     34        ; something missing - No NLT code, etc.
     35        I LA7VAL="" Q
     36        ;
     37        ; Check for missing units/reference ranges
     38        S LA7X=$P(LA7VAL,"^",5)
     39        ;
     40        ; Results missing units, lookup in file #60
     41        I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3)
     42        ;
     43        ; If results missing reference ranges, use values from file #60.
     44        I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D
     45        . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5))
     46        . S $P(LA7X,"!",2)=$P(LA7Y,"^")
     47        . S $P(LA7X,"!",3)=$P(LA7Y,"^",2)
     48        . S $P(LA7X,"!",11)=$P(LA7Y,"^",6)
     49        . S $P(LA7X,"!",12)=$P(LA7Y,"^",7)
     50        ; Use therapeutic low/high if low/high missing.
     51        I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D
     52        . S $P(LA7X,"!",2)=$P(LA7X,"!",11)
     53        . S $P(LA7X,"!",3)=$P(LA7X,"!",12)
     54        ;
     55        ; Evaluate low/high reference ranges in case M code in these fields.
     56        S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99
     57        F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D
     58        . S @("X="_$P(LA7X,"!",LA7I))
     59        . S $P(LA7X,"!",LA7I)=X
     60        ;
     61        ; Put units/reference ranges back in variable LA7VAL
     62        S $P(LA7VAL,"^",5)=LA7X
     63        ;
     64        ; Initialize OBX segment
     65        S LA7OBX(0)="OBX"
     66        S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
     67        ;
     68        ; Value type
     69        S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB)
     70        ;
     71        ; Observation identifer
     72        ; build alternate code based on dataname from file #63 in case it's needed
     73        S LA7X=$P(LA7VAL,"^",3)
     74        S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63"
     75        S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH)
     76        ;
     77        ; Test value
     78        S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH)
     79        ;
     80        ; Units - remove leading and trailing spaces
     81        S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ")
     82        S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH)
     83        ;
     84        ; Reference range
     85        S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH)
     86        ;
     87        ; Abnormal flags
     88        S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2))
     89        ;
     90        ; "P"artial or "F"inal results
     91        S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F"))
     92        ;
     93        ; Observation date/time - collection date/time per HL7 standard
     94        I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^"))
     95        ;
     96        S LA7DIV=$P(LA7VAL,"^",9)
     97        I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0))
     98        ;
     99        ; Facility that performed the testing
     100        S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH)
     101        ;
     102        ; Person that verified the test
     103        S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH)
     104        ;
     105        ; Observation method
     106        S LA7X=$P($P(LA7VAL,"^",3),"!",4)
     107        I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH)
     108        ;
     109        ; Equipment entity identifier
     110        I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH)
     111        ;
     112        D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS)
     113        ;
     114        Q

  • ccr/branches/ohum/p/C0CVORU.m

    r1342 r1428  
    1 C0C7VORU ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009
    2  ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994;Build 2
    3  ;
    4 EN(LA) ; called from C0CVLAB
    5  ; variables
    6  ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68)
    7  ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4)
    8  ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68)
    9  ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64)
    10  ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64)
    11  ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time)
    12  ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60)
    13  ; LA("LRDFN") - IEN in LAB DATA file (#63)
    14  ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results.
    15  ; LA("AUTO-INST") - Auto-Instrument
    16  ;
    17  N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY
    18  ;
    19  S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")=""
    20  I $G(PRIMARY)'="" D
    21  . S PRIMARY=$$SITE^VASITE(DT,PRIMARY)
    22  . S PRIMARY=$P(PRIMARY,U,3)
    23  . S LA("AUTO-INST")="LA7V HOST "_PRIMARY
    24  ;
    25  I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D  Q
    26  . ; need to add error logging when no entry in 63.
    27  ;
    28  ; Get zeroth node of entry in #63.
    29  S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
    30  S LA7NLT=$G(LA("NLT"))
    31  ;
    32  S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))
    33  S LA7NTESN=0
    34  D ORC
    35  ;
    36  I $G(LA("SUB"))="CH" D CH
    37  ;I $G(LA("SUB"))="MI" D MI^LA7VORU1
    38  ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2
    39  Q
    40  ;
    41  ;
    42 CH ; Build segments for "CH" subscript
    43  ;
    44  D OBR
    45  D NTE
    46  S LA7OBXSN=0
    47  D OBX
    48  ;
    49  Q
    50  ;
    51  ;
    52 ORC ; Build ORC segment
    53  ;
    54  N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC
    55  ;
    56  S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
    57  ;
    58  S ORC(0)="ORC"
    59  ;
    60  ; Order control
    61  S ORC(1)=$$ORC1^LA7VORC("RE")
    62  ;
    63  ; Remote UID
    64  S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH)
    65  ;
    66  ; Host UID
    67  S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH)
    68  ;
    69  ; Return shipping manifest if found
    70  S LA7SM="",LA7696=0
    71  I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0))
    72  I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14)
    73  I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH)
    74  ;
    75  ; Order status
    76  ; DoD/CHCS requires ORC-5 valued otherwise will not process message
    77  I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH)
    78  ;
    79  ; Ordering provider
    80  S (LA7X,LA7Y)=""
    81  ; "CH" subscript stores requesting provider and requesting div/location.
    82  I LA("SUB")="CH" D
    83  . N LA7J
    84  . S LA7J=$P(LA763(0),"^",13)
    85  . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
    86  . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
    87  . S LA7X=$P(LA763(0),"^",10)
    88  ;
    89  ; Other subscripts only store requesting provider
    90  I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
    91  ; Get default institution from MailMan Site Parameters file
    92  I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
    93  S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
    94  ;
    95  ; Entering organization
    96  S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH)
    97  ;
    98  D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
    99  D FILESEG^LA7VHLU(GBL,.LA7DATA)
    100  ;
    101  ; Check for flag to only build message but do not file
    102  I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA)
    103  ;
    104  Q
    105  ;
    106  ;
    107 OBR ;Observation Request segment for Lab Order
    108  ;
    109  N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR
    110  ;
    111  ; Retrieve placer's OBR information stored in #69.6
    112  D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR)
    113  ;
    114  ; Initialize OBR segment
    115  S OBR(0)="OBR"
    116  S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
    117  ;
    118  ; Remote UID
    119  S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH)
    120  ;
    121  ; Host UID
    122  S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH)
    123  ;
    124  ; Universal service ID, build from info stored in #69.6
    125  S LA7X=""
    126  I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH)
    127  E  S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH)
    128  ;
    129  ; Collection D/T
    130  S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U))
    131  ;
    132  ; Specimen action code
    133  ; If no OBR from PENDING ORDER file (#69.6) then assume added test.
    134  I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A")
    135  ;
    136  ; Infection Warning
    137  S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
    138  ;
    139  ; Lab Arrival Time
    140  ; "CH" subscript does not store lab arrival time, use collection time.
    141  ; Other subscripts do store lab arrival time (date/time received).
    142  I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10))
    143  I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^"))
    144  ;
    145  ; Specimen source
    146  S (LA761,LA762)=""
    147  I "CHMI"[LA("SUB") D
    148  . S LA761=$P(LA763(0),U,5)
    149  . I LA761="" D CREATE^LA7LOG(27)
    150  . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11)
    151  S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH)
    152  ;
    153  ; Ordering provider
    154  S (LA7X,LA7Y)=""
    155  ; "CH" subscript stores requesting provider and requesting div/location.
    156  I LA("SUB")="CH" D
    157  . N LA7J
    158  . S LA7J=$P(LA763(0),"^",13)
    159  . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
    160  . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
    161  . S LA7X=$P(LA763(0),"^",10)
    162  ;
    163  ; Other subscripts only store requesting provider
    164  I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
    165  ; Get default institution from MailMan Site Parameters file
    166  I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
    167  S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
    168  ;
    169  ; Placer Field #1 (remote auto-inst)
    170  ; Build from info stored in #69.6
    171  I $G(LA7PLOBR("OBR-18"))'="" D
    172  . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH)
    173  ; Else build "auto instrument" if sending to VA facility
    174  I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D
    175  . N LA7X
    176  . S LA7X(1)=LA("AUTO-INST")
    177  . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
    178  ;
    179  ; Placer Field #2
    180  I $G(LA7PLOBR("OBR-19"))'="" D
    181  . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH)
    182  ; Else build collecting UID if sending to VA facility
    183  I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D
    184  . K LA7X
    185  . S LA7X(7)=LA("RUID")
    186  . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
    187  ;
    188  ; Filler Field #1
    189  ; Send file #63 ien info - used by HDR to track patient/specimen
    190  K LA7X
    191  S LA7X(1)=LA("LRDFN")
    192  S LA7X(2)=LA("SUB")
    193  S LA7X(3)=LA("LRIDT")
    194  S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
    195  ;
    196  ; Date Report Completed
    197  I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3))
    198  ;
    199  ; Diagnostic service id
    200  S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB))
    201  ;
    202  ; Parent Result and Parent
    203  I $D(LA7PARNT) D
    204  . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH)
    205  . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH)
    206  ;
    207  ; Principle result interpreter
    208  ; Get default institution from MailMan Site Parameters file
    209  I "CYEMMISP"[LA("SUB") D
    210  . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4)
    211  . E  S LA7X=$P(LA763(0),"^",2)
    212  . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
    213  . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
    214  ;
    215  ; Assistant result interpreter
    216  ; Get default institution from MailMan Site Parameters file
    217  I "EMSP"[LA("SUB") D
    218  . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
    219  . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
    220  ;
    221  ; Technician
    222  ; Get default institution from MailMan Site Parameters file
    223  I "CYEM"[LA("SUB") D
    224  . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
    225  . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
    226  ;
    227  ; Typist - VistA stores as free text
    228  ; Get default institution from MailMan Site Parameters file
    229  I "CYEMSP"[LA("SUB") D
    230  . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
    231  . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
    232  ;
    233  D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
    234  D FILESEG^LA7VHLU(GBL,.LA7DATA)
    235  ;
    236  ; Check for flag to only build message but do not file
    237  I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
    238  ;
    239  Q
    240  ;
    241  ;
    242 OBX ;Observation/Result segment for Lab Results
    243  ;
    244  N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X
    245  ;
    246  S LA7VTIEN=0
    247  F  S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN  D
    248  . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2)
    249  . ; Build OBX segment
    250  . K LA7DATA
    251  . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF))
    252  . ; If OBX failed to build then don't store
    253  . I '$D(LA7DATA) Q
    254  . ;
    255  . D FILESEG^LA7VHLU(GBL,.LA7DATA)
    256  . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
    257  . ;
    258  . ; Send performing lab comment and interpretation from file #60
    259  . S LA7NTESN=0
    260  . I LA7NVAF=1 D PLC^LA7VORUA
    261  . D INTRP^LA7VORUA
    262  . ;
    263  . ; Mark result as sent - set to 1, if corrected results set to 2
    264  . I LA("SUB")="CH" D
    265  . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q
    266  . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1)
    267  ;
    268  Q
    269  ;
    270  ;
    271 NTE ; Build NTE segment
    272  ;
    273  D NTE^LA7VORUA
    274  Q
     1C0C7VORU        ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009 ; 5/10/12 5:19pm
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;
     4EN(LA)  ; called from C0CVLAB
     5        ; variables
     6        ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68)
     7        ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4)
     8        ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68)
     9        ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64)
     10        ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64)
     11        ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time)
     12        ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60)
     13        ; LA("LRDFN") - IEN in LAB DATA file (#63)
     14        ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results.
     15        ; LA("AUTO-INST") - Auto-Instrument
     16        ;
     17        N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY
     18        ;
     19        S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")=""
     20        I $G(PRIMARY)'="" D
     21        . S PRIMARY=$$SITE^VASITE(DT,PRIMARY)
     22        . S PRIMARY=$P(PRIMARY,U,3)
     23        . S LA("AUTO-INST")="LA7V HOST "_PRIMARY
     24        ;
     25        I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D  Q
     26        . ; need to add error logging when no entry in 63.
     27        ;
     28        ; Get zeroth node of entry in #63.
     29        S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
     30        S LA7NLT=$G(LA("NLT"))
     31        ;
     32        S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))
     33        S LA7NTESN=0
     34        D ORC
     35        ;
     36        I $G(LA("SUB"))="CH" D CH
     37        ;I $G(LA("SUB"))="MI" D MI^LA7VORU1
     38        ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2
     39        Q
     40        ;
     41        ;
     42CH      ; Build segments for "CH" subscript
     43        ;
     44        D OBR
     45        D NTE
     46        S LA7OBXSN=0
     47        D OBX
     48        ;
     49        Q
     50        ;
     51        ;
     52ORC     ; Build ORC segment
     53        ;
     54        N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC
     55        ;
     56        S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
     57        ;
     58        S ORC(0)="ORC"
     59        ;
     60        ; Order control
     61        S ORC(1)=$$ORC1^LA7VORC("RE")
     62        ;
     63        ; Remote UID
     64        S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH)
     65        ;
     66        ; Host UID
     67        S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH)
     68        ;
     69        ; Return shipping manifest if found
     70        S LA7SM="",LA7696=0
     71        I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0))
     72        I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14)
     73        I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH)
     74        ;
     75        ; Order status
     76        ; DoD/CHCS requires ORC-5 valued otherwise will not process message
     77        I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH)
     78        ;
     79        ; Ordering provider
     80        S (LA7X,LA7Y)=""
     81        ; "CH" subscript stores requesting provider and requesting div/location.
     82        I LA("SUB")="CH" D
     83        . N LA7J
     84        . S LA7J=$P(LA763(0),"^",13)
     85        . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
     86        . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
     87        . S LA7X=$P(LA763(0),"^",10)
     88        ;
     89        ; Other subscripts only store requesting provider
     90        I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
     91        ; Get default institution from MailMan Site Parameters file
     92        I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
     93        S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
     94        ;
     95        ; Entering organization
     96        S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH)
     97        ;
     98        D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
     99        D FILESEG^LA7VHLU(GBL,.LA7DATA)
     100        ;
     101        ; Check for flag to only build message but do not file
     102        I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA)
     103        ;
     104        Q
     105        ;
     106        ;
     107OBR     ;Observation Request segment for Lab Order
     108        ;
     109        N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR
     110        ;
     111        ; Retrieve placer's OBR information stored in #69.6
     112        D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR)
     113        ;
     114        ; Initialize OBR segment
     115        S OBR(0)="OBR"
     116        S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
     117        ;
     118        ; Remote UID
     119        S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH)
     120        ;
     121        ; Host UID
     122        S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH)
     123        ;
     124        ; Universal service ID, build from info stored in #69.6
     125        S LA7X=""
     126        I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH)
     127        E  S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH)
     128        ;
     129        ; Collection D/T
     130        S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U))
     131        ;
     132        ; Specimen action code
     133        ; If no OBR from PENDING ORDER file (#69.6) then assume added test.
     134        I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A")
     135        ;
     136        ; Infection Warning
     137        S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
     138        ;
     139        ; Lab Arrival Time
     140        ; "CH" subscript does not store lab arrival time, use collection time.
     141        ; Other subscripts do store lab arrival time (date/time received).
     142        I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10))
     143        I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^"))
     144        ;
     145        ; Specimen source
     146        S (LA761,LA762)=""
     147        I "CHMI"[LA("SUB") D
     148        . S LA761=$P(LA763(0),U,5)
     149        . I LA761="" D CREATE^LA7LOG(27)
     150        . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11)
     151        S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH)
     152        ;
     153        ; Ordering provider
     154        S (LA7X,LA7Y)=""
     155        ; "CH" subscript stores requesting provider and requesting div/location.
     156        I LA("SUB")="CH" D
     157        . N LA7J
     158        . S LA7J=$P(LA763(0),"^",13)
     159        . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
     160        . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
     161        . S LA7X=$P(LA763(0),"^",10)
     162        ;
     163        ; Other subscripts only store requesting provider
     164        I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
     165        ; Get default institution from MailMan Site Parameters file
     166        I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
     167        S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
     168        ;
     169        ; Placer Field #1 (remote auto-inst)
     170        ; Build from info stored in #69.6
     171        I $G(LA7PLOBR("OBR-18"))'="" D
     172        . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH)
     173        ; Else build "auto instrument" if sending to VA facility
     174        I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D
     175        . N LA7X
     176        . S LA7X(1)=LA("AUTO-INST")
     177        . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
     178        ;
     179        ; Placer Field #2
     180        I $G(LA7PLOBR("OBR-19"))'="" D
     181        . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH)
     182        ; Else build collecting UID if sending to VA facility
     183        I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D
     184        . K LA7X
     185        . S LA7X(7)=LA("RUID")
     186        . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
     187        ;
     188        ; Filler Field #1
     189        ; Send file #63 ien info - used by HDR to track patient/specimen
     190        K LA7X
     191        S LA7X(1)=LA("LRDFN")
     192        S LA7X(2)=LA("SUB")
     193        S LA7X(3)=LA("LRIDT")
     194        S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
     195        ;
     196        ; Date Report Completed
     197        I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3))
     198        ;
     199        ; Diagnostic service id
     200        S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB))
     201        ;
     202        ; Parent Result and Parent
     203        I $D(LA7PARNT) D
     204        . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH)
     205        . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH)
     206        ;
     207        ; Principle result interpreter
     208        ; Get default institution from MailMan Site Parameters file
     209        I "CYEMMISP"[LA("SUB") D
     210        . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4)
     211        . E  S LA7X=$P(LA763(0),"^",2)
     212        . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
     213        . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
     214        ;
     215        ; Assistant result interpreter
     216        ; Get default institution from MailMan Site Parameters file
     217        I "EMSP"[LA("SUB") D
     218        . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
     219        . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
     220        ;
     221        ; Technician
     222        ; Get default institution from MailMan Site Parameters file
     223        I "CYEM"[LA("SUB") D
     224        . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
     225        . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
     226        ;
     227        ; Typist - VistA stores as free text
     228        ; Get default institution from MailMan Site Parameters file
     229        I "CYEMSP"[LA("SUB") D
     230        . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
     231        . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
     232        ;
     233        D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
     234        D FILESEG^LA7VHLU(GBL,.LA7DATA)
     235        ;
     236        ; Check for flag to only build message but do not file
     237        I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
     238        ;
     239        Q
     240        ;
     241        ;
     242OBX     ;Observation/Result segment for Lab Results
     243        ;
     244        N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X
     245        ;
     246        S LA7VTIEN=0
     247        F  S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN  D
     248        . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2)
     249        . ; Build OBX segment
     250        . K LA7DATA
     251        . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF))
     252        . ; If OBX failed to build then don't store
     253        . I '$D(LA7DATA) Q
     254        . ;
     255        . D FILESEG^LA7VHLU(GBL,.LA7DATA)
     256        . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
     257        . ;
     258        . ; Send performing lab comment and interpretation from file #60
     259        . S LA7NTESN=0
     260        . I LA7NVAF=1 D PLC^LA7VORUA
     261        . D INTRP^LA7VORUA
     262        . ;
     263        . ; Mark result as sent - set to 1, if corrected results set to 2
     264        . I LA("SUB")="CH" D
     265        . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q
     266        . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1)
     267        ;
     268        Q
     269        ;
     270        ;
     271NTE     ; Build NTE segment
     272        ;
     273        D NTE^LA7VORUA
     274        Q

  • ccr/branches/ohum/p/C0CXEWD.m

    r1342 r1428  
    1 C0CXEWD   ; C0C/GPL - EWD based XPath utilities; 10/11/09
    2  ;;0.1;C0C;nopatch;noreleasedate;Build 2
    3  ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
    5  ;
    6  ;This program is free software; you can redistribute it and/or modify
    7  ;it under the terms of the GNU General Public License as published by
    8  ;the Free Software Foundation; either version 2 of the License, or
    9  ;(at your option) any later version.
    10  ;
    11  ;This program is distributed in the hope that it will be useful,
    12  ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13  ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14  ;GNU General Public License for more details.
    15  ;
    16  ;You should have received a copy of the GNU General Public License along
    17  ;with this program; if not, write to the Free Software Foundation, Inc.,
    18  ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19  ;
    20  Q
    21  ;
    22 TEST ;
    23  D XPATH($$FIRST($$ID("CCR1")),"/","GIDX","GARY")
    24  Q
    25  ;
    26 TEST2 ;
    27  S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail"
    28  D XPATH($$FIRST($$ID("gpl")),"/","GIDX","GARY","",REDUX)
    29  Q
    30  ;
    31 XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE
    32  ; THE XPATH INDEX ZXIDX, PASSED BY NAME
    33  ; THE XPATH ARRAY XPARY, PASSED BY NAME
    34  ; ZOID IS THE STARTING OID
    35  ; ZPATH IS THE STARTING XPATH, USUALLY "/"
    36  ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
    37  ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
    38  I '$D(ZREDUX) S ZREDUX=""
    39  N NEWPATH
    40  N NEWNUM S NEWNUM=""
    41  I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
    42  S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
    43  I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
    44  . N GT S GT=$P(NEWPATH,ZREDUX,2)
    45  . I GT'="" S NEWPATH=GT
    46  S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
    47  N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
    48  I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
    49  E  I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
    50  I GD'="" S @ZXPARY@(NEWPATH)=GD ; IF YES, ADD IT TO THE XPATH ARRAY
    51  N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
    52  I ZFRST'="" D  ; THERE IS A CHILD
    53  . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
    54  . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD
    55  N GNXT S GNXT=$$NXTSIB(ZOID)
    56  I GNXT'="" D  ; MOVE ON TO THE NEXT SIBLING
    57  . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB
    58  Q
    59  ;
    60 PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
    61  ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
    62  ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
    63  N ZR
    64  M ^CacheTempEWD($j)=@INXML ;
    65  S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
    66  Q ZR
    67  ;
    68 ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
    69  N ZN
    70  S ZN=$$NXTSIB(ZOID)
    71  I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
    72  Q 0
    73  ;
    74 DETAIL(ZRTN,ZOID) ; RETURNS DETAIL FOR NODE ZOID IN ZRTN, PASSED BY NAME
    75  N DET
    76  D getElementDetails^%zewdXPath(ZOID,.DET)
    77  M @ZRTN=DET
    78  Q
    79  ;
    80 ID(ZNAME) ;RETURNS THE docOID OF THE DOCUMENT NAMED ZNAME
    81  Q $$getDocumentNode^%zewdDOM(ZNAME)
    82  ;
    83 NAME(ZOID) ;RETURNS THE NAME OF THE DOCUMENAT WITH docOID ZOID
    84  Q $$getDocumentName^%zewdDOM(ZOID)
    85  ;
    86 FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
    87  N GOID
    88  S GOID=ZOID
    89  S GOID=$$getFirstChild^%zewdDOM(GOID)
    90  I GOID="" Q ""
    91  I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
    92  Q GOID
    93  ;
    94 HASCHILD(ZOID) ; RETURNS TRUE IF ZOID HAS CHILD NODES
    95  Q $$hasChildNodes^%zewdDOM(ZOID)
    96  ;
    97 CHILDREN(ZRTN,ZOID) ;RETURNS CHILDREN OF ZOID IN ARRAY ZRTN, PASSED BY NAME
    98  N childArray
    99  d getChildrenInOrder^%zewdDOM(ZOID,.childArray)
    100  m @ZRTN=childArray
    101  q
    102  ;
    103 TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE
    104  Q $$getName^%zewdDOM(ZOID)
    105  ;
    106 NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING
    107  Q $$getNextSibling^%zewdDOM(ZOID)
    108  ;
    109 NXTCHLD(ZOID) ; RETURNS THE NEXT CHILD IN PARENT ZPAR
    110  N GOID
    111  S GOID=$$getNextChild^%zewdDOM($$PARENT(ZOID),ZOID)
    112  I GOID="" Q ""
    113  I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
    114  Q GOID
    115  ;
    116 PARENT(ZOID) ; RETURNS PARENT OF ZOID
    117  Q $$getParentNode^%zewdDOM(ZOID)
    118  ;
    119 DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE
    120  N ZT2
    121  S ZT2=$$getElementText^%zewdDOM(ZOID,.ZT2)
    122  M @ZT=ZT2
    123  Q
    124  ;Q $$getTextValue^%zewdXPath(ZOID)
    125  ;Q $$getData^%zewdDOM(ZOID,.ZT)
    126  ;
     1C0CXEWD   ; C0C/GPL - EWD based XPath utilities; 10/11/09
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4        ;General Public License See attached copy of the License.
     5        ;
     6        ;This program is free software; you can redistribute it and/or modify
     7        ;it under the terms of the GNU General Public License as published by
     8        ;the Free Software Foundation; either version 2 of the License, or
     9        ;(at your option) any later version.
     10        ;
     11        ;This program is distributed in the hope that it will be useful,
     12        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14        ;GNU General Public License for more details.
     15        ;
     16        ;You should have received a copy of the GNU General Public License along
     17        ;with this program; if not, write to the Free Software Foundation, Inc.,
     18        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19        ;
     20        Q
     21        ;
     22TEST    ;
     23        D XPATH($$FIRST($$ID("CCR1")),"/","GIDX","GARY")
     24        Q
     25        ;
     26TEST2   ;
     27        S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail"
     28        D XPATH($$FIRST($$ID("gpl")),"/","GIDX","GARY","",REDUX)
     29        Q
     30        ;
     31XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX)      ; RECURSIVE ROUTINE TO POPULATE
     32        ; THE XPATH INDEX ZXIDX, PASSED BY NAME
     33        ; THE XPATH ARRAY XPARY, PASSED BY NAME
     34        ; ZOID IS THE STARTING OID
     35        ; ZPATH IS THE STARTING XPATH, USUALLY "/"
     36        ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
     37        ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
     38        I '$D(ZREDUX) S ZREDUX=""
     39        N NEWPATH
     40        N NEWNUM S NEWNUM=""
     41        I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
     42        S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
     43        I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
     44        . N GT S GT=$P(NEWPATH,ZREDUX,2)
     45        . I GT'="" S NEWPATH=GT
     46        S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
     47        N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
     48        I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
     49        E  I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
     50        I GD'="" S @ZXPARY@(NEWPATH)=GD ; IF YES, ADD IT TO THE XPATH ARRAY
     51        N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
     52        I ZFRST'="" D  ; THERE IS A CHILD
     53        . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
     54        . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD
     55        N GNXT S GNXT=$$NXTSIB(ZOID)
     56        I GNXT'="" D  ; MOVE ON TO THE NEXT SIBLING
     57        . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB
     58        Q
     59        ;
     60PARSE(INXML,INDOC)      ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
     61        ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
     62        ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
     63        N ZR
     64        M ^CacheTempEWD($j)=@INXML ;
     65        S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
     66        Q ZR
     67        ;
     68ISMULT(ZOID)    ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
     69        N ZN
     70        S ZN=$$NXTSIB(ZOID)
     71        I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
     72        Q 0
     73        ;
     74DETAIL(ZRTN,ZOID)       ; RETURNS DETAIL FOR NODE ZOID IN ZRTN, PASSED BY NAME
     75        N DET
     76        D getElementDetails^%zewdXPath(ZOID,.DET)
     77        M @ZRTN=DET
     78        Q
     79        ;
     80ID(ZNAME)       ;RETURNS THE docOID OF THE DOCUMENT NAMED ZNAME
     81        Q $$getDocumentNode^%zewdDOM(ZNAME)
     82        ;
     83NAME(ZOID)      ;RETURNS THE NAME OF THE DOCUMENAT WITH docOID ZOID
     84        Q $$getDocumentName^%zewdDOM(ZOID)
     85        ;
     86FIRST(ZOID)     ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
     87        N GOID
     88        S GOID=ZOID
     89        S GOID=$$getFirstChild^%zewdDOM(GOID)
     90        I GOID="" Q ""
     91        I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
     92        Q GOID
     93        ;
     94HASCHILD(ZOID)  ; RETURNS TRUE IF ZOID HAS CHILD NODES
     95        Q $$hasChildNodes^%zewdDOM(ZOID)
     96        ;
     97CHILDREN(ZRTN,ZOID)     ;RETURNS CHILDREN OF ZOID IN ARRAY ZRTN, PASSED BY NAME
     98        N childArray
     99        d getChildrenInOrder^%zewdDOM(ZOID,.childArray)
     100        m @ZRTN=childArray
     101        q
     102        ;
     103TAG(ZOID)       ; RETURNS THE XML TAG FOR THE NODE
     104        Q $$getName^%zewdDOM(ZOID)
     105        ;
     106NXTSIB(ZOID)    ; RETURNS THE NEXT SIBLING
     107        Q $$getNextSibling^%zewdDOM(ZOID)
     108        ;
     109NXTCHLD(ZOID)   ; RETURNS THE NEXT CHILD IN PARENT ZPAR
     110        N GOID
     111        S GOID=$$getNextChild^%zewdDOM($$PARENT(ZOID),ZOID)
     112        I GOID="" Q ""
     113        I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
     114        Q GOID
     115        ;
     116PARENT(ZOID)    ; RETURNS PARENT OF ZOID
     117        Q $$getParentNode^%zewdDOM(ZOID)
     118        ;
     119DATA(ZT,ZOID)   ; RETURNS DATA FOR THE NODE
     120        N ZT2
     121        S ZT2=$$getElementText^%zewdDOM(ZOID,.ZT2)
     122        M @ZT=ZT2
     123        Q
     124        ;Q $$getTextValue^%zewdXPath(ZOID)
     125        ;Q $$getData^%zewdDOM(ZOID,.ZT)
     126        ;

  • ccr/branches/ohum/p/C0CXPAT0.m

    r1342 r1428  
    1 C0CXPAT0   ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008 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 "NO ENTRY",!
    21         Q
    22         ;
    23  ;;><TEST>
    24  ;;><INIT>
    25  ;;>>>K C0C S C0C=""
    26  ;;>>>D PUSH^C0CXPATH("C0C","FIRST")
    27  ;;>>>D PUSH^C0CXPATH("C0C","SECOND")
    28  ;;>>>D PUSH^C0CXPATH("C0C","THIRD")
    29  ;;>>>D PUSH^C0CXPATH("C0C","FOURTH")
    30  ;;>>?C0C(0)=4
    31  ;;><INITXML>
    32  ;;>>>K GXML S GXML=""
    33  ;;>>>D PUSH^C0CXPATH("GXML","<FIRST>")
    34  ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>")
    35  ;;>>>D PUSH^C0CXPATH("GXML","<THIRD>")
    36  ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>@@DATA1@@</FOURTH>")
    37  ;;>>>D PUSH^C0CXPATH("GXML","<FIFTH>")
    38  ;;>>>D PUSH^C0CXPATH("GXML","@@DATA2@@")
    39  ;;>>>D PUSH^C0CXPATH("GXML","</FIFTH>")
    40  ;;>>>D PUSH^C0CXPATH("GXML","<SIXTH ID=""SELF"" />")
    41  ;;>>>D PUSH^C0CXPATH("GXML","</THIRD>")
    42  ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>")
    43  ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>")
    44  ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>")
    45  ;;>>>D PUSH^C0CXPATH("GXML","</FIRST>")
    46  ;;><INITXML2>
    47  ;;>>>K GXML S GXML=""
    48  ;;>>>D PUSH^C0CXPATH("GXML","<FIRST>")
    49  ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>")
    50  ;;>>>D PUSH^C0CXPATH("GXML","<THIRD>")
    51  ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>DATA1</FOURTH>")
    52  ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>")
    53  ;;>>>D PUSH^C0CXPATH("GXML","DATA2")
    54  ;;>>>D PUSH^C0CXPATH("GXML","</FOURTH>")
    55  ;;>>>D PUSH^C0CXPATH("GXML","</THIRD>")
    56  ;;>>>D PUSH^C0CXPATH("GXML","<_SECOND>")
    57  ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>DATA3</FOURTH>")
    58  ;;>>>D PUSH^C0CXPATH("GXML","</_SECOND>")
    59  ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>")
    60  ;;>>>D PUSH^C0CXPATH("GXML","</FIRST>")
    61  ;;><PUSHPOP>
    62  ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
    63  ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT")
    64  ;;>>?C0C(C0C(0))="FOURTH"
    65  ;;>>>D POP^C0CXPATH("C0C",.GX)
    66  ;;>>?GX="FOURTH"
    67  ;;>>?C0C(C0C(0))="THIRD"
    68  ;;>>>D POP^C0CXPATH("C0C",.GX)
    69  ;;>>?GX="THIRD"
    70  ;;>>?C0C(C0C(0))="SECOND"
    71  ;;><MKMDX>
    72  ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
    73  ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT")
    74  ;;>>>S GX=""
    75  ;;>>>D MKMDX^C0CXPATH("C0C",.GX)
    76  ;;>>?GX="//FIRST/SECOND/THIRD/FOURTH"
    77  ;;><XNAME>
    78  ;;>>?$$XNAME^C0CXPATH("<FOURTH>DATA1</FOURTH>")="FOURTH"
    79  ;;>>?$$XNAME^C0CXPATH("<SIXTH  ID=""SELF"" />")="SIXTH"
    80  ;;>>?$$XNAME^C0CXPATH("</THIRD>")="THIRD"
    81  ;;><INDEX>
    82  ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
    83  ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INITXML")
    84  ;;>>>D INDEX^C0CXPATH("GXML")
    85  ;;>>?GXML("//FIRST/SECOND")="2^12"
    86  ;;>>?GXML("//FIRST/SECOND/THIRD")="3^9"
    87  ;;>>?GXML("//FIRST/SECOND/THIRD/FIFTH")="5^7"
    88  ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^4^@@DATA1@@"
    89  ;;>>?GXML("//FIRST/SECOND/THIRD/SIXTH")="8^8^"
    90  ;;>>?GXML("//FIRST/SECOND")="2^12"
    91  ;;>>?GXML("//FIRST")="1^13"
    92  ;;><INDEX2>
    93  ;;>>>D ZTEST^C0CXPATH("INITXML2")
    94  ;;>>>D INDEX^C0CXPATH("GXML")
    95  ;;>>?GXML("//FIRST/SECOND")="2^12"
    96  ;;>>?GXML("//FIRST/SECOND/_SECOND")="9^11"
    97  ;;>>?GXML("//FIRST/SECOND/_SECOND/FOURTH")="10^10^DATA3"
    98  ;;>>?GXML("//FIRST/SECOND/THIRD")="3^8"
    99  ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH[1]")="4^4^DATA1"
    100  ;;>>?GXML("//FIRST")="1^13"
    101  ;;><MISSING>
    102  ;;>>>D ZTEST^C0CXPATH("INITXML")
    103  ;;>>>S OUTARY="^TMP($J,""MISSINGTEST"")"
    104  ;;>>>D MISSING^C0CXPATH("GXML",OUTARY)
    105  ;;>>?@OUTARY@(1)="DATA1"
    106  ;;>>?@OUTARY@(2)="DATA2"
    107  ;;><MAP>
    108  ;;>>>D ZTEST^C0CXPATH("INITXML")
    109  ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")"
    110  ;;>>>S OUTARY="^TMP($J,""MAPTEST"")"
    111  ;;>>>S @MAPARY@("DATA2")="VALUE2"
    112  ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY)
    113  ;;>>?@OUTARY@(6)="VALUE2"
    114  ;;><MAP2>
    115  ;;>>>D ZTEST^C0CXPATH("INITXML")
    116  ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")"
    117  ;;>>>S OUTARY="^TMP($J,""MAPTEST"")"
    118  ;;>>>S @MAPARY@("DATA1")="VALUE1"
    119  ;;>>>S @MAPARY@("DATA2")="VALUE2"
    120  ;;>>>S @MAPARY@("DATA3")="VALUE3"
    121  ;;>>>S GXML(4)="<FOURTH>@@DATA1@@ AND @@DATA3@@</FOURTH>"
    122  ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY)
    123  ;;>>>D PARY^C0CXPATH(OUTARY)
    124  ;;>>?@OUTARY@(4)="<FOURTH>VALUE1 AND VALUE3</FOURTH>"
    125  ;;><QUEUE>
    126  ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",2,3)
    127  ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",4,5)
    128  ;;>>?$P(BTLIST(2),";",2)=4
    129  ;;><BUILD>
    130  ;;>>>D ZTEST^C0CXPATH("INITXML")
    131  ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FOURTH","G2")
    132  ;;>>>D ZTEST^C0CXPATH("QUEUE")
    133  ;;>>>D BUILD^C0CXPATH("BTLIST","G3")
    134  ;;><CP>
    135  ;;>>>D ZTEST^C0CXPATH("INITXML")
    136  ;;>>>D CP^C0CXPATH("GXML","G2")
    137  ;;>>?G2(0)=13
    138  ;;><QOPEN>
    139  ;;>>>K G2,GBL
    140  ;;>>>D ZTEST^C0CXPATH("INITXML")
    141  ;;>>>D QOPEN^C0CXPATH("GBL","GXML")
    142  ;;>>?$P(GBL(1),";",3)=12
    143  ;;>>>D BUILD^C0CXPATH("GBL","G2")
    144  ;;>>?G2(G2(0))="</SECOND>"
    145  ;;><QOPEN2>
    146  ;;>>>K G2,GBL
    147  ;;>>>D ZTEST^C0CXPATH("INITXML")
    148  ;;>>>D QOPEN^C0CXPATH("GBL","GXML","//FIRST/SECOND")
    149  ;;>>?$P(GBL(1),";",3)=11
    150  ;;>>>D BUILD^C0CXPATH("GBL","G2")
    151  ;;>>?G2(G2(0))="</SECOND>"
    152  ;;><QCLOSE>
    153  ;;>>>K G2,GBL
    154  ;;>>>D ZTEST^C0CXPATH("INITXML")
    155  ;;>>>D QCLOSE^C0CXPATH("GBL","GXML")
    156  ;;>>?$P(GBL(1),";",3)=13
    157  ;;>>>D BUILD^C0CXPATH("GBL","G2")
    158  ;;>>?G2(G2(0))="</FIRST>"
    159  ;;><QCLOSE2>
    160  ;;>>>K G2,GBL
    161  ;;>>>D ZTEST^C0CXPATH("INITXML")
    162  ;;>>>D QCLOSE^C0CXPATH("GBL","GXML","//FIRST/SECOND/THIRD")
    163  ;;>>?$P(GBL(1),";",3)=13
    164  ;;>>>D BUILD^C0CXPATH("GBL","G2")
    165  ;;>>?G2(G2(0))="</FIRST>"
    166  ;;>>?G2(1)="</THIRD>"
    167  ;;><INSERT>
    168  ;;>>>K G2,GBL,G3,G4
    169  ;;>>>D ZTEST^C0CXPATH("INITXML")
    170  ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2")
    171  ;;>>>D INSERT^C0CXPATH("GXML","G2","//FIRST/SECOND/THIRD")
    172  ;;>>>D INSERT^C0CXPATH("G3","G2","//")
    173  ;;>>?G2(1)=GXML(9)
    174  ;;><REPLACE>
    175  ;;>>>K G2,GBL,G3
    176  ;;>>>D ZTEST^C0CXPATH("INITXML")
    177  ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2")
    178  ;;>>>D REPLACE^C0CXPATH("GXML","G2","//FIRST/SECOND")
    179  ;;>>?GXML(2)="<FIFTH>"
    180  ;;><INSINNER>
    181  ;;>>>K GXML,G2,GBL,G3
    182  ;;>>>D ZTEST^C0CXPATH("INITXML")
    183  ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2")
    184  ;;>>>D INSINNER^C0CXPATH("GXML","G2","//FIRST/SECOND/THIRD")
    185  ;;>>?GXML(10)="<FIFTH>"
    186  ;;><INSINNER2>
    187  ;;>>>K GXML,G2,GBL,G3
    188  ;;>>>D ZTEST^C0CXPATH("INITXML")
    189  ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2")
    190  ;;>>>D INSINNER^C0CXPATH("G2","G2")
    191  ;;>>?G2(8)="<FIFTH>"
    192  ;;><PUSHA>
    193  ;;>>>K GTMP,GTMP2
    194  ;;>>>N GTMP,GTMP2
    195  ;;>>>D PUSH^C0CXPATH("GTMP","A")
    196  ;;>>>D PUSH^C0CXPATH("GTMP2","B")
    197  ;;>>>D PUSH^C0CXPATH("GTMP2","C")
    198  ;;>>>D PUSHA^C0CXPATH("GTMP","GTMP2")
    199  ;;>>?GTMP(3)="C"
    200  ;;>>?GTMP(0)=3
    201  ;;><H2ARY>
    202  ;;>>>K GTMP,GTMP2
    203  ;;>>>S GTMP("TEST1")=1
    204  ;;>>>D H2ARY^C0CXPATH("GTMP2","GTMP")
    205  ;;>>?GTMP2(0)=1
    206  ;;>>?GTMP2(1)="^TEST1^1"
    207  ;;><XVARS>
    208  ;;>>>K GTMP,GTMP2
    209  ;;>>>D PUSH^C0CXPATH("GTMP","<VALUE>@@VAR1@@</VALUE>")
    210  ;;>>>D XVARS^C0CXPATH("GTMP2","GTMP")
    211  ;;>>?GTMP2(1)="^VAR1^1"
    212  ;;></TEST>
     1C0CXPAT0          ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008 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 "NO ENTRY",!
     21               Q
     22               ;
     23        ;;><TEST>
     24        ;;><INIT>
     25        ;;>>>K C0C S C0C=""
     26        ;;>>>D PUSH^C0CXPATH("C0C","FIRST")
     27        ;;>>>D PUSH^C0CXPATH("C0C","SECOND")
     28        ;;>>>D PUSH^C0CXPATH("C0C","THIRD")
     29        ;;>>>D PUSH^C0CXPATH("C0C","FOURTH")
     30        ;;>>?C0C(0)=4
     31        ;;><INITXML>
     32        ;;>>>K GXML S GXML=""
     33        ;;>>>D PUSH^C0CXPATH("GXML","<FIRST>")
     34        ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>")
     35        ;;>>>D PUSH^C0CXPATH("GXML","<THIRD>")
     36        ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>@@DATA1@@</FOURTH>")
     37        ;;>>>D PUSH^C0CXPATH("GXML","<FIFTH>")
     38        ;;>>>D PUSH^C0CXPATH("GXML","@@DATA2@@")
     39        ;;>>>D PUSH^C0CXPATH("GXML","</FIFTH>")
     40        ;;>>>D PUSH^C0CXPATH("GXML","<SIXTH ID=""SELF"" />")
     41        ;;>>>D PUSH^C0CXPATH("GXML","</THIRD>")
     42        ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>")
     43        ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>")
     44        ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>")
     45        ;;>>>D PUSH^C0CXPATH("GXML","</FIRST>")
     46        ;;><INITXML2>
     47        ;;>>>K GXML S GXML=""
     48        ;;>>>D PUSH^C0CXPATH("GXML","<FIRST>")
     49        ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>")
     50        ;;>>>D PUSH^C0CXPATH("GXML","<THIRD>")
     51        ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>DATA1</FOURTH>")
     52        ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>")
     53        ;;>>>D PUSH^C0CXPATH("GXML","DATA2")
     54        ;;>>>D PUSH^C0CXPATH("GXML","</FOURTH>")
     55        ;;>>>D PUSH^C0CXPATH("GXML","</THIRD>")
     56        ;;>>>D PUSH^C0CXPATH("GXML","<_SECOND>")
     57        ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>DATA3</FOURTH>")
     58        ;;>>>D PUSH^C0CXPATH("GXML","</_SECOND>")
     59        ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>")
     60        ;;>>>D PUSH^C0CXPATH("GXML","</FIRST>")
     61        ;;><PUSHPOP>
     62        ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
     63        ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT")
     64        ;;>>?C0C(C0C(0))="FOURTH"
     65        ;;>>>D POP^C0CXPATH("C0C",.GX)
     66        ;;>>?GX="FOURTH"
     67        ;;>>?C0C(C0C(0))="THIRD"
     68        ;;>>>D POP^C0CXPATH("C0C",.GX)
     69        ;;>>?GX="THIRD"
     70        ;;>>?C0C(C0C(0))="SECOND"
     71        ;;><MKMDX>
     72        ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
     73        ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT")
     74        ;;>>>S GX=""
     75        ;;>>>D MKMDX^C0CXPATH("C0C",.GX)
     76        ;;>>?GX="//FIRST/SECOND/THIRD/FOURTH"
     77        ;;><XNAME>
     78        ;;>>?$$XNAME^C0CXPATH("<FOURTH>DATA1</FOURTH>")="FOURTH"
     79        ;;>>?$$XNAME^C0CXPATH("<SIXTH  ID=""SELF"" />")="SIXTH"
     80        ;;>>?$$XNAME^C0CXPATH("</THIRD>")="THIRD"
     81        ;;><INDEX>
     82        ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
     83        ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INITXML")
     84        ;;>>>D INDEX^C0CXPATH("GXML")
     85        ;;>>?GXML("//FIRST/SECOND")="2^12"
     86        ;;>>?GXML("//FIRST/SECOND/THIRD")="3^9"
     87        ;;>>?GXML("//FIRST/SECOND/THIRD/FIFTH")="5^7"
     88        ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^4^@@DATA1@@"
     89        ;;>>?GXML("//FIRST/SECOND/THIRD/SIXTH")="8^8^"
     90        ;;>>?GXML("//FIRST/SECOND")="2^12"
     91        ;;>>?GXML("//FIRST")="1^13"
     92        ;;><INDEX2>
     93        ;;>>>D ZTEST^C0CXPATH("INITXML2")
     94        ;;>>>D INDEX^C0CXPATH("GXML")
     95        ;;>>?GXML("//FIRST/SECOND")="2^12"
     96        ;;>>?GXML("//FIRST/SECOND/_SECOND")="9^11"
     97        ;;>>?GXML("//FIRST/SECOND/_SECOND/FOURTH")="10^10^DATA3"
     98        ;;>>?GXML("//FIRST/SECOND/THIRD")="3^8"
     99        ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH[1]")="4^4^DATA1"
     100        ;;>>?GXML("//FIRST")="1^13"
     101        ;;><MISSING>
     102        ;;>>>D ZTEST^C0CXPATH("INITXML")
     103        ;;>>>S OUTARY="^TMP($J,""MISSINGTEST"")"
     104        ;;>>>D MISSING^C0CXPATH("GXML",OUTARY)
     105        ;;>>?@OUTARY@(1)="DATA1"
     106        ;;>>?@OUTARY@(2)="DATA2"
     107        ;;><MAP>
     108        ;;>>>D ZTEST^C0CXPATH("INITXML")
     109        ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")"
     110        ;;>>>S OUTARY="^TMP($J,""MAPTEST"")"
     111        ;;>>>S @MAPARY@("DATA2")="VALUE2"
     112        ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY)
     113        ;;>>?@OUTARY@(6)="VALUE2"
     114        ;;><MAP2>
     115        ;;>>>D ZTEST^C0CXPATH("INITXML")
     116        ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")"
     117        ;;>>>S OUTARY="^TMP($J,""MAPTEST"")"
     118        ;;>>>S @MAPARY@("DATA1")="VALUE1"
     119        ;;>>>S @MAPARY@("DATA2")="VALUE2"
     120        ;;>>>S @MAPARY@("DATA3")="VALUE3"
     121        ;;>>>S GXML(4)="<FOURTH>@@DATA1@@ AND @@DATA3@@</FOURTH>"
     122        ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY)
     123        ;;>>>D PARY^C0CXPATH(OUTARY)
     124        ;;>>?@OUTARY@(4)="<FOURTH>VALUE1 AND VALUE3</FOURTH>"
     125        ;;><QUEUE>
     126        ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",2,3)
     127        ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",4,5)
     128        ;;>>?$P(BTLIST(2),";",2)=4
     129        ;;><BUILD>
     130        ;;>>>D ZTEST^C0CXPATH("INITXML")
     131        ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FOURTH","G2")
     132        ;;>>>D ZTEST^C0CXPATH("QUEUE")
     133        ;;>>>D BUILD^C0CXPATH("BTLIST","G3")
     134        ;;><CP>
     135        ;;>>>D ZTEST^C0CXPATH("INITXML")
     136        ;;>>>D CP^C0CXPATH("GXML","G2")
     137        ;;>>?G2(0)=13
     138        ;;><QOPEN>
     139        ;;>>>K G2,GBL
     140        ;;>>>D ZTEST^C0CXPATH("INITXML")
     141        ;;>>>D QOPEN^C0CXPATH("GBL","GXML")
     142        ;;>>?$P(GBL(1),";",3)=12
     143        ;;>>>D BUILD^C0CXPATH("GBL","G2")
     144        ;;>>?G2(G2(0))="</SECOND>"
     145        ;;><QOPEN2>
     146        ;;>>>K G2,GBL
     147        ;;>>>D ZTEST^C0CXPATH("INITXML")
     148        ;;>>>D QOPEN^C0CXPATH("GBL","GXML","//FIRST/SECOND")
     149        ;;>>?$P(GBL(1),";",3)=11
     150        ;;>>>D BUILD^C0CXPATH("GBL","G2")
     151        ;;>>?G2(G2(0))="</SECOND>"
     152        ;;><QCLOSE>
     153        ;;>>>K G2,GBL
     154        ;;>>>D ZTEST^C0CXPATH("INITXML")
     155        ;;>>>D QCLOSE^C0CXPATH("GBL","GXML")
     156        ;;>>?$P(GBL(1),";",3)=13
     157        ;;>>>D BUILD^C0CXPATH("GBL","G2")
     158        ;;>>?G2(G2(0))="</FIRST>"
     159        ;;><QCLOSE2>
     160        ;;>>>K G2,GBL
     161        ;;>>>D ZTEST^C0CXPATH("INITXML")
     162        ;;>>>D QCLOSE^C0CXPATH("GBL","GXML","//FIRST/SECOND/THIRD")
     163        ;;>>?$P(GBL(1),";",3)=13
     164        ;;>>>D BUILD^C0CXPATH("GBL","G2")
     165        ;;>>?G2(G2(0))="</FIRST>"
     166        ;;>>?G2(1)="</THIRD>"
     167        ;;><INSERT>
     168        ;;>>>K G2,GBL,G3,G4
     169        ;;>>>D ZTEST^C0CXPATH("INITXML")
     170        ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2")
     171        ;;>>>D INSERT^C0CXPATH("GXML","G2","//FIRST/SECOND/THIRD")
     172        ;;>>>D INSERT^C0CXPATH("G3","G2","//")
     173        ;;>>?G2(1)=GXML(9)
     174        ;;><REPLACE>
     175        ;;>>>K G2,GBL,G3
     176        ;;>>>D ZTEST^C0CXPATH("INITXML")
     177        ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2")
     178        ;;>>>D REPLACE^C0CXPATH("GXML","G2","//FIRST/SECOND")
     179        ;;>>?GXML(2)="<FIFTH>"
     180        ;;><INSINNER>
     181        ;;>>>K GXML,G2,GBL,G3
     182        ;;>>>D ZTEST^C0CXPATH("INITXML")
     183        ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2")
     184        ;;>>>D INSINNER^C0CXPATH("GXML","G2","//FIRST/SECOND/THIRD")
     185        ;;>>?GXML(10)="<FIFTH>"
     186        ;;><INSINNER2>
     187        ;;>>>K GXML,G2,GBL,G3
     188        ;;>>>D ZTEST^C0CXPATH("INITXML")
     189        ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2")
     190        ;;>>>D INSINNER^C0CXPATH("G2","G2")
     191        ;;>>?G2(8)="<FIFTH>"
     192        ;;><PUSHA>
     193        ;;>>>K GTMP,GTMP2
     194        ;;>>>N GTMP,GTMP2
     195        ;;>>>D PUSH^C0CXPATH("GTMP","A")
     196        ;;>>>D PUSH^C0CXPATH("GTMP2","B")
     197        ;;>>>D PUSH^C0CXPATH("GTMP2","C")
     198        ;;>>>D PUSHA^C0CXPATH("GTMP","GTMP2")
     199        ;;>>?GTMP(3)="C"
     200        ;;>>?GTMP(0)=3
     201        ;;><H2ARY>
     202        ;;>>>K GTMP,GTMP2
     203        ;;>>>S GTMP("TEST1")=1
     204        ;;>>>D H2ARY^C0CXPATH("GTMP2","GTMP")
     205        ;;>>?GTMP2(0)=1
     206        ;;>>?GTMP2(1)="^TEST1^1"
     207        ;;><XVARS>
     208        ;;>>>K GTMP,GTMP2
     209        ;;>>>D PUSH^C0CXPATH("GTMP","<VALUE>@@VAR1@@</VALUE>")
     210        ;;>>>D XVARS^C0CXPATH("GTMP2","GTMP")
     211        ;;>>?GTMP2(1)="^VAR1^1"
     212        ;;></TEST>

  • ccr/branches/ohum/p/C0CXPATH.m

    r1342 r1428  
    1 C0CXPATH   ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
    2  ;;1.0;C0C;;May 19, 2009;Build 2
    3  ;Copyright 2008 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  ;
     1C0CXPATH          ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
     2        ;;1.2;C0C;;May 11, 2012;Build 46
     3        ;Copyright 2008 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
     598        ;
     599DOFLD   ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE
     600        ;
     601        Q
     602        ;
     603TRIM(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        ;
     641UNMARK(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        ;
     649PARY(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        ;
     657H2ARY(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        ;
     683XVARS(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        ;
     694DXVARS(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        ;
     710TEST        ; Run all the test cases
     711        D TESTALL^C0CUNIT("C0CXPAT0")
     712        Q
     713        ;
     714ZTEST(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        ;
     721TLIST     ; LIST THE TESTS
     722        N ZTMP
     723        D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
     724        D TLIST^C0CUNIT(.ZTMP)
     725        Q
     726        ;
Note: See TracChangeset for help on using the changeset viewer.