Changeset 1337 for ccr/branches/ohum


Ignore:
Timestamp:
Jan 4, 2012, 9:40:24 PM (13 years ago)
Author:
George Lilly
Message:

certification version without tabs

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

Legend:

Unmodified
Added
Removed

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

    r1333 r1337  
    1 C0CACTOR        ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CALERT        ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CBAT    ; CCDCCR/GPL - CCR Batch utilities; 4/21/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "This is the CCR 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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CCCD    ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

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

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

    r1333 r1337  
    1 C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CCMT  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10
    2         ;;1.0;C0C;;May 21, 2010;Build 1
    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.0;C0C;;May 21, 2010;Build 38
     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

    r1333 r1337  
    1 C0CCPT  ;;BSL;RETURN CPT DATA;
    2         ;Sequence Managers Software GPL;;;;;Build 1
    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         ;OHUM/RUT 3111228 Date Range for Notes
    22                S STDT=^TMP("C0CCCR","TIULIMIT") D NOW^%DTC S ENDDT=X
    23                ;OHUM/RUT
    24                S Z=""
    25                F  S Z=$O(NOTE(Z)) Q:Z=""  D
    26                . S DT=$P(^TIU(8925,Z,0),U,7)
    27                . I $G(STDT)]"" D
    28                .. I STDT>DT S NOTE(Z)="D"  ;SET NOTE TO BE DELETED
    29                . I $G(ENDDT)]"" D
    30                .. I ENDDT<DT S NOTE(Z)="D"
    31                . I NOTE(Z)="D" K NOTE(Z)
    32         D VISIT
    33                Q
    34 VISIT     ;GET VISIT INFO FOR A GIVEN NOTE. BUILD INTO RETURN ARRAY .VISIT
    35         S ILST=1,X0="",X12="",VISIT="",LST="",X811=""
    36         S IEN=""  F  S IEN=$O(NOTE(IEN)) Q:IEN=""  D
    37         . S X0=^TIU(8925,IEN,0),X12=$G(^(12))
    38         . S VISIT=$P(X12,U,7)
    39         . I 'VISIT S VISIT=$P(X0,U,3)
    40         . K ^TMP("PXKENC",$J)
    41         . Q:VISIT=""!(VISIT'>0)
    42         . D ENCEVENT^PXKENC(VISIT,1)
    43         . I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q
    44         . S IPRV=0 F  S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV  D
    45         .. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0)
    46         .. ;Q:$P(X0,U,4)'="P"
    47         .. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U)
    48         .. S PRIM=($P(X0,U,4)="P")
    49         .. S ILST=ILST+1
    50         .. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM
    51         .. S VISIT(IEN,"PRV",ILST)=CODE_"^^^"_NARR_"^"_PRIM
    52         . S IPOV=0 F  S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV  D
    53         .. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811))
    54         .. S CODE=$P(X0,U)
    55         .. S:CODE CODE=$P(^ICD9(CODE,0),U)
    56         .. S CAT=$P(X802,U)
    57         .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
    58         .. S NARR=$P(X0,U,4)
    59         .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
    60         .. S PRIM=($P(X0,U,12)="P")
    61         .. S PRV=$P(X12,U,4)
    62         .. S ILST=ILST+1
    63         .. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV
    64         .. S VISIT(IEN,"POV",ILST)=CODE_U_CAT_U_NARR_U_PRIM_U_PRV
    65         . S ICPT=0 F  S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT  D
    66         .. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811))
    67         .. ;S CODE=$P(X0,U)
    68         .. S CODE=$O(^ICPT("B",$P(X0,U),0))
    69         .. S:CODE CODE=$P(^ICPT(CODE,0),U)
    70         .. S CAT=$P(X802,U)
    71         .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
    72         .. S NARR=$P(X0,U,4)
    73         .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
    74         .. S QTY=$P(X0,U,16)
    75         .. S PRV=$P(X12,U,4)
    76         .. S MCNT=0,MIDX=0,MODS=""
    77         .. F  S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX  D
    78         ... S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0))
    79         ... I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN
    80         .. I +MCNT S MODS=MCNT_MODS
    81         .. S ILST=ILST+1
    82         .. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
    83         .. S VISIT(IEN,"CPT",ILST)=CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
    84         . S VISIT(IEN,"DATE",0)=$P($P(^TIU(8925,IEN,0),U,7),".")
    85         . S VISIT(IEN,"CLASS")=$$GET1^DIQ(8925,IEN_",",.04) ;GPL 5/21/10
    86         . I $G(TXT)=1 D GETNOTE(IEN)
    87         Q
    88 GETNOTE(IEN)    ;GET THE TEXT THAT GOES WITH VISIT
    89         ;EXTRACT NOTE TEXT FROM ^TIU(8925,IEN,"TEXT"
    90         Q:'$D(VISIT(IEN,"CPT"))
    91         S TXTCNT=0
    92         F  S TXTCNT=TXTCNT+1 Q:'$D(^TIU(8925,IEN,"TEXT",TXTCNT,0))  D
    93         . S VISIT(IEN,"TEXT",TXTCNT)=^TIU(8925,IEN,"TEXT",TXTCNT,0)
    94         Q
     1C0CCPT ;;BSL;RETURN CPT DATA;
     2 ;Sequence Managers Software GPL;;;;;Build 38
     3 ;Copied into C0C namespace from SQMCPT with permission from
     4 ;Brian Lord - and with our thanks. gpl 01/20/2010
     5ENTRY(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        S Z=""
     22        F  S Z=$O(NOTE(Z)) Q:Z=""  D
     23        . S DT=$P(^TIU(8925,Z,0),U,7)
     24        . I $G(STDT)]"" D
     25        .. I STDT>DT S NOTE(Z)="D"  ;SET NOTE TO BE DELETED
     26        . I $G(ENDDT)]"" D
     27        .. I ENDDT<DT S NOTE(Z)="D"
     28        . I NOTE(Z)="D" K NOTE(Z)
     29 D VISIT
     30        Q
     31VISIT   ;GET VISIT INFO FOR A GIVEN NOTE. BUILD INTO RETURN ARRAY .VISIT
     32 S ILST=1,X0="",X12="",VISIT="",LST="",X811=""
     33 S IEN=""  F  S IEN=$O(NOTE(IEN)) Q:IEN=""  D
     34 . S X0=^TIU(8925,IEN,0),X12=$G(^(12))
     35 . S VISIT=$P(X12,U,7)
     36 . I 'VISIT S VISIT=$P(X0,U,3)
     37 . K ^TMP("PXKENC",$J)
     38 . Q:VISIT=""!(VISIT'>0)
     39 . D ENCEVENT^PXKENC(VISIT,1)
     40 . I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q
     41 . S IPRV=0 F  S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV  D
     42 .. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0)
     43 .. ;Q:$P(X0,U,4)'="P"
     44 .. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U)
     45 .. S PRIM=($P(X0,U,4)="P")
     46 .. S ILST=ILST+1
     47 .. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM
     48 .. S VISIT(IEN,"PRV",ILST)=CODE_"^^^"_NARR_"^"_PRIM
     49 . S IPOV=0 F  S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV  D
     50 .. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811))
     51 .. S CODE=$P(X0,U)
     52 .. S:CODE CODE=$P(^ICD9(CODE,0),U)
     53 .. S CAT=$P(X802,U)
     54 .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
     55 .. S NARR=$P(X0,U,4)
     56 .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
     57 .. S PRIM=($P(X0,U,12)="P")
     58 .. S PRV=$P(X12,U,4)
     59 .. S ILST=ILST+1
     60 .. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV
     61 .. S VISIT(IEN,"POV",ILST)=CODE_U_CAT_U_NARR_U_PRIM_U_PRV
     62 . S ICPT=0 F  S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT  D
     63 .. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811))
     64 .. ;S CODE=$P(X0,U)
     65 .. S CODE=$O(^ICPT("B",$P(X0,U),0))
     66 .. S:CODE CODE=$P(^ICPT(CODE,0),U)
     67 .. S CAT=$P(X802,U)
     68 .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
     69 .. S NARR=$P(X0,U,4)
     70 .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
     71 .. S QTY=$P(X0,U,16)
     72 .. S PRV=$P(X12,U,4)
     73 .. S MCNT=0,MIDX=0,MODS=""
     74 .. F  S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX  D
     75 ... S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0))
     76 ... I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN
     77 .. I +MCNT S MODS=MCNT_MODS
     78 .. S ILST=ILST+1
     79 .. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
     80 .. S VISIT(IEN,"CPT",ILST)=CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
     81 . S VISIT(IEN,"DATE",0)=$P($P(^TIU(8925,IEN,0),U,7),".")
     82 . S VISIT(IEN,"CLASS")=$$GET1^DIQ(8925,IEN_",",.04) ;GPL 5/21/10
     83 . I $G(TXT)=1 D GETNOTE(IEN)
     84 Q
     85GETNOTE(IEN) ;GET THE TEXT THAT GOES WITH VISIT
     86 ;EXTRACT NOTE TEXT FROM ^TIU(8925,IEN,"TEXT"
     87 Q:'$D(VISIT(IEN,"CPT"))
     88 S TXTCNT=0
     89 F  S TXTCNT=TXTCNT+1 Q:'$D(^TIU(8925,IEN,"TEXT",TXTCNT,0))  D
     90 . S VISIT(IEN,"TEXT",TXTCNT)=^TIU(8925,IEN,"TEXT",TXTCNT,0)
     91 Q

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

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

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

    r1333 r1337  
    1 C0CDOM    ; GPL - DOM PROCESSING ROUTINES ;6/6/11  17:05
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21         ;
    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 ;;0.1;C0C;nopatch;noreleasedate;Build 38
     3 ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 Q
     21 ;
     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

    r1333 r1337  
    1 C0CDPT  ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CENC  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10
    2         ;;1.0;C0C;;May 21, 2010;Build 1
    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.0;C0C;;May 21, 2010;Build 38
     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

    r1333 r1337  
    1 C0CENV  ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;
     3 ;
     4 ;
     5ENV ; Does not prevent loading of the transport global.
     6 ; Environment check is done only during the install.
     7 ;
     8 N XQA,XQAMSG
     9 ;
     10 ;
     11 ; Make sure the patch name exist
     12 ;
     13 I '$D(XPDNM) D  Q
     14 . D BMES("No valid patch name exist")
     15 . S XPDQUIT=2
     16 . D EXIT
     17 ;
     18 D CHECK
     19 D EXIT
     20 Q
     21 ;
     22 ;
     23CHECK ; Perform environment check
     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

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

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

    r1333 r1337  
    1 C0CEWD    ; CCDCCR/GPL - CCR EWD utilities; 1/6/11
    2         ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
    3         ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21         ;
    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 ;;0.1;CCDCCR;nopatch;noreleasedate;Build 77
     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

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

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

    r1333 r1337  
    1 C0CFM1    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "This is the CCR FILEMAN Utility Library ",!
    21         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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CFM2    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "This is the CCR FILEMAN Utility Library ",!
    21         ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF
    22         ; CCR ELEMENTS (^C0C(179.201,
    23         ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE
    24         ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT
    25         ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS
    26         ; ALL SUB-VARIABLES HAVE BEEN REMOVED
    27         W !
    28         Q
    29         ;
    30 RIMTBL(ZWHICH)  ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE
    31         ;
    32         I '$D(RIMBASE) D ASETUP^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.0;C0C;;May 19, 2009;Build 38
     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

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

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

    r1333 r1337  
    1 C0CIM2  ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10
    2         ;;1.0;C0C;;Feb 16, 2010;Build 1
    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.0;C0C;;Feb 16, 2010;Build 38
     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

    r1333 r1337  
    1 C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CIN     ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08
    2         ;;1.0;C0C;;Sep 20, 2009;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "This is the CCR 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.0;C0C;;Sep 20, 2009;Build 38
     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

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

    r1333 r1337  
    1 C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CALABS        ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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         ;
     1C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08
     2 ;;1.0;C0C;;May 19, 2009;Build 38
     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

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

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

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

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

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

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

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

    r1333 r1337  
    1 C0CMED  ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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 QUIT
     59 ZWRITE:$G(DEBUG) MEDS
     60 N RXIEN S RXIEN=0
     61 F  S RXIEN=$O(MEDS(RXIEN)) Q: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

    r1333 r1337  
    1 C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CMED4         ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08
    2         ;;0.1;CCDCCR;;;Build 1
    3         ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4         ; General Public License See attached copy of the License.
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License along
    17         ; with this program; if not, write to the Free Software Foundation, Inc.,
    18         ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "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
     2 ;;0.1;CCDCCR;;;
     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($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

    r1333 r1337  
    1 C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    3         ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4         ; General Public License See attached copy of the License.
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License along
    17         ; with this program; if not, write to the Free Software Foundation, Inc.,
    18         ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "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.0;C0C;;May 19, 2009;
     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

    r1333 r1337  
    1 C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm
    2         ;;1.0;C0C;;Mar 8, 2011;Build 1
    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.0;C0C;;Mar 8, 2011;
     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

    r1333 r1337  
    1 C0CMXML   ; GPL - MXML based XPath utilities;10/13/09  17:05
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21         ; 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 ;;0.1;C0C;nopatch;noreleasedate;Build 38
     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

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

    r1333 r1337  
    1 C0CMXP    ; GPL - MXML based XPath utilities;12/04/09  17:05
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21         ;
    22 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 ;;0.1;C0C;nopatch;noreleasedate;Build 38
     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

    r1333 r1337  
    1 C0CNHIN   ; GPL - PROCESSING FOR OUTPUT OF NHINV ROUTINES;6/3/11  17:05
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21 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 ;;0.1;C0C;nopatch;noreleasedate;Build 38
     3 ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 Q
     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

    r1333 r1337  
    1 C0CMED  ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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         ;
     1C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
     2 ;;1.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CMED4         ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08
    2         ;;0.1;CCDCCR;;;Build 1
    3         ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4         ; General Public License See attached copy of the License.
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License along
    17         ; with this program; if not, write to the Free Software Foundation, Inc.,
    18         ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "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         ;
     1C0CMED4         ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08
     2 ;;0.1;CCDCCR;;;
     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

    r1333 r1337  
    1 C0CORSLT        ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11
    2         ;;1.0;C0C;;Jan 21, 2010;Build 1
    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.0;C0C;;Jan 21, 2010;Build 38
     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

    r1333 r1337  
    1 C0CPARMS        ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    3         ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20 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         S @C0CPARMS@("LABLIMIT")=^TMP("C0CCCR","LABLIMIT"),@C0CPARMS@("VITLIMIT")=^TMP("C0CCCR","VITLIMIT"),@C0CPARMS@("TIULIMIT")=^TMP("C0CCCR","TIULIMIT"),@C0CPARMS@("MEDLIMIT")=^TMP("C0CCCR","MEDLIMIT")
    51         I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
    52         I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
    53         I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
    54         I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
    55         I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
    56         I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=1 ; NON-PENDING NON-ACTIVE
    57         ;I '$D(@C0CPARMS@("RALIMIT")) S @C0CPARMS@("RALIMIT")="T-36500" ;ONE YR WORTH
    58         ;I '$D(@C0CPARMS@("RASTART")) S @C0CPARMS@("RASTART")="T" ;TODAY
    59         I '$D(@C0CPARMS@("TIUSTART")) S @C0CPARMS@("TIUSTART")="T" ;TODAY
    60         ;OHUM/RUT
    61         Q
    62         ;
    63 CHECK   ; CHECK TO SEE IF PARMS ARE PRESENT, ELSE RUN SET
    64         ;
    65         I '$D(C0CPARMS) S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;SHOULDN'T HAPPEN
    66         I '$D(@C0CPARMS) D SET("SETWITHCHECK:1")
    67         Q
    68         ;
    69 GET(WHICHP)     ;EXTRINSIC TO RETURN THE VALUE OF PARAMETER WHICHP
    70         ;
    71         D CHECK ; SHOULDN'T HAPPEN BUT TO BE SAFE
    72         N GTMP
    73         Q $G(@C0CPARMS@(WHICHP)) ;PULL THE PARM FROM THE TABLE
    74         ;
     1C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09
     2 ;;1.0;C0C;;May 19, 2009;Build 38
     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 I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH
     41 I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
     42 I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS
     43 I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
     44 I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
     45 I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS
     46 I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
     47 I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
     48 I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE
     49 Q
     50 ;
     51CHECK ; CHECK TO SEE IF PARMS ARE PRESENT, ELSE RUN SET
     52 ;
     53 I '$D(C0CPARMS) S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;SHOULDN'T HAPPEN
     54 I '$D(@C0CPARMS) D SET("SETWITHCHECK:1")
     55 Q
     56 ;
     57GET(WHICHP) ;EXTRINSIC TO RETURN THE VALUE OF PARAMETER WHICHP
     58 ;
     59 D CHECK ; SHOULDN'T HAPPEN BUT TO BE SAFE
     60 N GTMP
     61 Q $G(@C0CPARMS@(WHICHP)) ;PULL THE PARM FROM THE TABLE
     62 ;

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

    r1333 r1337  
    1 C0CPROBS        ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CPROC  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10
    2         ;;1.0;C0C;;Jan 21, 2010;Build 1
    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.0;C0C;;Jan 21, 2010;Build 38
     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

    r1333 r1337  
    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;;;
     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

    r1333 r1337  
    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 1
    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        ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 31
     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

    r1333 r1337  
    1 LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09
    2         ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994;Build 1
    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 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994
     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

    r1333 r1337  
    1 C0CRIMA   ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CRNF    ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "This is the 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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CRNFRPC         ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09
    2         ;;1.0;C0C;;Dec 9, 2009;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "This is the 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         ;
     1C0CRNFRPC   ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09
     2 ;;1.0;C0C;;Dec 9, 2009;
     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

    r1333 r1337  
    1 C0CRPMS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR RPMS ;1/14/09  14:33
    2         ;;0.1;CCDCCR;;JUL 16,2008;Build 1
    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 ;;0.1;CCDCCR;;JUL 16,2008;Build 7
     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

    r1333 r1337  
    1 C0CRXN    ; CCDCCR/GPL - CCR RXN utilities; 12/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "This is the CCR 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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CRXNRD        ; WV/SMH - CCR/CCD PROJECT: Routine to Read RxNorm files;11/15/08
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    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 ;;0.1;C0C;nopatch;noreleasedate
     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

    r1333 r1337  
    1 C0CSNOA   ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/08
    2         ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
    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 ;;0.1;CCDCCR;nopatch;noreleasedate
     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

    r1333 r1337  
    1 C0CSOAP  ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CSUB1   ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "This is the CCR 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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CSYS  ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    3         ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4         ; General Public License See attached copy of the License.
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ; This program is distributed in the hope that it will be useful,
    12         ; but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ; GNU General Public License for more details.
    15         ;
    16         ; You should have received a copy of the GNU General Public License along
    17         ; with this program; if not, write to the Free Software Foundation, Inc.,
    18         ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         W "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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08
    2         ;;0.1;C0C;;Jun 15, 2008;Build 1
    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 ;;0.1;C0C;;Jun 15, 2008;Build 38
     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

    r1333 r1337  
    1 C0CVA200        ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
    2         ;;1.0;C0C;;Feb 16, 2010;Build 1
    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.0;C0C;;Feb 16, 2010;Build 38
     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

    r1333 r1337  
    1 C0CVITAL        ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    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 1
    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 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994
     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

    r1333 r1337  
    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 1
    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
     2 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
     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

    r1333 r1337  
    1 C0CXEWD   ; C0C/GPL - EWD based XPath utilities; 10/11/09
    2         ;;0.1;C0C;nopatch;noreleasedate;Build 1
    3         ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
    4         ;General Public License See attached copy of the License.
    5         ;
    6         ;This program is free software; you can redistribute it and/or modify
    7         ;it under the terms of the GNU General Public License as published by
    8         ;the Free Software Foundation; either version 2 of the License, or
    9         ;(at your option) any later version.
    10         ;
    11         ;This program is distributed in the hope that it will be useful,
    12         ;but WITHOUT ANY WARRANTY; without even the implied warranty of
    13         ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14         ;GNU General Public License for more details.
    15         ;
    16         ;You should have received a copy of the GNU General Public License along
    17         ;with this program; if not, write to the Free Software Foundation, Inc.,
    18         ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19         ;
    20         Q
    21         ;
    22 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 ;;0.1;C0C;nopatch;noreleasedate
     3 ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
     4 ;General Public License See attached copy of the License.
     5 ;
     6 ;This program is free software; you can redistribute it and/or modify
     7 ;it under the terms of the GNU General Public License as published by
     8 ;the Free Software Foundation; either version 2 of the License, or
     9 ;(at your option) any later version.
     10 ;
     11 ;This program is distributed in the hope that it will be useful,
     12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
     13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14 ;GNU General Public License for more details.
     15 ;
     16 ;You should have received a copy of the GNU General Public License along
     17 ;with this program; if not, write to the Free Software Foundation, Inc.,
     18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     19 ;
     20 Q
     21 ;
     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

    r1333 r1337  
    1 C0CXPAT0          ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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

    r1333 r1337  
    1 C0CXPATH          ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
    2         ;;1.0;C0C;;May 19, 2009;Build 1
    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.0;C0C;;May 19, 2009;Build 38
     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.