Changeset 1206 for ccr/trunk

Timestamp:

Jul 15, 2011, 4:47:06 PM (13 years ago)

Author:

George Lilly

Message:

removed tabs after certification

Location:

ccr/trunk/p

Files:

• C0CACTOR.m (modified) (1 diff)
• C0CALERT.m (modified) (1 diff)
• C0CBAT.m (modified) (1 diff)
• C0CCCD.m (modified) (1 diff)
• C0CCCD1.m (modified) (1 diff)
• C0CCCR.m (modified) (1 diff)
• C0CCCR0.m (modified) (1 diff)
• C0CCMT.m (modified) (1 diff)
• C0CCPT.m (modified) (1 diff)
• C0CDPT.m (modified) (1 diff)
• C0CENC.m (modified) (1 diff)
• C0CEWD.m (modified) (1 diff)
• C0CFM1.m (modified) (1 diff)
• C0CFM2.m (modified) (1 diff)
• C0CIM2.m (modified) (1 diff)
• C0CIMMU.m (modified) (1 diff)
• C0CIN.m (modified) (1 diff)
• C0CLABS.m (modified) (1 diff)
• C0CMAIL2.m (modified) (1 diff)
• C0CMAIL3.m (modified) (1 diff)
• C0CMED.m (modified) (1 diff)
• C0CMED1.m (modified) (1 diff)
• C0CMED2.m (modified) (1 diff)
• C0CMED3.m (modified) (1 diff)
• C0CMXML.m (modified) (1 diff)
• C0CMXP.m (modified) (1 diff)
• C0CORSLT.m (modified) (1 diff)
• C0CPARMS.m (modified) (1 diff)
• C0CPROBS.m (modified) (1 diff)
• C0CPROC.m (modified) (1 diff)
• C0CRIMA.m (modified) (1 diff)
• C0CRNF.m (modified) (1 diff)
• C0CRXN.m (modified) (1 diff)
• C0CSOAP.m (modified) (1 diff)
• C0CSUB1.m (modified) (1 diff)
• C0CSYS.m (modified) (1 diff)
• C0CUNIT.m (modified) (1 diff)
• C0CUTIL.m (modified) (2 diffs)
• C0CVA200.m (modified) (1 diff)
• C0CVIT2.m (modified) (1 diff)
• C0CVITAL.m (modified) (1 diff)
• C0CXPAT0.m (modified) (1 diff)
• C0CXPATH.m (modified) (1 diff)

ccr/trunk/p/C0CACTOR.m

@@ -1 @@
-C0CACTOR         ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008,2009 George Lilly, University of Minnesota.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ; This program is free software; you can redistribute it and/or modify
-        ; it under the terms of the GNU General Public License as published by
-        ; the Free Software Foundation; either version 2 of the License, or
-        ; (at your option) any later version.
-        ;
-        ; This program is distributed in the hope that it will be useful,
-        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ; GNU General Public License for more details.
-        ;
-        ; You should have received a copy of the GNU General Public License along
-        ; with this program; if not, write to the Free Software Foundation, Inc.,
-        ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        ;  PROCESS THE ACTORS SECTION OF THE CCR
-        ;
-        ; ===Revision History===
-        ; 0.1 Initial Writing of Skeleton--GPL
-        ; 0.2 Patient Data Extraction--SMH
-        ; 0.3 Information System Info Extraction--SMH
-        ; 0.4 Patient data rouine refactored; adjustments here--SMH
-        ;
-EXTRACT(IPXML,ALST,AXML)        ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE
-        ; IPXML is the Input Actor Template into which we  substitute values
-        ; This is straight XML. Values to be substituted are in @@VAL@@ format.
-        ; ALST is the actor list global generated by ACTLST^C0CCCR and has format:
-        ; ^TMP(7542,1,"ACTORS",0)=Count
-        ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN"
-        ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM"
-        ; AXML is the output arrary, to contain XML.
-        ;
-        N I,J,AMAP,AOID,ATYP,AIEN
-        D CP^C0CXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML
-        D REPLACE^C0CXPATH(AXML,"","//Actors") ; DELETE THE INSIDES
-        I DEBUG W "PROCESSING ACTORS ",!
-        F I=1:1:@ALST@(0) D  ; PROCESS ALL ACTORS IN THE LIST
-        . I @ALST@(I)["@@" Q  ; NOT A VALID ACTOR
-        . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID
-        . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE
-        . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER
-        . I AIEN="" D  Q  ; IEN CAN'T BE NULL
-        . . W "WARING NUL ACTOR: ",ATYP,!
-        . I ATYP="" Q  ; NOT A VALID ACTOR
-        . ;
-        . I DEBUG W AOID_" "_ATYP_" "_AIEN,!
-        . I ATYP="PATIENT" D  ; PATIENT ACTOR TYPE
-        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP")
-        . . D PATIENT("ATMP",AIEN,AOID,"ATMP2")
-        . ;
-        . I ATYP="SYSTEM" D  ; SYSTEM ACTOR TYPE
-        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP")
-        . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2")
-        . ;
-        . I ATYP="NOK" D  ; NOK ACTOR TYPE
-        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP")
-        . . D NOK("ATMP",AIEN,AOID,"ATMP2")
-        . ;
-        . I ATYP="PROVIDER" D  ; PROVIDER ACTOR TYPE
-        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP")
-        . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2")
-        . ;
-        . I ATYP="ORGANIZATION" D  ; PROVIDER ACTOR TYPE
-        . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP")
-        . . D ORG("ATMP",AIEN,AOID,"ATMP2")
-        . ;
-        . W "PROCESSING:",ATYP," ",AIEN,!
-        . ;I @ATMP2@(0)=0 Q  ; NOTHING RETURNED, SKIP THIS ONE
-        . D INSINNER^C0CXPATH(AXML,"ATMP2") ; INSERT INTO ROOT
-        . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE
-        ;
-        N ACTTMP
-        D MISSING^C0CXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS
-        I ACTTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
-        . ; STRINGS MARKED AS @@X@@
-        . W "ACTORS Missing list: ",!
-        . F I=1:1:ACTTMP(0) W ACTTMP(I),!
-        Q
-        ;
-PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR
-        I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,!
-        ;GPL SEPARATED EXTRACT FROM MAP FOR PROCESSING PATIENTS - TO MAKE
-        ; CODE REUSABLE FROM ERX
-        N AMAP
-        S AMAP=$NA(^TMP($J,"AMAP"))
-        K @AMAP
-        D PEXTRACT(AMAP,AIEN,AOID) ;EXTRACT THE PATIENT ACTOR
-        I $P($$SITE^VASITE(),U,2)="OROVILLE HOSPITAL" S C0CDE=1
-        I $G(C0CDE)'="" D DEIDENT(AMAP,AIEN) ; DEIDENTIFY THE CCR
-        D MAP(INXML,AMAP,OUTXML) ;MAP TO XML
-        K @AMAP ; CLEAN UP BEHIND US
-        Q
-        ;
-DEIDENT(GPL,ZDFN)       ; QUICK WAY TO DEIDENTIFY THE CCR
-        S @GPL@("ACTORADDRESSCITY")="ALTON"
-        S @GPL@("ACTORADDRESSLINE1")="1234 Somewhere Lane"
-        S @GPL@("ACTORADDRESSLINE2")=""
-        S @GPL@("ACTORADDRESSSOURCEID")="ACTORPATIENT_"_ZDFN
-        S @GPL@("ACTORADDRESSSTATE")="KANSAS"
-        S @GPL@("ACTORADDRESSTYPE")="Home"
-        S @GPL@("ACTORADDRESSZIPCODE")=67623
-        S @GPL@("ACTORCELLTEL")=""
-        S @GPL@("ACTORCELLTELTEXT")=""
-        S @GPL@("ACTORDATEOFBIRTH")="1957-12-25"
-        S @GPL@("ACTOREMAIL")=""
-        S @GPL@("ACTORFAMILYNAME")="ZZ PATIENT"_ZDFN
-        ;S @GPL@("ACTORGENDER")="MALE"
-        S @GPL@("ACTORGIVENNAME")="TEST"_ZDFN
-        S @GPL@("ACTORIEN")=2
-        S @GPL@("ACTORMIDDLENAME")="TWO"
-        S @GPL@("ACTOROBJECTID")="ACTORPATIENT_"_ZDFN
-        S @GPL@("ACTORRESTEL")="888-555-1212"
-        S @GPL@("ACTORRESTELTEXT")="Residential Telephone"
-        S @GPL@("ACTORSOURCEID")="ACTORSYSTEM_1"
-        S @GPL@("ACTORSSN")="769122557P"
-        S @GPL@("ACTORSSNSOURCEID")="ACTORPATIENT_"_ZDFN
-        S @GPL@("ACTORSSNTEXT")="SSN"
-        S @GPL@("ACTORSUFFIXNAME")=""
-        S @GPL@("ACTORWORKTEL")="888-121-1212"
-        S @GPL@("ACTORWORKTELTEXT")="Work Telephone"
-        Q
-        ;
-PEXTRACT(AMAP,AIEN,AOID)        ; EXTRACT TO RETURN ARRAY RARY PASSED BY NAME
-        N ZX
-        S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
-        S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CDPT(AIEN)
-        S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CDPT(AIEN)
-        S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CDPT(AIEN)
-        S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^C0CDPT(AIEN)
-        S @AMAP@("ACTORGENDER")=$P($$GENDER^C0CDPT(AIEN),U,2)
-        S @AMAP@("ACTORGENDERCODE")=$P($$GENDER^C0CDPT(AIEN),U,1)
-        S @AMAP@("ACTORSSN")=""
-        S @AMAP@("ACTORSSNTEXT")=""
-        S @AMAP@("ACTORSSNSOURCEID")=""
-        S X="MSCDPTID" ; ROUTINE TO TEST FOR MRN ON OPENVISTA
-        X ^%ZOSF("TEST") ; TEST TO SEE IF THE ROUTINE EXISTS
-        I $T S MRN=$$^MSCDPTID(DFN) ;TEST FOR MRN ON OPENVISTA ;GPL
-        I $G(MRN)'="" D  ; IF MRN IS PRESENT
-        . S @AMAP@("ACTORSSN")=MRN
-        . S @AMAP@("ACTORSSNTEXT")="MRN"
-        . S @AMAP@("ACTORSSNSOURCEID")=AOID
-        E  D  ; NO MRN, USE SSN
-        . S ZX=$$SSN^C0CDPT(AIEN)
-        . I ZX'="" D  ; IF THERE IS A SSN IN THE RECORD
-        . . S @AMAP@("ACTORSSN")=ZX
-        . . S @AMAP@("ACTORSSNTEXT")="SSN"
-        . . S @AMAP@("ACTORSSNSOURCEID")=AOID
-        S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^C0CDPT(AIEN)
-        S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^C0CDPT(AIEN)
-        S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^C0CDPT(AIEN)
-        S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CDPT(AIEN)
-        S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CDPT(AIEN)
-        S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^C0CDPT(AIEN)
-        S @AMAP@("ACTORRESTEL")=""
-        S @AMAP@("ACTORRESTELTEXT")=""
-        S ZX=$$RESTEL^C0CDPT(AIEN)
-        I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
-        . S @AMAP@("ACTORRESTEL")=ZX
-        . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone"
-        S @AMAP@("ACTORWORKTEL")=""
-        S @AMAP@("ACTORWORKTELTEXT")=""
-        S ZX=$$WORKTEL^C0CDPT(AIEN)
-        I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
-        . S @AMAP@("ACTORWORKTEL")=ZX
-        . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone"
-        S @AMAP@("ACTORCELLTEL")=""
-        S @AMAP@("ACTORCELLTELTEXT")=""
-        S ZX=$$CELLTEL^C0CDPT(AIEN)
-        I ZX'="" D  ; IF THERE IS A CELL PHONE IN THE RECORD
-        . S @AMAP@("ACTORCELLTEL")=ZX
-        . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone"
-        S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CDPT(AIEN)
-        S @AMAP@("ACTORADDRESSSOURCEID")=AOID
-        S @AMAP@("ACTORIEN")=AIEN
-        S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX
-        S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
-        Q
-        ;
-MAP(INXML,AMAP,OUTXML)  ;MAP ANY ACTOR TO XML
-        D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
-        Q
-        ;
-SYSTEM(INXML,AIEN,AOID,OUTXML)  ; PROCESS A SYSTEM ACTOR
-            ;
-            ; N AMAP
-            S AMAP=$NA(^TMP($J,"AMAP"))
-            K @AMAP
-            S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
-            S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^C0CSYS
-            S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^C0CSYS
-            S @AMAP@("ACTORINFOSYSSOURCEID")=AOID
-            D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
-            Q
-            ;
-NOK(INXML,AIEN,AOID,OUTXML)     ; PROCESS A NEXT OF KIN TYPE ACTOR
-            ;
-            ; N AMAP
-            S AMAP=$NA(^TMP($J,"AMAP"))
-            K @AMAP
-            S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
-            S @AMAP@("ACTORDISPLAYNAME")=""
-            S @AMAP@("ACTORRELATION")=""
-            S @AMAP@("ACTORRELATIONSOURCEID")=""
-            S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
-            D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
-            Q
-            ;
-ORG(INXML,AIEN,AOID,OUTXML)     ; PROCESS AN ORGANIZATION TYPE ACTOR
-            ;
-            N AMAP,ZIEN,ZSITE
-            S AMAP=$NA(^TMP($J,"AMAP"))
-            K @AMAP
-            S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
-            S ZSITE=$$SITE^VASITE ; SITE FORMAT IEN^NAME^DATE
-            S ZIEN=$P(ZSITE,"^",1)
-            S @AMAP@("ORGANIZATIONNAME")=$P(ZSITE,U,2)
-            S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1"
-            S @AMAP@("ACTORADDRESSTYPE")="Office"
-            S @AMAP@("ACTORADDRESSLINE1")=$$GET1^DIQ(4,ZIEN_",",1.01)
-            S @AMAP@("ACTORADDRESSLINE2")=$$GET1^DIQ(4,ZIEN_",",1.02)
-            S @AMAP@("ACTORADDRESSCITY")=$$GET1^DIQ(4,ZIEN_",",1.03)
-            S @AMAP@("ACTORADDRESSSTATE")=$$GET1^DIQ(4,ZIEN_",",.02)
-            S @AMAP@("ACTORPOSTALCODE")=$$GET1^DIQ(4,ZIEN_",",1.04)
-            S @AMAP@("ACTORTELEPHONE")=""
-            S @AMAP@("ACTORTELEPHONETYPE")=""
-            S ZX=$$GET1^DIQ(4.03,"1,"_ZIEN_",",.03)
-            I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
-            . S @AMAP@("ACTORTELEPHONE")=ZX
-            . S @AMAP@("ACTORTELEPHONETYPE")="Office"
-            D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
-            K @AMAP
-            Q
-            ;
-PROVIDER(INXML,AIEN,AOID,OUTXML)        ; PROCESS A PROVIDER TYPE ACTOR
-            ;
-            ; N AMAP
-            S AMAP=$NA(^TMP($J,"AMAP"))
-            K @AMAP
-            I '$D(^VA(200,AIEN,0)) D  Q  ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN)
-            . W "WARNING - MISSING PROVIDER: ",AIEN,!
-            . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT
-            S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
-            S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CVA200(AIEN)
-            S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CVA200(AIEN)
-            S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CVA200(AIEN)
-            S @AMAP@("ACTORTITLE")=$$TITLE^C0CVA200(AIEN)
-            S @AMAP@("IDTYPE")=$P($$NPI^C0CVA200(AIEN),U,1)
-            S @AMAP@("ID")=$P($$NPI^C0CVA200(AIEN),U,2)
-            S @AMAP@("IDDESC")=$P($$NPI^C0CVA200(AIEN),U,3)
-            S @AMAP@("ACTORSPECIALITY")=$$SPEC^C0CVA200(AIEN)
-            S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^C0CVA200(AIEN)
-            S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^C0CVA200(AIEN)
-            S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CVA200(AIEN)
-            S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CVA200(AIEN)
-            S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^C0CVA200(AIEN)
-            S @AMAP@("ACTORTELEPHONE")=""
-            S @AMAP@("ACTORTELEPHONETYPE")=""
-            S ZX=$$TEL^C0CVA200(AIEN)
-            I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
-            . S @AMAP@("ACTORTELEPHONE")=ZX
-            . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^C0CVA200(AIEN)
-            S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CVA200(AIEN)
-            S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1"
-            S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
-            S @AMAP@("ACTORORGLINK")="ACTORORGANIZATION_1"
-            D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
-            Q
-            ;
+C0CACTOR  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008,2009 George Lilly, University of Minnesota.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License along
+ ; with this program; if not, write to the Free Software Foundation, Inc.,
+ ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ ;  PROCESS THE ACTORS SECTION OF THE CCR
+ ;
+ ; ===Revision History===
+ ; 0.1 Initial Writing of Skeleton--GPL
+ ; 0.2 Patient Data Extraction--SMH
+ ; 0.3 Information System Info Extraction--SMH
+ ; 0.4 Patient data rouine refactored; adjustments here--SMH
+ ;
+EXTRACT(IPXML,ALST,AXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE
+ ; IPXML is the Input Actor Template into which we  substitute values
+ ; This is straight XML. Values to be substituted are in @@VAL@@ format.
+ ; ALST is the actor list global generated by ACTLST^C0CCCR and has format:
+ ; ^TMP(7542,1,"ACTORS",0)=Count
+ ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN"
+ ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM"
+ ; AXML is the output arrary, to contain XML.
+ ;
+ N I,J,AMAP,AOID,ATYP,AIEN
+ D CP^C0CXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML
+ D REPLACE^C0CXPATH(AXML,"","//Actors") ; DELETE THE INSIDES
+ I DEBUG W "PROCESSING ACTORS ",!
+ F I=1:1:@ALST@(0) D  ; PROCESS ALL ACTORS IN THE LIST
+ . I @ALST@(I)["@@" Q  ; NOT A VALID ACTOR
+ . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID
+ . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE
+ . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER
+ . I AIEN="" D  Q  ; IEN CAN'T BE NULL
+ . . W "WARING NUL ACTOR: ",ATYP,!
+ . I ATYP="" Q  ; NOT A VALID ACTOR
+ . ;
+ . I DEBUG W AOID_" "_ATYP_" "_AIEN,!
+ . I ATYP="PATIENT" D  ; PATIENT ACTOR TYPE
+ . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP")
+ . . D PATIENT("ATMP",AIEN,AOID,"ATMP2")
+ . ;
+ . I ATYP="SYSTEM" D  ; SYSTEM ACTOR TYPE
+ . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP")
+ . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2")
+ . ;
+ . I ATYP="NOK" D  ; NOK ACTOR TYPE
+ . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP")
+ . . D NOK("ATMP",AIEN,AOID,"ATMP2")
+ . ;
+ . I ATYP="PROVIDER" D  ; PROVIDER ACTOR TYPE
+ . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP")
+ . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2")
+ . ;
+ . I ATYP="ORGANIZATION" D  ; PROVIDER ACTOR TYPE
+ . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP")
+ . . D ORG("ATMP",AIEN,AOID,"ATMP2")
+ . ;
+ . W "PROCESSING:",ATYP," ",AIEN,!
+ . ;I @ATMP2@(0)=0 Q  ; NOTHING RETURNED, SKIP THIS ONE
+ . D INSINNER^C0CXPATH(AXML,"ATMP2") ; INSERT INTO ROOT
+ . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE
+ ;
+ N ACTTMP
+ D MISSING^C0CXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS
+ I ACTTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
+ . ; STRINGS MARKED AS @@X@@
+ . W "ACTORS Missing list: ",!
+ . F I=1:1:ACTTMP(0) W ACTTMP(I),!
+ Q
+ ;
+PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR
+ I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,!
+ ;GPL SEPARATED EXTRACT FROM MAP FOR PROCESSING PATIENTS - TO MAKE
+ ; CODE REUSABLE FROM ERX
+ N AMAP
+ S AMAP=$NA(^TMP($J,"AMAP"))
+ K @AMAP
+ D PEXTRACT(AMAP,AIEN,AOID) ;EXTRACT THE PATIENT ACTOR
+ I $P($$SITE^VASITE(),U,2)="OROVILLE HOSPITAL" S C0CDE=1
+ I $G(C0CDE)'="" D DEIDENT(AMAP,AIEN) ; DEIDENTIFY THE CCR
+ D MAP(INXML,AMAP,OUTXML) ;MAP TO XML
+ K @AMAP ; CLEAN UP BEHIND US
+ Q
+ ;
+DEIDENT(GPL,ZDFN) ; QUICK WAY TO DEIDENTIFY THE CCR
+ S @GPL@("ACTORADDRESSCITY")="ALTON"
+ S @GPL@("ACTORADDRESSLINE1")="1234 Somewhere Lane"
+ S @GPL@("ACTORADDRESSLINE2")=""
+ S @GPL@("ACTORADDRESSSOURCEID")="ACTORPATIENT_"_ZDFN
+ S @GPL@("ACTORADDRESSSTATE")="KANSAS"
+ S @GPL@("ACTORADDRESSTYPE")="Home"
+ S @GPL@("ACTORADDRESSZIPCODE")=67623
+ S @GPL@("ACTORCELLTEL")=""
+ S @GPL@("ACTORCELLTELTEXT")=""
+ S @GPL@("ACTORDATEOFBIRTH")="1957-12-25"
+ S @GPL@("ACTOREMAIL")=""
+ S @GPL@("ACTORFAMILYNAME")="ZZ PATIENT"_ZDFN
+ ;S @GPL@("ACTORGENDER")="MALE"
+ S @GPL@("ACTORGIVENNAME")="TEST"_ZDFN
+ S @GPL@("ACTORIEN")=2
+ S @GPL@("ACTORMIDDLENAME")="TWO"
+ S @GPL@("ACTOROBJECTID")="ACTORPATIENT_"_ZDFN
+ S @GPL@("ACTORRESTEL")="888-555-1212"
+ S @GPL@("ACTORRESTELTEXT")="Residential Telephone"
+ S @GPL@("ACTORSOURCEID")="ACTORSYSTEM_1"
+ S @GPL@("ACTORSSN")="769122557P"
+ S @GPL@("ACTORSSNSOURCEID")="ACTORPATIENT_"_ZDFN
+ S @GPL@("ACTORSSNTEXT")="SSN"
+ S @GPL@("ACTORSUFFIXNAME")=""
+ S @GPL@("ACTORWORKTEL")="888-121-1212"
+ S @GPL@("ACTORWORKTELTEXT")="Work Telephone"
+ Q
+ ;
+PEXTRACT(AMAP,AIEN,AOID) ; EXTRACT TO RETURN ARRAY RARY PASSED BY NAME
+ N ZX
+ S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
+ S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CDPT(AIEN)
+ S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CDPT(AIEN)
+ S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CDPT(AIEN)
+ S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^C0CDPT(AIEN)
+ S @AMAP@("ACTORGENDER")=$P($$GENDER^C0CDPT(AIEN),U,2)
+ S @AMAP@("ACTORGENDERCODE")=$P($$GENDER^C0CDPT(AIEN),U,1)
+ S @AMAP@("ACTORSSN")=""
+ S @AMAP@("ACTORSSNTEXT")=""
+ S @AMAP@("ACTORSSNSOURCEID")=""
+ S X="MSCDPTID" ; ROUTINE TO TEST FOR MRN ON OPENVISTA
+ X ^%ZOSF("TEST") ; TEST TO SEE IF THE ROUTINE EXISTS
+ I $T S MRN=$$^MSCDPTID(DFN) ;TEST FOR MRN ON OPENVISTA ;GPL
+ I $G(MRN)'="" D  ; IF MRN IS PRESENT
+ . S @AMAP@("ACTORSSN")=MRN
+ . S @AMAP@("ACTORSSNTEXT")="MRN"
+ . S @AMAP@("ACTORSSNSOURCEID")=AOID
+ E  D  ; NO MRN, USE SSN
+ . S ZX=$$SSN^C0CDPT(AIEN)
+ . I ZX'="" D  ; IF THERE IS A SSN IN THE RECORD
+ . . S @AMAP@("ACTORSSN")=ZX
+ . . S @AMAP@("ACTORSSNTEXT")="SSN"
+ . . S @AMAP@("ACTORSSNSOURCEID")=AOID
+ S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^C0CDPT(AIEN)
+ S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^C0CDPT(AIEN)
+ S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^C0CDPT(AIEN)
+ S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CDPT(AIEN)
+ S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CDPT(AIEN)
+ S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^C0CDPT(AIEN)
+ S @AMAP@("ACTORRESTEL")=""
+ S @AMAP@("ACTORRESTELTEXT")=""
+ S ZX=$$RESTEL^C0CDPT(AIEN)
+ I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
+ . S @AMAP@("ACTORRESTEL")=ZX
+ . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone"
+ S @AMAP@("ACTORWORKTEL")=""
+ S @AMAP@("ACTORWORKTELTEXT")=""
+ S ZX=$$WORKTEL^C0CDPT(AIEN)
+ I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
+ . S @AMAP@("ACTORWORKTEL")=ZX
+ . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone"
+ S @AMAP@("ACTORCELLTEL")=""
+ S @AMAP@("ACTORCELLTELTEXT")=""
+ S ZX=$$CELLTEL^C0CDPT(AIEN)
+ I ZX'="" D  ; IF THERE IS A CELL PHONE IN THE RECORD
+ . S @AMAP@("ACTORCELLTEL")=ZX
+ . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone"
+ S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CDPT(AIEN)
+ S @AMAP@("ACTORADDRESSSOURCEID")=AOID
+ S @AMAP@("ACTORIEN")=AIEN
+ S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX
+ S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
+ Q
+ ;
+MAP(INXML,AMAP,OUTXML) ;MAP ANY ACTOR TO XML
+ D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
+ Q
+ ;
+SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR
+     ;
+     ; N AMAP
+     S AMAP=$NA(^TMP($J,"AMAP"))
+     K @AMAP
+     S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
+     S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^C0CSYS
+     S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^C0CSYS
+     S @AMAP@("ACTORINFOSYSSOURCEID")=AOID
+     D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
+     Q
+     ;
+NOK(INXML,AIEN,AOID,OUTXML) ; PROCESS A NEXT OF KIN TYPE ACTOR
+     ;
+     ; N AMAP
+     S AMAP=$NA(^TMP($J,"AMAP"))
+     K @AMAP
+     S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
+     S @AMAP@("ACTORDISPLAYNAME")=""
+     S @AMAP@("ACTORRELATION")=""
+     S @AMAP@("ACTORRELATIONSOURCEID")=""
+     S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
+     D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
+     Q
+     ;
+ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR
+     ;
+     N AMAP,ZIEN,ZSITE
+     S AMAP=$NA(^TMP($J,"AMAP"))
+     K @AMAP
+     S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
+     S ZSITE=$$SITE^VASITE ; SITE FORMAT IEN^NAME^DATE
+     S ZIEN=$P(ZSITE,"^",1)
+     S @AMAP@("ORGANIZATIONNAME")=$P(ZSITE,U,2)
+     S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1"
+     S @AMAP@("ACTORADDRESSTYPE")="Office"
+     S @AMAP@("ACTORADDRESSLINE1")=$$GET1^DIQ(4,ZIEN_",",1.01)
+     S @AMAP@("ACTORADDRESSLINE2")=$$GET1^DIQ(4,ZIEN_",",1.02)
+     S @AMAP@("ACTORADDRESSCITY")=$$GET1^DIQ(4,ZIEN_",",1.03)
+     S @AMAP@("ACTORADDRESSSTATE")=$$GET1^DIQ(4,ZIEN_",",.02)
+     S @AMAP@("ACTORPOSTALCODE")=$$GET1^DIQ(4,ZIEN_",",1.04)
+     S @AMAP@("ACTORTELEPHONE")=""
+     S @AMAP@("ACTORTELEPHONETYPE")=""
+     S ZX=$$GET1^DIQ(4.03,"1,"_ZIEN_",",.03)
+     I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
+     . S @AMAP@("ACTORTELEPHONE")=ZX
+     . S @AMAP@("ACTORTELEPHONETYPE")="Office"
+     D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
+     K @AMAP
+     Q
+     ;
+PROVIDER(INXML,AIEN,AOID,OUTXML) ; PROCESS A PROVIDER TYPE ACTOR
+     ;
+     ; N AMAP
+     S AMAP=$NA(^TMP($J,"AMAP"))
+     K @AMAP
+     I '$D(^VA(200,AIEN,0)) D  Q  ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN)
+     . W "WARNING - MISSING PROVIDER: ",AIEN,!
+     . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT
+     S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
+     S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CVA200(AIEN)
+     S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CVA200(AIEN)
+     S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CVA200(AIEN)
+     S @AMAP@("ACTORTITLE")=$$TITLE^C0CVA200(AIEN)
+     S @AMAP@("IDTYPE")=$P($$NPI^C0CVA200(AIEN),U,1)
+     S @AMAP@("ID")=$P($$NPI^C0CVA200(AIEN),U,2)
+     S @AMAP@("IDDESC")=$P($$NPI^C0CVA200(AIEN),U,3)
+     S @AMAP@("ACTORSPECIALITY")=$$SPEC^C0CVA200(AIEN)
+     S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^C0CVA200(AIEN)
+     S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^C0CVA200(AIEN)
+     S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CVA200(AIEN)
+     S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CVA200(AIEN)
+     S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^C0CVA200(AIEN)
+     S @AMAP@("ACTORTELEPHONE")=""
+     S @AMAP@("ACTORTELEPHONETYPE")=""
+     S ZX=$$TEL^C0CVA200(AIEN)
+     I ZX'="" D  ; THERE IS A PHONE NUMBER AVAILABLE
+     . S @AMAP@("ACTORTELEPHONE")=ZX
+     . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^C0CVA200(AIEN)
+     S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CVA200(AIEN)
+     S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1"
+     S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
+     S @AMAP@("ACTORORGLINK")="ACTORORGANIZATION_1"
+     D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
+     Q
+     ;

ccr/trunk/p/C0CALERT.m

@@ -1 @@
-C0CALERT         ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "NO ENTRY FROM TOP",!
-        Q
-        ;
-EXTRACT(ALTXML,DFN,ALTOUTXML,CALLBK)    ; EXTRACT ALERTS INTO  XML TEMPLATE
-        ; CALLBACK IF PROVIDED IS CALLED FOR EACH ALLERGY BEFORE MAPPING
-        ; ALTXML AND ALTOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
-        ;
-        ; GET ADVERSE REACTIONS AND ALLERGIES
-        ; N GMRA,GMRAL ; FOR DEBUGGING, DON'T NEW THESE VARIABLES
-        S GMRA="0^0^111"
-        D EN1^GMRADPT
-        I $G(GMRAL)'=1 D  Q ; NO ALLERGIES FOUND THUS *QUIT*
-        . S @ALTOUTXML@(0)=0
-        ; DEFINE MAPPING
-        N ALTTVMAP,ALTVMAP,ALTTARYTMP,ALTARYTMP
-        S ALTTVMAP=$NA(^TMP("C0CCCR",$J,"ALERTS"))
-        S ALTTARYTMP=$NA(^TMP("C0CCCR",$J,"ALERTSARYTMP"))
-        K @ALTTVMAP,@ALTTARYTMP
-        N ALTTMP,ALTCNT S ALTG=$NA(GMRAL),ALTCNT=1
-        S ALTTMP="" ;
-        F  S ALTTMP=$O(@ALTG@(ALTTMP)) Q:ALTTMP=""  D  ; CHANGED TO $O BY GPL
-        . W "ALTTMP="_ALTTMP,!
-        . ; I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q
-        . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT))
-        . K @ALTVMAP
-        . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT
-        . N A1 S A1=@ALTG@(ALTTMP) ; ALL THE PIECES
-        . I $D(CALLBK) D @CALLBK ;CALLBACK FOR EPRESCRIBING
-        . N A2 S A2=$$GET1^DIQ(120.8,ALTTMP,"MECHANISM","I") ; MECHANISM
-        . N A3 S A3=$P(A1,U,5) ; ADVERSE FLAG
-        . N ADT S ADT="Patient has an " ; X $ZINT H 5
-        . S ADT=ADT_$S(A2="P":"ADVERSE",A2="A":"ALLERGIC",1:"UNKNOWN")
-        . S ADT=ADT_" reaction to "_$P(@ALTG@(ALTTMP),U,2)_"."
-        . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT
-        . N ADTY S ADTY=$S(A2="P":"Adverse Reaction",A2="A":"Allergy",1:"") ;
-        . S @ALTVMAP@("ALERTTYPE")=ADTY ; type of allergy
-        . N ALTCDE ; SNOMED CODE THE THE ALERT
-        . S ALTCDE=$S(A2="P":"282100009",A2="A":"416098002",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC
-        . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ;
-        . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE
-        . ; AND  282100009 FOR ADVERSE REACTION TO A SUBSTANCE
-        . I ALTCDE'="" D  ; IF THERE IS A CODE
-        . . S @ALTVMAP@("ALERTCODESYSTEM")="SNOMED CT"
-        . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="2008"
-        . E  D  ; SET TO NULL
-        . . S @ALTVMAP@("ALERTCODESYSTEM")=""
-        . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")=""
-        . S @ALTVMAP@("ALERTSTATUSTEXT")="" ; WHERE DO WE GET THIS?
-        . N ALTPROV S ALTPROV=$P(^GMR(120.8,ALTTMP,0),U,5) ; SOURCE PROVIDER IEN
-        . I ALTPROV'="" D  ; PROVIDER PROVIDEED
-        . . S @ALTVMAP@("ALERTSOURCEID")="ACTORPROVIDER_"_ALTPROV
-        . E  S @ALTVMAP@("ALERTSOURCEID")="" ; SOURCE NULL - SHOULD NOT HAPPEN
-        . W "RUNNING ALERTS, PROVIDER: ",@ALTVMAP@("ALERTSOURCEID"),!
-        . N ACGL1,ACGFI,ACIEN,ACVUID,ACNM,ACTMP
-        . S ACGL1=$P(@ALTG@(ALTTMP),U,9) ; ADDRESS OF THE REACTANT XX;GLB(YY.Z,
-        . S ACGFI=$$PRSGLB($P(ACGL1,";",2)) ; FILE NUMBER
-        . S ACIEN=$P(ACGL1,";",1) ; IEN OF REACTANT
-        . S ACVUID=$$GET1^DIQ(ACGFI,ACIEN,"VUID") ; VUID OF THE REACTANT
-        . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="PRODUCT_"_ACIEN ; IE OF REACTANT
-        . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="" ; WHERE DO WE GET THIS?
-        . S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT
-        . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM
-        . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
-        . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE
-        . I ACVUID'="" D  ; IF VUID IS NOT NULL
-        . . S ZC=$$CODE^C0CUTIL(ACVUID)
-        . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
-        . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
-        . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
-        . E  D  ; IF REACTANT CODE VALUE IS NULL
-        . . I $G(DUZ("AG"))="I" D  ; IF WE ARE RUNNING ON RPMS
-        . . . S ACTMP=$O(^C0CCODES(176.112,"C",ACNM,0)) ;
-        . . . W "RPMS NAME FOUND",ACNM," ",ACTMP,!
-        . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=""
-        . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=""
-        . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ZCD
-        . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=ZCDS
-        . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM_" "_ZCDS_": "_ZCD
-        . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT_" "_ZCDS_": "_ZCD
-        . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW
-        . N ARTMP,ARIEN,ARDES,ARVUID
-        . S (ARTMP,ARDES,ARVUID)=""
-        . I $D(@ALTG@(ALTTMP,"S",1)) D  ; IF REACTION EXISTS
-        . . S ARTMP=@ALTG@(ALTTMP,"S",1)
-        . . W "REACTION:",ARTMP,!
-        . . S ARIEN=$P(ARTMP,";",2)
-        . . S ARDES=$P(ARTMP,";",1)
-        . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID")
-        . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES
-        . I ARVUID'="" D  ; IF REACTION VUID IS NOT NULL
-        . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID
-        . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID"
-        . E  D  ; IF IT IS NULL DON'T SET CODE SYSTEM
-        . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=""
-        . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")=""
-        . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT))
-        . ; NOW GO TO THE GLOBAL TO GET THE DATE/TIME AND BETTER DESCRIPTION
-        . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL
-        . D GETN1^C0CRNF("C0CG1",120.8,ALTTMP,"") ;GET VALUES BY NAME
-        . S C0CT=$$ZVALUEI^C0CRNF("ORIGINATION DATE/TIME","C0CG1")
-        . S @ALTVMAP@("ALERTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CT,"DT")
-        . K @ALTARYTMP
-        . D MAP^C0CXPATH(ALTXML,ALTVMAP,ALTARYTMP)
-        . I ALTCNT=1 D CP^C0CXPATH(ALTARYTMP,ALTOUTXML)
-        . I ALTCNT>1 D INSINNER^C0CXPATH(ALTOUTXML,ALTARYTMP)
-        . S ALTCNT=ALTCNT+1
-        S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS
-        Q
-PRSGLB(INGLB)   ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER
-        ; INGLB IS OF THE FORM: PSNDF(50.6,
-        ; RETURN 50.6
-        Q $P($P(INGLB,"(",2),",",1)  ;
+C0CALERT  ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "NO ENTRY FROM TOP",!
+ Q
+ ;
+EXTRACT(ALTXML,DFN,ALTOUTXML,CALLBK) ; EXTRACT ALERTS INTO  XML TEMPLATE
+ ; CALLBACK IF PROVIDED IS CALLED FOR EACH ALLERGY BEFORE MAPPING
+ ; ALTXML AND ALTOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
+ ;
+ ; GET ADVERSE REACTIONS AND ALLERGIES
+ ; N GMRA,GMRAL ; FOR DEBUGGING, DON'T NEW THESE VARIABLES
+ S GMRA="0^0^111"
+ D EN1^GMRADPT
+ I $G(GMRAL)'=1 D  Q ; NO ALLERGIES FOUND THUS *QUIT*
+ . S @ALTOUTXML@(0)=0
+ ; DEFINE MAPPING
+ N ALTTVMAP,ALTVMAP,ALTTARYTMP,ALTARYTMP
+ S ALTTVMAP=$NA(^TMP("C0CCCR",$J,"ALERTS"))
+ S ALTTARYTMP=$NA(^TMP("C0CCCR",$J,"ALERTSARYTMP"))
+ K @ALTTVMAP,@ALTTARYTMP
+ N ALTTMP,ALTCNT S ALTG=$NA(GMRAL),ALTCNT=1
+ S ALTTMP="" ;
+ F  S ALTTMP=$O(@ALTG@(ALTTMP)) Q:ALTTMP=""  D  ; CHANGED TO $O BY GPL
+ . W "ALTTMP="_ALTTMP,!
+ . ; I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q
+ . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT))
+ . K @ALTVMAP
+ . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT
+ . N A1 S A1=@ALTG@(ALTTMP) ; ALL THE PIECES
+ . I $D(CALLBK) D @CALLBK ;CALLBACK FOR EPRESCRIBING
+ . N A2 S A2=$$GET1^DIQ(120.8,ALTTMP,"MECHANISM","I") ; MECHANISM
+ . N A3 S A3=$P(A1,U,5) ; ADVERSE FLAG
+ . N ADT S ADT="Patient has an " ; X $ZINT H 5
+ . S ADT=ADT_$S(A2="P":"ADVERSE",A2="A":"ALLERGIC",1:"UNKNOWN")
+ . S ADT=ADT_" reaction to "_$P(@ALTG@(ALTTMP),U,2)_"."
+ . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT
+ . N ADTY S ADTY=$S(A2="P":"Adverse Reaction",A2="A":"Allergy",1:"") ;
+ . S @ALTVMAP@("ALERTTYPE")=ADTY ; type of allergy
+ . N ALTCDE ; SNOMED CODE THE THE ALERT
+ . S ALTCDE=$S(A2="P":"282100009",A2="A":"416098002",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC
+ . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ;
+ . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE
+ . ; AND  282100009 FOR ADVERSE REACTION TO A SUBSTANCE
+ . I ALTCDE'="" D  ; IF THERE IS A CODE
+ . . S @ALTVMAP@("ALERTCODESYSTEM")="SNOMED CT"
+ . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="2008"
+ . E  D  ; SET TO NULL
+ . . S @ALTVMAP@("ALERTCODESYSTEM")=""
+ . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")=""
+ . S @ALTVMAP@("ALERTSTATUSTEXT")="" ; WHERE DO WE GET THIS?
+ . N ALTPROV S ALTPROV=$P(^GMR(120.8,ALTTMP,0),U,5) ; SOURCE PROVIDER IEN
+ . I ALTPROV'="" D  ; PROVIDER PROVIDEED
+ . . S @ALTVMAP@("ALERTSOURCEID")="ACTORPROVIDER_"_ALTPROV
+ . E  S @ALTVMAP@("ALERTSOURCEID")="" ; SOURCE NULL - SHOULD NOT HAPPEN
+ . W "RUNNING ALERTS, PROVIDER: ",@ALTVMAP@("ALERTSOURCEID"),!
+ . N ACGL1,ACGFI,ACIEN,ACVUID,ACNM,ACTMP
+ . S ACGL1=$P(@ALTG@(ALTTMP),U,9) ; ADDRESS OF THE REACTANT XX;GLB(YY.Z,
+ . S ACGFI=$$PRSGLB($P(ACGL1,";",2)) ; FILE NUMBER
+ . S ACIEN=$P(ACGL1,";",1) ; IEN OF REACTANT
+ . S ACVUID=$$GET1^DIQ(ACGFI,ACIEN,"VUID") ; VUID OF THE REACTANT
+ . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="PRODUCT_"_ACIEN ; IE OF REACTANT
+ . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="" ; WHERE DO WE GET THIS?
+ . S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT
+ . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM
+ . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
+ . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE
+ . I ACVUID'="" D  ; IF VUID IS NOT NULL
+ . . S ZC=$$CODE^C0CUTIL(ACVUID)
+ . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
+ . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
+ . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
+ . E  D  ; IF REACTANT CODE VALUE IS NULL
+ . . I $G(DUZ("AG"))="I" D  ; IF WE ARE RUNNING ON RPMS
+ . . . S ACTMP=$O(^C0CCODES(176.112,"C",ACNM,0)) ;
+ . . . W "RPMS NAME FOUND",ACNM," ",ACTMP,!
+ . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=""
+ . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=""
+ . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ZCD
+ . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=ZCDS
+ . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM_" "_ZCDS_": "_ZCD
+ . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT_" "_ZCDS_": "_ZCD
+ . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW
+ . N ARTMP,ARIEN,ARDES,ARVUID
+ . S (ARTMP,ARDES,ARVUID)=""
+ . I $D(@ALTG@(ALTTMP,"S",1)) D  ; IF REACTION EXISTS
+ . . S ARTMP=@ALTG@(ALTTMP,"S",1)
+ . . W "REACTION:",ARTMP,!
+ . . S ARIEN=$P(ARTMP,";",2)
+ . . S ARDES=$P(ARTMP,";",1)
+ . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID")
+ . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES
+ . I ARVUID'="" D  ; IF REACTION VUID IS NOT NULL
+ . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID
+ . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID"
+ . E  D  ; IF IT IS NULL DON'T SET CODE SYSTEM
+ . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=""
+ . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")=""
+ . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT))
+ . ; NOW GO TO THE GLOBAL TO GET THE DATE/TIME AND BETTER DESCRIPTION
+ . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL
+ . D GETN1^C0CRNF("C0CG1",120.8,ALTTMP,"") ;GET VALUES BY NAME
+ . S C0CT=$$ZVALUEI^C0CRNF("ORIGINATION DATE/TIME","C0CG1")
+ . S @ALTVMAP@("ALERTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CT,"DT")
+ . K @ALTARYTMP
+ . D MAP^C0CXPATH(ALTXML,ALTVMAP,ALTARYTMP)
+ . I ALTCNT=1 D CP^C0CXPATH(ALTARYTMP,ALTOUTXML)
+ . I ALTCNT>1 D INSINNER^C0CXPATH(ALTOUTXML,ALTARYTMP)
+ . S ALTCNT=ALTCNT+1
+ S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS
+ Q
+PRSGLB(INGLB) ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER
+ ; INGLB IS OF THE FORM: PSNDF(50.6,
+ ; RETURN 50.6
+ Q $P($P(INGLB,"(",2),",",1)  ;

ccr/trunk/p/C0CBAT.m

@@ -1 @@
-C0CBAT    ; CCDCCR/GPL - CCR Batch utilities; 4/21/09
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "This is the CCR Batch Utility Library ",!
-        Q
-        ;
-STOP    ; STOP A CURRENTLY RUNNING BATCH JOB
-        I '$D(^TMP("C0CBAT","RUNNING")) Q  ;
-        W !,!,"HALTING CCR BATCH",!
-        S ^TMP("C0CBAT","STOP")="" ; SIGNAL JOB TO TERMINATE
-        H 10 ; WAIT TEN SECONDS FOR SIGNAL TO BE RECEIVED
-        I '$D(^TMP("C0CBAT","STOP")) D  ; SIGNAL RECEIVED
-        . W "CCR BATCH JOB TERMINATING",!
-        E  D  ;
-        . K ^TMP("C0CBAT","STOP") ; STOP SIGNALING
-        . W !,"BATCH PROCESSING APPARENTLY NOT RUNNING",!
-        Q
-        ;
-START   ; STARTS A TAKSMAN CCR BATCH JOB - FOR USE IN A MENU OPTION
-        ;
-        I $D(^TMP("C0CBAT","RUNNING")) D  Q  ; ONLY ONE ALLOWED AT A TIME
-        . W !,"CCR BATCH ALREADY RUNNING",!
-        . W !,"STOP FIRST WITH STOP^C0CBAT",!
-        N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTIO
-        S ZTRTN="EN^C0CBAT",ZTDESC="CCR Batch"
-        S ZTDTH=$H ; 
-        ;S ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10))
-        S ZTSAVE("C0C")="",ZTSAVE("C0C*")=""
-        S ZTIO="NULL" ;
-        W !,!,"CCR BATCH JOB STARTED",!
-        D ^%ZTLOAD
-        Q
-        ;
-EN      ; BATCH ENTRY POINT
-        ; PROCESSES THE SUBSCRIPTION FILE, EXTRACTING CCR VARIABLES FOR EACH
-        ; PATIENT WITH AN ACTIVE SUBSCRIPTION, AND IF CHECKSUMS INDICATE A CHANGE,
-        ; GENERATES A NEW CCR FOR THE PATIENT
-        ; UPDATES THE E2 CCR ELEMENTS FILE
-        ;
-        S C0CQT=1 ; QUIET MODE
-        I $D(^TMP("C0CBAT","RUNNING")) Q  ; ONLY ONE AT A TIME
-        S ^TMP("C0CBAT","RUNNING")="" ; RUNNING SIGNAL
-        S C0CBDT=$$NOW^XLFDT ; DATE OF THIS RUN
-        S C0CBF=177.301 ; FILE NUMBER OF C0C BATCH CONTROL FILE
-        S C0CBFR=177.3013 ; FILE NUMBER OF UPDATE SUBFILE
-        S C0CBB=$NA(^TMP("C0CBATCH",C0CBDT)) ; BATCH WORK AREA
-        I $D(@C0CBB@(0)) D  ; ERROR SHOULDN'T EXIST
-        . W "WORK AREA ERROR",!
-        . B
-        S @C0CBB@(0)="V22" ; VERSION USED TO CREATE THIS WORK AREA
-        S C0CBH=$NA(@C0CBB@("HOTLIST")) ; BASE FOR HOT LIST
-        S C0CBS=$NA(^C0CS("B")) ; SUBSCRIPTION LIST BASE
-        ;I $D(^C0CB("B",C0CDT)) D  ; BATCH RECORD EXISTS
-        ;. H 10 ; HANG 10 SECONDS
-        ;. S C0CBDT=$$NOW^XLFDT ; NEW DATE FOR THIS RUN
-        ;. I $D(^C0CB("B",C0CDT)) B ;DIDN'T WORK
-        D BLDHOT(C0CBH) ; BUILD THE HOT LIST
-        S C0CHN=$$COUNT(C0CBH) ;COUNT NUMBER IN HOT LIST
-        S C0CSN=$$COUNT(C0CBS) ;COUNT NUMBER OF PATIENTS WITH SUBSCRIPTIONS
-        S C0CFDA(C0CBF,"+1,",.01)=C0CBDT ; DATE KEY OF BATCH CONTROL
-        S C0CFDA(C0CBF,"+1,",.02)=C0CBDT ; BATCH ID IS DATE IN STRING FORM
-        S C0CFDA(C0CBF,"+1,",1)=C0CSN ; TOTAL SUBSCRIPTIONS
-        S C0CFDA(C0CBF,"+1,",2)=C0CHN ; TOTAL HOT LIST
-        D UPDIE ; CREATE THE BATCH RECORD
-        S C0CIEN=$O(^C0CB("B",C0CBDT,""))
-        S (C0CN,C0CNH)=0 ; COUNTERS FOR TOTAL AND HOT LIST
-        S C0CBCUR="" ; CURRENT PATIENT
-        S C0CSTOP=0 ; STOP FLAG FOR HALTING BATCH SET ^TMP("C0CBAT","STOP")=""
-        ;F  S C0CBCUR=$O(@C0CBH@(C0CBCUR),-1) Q:C0CBCUR=""  D  ; HOT LIST LATEST FIRST
-        F  S C0CBCUR=$O(@C0CBH@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="")  D  ; HOT LIST FIRST
-        . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-900^VITLIMIT:T-900")
-        . I $G(C0CCHK) D  ;
-        . . D PUTRIM^C0CFM2(C0CBCUR)
-        . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR
-        . . K C0CFDA
-        . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR
-        . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y"
-        . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR))
-        . . D UPDIE ; CREATE UPDATE SUBFILE 
-        . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL
-        . S C0CNH=C0CNH+1 ; INCREMENT HOT LIST TOTAL
-        . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS
-        . S C0CFDA(C0CBF,C0CIEN_",",2.1)=C0CNH ; UPDATE HOT LIST PROGRESS
-        . S C0CNOW=$$NOW^XLFDT
-        . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD
-        . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS
-        . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME
-        . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME
-        . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME 
-        . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START
-        . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME
-        . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; LAST RECORD PROCESSED
-        . D UPDIE ;
-        . I $D(^TMP("C0CBAT","STOP")) D  ; IF STOP SIGNAL DETECTED
-        . . S C0CSTOP=1
-        . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED 
-        . H 1 ; GIVE OTHERS A CHANCE 
-        F  S C0CBCUR=$O(@C0CBS@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="")  D  ; SUBS LIST
-        . I $D(@C0CBH@(C0CBCUR)) Q  ; SKIP IF IN HOT LIST - ALREADY DONE
-        . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-760^VITLIMIT:T-760")
-        . I $G(C0CCHK) D  ; IF CHECKSUMS HAVE CHANGED
-        . . D PUTRIM^C0CFM2(C0CBCUR)
-        . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR
-        . . K C0CFDA
-        . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR
-        . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y"
-        . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR))
-        . . D UPDIE ; CREATE UPDATE SUBFILE 
-        . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL
-        . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS
-        . S C0CNOW=$$NOW^XLFDT
-        . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD
-        . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS
-        . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME
-        . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME
-        . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME 
-        . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START
-        . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME
-        . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; 
-        . D UPDIE ; 
-        . I $D(^TMP("C0CBAT","STOP")) D  ; IF STOP SIGNAL DETECTED
-        . . S C0CSTOP=1
-        . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED 
-        . H 1 ; GIVE IT A BREAK
-        I (C0CSTOP) S C0CDISP="KILLED"
-        E  S C0CDISP="FINISHED"
-        S C0CFDA(C0CBF,C0CIEN_",",6)=C0CDISP
-        D UPDIE ; SET DISPOSITION FIELD
-        K ^TMP("C0CBAT","RUNNING")
-        Q
-        ;
-BLDHOT(ZHB)     ; BUILD HOT LIST AT GLOBAL ZHB, PASSED BY NAME
-        ; SEARCHS FOR PATIENTS IN THE "AC" INDEX OF THE ORDER FILE
-        N ZDFN
-        S ZDFN=""
-        F  S ZDFN=$O(^OR(100,"AC",ZDFN)) Q:ZDFN=""  D  ; ALL PATIENTS IN THE AC INDX
-        . S ZZDFN=$P(ZDFN,";",1) ; FORMAT IS "N;DPT("
-        . I '$D(@C0CBS@(ZZDFN)) Q  ; SKIP IF NOT IN SUBSCRIPTION LIST
-        . S @ZHB@(ZZDFN)="" ;ADD PATIENT TO THE HOT LIST
-        Q
-        ;
-COUNT(ZB)       ; EXTRINSIC THAT RETURNS THE NUMBER OF ARRAY ELEMENTS
-        N ZI,ZN
-        S ZN=0
-        S ZI=""
-        F  S ZI=$O(@ZB@(ZI)) Q:ZI=""  D  ;
-        . S ZN=ZN+1
-        Q ZN
-        ;
-UPDIEVARPTR(ZVAR,ZTYP)  ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
-        ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
-        ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
-        ;
-        N ZCCRD,ZVARN,C0CFDA2
-        S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
-        S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
-        I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
-        . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
-        . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
-        . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
-        . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
-        . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
-        . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
-        . I $D(ZERR) D  ; LAYGO ERROR
-        . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
-        . E  D  ;
-        . . D CLEAN^DILF ; CLEAN UP
-        . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
-        . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
-        Q ZVARN
-        ;
-UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
-        K ZERR
-        D CLEAN^DILF
-        D UPDATE^DIE("","C0CFDA","","ZERR")
-        I $D(ZERR) D  ;
-        . W "ERROR",!
-        . ZWR ZERR
-        . B
-        K C0CFDA
-        Q
-        ;
-SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
-        ; TO SET TO VALUE C0CSV.
-        ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
-        ; C0CSN,C0CSV ARE PASSED BY VALUE
-        ;
-        N C0CSI,C0CSJ
-        S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
-        S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
-        S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
-        Q
-ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
-        E  S ZR=""
-        Q ZR
-ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
-        E  S ZR=""
-        Q ZR
-        ;
-ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
-        E  S ZR=""
-        Q ZR
-        ;
+C0CBAT   ; CCDCCR/GPL - CCR Batch utilities; 4/21/09
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "This is the CCR Batch Utility Library ",!
+ Q
+ ;
+STOP ; STOP A CURRENTLY RUNNING BATCH JOB
+ I '$D(^TMP("C0CBAT","RUNNING")) Q  ;
+ W !,!,"HALTING CCR BATCH",!
+ S ^TMP("C0CBAT","STOP")="" ; SIGNAL JOB TO TERMINATE
+ H 10 ; WAIT TEN SECONDS FOR SIGNAL TO BE RECEIVED
+ I '$D(^TMP("C0CBAT","STOP")) D  ; SIGNAL RECEIVED
+ . W "CCR BATCH JOB TERMINATING",!
+ E  D  ;
+ . K ^TMP("C0CBAT","STOP") ; STOP SIGNALING
+ . W !,"BATCH PROCESSING APPARENTLY NOT RUNNING",!
+ Q
+ ;
+START ; STARTS A TAKSMAN CCR BATCH JOB - FOR USE IN A MENU OPTION
+ ;
+ I $D(^TMP("C0CBAT","RUNNING")) D  Q  ; ONLY ONE ALLOWED AT A TIME
+ . W !,"CCR BATCH ALREADY RUNNING",!
+ . W !,"STOP FIRST WITH STOP^C0CBAT",!
+ N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTIO
+ S ZTRTN="EN^C0CBAT",ZTDESC="CCR Batch"
+ S ZTDTH=$H ; 
+ ;S ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10))
+ S ZTSAVE("C0C")="",ZTSAVE("C0C*")=""
+ S ZTIO="NULL" ;
+ W !,!,"CCR BATCH JOB STARTED",!
+ D ^%ZTLOAD
+ Q
+ ;
+EN ; BATCH ENTRY POINT
+ ; PROCESSES THE SUBSCRIPTION FILE, EXTRACTING CCR VARIABLES FOR EACH
+ ; PATIENT WITH AN ACTIVE SUBSCRIPTION, AND IF CHECKSUMS INDICATE A CHANGE,
+ ; GENERATES A NEW CCR FOR THE PATIENT
+ ; UPDATES THE E2 CCR ELEMENTS FILE
+ ;
+ S C0CQT=1 ; QUIET MODE
+ I $D(^TMP("C0CBAT","RUNNING")) Q  ; ONLY ONE AT A TIME
+ S ^TMP("C0CBAT","RUNNING")="" ; RUNNING SIGNAL
+ S C0CBDT=$$NOW^XLFDT ; DATE OF THIS RUN
+ S C0CBF=177.301 ; FILE NUMBER OF C0C BATCH CONTROL FILE
+ S C0CBFR=177.3013 ; FILE NUMBER OF UPDATE SUBFILE
+ S C0CBB=$NA(^TMP("C0CBATCH",C0CBDT)) ; BATCH WORK AREA
+ I $D(@C0CBB@(0)) D  ; ERROR SHOULDN'T EXIST
+ . W "WORK AREA ERROR",!
+ . B
+ S @C0CBB@(0)="V22" ; VERSION USED TO CREATE THIS WORK AREA
+ S C0CBH=$NA(@C0CBB@("HOTLIST")) ; BASE FOR HOT LIST
+ S C0CBS=$NA(^C0CS("B")) ; SUBSCRIPTION LIST BASE
+ ;I $D(^C0CB("B",C0CDT)) D  ; BATCH RECORD EXISTS
+ ;. H 10 ; HANG 10 SECONDS
+ ;. S C0CBDT=$$NOW^XLFDT ; NEW DATE FOR THIS RUN
+ ;. I $D(^C0CB("B",C0CDT)) B ;DIDN'T WORK
+ D BLDHOT(C0CBH) ; BUILD THE HOT LIST
+ S C0CHN=$$COUNT(C0CBH) ;COUNT NUMBER IN HOT LIST
+ S C0CSN=$$COUNT(C0CBS) ;COUNT NUMBER OF PATIENTS WITH SUBSCRIPTIONS
+ S C0CFDA(C0CBF,"+1,",.01)=C0CBDT ; DATE KEY OF BATCH CONTROL
+ S C0CFDA(C0CBF,"+1,",.02)=C0CBDT ; BATCH ID IS DATE IN STRING FORM
+ S C0CFDA(C0CBF,"+1,",1)=C0CSN ; TOTAL SUBSCRIPTIONS
+ S C0CFDA(C0CBF,"+1,",2)=C0CHN ; TOTAL HOT LIST
+ D UPDIE ; CREATE THE BATCH RECORD
+ S C0CIEN=$O(^C0CB("B",C0CBDT,""))
+ S (C0CN,C0CNH)=0 ; COUNTERS FOR TOTAL AND HOT LIST
+ S C0CBCUR="" ; CURRENT PATIENT
+ S C0CSTOP=0 ; STOP FLAG FOR HALTING BATCH SET ^TMP("C0CBAT","STOP")=""
+ ;F  S C0CBCUR=$O(@C0CBH@(C0CBCUR),-1) Q:C0CBCUR=""  D  ; HOT LIST LATEST FIRST
+ F  S C0CBCUR=$O(@C0CBH@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="")  D  ; HOT LIST FIRST
+ . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-900^VITLIMIT:T-900")
+ . I $G(C0CCHK) D  ;
+ . . D PUTRIM^C0CFM2(C0CBCUR)
+ . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR
+ . . K C0CFDA
+ . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR
+ . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y"
+ . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR))
+ . . D UPDIE ; CREATE UPDATE SUBFILE 
+ . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL
+ . S C0CNH=C0CNH+1 ; INCREMENT HOT LIST TOTAL
+ . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS
+ . S C0CFDA(C0CBF,C0CIEN_",",2.1)=C0CNH ; UPDATE HOT LIST PROGRESS
+ . S C0CNOW=$$NOW^XLFDT
+ . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD
+ . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS
+ . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME
+ . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME
+ . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME 
+ . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START
+ . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME
+ . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; LAST RECORD PROCESSED
+ . D UPDIE ;
+ . I $D(^TMP("C0CBAT","STOP")) D  ; IF STOP SIGNAL DETECTED
+ . . S C0CSTOP=1
+ . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED 
+ . H 1 ; GIVE OTHERS A CHANCE 
+ F  S C0CBCUR=$O(@C0CBS@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="")  D  ; SUBS LIST
+ . I $D(@C0CBH@(C0CBCUR)) Q  ; SKIP IF IN HOT LIST - ALREADY DONE
+ . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-760^VITLIMIT:T-760")
+ . I $G(C0CCHK) D  ; IF CHECKSUMS HAVE CHANGED
+ . . D PUTRIM^C0CFM2(C0CBCUR)
+ . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR
+ . . K C0CFDA
+ . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR
+ . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y"
+ . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR))
+ . . D UPDIE ; CREATE UPDATE SUBFILE 
+ . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL
+ . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS
+ . S C0CNOW=$$NOW^XLFDT
+ . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD
+ . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS
+ . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME
+ . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME
+ . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME 
+ . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START
+ . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME
+ . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; 
+ . D UPDIE ; 
+ . I $D(^TMP("C0CBAT","STOP")) D  ; IF STOP SIGNAL DETECTED
+ . . S C0CSTOP=1
+ . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED 
+ . H 1 ; GIVE IT A BREAK
+ I (C0CSTOP) S C0CDISP="KILLED"
+ E  S C0CDISP="FINISHED"
+ S C0CFDA(C0CBF,C0CIEN_",",6)=C0CDISP
+ D UPDIE ; SET DISPOSITION FIELD
+ K ^TMP("C0CBAT","RUNNING")
+ Q
+ ;
+BLDHOT(ZHB) ; BUILD HOT LIST AT GLOBAL ZHB, PASSED BY NAME
+ ; SEARCHS FOR PATIENTS IN THE "AC" INDEX OF THE ORDER FILE
+ N ZDFN
+ S ZDFN=""
+ F  S ZDFN=$O(^OR(100,"AC",ZDFN)) Q:ZDFN=""  D  ; ALL PATIENTS IN THE AC INDX
+ . S ZZDFN=$P(ZDFN,";",1) ; FORMAT IS "N;DPT("
+ . I '$D(@C0CBS@(ZZDFN)) Q  ; SKIP IF NOT IN SUBSCRIPTION LIST
+ . S @ZHB@(ZZDFN)="" ;ADD PATIENT TO THE HOT LIST
+ Q
+ ;
+COUNT(ZB) ; EXTRINSIC THAT RETURNS THE NUMBER OF ARRAY ELEMENTS
+ N ZI,ZN
+ S ZN=0
+ S ZI=""
+ F  S ZI=$O(@ZB@(ZI)) Q:ZI=""  D  ;
+ . S ZN=ZN+1
+ Q ZN
+ ;
+UPDIEVARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
+ ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
+ ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
+ ;
+ N ZCCRD,ZVARN,C0CFDA2
+ S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
+ S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
+ I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
+ . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
+ . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
+ . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
+ . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
+ . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
+ . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
+ . I $D(ZERR) D  ; LAYGO ERROR
+ . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
+ . E  D  ;
+ . . D CLEAN^DILF ; CLEAN UP
+ . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
+ . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
+ Q ZVARN
+ ;
+UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
+ K ZERR
+ D CLEAN^DILF
+ D UPDATE^DIE("","C0CFDA","","ZERR")
+ I $D(ZERR) D  ;
+ . W "ERROR",!
+ . ZWR ZERR
+ . B
+ K C0CFDA
+ Q
+ ;
+SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
+ ; TO SET TO VALUE C0CSV.
+ ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
+ ; C0CSN,C0CSV ARE PASSED BY VALUE
+ ;
+ N C0CSI,C0CSJ
+ S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
+ S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
+ S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
+ Q
+ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
+ E  S ZR=""
+ Q ZR
+ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
+ E  S ZR=""
+ Q ZR
+ ;
+ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
+ E  S ZR=""
+ Q ZR
+ ;

ccr/trunk/p/C0CCCD.m

@@ -1 @@
-C0CCCD    ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008,2009 George Lilly, University of Minnesota.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        ; EXPORT A CCR
-        ;
-EXPORT    ; EXPORT ENTRY POINT FOR CCR
-              ; Select a patient.
-              S DIC=2,DIC(0)="AEMQ" D ^DIC
-              I Y<1 Q  ; EXIT
-              S DFN=$P(Y,U,1) ; SET THE PATIENT
-              D XPAT(DFN,"","") ; EXPORT TO A FILE
-              Q
-              ;
-XPAT(DFN,DIR,FN)        ; EXPORT ONE PATIENT TO A FILE
-              ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR")
-              ; FN IS FILE NAME, DEFAULTS IF NULL
-              ; N CCDGLO
-              D CCDRPC(.CCDGLO,DFN,"CCD","","","")
-              S OARY=$NA(^TMP("C0CCCR",$J,DFN,"CCD",1))
-              S ONAM=FN
-              I FN="" S ONAM="PAT_"_DFN_"_CCD_V1.xml"
-              S ODIRGLB=$NA(^TMP("C0CCCR","ODIR"))
-              I '$D(@ODIRGLB) D  ; IF NOT ODIR HAS BEEN SET
-              . S @ODIRGLB="/home/glilly/CCROUT"
-              . ;S @ODIRGLB="/home/cedwards/"
-              . ;S @ODIRGLB="/opt/wv/p/"
-              S ODIR=DIR
-              I DIR="" S ODIR=@ODIRGLB
-              N ZY
-              S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR)
-              W $P(ZY,U,2)
-              Q
-              ;
-CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY)   ;RPC ENTRY POINT FOR CCR OUTPUT
-           ; CCRGRTN IS RETURN ARRAY PASSED BY NAME
-           ; DFN IS PATIENT IEN
-           ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART
-           ;   OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC
-           ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL
-           ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME
-           ; - NULL MEANS NOW
-           ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND
-           ;    "TO" VARIABLES
-           ;    IF NULL WILL DEFAULT TO "FROM" ORGANIZATION AND "TO" DFN
-           I '$D(DEBUG) S DEBUG=0
-           N CCD S CCD=0 ; FLAG FOR PROCESSING A CCD
-           I CCRPART="CCD" S CCD=1 ; WE ARE PROCESSING A CCD
-           S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE
-           I CCD S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCD")) ; GLOBAL FOR THE CCD
-           E  S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR
-           S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS
-           ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC
-           S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL
-           I CCD D LOAD^C0CCCD1(TGLOBAL)  ; LOAD THE CCR TEMPLATE
-           E  D LOAD^C0CCCR0(TGLOBAL)  ; LOAD THE CCR TEMPLATE
-           D CP^C0CXPATH(TGLOBAL,CCDGLO) ; COPY THE TEMPLATE TO CCR GLOBAL
-           N CAPSAVE,CAPSAVE2 ; FOR HOLDING THE CCD ROOT LINES
-           S CAPSAVE=@TGLOBAL@(3) ; SAVE THE CCD ROOT
-           S CAPSAVE2=@TGLOBAL@(@TGLOBAL@(0)) ; SAVE LAST LINE OF CCD
-           S @CCDGLO@(3)="<ContinuityOfCareRecord>" ; CAP WITH CCR ROOT
-           S @TGLOBAL@(3)=@CCDGLO@(3) ; CAP THE TEMPLATE TOO
-           S @CCDGLO@(@CCDGLO@(0))="</ContinuityOfCareRecord>" ; FINISH CAP
-           S @TGLOBAL@(@TGLOBAL@(0))="</ContinuityOfCareRecord>" ; FINISH CAP TEMP
-           ;
-           ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL
-           ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES
-           D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Body")
-           D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Actors")
-           I 'CCD D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Signatures")
-           I DEBUG F I=1:1:@CCDGLO@(0) W @CCDGLO@(I),!
-           ;
-           I 'CCD D HDRMAP(CCDGLO,DFN,HDRARY) ; MAP HEADER VARIABLES
-           ; MAPPING THE PATIENT PORTION OF THE CDA HEADER
-           S ZZX="//ContinuityOfCareRecord/recordTarget/patientRole/patient"
-           D QUERY^C0CXPATH(CCDGLO,ZZX,"ACTT1")
-           D PATIENT^C0CACTOR("ACTT1",DFN,"ACTORPATIENT_"_DFN,"ACTT2") ; MAP PATIENT
-           I DEBUG D PARY^C0CXPATH("ACTT2")
-           D REPLACE^C0CXPATH(CCDGLO,"ACTT2",ZZX)
-           I DEBUG D PARY^C0CXPATH(CCDGLO)
-           K ACTT1 K ACCT2
-           ; MAPPING THE PROVIDER ORGANIZATION,AUTHOR,INFORMANT,CUSTODIAN CDA HEADER
-           ; FOR NOW, THEY ARE ALL THE SAME AND RESOLVE TO ORGANIZATION
-           D ORG^C0CACTOR(CCDGLO,DFN,"ACTORPATIENTORGANIZATION","ACTT2") ; MAP ORG
-           D CP^C0CXPATH("ACTT2",CCDGLO)
-           ;
-           K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT
-           S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS
-           D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS
-           N I,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD
-           F I=1:1:@CCRXTAB@(0)  D  ; PROCESS THE CCR BODY SECTIONS
-           . S XI=@CCRXTAB@(I) ; CALL COPONENTS TO PARSE
-           . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL
-           . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL
-           . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE
-           . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS
-           . S IXML="INXML"
-           . I CCD D SHAVE(IXML) ; REMOVE ALL BUT REPEATING PARTS OF TEMPLATE SECTION
-           . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES
-           . ; W OXML,!
-           . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL
-           . W "RUNNING ",CALL,!
-           . X CALL
-           . I @OXML@(0)'=0 D  ; THERE IS A RESULT
-           . . I CCD D QUERY^C0CXPATH(TGLOBAL,XPATH,"ITMP") ; XML TO UNSHAVE WITH
-           . . I CCD D UNSHAVE("ITMP",OXML)
-           . . I CCD D UNMARK^C0CXPATH(OXML) ; REMOVE THE CCR MARKUP FROM SECTION
-           . ; NOW INSERT THE RESULTS IN THE CCR BUFFER
-           . D INSERT^C0CXPATH(CCDGLO,OXML,"//ContinuityOfCareRecord/Body")
-           . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),!
-           ; NEED TO ADD BACK IN ACTOR PROCESSING AFTER WE FIGURE OUT LINKAGE
-           ; D ACTLST^C0CCCR(CCDGLO,ACTGLO) ; GEN THE ACTOR LIST
-           ; D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT")
-           ; D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2")
-           ; D INSINNER^C0CXPATH(CCDGLO,"ACTT2","//ContinuityOfCareRecord/Actors")
-           N I,J,DONE S DONE=0
-           F I=0:0 D  Q:DONE  ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE
-           . S J=$$TRIM^C0CXPATH(CCDGLO) ; DELETE EMPTY ELEMENTS
-           . W "TRIMMED",J,!
-           . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE
-           I CCD D  ; TURN THE BODY INTO A CCD COMPONENT
-           . N I
-           . F I=1:1:@CCDGLO@(0) D  ; SEARCH THROUGH THE ENTIRE ARRAY
-           . . I @CCDGLO@(I)["<Body>" D  ; REPLACE BODY MARKUP
-           . . . S @CCDGLO@(I)="<component><structuredBody>" ; WITH CCD EQ
-           . . I @CCDGLO@(I)["</Body>" D  ; REPLACE BODY MARKUP
-           . . . S @CCDGLO@(I)="</structuredBody></component>"
-           S @CCDGLO@(3)=CAPSAVE ; UNCAP - TURN IT BACK INTO A CCD
-           S @CCDGLO@(@CCDGLO@(0))=CAPSAVE2 ; UNCAP LAST LINE
-           Q
-           ;
-INITSTPS(TAB)    ; INITIALIZE CCR PROCESSING STEPS
-           ; TAB IS PASSED BY NAME
-           W "TAB= ",TAB,!
-           ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS
-           D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")")
-           ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")")
-           I 'CCD D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")")
-           Q
-           ;
-SHAVE(SHXML)    ; REMOVES THE 2-6 AND N-1 AND N-2 LINES FROM A COMPONENT
-           ; NEEDED TO EXPOSE THE REPEATING PARTS FOR GENERATION
-           N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST
-           W SHXML,!
-           W @SHXML@(1),!
-           D QUEUE^C0CXPATH("SHBLD",SHXML,1,1) ; THE FIRST LINE IS NEEDED
-           D QUEUE^C0CXPATH("SHBLD",SHXML,7,@SHXML@(0)-3) ; REPEATING PART
-           D QUEUE^C0CXPATH("SHBLD",SHXML,@SHXML@(0),@SHXML@(0)) ; LAST LINE
-           D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST
-           D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION
-           D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY
-           Q
-           ;
-UNSHAVE(ORIGXML,SHXML)  ; REPLACES THE 2-6 AND N-1 AND N-2 LINES FROM TEMPLATE
-           ; NEEDED TO RESTORM FIXED TOP AND BOTTOM OF THE COMPONENT XML
-           N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST
-           W SHXML,!
-           W @SHXML@(1),!
-           D QUEUE^C0CXPATH("SHBLD",ORIGXML,1,6) ; FIRST 6 LINES OF TEMPLATE
-           D QUEUE^C0CXPATH("SHBLD",SHXML,2,@SHXML@(0)-1) ; INS ALL BUT FIRST/LAST
-           D QUEUE^C0CXPATH("SHBLD",ORIGXML,@ORIGXML@(0)-2,@ORIGXML@(0)) ; FROM TEMP
-           D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST
-           D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION
-           D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY
-           Q
-           ;
-HDRMAP(CXML,DFN,IHDR)     ; MAP HEADER VARIABLES: FROM, TO ECT
-           N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER"))
-           ; K @VMAP
-           S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT")
-           I IHDR="" D  ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS
-           . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN
-           . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ???
-           . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM
-           . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN  ; FOR TEST PURPOSES
-           . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR"  ; FOR TEST PURPOSES
-           . S @VMAP@("ACTORTOTEXT")="Patient"  ; FOR TEST PURPOSES
-           . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT
-           I IHDR'="" D  ; HEADER VALUES ARE PROVIDED
-           . D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY
-           N CTMP
-           D MAP^C0CXPATH(CXML,VMAP,"CTMP")
-           D CP^C0CXPATH("CTMP",CXML)
-           Q
-           ;
-ACTLST(AXML,ACTRTN)     ; RETURN THE ACTOR LIST FOR THE XML IN AXML
-           ; AXML AND ACTRTN ARE PASSED BY NAME
-           ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2
-           ; P1= OBJECTID - ACTORPATIENT_2
-           ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE
-           ;OR INSTITUTION
-           ;  OR PERSON(IN PATIENT FILE IE NOK)
-           ; P3= IEN RECORD NUMBER FOR ACTOR - 2
-           N I,J,K,L
-           K @ACTRTN ; CLEAR RETURN ARRAY
-           F I=1:1:@AXML@(0) D  ; SCAN ALL LINES
-           . I @AXML@(I)?.E1"<ActorID>".E D  ; THERE IS AN ACTOR THIS LINE
-           . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1)
-           . . W "<ActorID>=>",J,!
-           . . I J'="" S K(J)="" ; HASHING ACTOR
-           . . ;  TO GET RID OF DUPLICATES
-           S I="" ; GOING TO $O THROUGH THE HASH
-           F J=0:0 D  Q:$O(K(I))=""  ;
-           . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS
-           . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID
-           . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE
-           . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR
-           . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY
-           Q
-           ;
-TEST    ; RUN ALL THE TEST CASES
-         D TESTALL^C0CUNIT("C0CCCR")
-         Q
-         ;
-ZTEST(WHICH)     ; RUN ONE SET OF TESTS
-         N ZTMP
-         D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
-         D ZTEST^C0CUNIT(.ZTMP,WHICH)
-         Q
-         ;
-TLIST    ; LIST THE TESTS
-         N ZTMP
-         D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
-         D TLIST^C0CUNIT(.ZTMP)
-         Q
-         ;
-        ;;><TEST>
-        ;;><PROBLEMS>
-        ;;>>>K C0C S C0C=""
-        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","","","")
-        ;;>>?@C0C@(@C0C@(0))["</Problems>"
-        ;;><VITALS>
-        ;;>>>K C0C S C0C=""
-        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","","","")
-        ;;>>?@C0C@(@C0C@(0))["</VitalSigns>"
-        ;;><CCR>
-        ;;>>>K C0C S C0C=""
-        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","")
-        ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>"
-        ;;><ACTLST>
-        ;;>>>K C0C S C0C=""
-        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","")
-        ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST")
-        ;;><ACTORS>
-        ;;>>>D ZTEST^C0CCCR("ACTLST")
-        ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2")
-        ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3")
-        ;;>>?G3(G3(0))["</Actors>"
-        ;;><TRIM>
-        ;;>>>D ZTEST^C0CCCR("CCR")
-        ;;>>>W $$TRIM^C0CXPATH(CCDGLO)
-        ;;><CCD>
-        ;;>>>K C0C S C0C=""
-        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCD","","","")
-        ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>"
-        ;;></TEST>
+C0CCCD   ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008,2009 George Lilly, University of Minnesota.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ ; EXPORT A CCR
+ ;
+EXPORT   ; EXPORT ENTRY POINT FOR CCR
+       ; Select a patient.
+       S DIC=2,DIC(0)="AEMQ" D ^DIC
+       I Y<1 Q  ; EXIT
+       S DFN=$P(Y,U,1) ; SET THE PATIENT
+       D XPAT(DFN,"","") ; EXPORT TO A FILE
+       Q
+       ;
+XPAT(DFN,DIR,FN) ; EXPORT ONE PATIENT TO A FILE
+       ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR")
+       ; FN IS FILE NAME, DEFAULTS IF NULL
+       ; N CCDGLO
+       D CCDRPC(.CCDGLO,DFN,"CCD","","","")
+       S OARY=$NA(^TMP("C0CCCR",$J,DFN,"CCD",1))
+       S ONAM=FN
+       I FN="" S ONAM="PAT_"_DFN_"_CCD_V1.xml"
+       S ODIRGLB=$NA(^TMP("C0CCCR","ODIR"))
+       I '$D(@ODIRGLB) D  ; IF NOT ODIR HAS BEEN SET
+       . S @ODIRGLB="/home/glilly/CCROUT"
+       . ;S @ODIRGLB="/home/cedwards/"
+       . ;S @ODIRGLB="/opt/wv/p/"
+       S ODIR=DIR
+       I DIR="" S ODIR=@ODIRGLB
+       N ZY
+       S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR)
+       W $P(ZY,U,2)
+       Q
+       ;
+CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY)  ;RPC ENTRY POINT FOR CCR OUTPUT
+    ; CCRGRTN IS RETURN ARRAY PASSED BY NAME
+    ; DFN IS PATIENT IEN
+    ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART
+    ;   OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC
+    ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL
+    ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME
+    ; - NULL MEANS NOW
+    ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND
+    ;    "TO" VARIABLES
+    ;    IF NULL WILL DEFAULT TO "FROM" ORGANIZATION AND "TO" DFN
+    I '$D(DEBUG) S DEBUG=0
+    N CCD S CCD=0 ; FLAG FOR PROCESSING A CCD
+    I CCRPART="CCD" S CCD=1 ; WE ARE PROCESSING A CCD
+    S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE
+    I CCD S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCD")) ; GLOBAL FOR THE CCD
+    E  S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR
+    S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS
+    ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC
+    S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL
+    I CCD D LOAD^C0CCCD1(TGLOBAL)  ; LOAD THE CCR TEMPLATE
+    E  D LOAD^C0CCCR0(TGLOBAL)  ; LOAD THE CCR TEMPLATE
+    D CP^C0CXPATH(TGLOBAL,CCDGLO) ; COPY THE TEMPLATE TO CCR GLOBAL
+    N CAPSAVE,CAPSAVE2 ; FOR HOLDING THE CCD ROOT LINES
+    S CAPSAVE=@TGLOBAL@(3) ; SAVE THE CCD ROOT
+    S CAPSAVE2=@TGLOBAL@(@TGLOBAL@(0)) ; SAVE LAST LINE OF CCD
+    S @CCDGLO@(3)="<ContinuityOfCareRecord>" ; CAP WITH CCR ROOT
+    S @TGLOBAL@(3)=@CCDGLO@(3) ; CAP THE TEMPLATE TOO
+    S @CCDGLO@(@CCDGLO@(0))="</ContinuityOfCareRecord>" ; FINISH CAP
+    S @TGLOBAL@(@TGLOBAL@(0))="</ContinuityOfCareRecord>" ; FINISH CAP TEMP
+    ;
+    ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL
+    ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES
+    D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Body")
+    D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Actors")
+    I 'CCD D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Signatures")
+    I DEBUG F I=1:1:@CCDGLO@(0) W @CCDGLO@(I),!
+    ;
+    I 'CCD D HDRMAP(CCDGLO,DFN,HDRARY) ; MAP HEADER VARIABLES
+    ; MAPPING THE PATIENT PORTION OF THE CDA HEADER
+    S ZZX="//ContinuityOfCareRecord/recordTarget/patientRole/patient"
+    D QUERY^C0CXPATH(CCDGLO,ZZX,"ACTT1")
+    D PATIENT^C0CACTOR("ACTT1",DFN,"ACTORPATIENT_"_DFN,"ACTT2") ; MAP PATIENT
+    I DEBUG D PARY^C0CXPATH("ACTT2")
+    D REPLACE^C0CXPATH(CCDGLO,"ACTT2",ZZX)
+    I DEBUG D PARY^C0CXPATH(CCDGLO)
+    K ACTT1 K ACCT2
+    ; MAPPING THE PROVIDER ORGANIZATION,AUTHOR,INFORMANT,CUSTODIAN CDA HEADER
+    ; FOR NOW, THEY ARE ALL THE SAME AND RESOLVE TO ORGANIZATION
+    D ORG^C0CACTOR(CCDGLO,DFN,"ACTORPATIENTORGANIZATION","ACTT2") ; MAP ORG
+    D CP^C0CXPATH("ACTT2",CCDGLO)
+    ;
+    K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT
+    S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS
+    D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS
+    N I,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD
+    F I=1:1:@CCRXTAB@(0)  D  ; PROCESS THE CCR BODY SECTIONS
+    . S XI=@CCRXTAB@(I) ; CALL COPONENTS TO PARSE
+    . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL
+    . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL
+    . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE
+    . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS
+    . S IXML="INXML"
+    . I CCD D SHAVE(IXML) ; REMOVE ALL BUT REPEATING PARTS OF TEMPLATE SECTION
+    . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES
+    . ; W OXML,!
+    . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL
+    . W "RUNNING ",CALL,!
+    . X CALL
+    . I @OXML@(0)'=0 D  ; THERE IS A RESULT
+    . . I CCD D QUERY^C0CXPATH(TGLOBAL,XPATH,"ITMP") ; XML TO UNSHAVE WITH
+    . . I CCD D UNSHAVE("ITMP",OXML)
+    . . I CCD D UNMARK^C0CXPATH(OXML) ; REMOVE THE CCR MARKUP FROM SECTION
+    . ; NOW INSERT THE RESULTS IN THE CCR BUFFER
+    . D INSERT^C0CXPATH(CCDGLO,OXML,"//ContinuityOfCareRecord/Body")
+    . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),!
+    ; NEED TO ADD BACK IN ACTOR PROCESSING AFTER WE FIGURE OUT LINKAGE
+    ; D ACTLST^C0CCCR(CCDGLO,ACTGLO) ; GEN THE ACTOR LIST
+    ; D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT")
+    ; D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2")
+    ; D INSINNER^C0CXPATH(CCDGLO,"ACTT2","//ContinuityOfCareRecord/Actors")
+    N I,J,DONE S DONE=0
+    F I=0:0 D  Q:DONE  ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE
+    . S J=$$TRIM^C0CXPATH(CCDGLO) ; DELETE EMPTY ELEMENTS
+    . W "TRIMMED",J,!
+    . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE
+    I CCD D  ; TURN THE BODY INTO A CCD COMPONENT
+    . N I
+    . F I=1:1:@CCDGLO@(0) D  ; SEARCH THROUGH THE ENTIRE ARRAY
+    . . I @CCDGLO@(I)["<Body>" D  ; REPLACE BODY MARKUP
+    . . . S @CCDGLO@(I)="<component><structuredBody>" ; WITH CCD EQ
+    . . I @CCDGLO@(I)["</Body>" D  ; REPLACE BODY MARKUP
+    . . . S @CCDGLO@(I)="</structuredBody></component>"
+    S @CCDGLO@(3)=CAPSAVE ; UNCAP - TURN IT BACK INTO A CCD
+    S @CCDGLO@(@CCDGLO@(0))=CAPSAVE2 ; UNCAP LAST LINE
+    Q
+    ;
+INITSTPS(TAB)  ; INITIALIZE CCR PROCESSING STEPS
+    ; TAB IS PASSED BY NAME
+    W "TAB= ",TAB,!
+    ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS
+    D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")")
+    ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")")
+    I 'CCD D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")")
+    Q
+    ;
+SHAVE(SHXML) ; REMOVES THE 2-6 AND N-1 AND N-2 LINES FROM A COMPONENT
+    ; NEEDED TO EXPOSE THE REPEATING PARTS FOR GENERATION
+    N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST
+    W SHXML,!
+    W @SHXML@(1),!
+    D QUEUE^C0CXPATH("SHBLD",SHXML,1,1) ; THE FIRST LINE IS NEEDED
+    D QUEUE^C0CXPATH("SHBLD",SHXML,7,@SHXML@(0)-3) ; REPEATING PART
+    D QUEUE^C0CXPATH("SHBLD",SHXML,@SHXML@(0),@SHXML@(0)) ; LAST LINE
+    D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST
+    D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION
+    D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY
+    Q
+    ;
+UNSHAVE(ORIGXML,SHXML) ; REPLACES THE 2-6 AND N-1 AND N-2 LINES FROM TEMPLATE
+    ; NEEDED TO RESTORM FIXED TOP AND BOTTOM OF THE COMPONENT XML
+    N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST
+    W SHXML,!
+    W @SHXML@(1),!
+    D QUEUE^C0CXPATH("SHBLD",ORIGXML,1,6) ; FIRST 6 LINES OF TEMPLATE
+    D QUEUE^C0CXPATH("SHBLD",SHXML,2,@SHXML@(0)-1) ; INS ALL BUT FIRST/LAST
+    D QUEUE^C0CXPATH("SHBLD",ORIGXML,@ORIGXML@(0)-2,@ORIGXML@(0)) ; FROM TEMP
+    D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST
+    D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION
+    D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY
+    Q
+    ;
+HDRMAP(CXML,DFN,IHDR)   ; MAP HEADER VARIABLES: FROM, TO ECT
+    N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER"))
+    ; K @VMAP
+    S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT")
+    I IHDR="" D  ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS
+    . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN
+    . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ???
+    . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM
+    . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN  ; FOR TEST PURPOSES
+    . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR"  ; FOR TEST PURPOSES
+    . S @VMAP@("ACTORTOTEXT")="Patient"  ; FOR TEST PURPOSES
+    . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT
+    I IHDR'="" D  ; HEADER VALUES ARE PROVIDED
+    . D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY
+    N CTMP
+    D MAP^C0CXPATH(CXML,VMAP,"CTMP")
+    D CP^C0CXPATH("CTMP",CXML)
+    Q
+    ;
+ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML
+    ; AXML AND ACTRTN ARE PASSED BY NAME
+    ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2
+    ; P1= OBJECTID - ACTORPATIENT_2
+    ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE
+    ;OR INSTITUTION
+    ;  OR PERSON(IN PATIENT FILE IE NOK)
+    ; P3= IEN RECORD NUMBER FOR ACTOR - 2
+    N I,J,K,L
+    K @ACTRTN ; CLEAR RETURN ARRAY
+    F I=1:1:@AXML@(0) D  ; SCAN ALL LINES
+    . I @AXML@(I)?.E1"<ActorID>".E D  ; THERE IS AN ACTOR THIS LINE
+    . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1)
+    . . W "<ActorID>=>",J,!
+    . . I J'="" S K(J)="" ; HASHING ACTOR
+    . . ;  TO GET RID OF DUPLICATES
+    S I="" ; GOING TO $O THROUGH THE HASH
+    F J=0:0 D  Q:$O(K(I))=""  ;
+    . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS
+    . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID
+    . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE
+    . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR
+    . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY
+    Q
+    ;
+TEST ; RUN ALL THE TEST CASES
+  D TESTALL^C0CUNIT("C0CCCR")
+  Q
+  ;
+ZTEST(WHICH)  ; RUN ONE SET OF TESTS
+  N ZTMP
+  D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
+  D ZTEST^C0CUNIT(.ZTMP,WHICH)
+  Q
+  ;
+TLIST  ; LIST THE TESTS
+  N ZTMP
+  D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
+  D TLIST^C0CUNIT(.ZTMP)
+  Q
+  ;
+ ;;><TEST>
+ ;;><PROBLEMS>
+ ;;>>>K C0C S C0C=""
+ ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","","","")
+ ;;>>?@C0C@(@C0C@(0))["</Problems>"
+ ;;><VITALS>
+ ;;>>>K C0C S C0C=""
+ ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","","","")
+ ;;>>?@C0C@(@C0C@(0))["</VitalSigns>"
+ ;;><CCR>
+ ;;>>>K C0C S C0C=""
+ ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","")
+ ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>"
+ ;;><ACTLST>
+ ;;>>>K C0C S C0C=""
+ ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","")
+ ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST")
+ ;;><ACTORS>
+ ;;>>>D ZTEST^C0CCCR("ACTLST")
+ ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2")
+ ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3")
+ ;;>>?G3(G3(0))["</Actors>"
+ ;;><TRIM>
+ ;;>>>D ZTEST^C0CCCR("CCR")
+ ;;>>>W $$TRIM^C0CXPATH(CCDGLO)
+ ;;><CCD>
+ ;;>>>K C0C S C0C=""
+ ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCD","","","")
+ ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>"
+ ;;></TEST>

ccr/trunk/p/C0CCCD1.m

@@ -1 @@
-C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008,2009 George Lilly, University of Minnesota.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-                 W "This is a CCD TEMPLATE with processing routines",!
-                 W !
-                 Q
-                 ;
-ZT(ZARY,BAT,LINE)       ; private routine to add a line to the ZARY array
-                 ; ZARY IS PASSED BY NAME
-                 ; BAT is a string identifying the section
-                 ; LINE is a test which will evaluate to true or false
-                 ; I '$G(@ZARY) D  ; IF ZARY DOES NOT EXIST '
-                 ; . S @ZARY@(0)=0 ; initially there are no elements
-                 ; . W "GOT HERE LOADING "_LINE,!
-                 N CNT ; count of array elements
-                 S CNT=@ZARY@(0) ; contains array count
-                 S CNT=CNT+1 ; increment count
-                 S @ZARY@(CNT)=LINE ; put the line in the array
-                 ; S @ZARY@(BAT,CNT)="" ; index the test by battery
-                 S @ZARY@(0)=CNT ; update the array counter
-                 Q
-                 ;
-ZLOAD(ZARY,ROUTINE)     ; load tests into ZARY which is passed by reference
-                 ; ZARY IS PASSED BY NAME
-                 ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
-                 ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
-                 K @ZARY S @ZARY=""
-                 S @ZARY@(0)=0 ; initialize array count
-                 N LINE,LABEL,BODY
-                 N INTEST S INTEST=0 ; switch for in the TEMPLATE section
-                 N SECTION S SECTION="[anonymous]" ; NO section LABEL
-                 ;
-                 N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
-                 . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section
-                 . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section
-                 . I INTEST  D  ; within the section
-                 . . I LINE?." "1";><".E  D  ; sub-section name found
-                 . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name
-                 . . I LINE?." "1";;".E  D  ; line found
-                 . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array
-                 Q
-                 ;
-LOAD(ARY)       ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME
-                 D ZLOAD(ARY,"C0CCCD1")
-                 ; ZWR @ARY
-                 Q
-                 ;
-TRMCCD     ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD
-                 Q
-MARKUP  ;<MARKUP>
-        ;;<Body>
-        ;;<Problems>
-        ;;</Problems>
-        ;;<FamilyHistory>
-        ;;</FamilyHistory>
-        ;;<SocialHistory>
-        ;;</SocialHistory>
-        ;;<Alerts>
-        ;;</Alerts>
-        ;;<Medications>
-        ;;</Medications>
-        ;;<VitalSigns>
-        ;;</VitalSigns>
-        ;;<Results>
-        ;;</Results>
-        ;;</Body>
-        ;;</ContinuityOfCareRecord>
-        ;</MARKUP>
-        ;;<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">
-        ;;</ClinicalDocument>
-        Q
-        ;
-        ;<TEMPLATE>
-        ;;<?xml version="1.0"?>
-        ;;<?xml-stylesheet type="text/xsl" href="CCD.xsl"?>
-        ;;<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">
-        ;;<typeId root="2.16.840.1.113883.1.3" extension="POCD_HD000040"/>
-        ;;<templateId root="2.16.840.1.113883.10.20.1"/>
-        ;;<id root="db734647-fc99-424c-a864-7e3cda82e703"/>
-        ;;<code code="34133-9" codeSystem="2.16.840.1.113883.6.1" displayName="Summarization of episode note"/>
-        ;;<title>Continuity of Care Document</title>
-        ;;<effectiveTime value="20000407130000+0500"/>
-        ;;<confidentialityCode code="N" codeSystem="2.16.840.1.113883.5.25"/>
-        ;;<languageCode code="en-US"/>
-        ;;<recordTarget>
-        ;;<patientRole>
-        ;;<id extension="@@ACTORIEN@@" root="2.16.840.1.113883.19.5"/>
-        ;;<patient>
-        ;;<name>
-        ;;<given>@@ACTORGIVENNAME@@</given>
-        ;;<family>@@ACTORFAMILYNAME@@</family>
-        ;;<suffix>@@ACTORSUFFIXNAME@@</suffix>
-        ;;</name>
-        ;;<administrativeGenderCode code="@@ACTORGENDER@@" codeSystem="2.16.840.1.113883.5.1"/>
-        ;;<birthTime value="@@ACTORDATEOFBIRTH@@"/>
-        ;;</patient>
-        ;;<providerOrganization>
-        ;;<id root="2.16.840.1.113883.19.5"/>
-        ;;<name>@@ORGANIZATIONNAME@@</name>
-        ;;</providerOrganization>
-        ;;</patientRole>
-        ;;</recordTarget>
-        ;;<author>
-        ;;<time value="20000407130000+0500"/>
-        ;;<assignedAuthor>
-        ;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/>
-        ;;<assignedPerson>
-        ;;<name>
-        ;;<prefix>@@ACTORNAMEPREFIX@@</prefix>
-        ;;<given>@@ACTORGIVENNAME@@</given>
-        ;;<family>@@ACTORFAMILYNAME@@</family>
-        ;;</name>
-        ;;</assignedPerson>
-        ;;<representedOrganization>
-        ;;<id root="2.16.840.1.113883.19.5"/>
-        ;;<name>@@ORGANIZATIONNAME@@</name>
-        ;;</representedOrganization>
-        ;;</assignedAuthor>
-        ;;</author>
-        ;;<informant>
-        ;;<assignedEntity>
-        ;;<id nullFlavor="NI"/>
-        ;;<representedOrganization>
-        ;;<id root="2.16.840.1.113883.19.5"/>
-        ;;<name>@@ORGANIZATIONNAME@@</name>
-        ;;</representedOrganization>
-        ;;</assignedEntity>
-        ;;</informant>
-        ;;<custodian>
-        ;;<assignedCustodian>
-        ;;<representedCustodianOrganization>
-        ;;<id root="2.16.840.1.113883.19.5"/>
-        ;;<name>@@ORGANIZATIONNAME@@</name>
-        ;;</representedCustodianOrganization>
-        ;;</assignedCustodian>
-        ;;</custodian>
-        ;;<legalAuthenticator>
-        ;;<time value="20000407130000+0500"/>
-        ;;<signatureCode code="S"/>
-        ;;<assignedEntity>
-        ;;<id nullFlavor="NI"/>
-        ;;<representedOrganization>
-        ;;<id root="2.16.840.1.113883.19.5"/>
-        ;;<name>@@ORGANIZATIONNAME@@</name>
-        ;;</representedOrganization>
-        ;;</assignedEntity>
-        ;;</legalAuthenticator>
-        ;;<Actors>
-        ;;<ACTOR-NOK>
-        ;;<participant typeCode="IND">
-        ;;<associatedEntity classCode="NOK">
-        ;;<id root="4ac71514-6a10-4164-9715-f8d96af48e6d"/>
-        ;;<code code="65656005" codeSystem="2.16.840.1.113883.6.96" displayName="Biiological mother"/>
-        ;;<telecom value="tel:(999)555-1212"/>
-        ;;<associatedPerson>
-        ;;<name>
-        ;;<given>Henrietta</given>
-        ;;<family>Levin</family>
-        ;;</name>
-        ;;</associatedPerson>
-        ;;</associatedEntity>
-        ;;</participant>
-        ;;</ACTOR-NOK>
-        ;;</Actors>
-        ;;<documentationOf>
-        ;;<serviceEvent classCode="PCPR">
-        ;;<effectiveTime>
-        ;;<high value="@@DATETIME@@"/>
-        ;;</effectiveTime>
-        ;;<performer typeCode="PRF">
-        ;;<functionCode code="PCP" codeSystem="2.16.840.1.113883.5.88"/>
-        ;;<time>
-        ;;<low value="1990"/>
-        ;;<high value='20000407'/>
-        ;;</time>
-        ;;<assignedEntity>
-        ;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/>
-        ;;<assignedPerson>
-        ;;<name>
-        ;;<prefix>@@ACTORPREFIXNAME@@</prefix>
-        ;;<given>@@ACTORGIVENNAME@@</given>
-        ;;<family>@@ACTORFAMILYNAME@@</family>
-        ;;</name>
-        ;;</assignedPerson>
-        ;;<representedOrganization>
-        ;;<id root="2.16.840.1.113883.19.5"/>
-        ;;<name>@@ORGANIZATIONNAME@@</name>
-        ;;</representedOrganization>
-        ;;</assignedEntity>
-        ;;</performer>
-        ;;</serviceEvent>
-        ;;</documentationOf>
-        ;;<Body>
-        ;;<PROBLEMS-HTML>
-        ;;<text><table border="1" width="100%"><thead><tr><th>Condition</th><th>Effective Dates</th><th>Condition Status</th></tr></thead><tbody>
-        ;;<tr><td>@@PROBLEMDESCRIPTION@@</td>
-        ;;<td>@@PROBLEMDATEOFONSET@@</td>
-        ;;<td>Active</td></tr>
-        ;;</tbody></table></text>
-        ;;</PROBLEMS-HTML>
-        ;;<Problems>
-        ;;<component>
-        ;;<section>
-        ;;<templateId root='2.16.840.1.113883.10.20.1.11'/>
-        ;;<code code="11450-4" codeSystem="2.16.840.1.113883.6.1"/>
-        ;;<title>Problems</title>
-        ;;<entry typeCode="DRIV">
-        ;;<act classCode="ACT" moodCode="EVN">
-        ;;<templateId root='2.16.840.1.113883.10.20.1.27'/>
-        ;;<id root="6a2fa88d-4174-4909-aece-db44b60a3abb"/>
-        ;;<code nullFlavor="NA"/>
-        ;;<entryRelationship typeCode="SUBJ">
-        ;;<observation classCode="OBS" moodCode="EVN">
-        ;;<templateId root='2.16.840.1.113883.10.20.1.28'/>
-        ;;<id root="d11275e7-67ae-11db-bd13-0800200c9a66"/>
-        ;;<code code="ASSERTION" codeSystem="2.16.840.1.113883.5.4"/>
-        ;;<statusCode code="completed"/>
-        ;;<effectiveTime>
-        ;;<low value="@@PROBLEMDATEOFONSET@@"/>
-        ;;</effectiveTime>
-        ;;<value xsi:type="CD" code="@@PROBLEMCODEVALUE@@" codeSystem="2.16.840.1.113883.6.96" displayName="@@PROBLEMDESCRIPTION@@"/>
-        ;;<entryRelationship typeCode="REFR">
-        ;;<observation classCode="OBS" moodCode="EVN">
-        ;;<templateId root='2.16.840.1.113883.10.20.1.50'/>
-        ;;<code code="33999-4" codeSystem="2.16.840.1.113883.6.1" displayName="Status"/>
-        ;;<statusCode code="completed"/>
-        ;;<value xsi:type="CE" code="55561003" codeSystem="2.16.840.1.113883.6.96" displayName="Active"/>
-        ;;</observation>
-        ;;</entryRelationship>
-        ;;</observation>
-        ;;</entryRelationship>
-        ;;</act>
-        ;;</entry>
-        ;;</section>
-        ;;</component>
-        ;;</Problems>
-        ;;<FamilyHistory>
-        ;;</FamilyHistory>
-        ;;<SocialHistory>
-        ;;</SocialHistory>
-        ;;<Alerts>
-        ;;</Alerts>
-        ;;<Medications>
-        ;;</Medications>
-        ;;<VitalSigns>
-        ;;</VitalSigns>
-        ;;<Results>
-        ;;</Results>
-        ;;</Body>
-        ;;</ClinicalDocument>
-        ;</TEMPLATE>
+C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008,2009 George Lilly, University of Minnesota.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+          W "This is a CCD TEMPLATE with processing routines",!
+          W !
+          Q
+          ;
+ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array
+          ; ZARY IS PASSED BY NAME
+          ; BAT is a string identifying the section
+          ; LINE is a test which will evaluate to true or false
+          ; I '$G(@ZARY) D  ; IF ZARY DOES NOT EXIST '
+          ; . S @ZARY@(0)=0 ; initially there are no elements
+          ; . W "GOT HERE LOADING "_LINE,!
+          N CNT ; count of array elements
+          S CNT=@ZARY@(0) ; contains array count
+          S CNT=CNT+1 ; increment count
+          S @ZARY@(CNT)=LINE ; put the line in the array
+          ; S @ZARY@(BAT,CNT)="" ; index the test by battery
+          S @ZARY@(0)=CNT ; update the array counter
+          Q
+          ;
+ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference
+          ; ZARY IS PASSED BY NAME
+          ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
+          ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
+          K @ZARY S @ZARY=""
+          S @ZARY@(0)=0 ; initialize array count
+          N LINE,LABEL,BODY
+          N INTEST S INTEST=0 ; switch for in the TEMPLATE section
+          N SECTION S SECTION="[anonymous]" ; NO section LABEL
+          ;
+          N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
+          . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section
+          . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section
+          . I INTEST  D  ; within the section
+          . . I LINE?." "1";><".E  D  ; sub-section name found
+          . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name
+          . . I LINE?." "1";;".E  D  ; line found
+          . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array
+          Q
+          ;
+LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME
+          D ZLOAD(ARY,"C0CCCD1")
+          ; ZWR @ARY
+          Q
+          ;
+TRMCCD    ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD
+          Q
+MARKUP ;<MARKUP>
+ ;;<Body>
+ ;;<Problems>
+ ;;</Problems>
+ ;;<FamilyHistory>
+ ;;</FamilyHistory>
+ ;;<SocialHistory>
+ ;;</SocialHistory>
+ ;;<Alerts>
+ ;;</Alerts>
+ ;;<Medications>
+ ;;</Medications>
+ ;;<VitalSigns>
+ ;;</VitalSigns>
+ ;;<Results>
+ ;;</Results>
+ ;;</Body>
+ ;;</ContinuityOfCareRecord>
+ ;</MARKUP>
+ ;;<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">
+ ;;</ClinicalDocument>
+ Q
+ ;
+ ;<TEMPLATE>
+ ;;<?xml version="1.0"?>
+ ;;<?xml-stylesheet type="text/xsl" href="CCD.xsl"?>
+ ;;<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">
+ ;;<typeId root="2.16.840.1.113883.1.3" extension="POCD_HD000040"/>
+ ;;<templateId root="2.16.840.1.113883.10.20.1"/>
+ ;;<id root="db734647-fc99-424c-a864-7e3cda82e703"/>
+ ;;<code code="34133-9" codeSystem="2.16.840.1.113883.6.1" displayName="Summarization of episode note"/>
+ ;;<title>Continuity of Care Document</title>
+ ;;<effectiveTime value="20000407130000+0500"/>
+ ;;<confidentialityCode code="N" codeSystem="2.16.840.1.113883.5.25"/>
+ ;;<languageCode code="en-US"/>
+ ;;<recordTarget>
+ ;;<patientRole>
+ ;;<id extension="@@ACTORIEN@@" root="2.16.840.1.113883.19.5"/>
+ ;;<patient>
+ ;;<name>
+ ;;<given>@@ACTORGIVENNAME@@</given>
+ ;;<family>@@ACTORFAMILYNAME@@</family>
+ ;;<suffix>@@ACTORSUFFIXNAME@@</suffix>
+ ;;</name>
+ ;;<administrativeGenderCode code="@@ACTORGENDER@@" codeSystem="2.16.840.1.113883.5.1"/>
+ ;;<birthTime value="@@ACTORDATEOFBIRTH@@"/>
+ ;;</patient>
+ ;;<providerOrganization>
+ ;;<id root="2.16.840.1.113883.19.5"/>
+ ;;<name>@@ORGANIZATIONNAME@@</name>
+ ;;</providerOrganization>
+ ;;</patientRole>
+ ;;</recordTarget>
+ ;;<author>
+ ;;<time value="20000407130000+0500"/>
+ ;;<assignedAuthor>
+ ;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/>
+ ;;<assignedPerson>
+ ;;<name>
+ ;;<prefix>@@ACTORNAMEPREFIX@@</prefix>
+ ;;<given>@@ACTORGIVENNAME@@</given>
+ ;;<family>@@ACTORFAMILYNAME@@</family>
+ ;;</name>
+ ;;</assignedPerson>
+ ;;<representedOrganization>
+ ;;<id root="2.16.840.1.113883.19.5"/>
+ ;;<name>@@ORGANIZATIONNAME@@</name>
+ ;;</representedOrganization>
+ ;;</assignedAuthor>
+ ;;</author>
+ ;;<informant>
+ ;;<assignedEntity>
+ ;;<id nullFlavor="NI"/>
+ ;;<representedOrganization>
+ ;;<id root="2.16.840.1.113883.19.5"/>
+ ;;<name>@@ORGANIZATIONNAME@@</name>
+ ;;</representedOrganization>
+ ;;</assignedEntity>
+ ;;</informant>
+ ;;<custodian>
+ ;;<assignedCustodian>
+ ;;<representedCustodianOrganization>
+ ;;<id root="2.16.840.1.113883.19.5"/>
+ ;;<name>@@ORGANIZATIONNAME@@</name>
+ ;;</representedCustodianOrganization>
+ ;;</assignedCustodian>
+ ;;</custodian>
+ ;;<legalAuthenticator>
+ ;;<time value="20000407130000+0500"/>
+ ;;<signatureCode code="S"/>
+ ;;<assignedEntity>
+ ;;<id nullFlavor="NI"/>
+ ;;<representedOrganization>
+ ;;<id root="2.16.840.1.113883.19.5"/>
+ ;;<name>@@ORGANIZATIONNAME@@</name>
+ ;;</representedOrganization>
+ ;;</assignedEntity>
+ ;;</legalAuthenticator>
+ ;;<Actors>
+ ;;<ACTOR-NOK>
+ ;;<participant typeCode="IND">
+ ;;<associatedEntity classCode="NOK">
+ ;;<id root="4ac71514-6a10-4164-9715-f8d96af48e6d"/>
+ ;;<code code="65656005" codeSystem="2.16.840.1.113883.6.96" displayName="Biiological mother"/>
+ ;;<telecom value="tel:(999)555-1212"/>
+ ;;<associatedPerson>
+ ;;<name>
+ ;;<given>Henrietta</given>
+ ;;<family>Levin</family>
+ ;;</name>
+ ;;</associatedPerson>
+ ;;</associatedEntity>
+ ;;</participant>
+ ;;</ACTOR-NOK>
+ ;;</Actors>
+ ;;<documentationOf>
+ ;;<serviceEvent classCode="PCPR">
+ ;;<effectiveTime>
+ ;;<high value="@@DATETIME@@"/>
+ ;;</effectiveTime>
+ ;;<performer typeCode="PRF">
+ ;;<functionCode code="PCP" codeSystem="2.16.840.1.113883.5.88"/>
+ ;;<time>
+ ;;<low value="1990"/>
+ ;;<high value='20000407'/>
+ ;;</time>
+ ;;<assignedEntity>
+ ;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/>
+ ;;<assignedPerson>
+ ;;<name>
+ ;;<prefix>@@ACTORPREFIXNAME@@</prefix>
+ ;;<given>@@ACTORGIVENNAME@@</given>
+ ;;<family>@@ACTORFAMILYNAME@@</family>
+ ;;</name>
+ ;;</assignedPerson>
+ ;;<representedOrganization>
+ ;;<id root="2.16.840.1.113883.19.5"/>
+ ;;<name>@@ORGANIZATIONNAME@@</name>
+ ;;</representedOrganization>
+ ;;</assignedEntity>
+ ;;</performer>
+ ;;</serviceEvent>
+ ;;</documentationOf>
+ ;;<Body>
+ ;;<PROBLEMS-HTML>
+ ;;<text><table border="1" width="100%"><thead><tr><th>Condition</th><th>Effective Dates</th><th>Condition Status</th></tr></thead><tbody>
+ ;;<tr><td>@@PROBLEMDESCRIPTION@@</td>
+ ;;<td>@@PROBLEMDATEOFONSET@@</td>
+ ;;<td>Active</td></tr>
+ ;;</tbody></table></text>
+ ;;</PROBLEMS-HTML>
+ ;;<Problems>
+ ;;<component>
+ ;;<section>
+ ;;<templateId root='2.16.840.1.113883.10.20.1.11'/>
+ ;;<code code="11450-4" codeSystem="2.16.840.1.113883.6.1"/>
+ ;;<title>Problems</title>
+ ;;<entry typeCode="DRIV">
+ ;;<act classCode="ACT" moodCode="EVN">
+ ;;<templateId root='2.16.840.1.113883.10.20.1.27'/>
+ ;;<id root="6a2fa88d-4174-4909-aece-db44b60a3abb"/>
+ ;;<code nullFlavor="NA"/>
+ ;;<entryRelationship typeCode="SUBJ">
+ ;;<observation classCode="OBS" moodCode="EVN">
+ ;;<templateId root='2.16.840.1.113883.10.20.1.28'/>
+ ;;<id root="d11275e7-67ae-11db-bd13-0800200c9a66"/>
+ ;;<code code="ASSERTION" codeSystem="2.16.840.1.113883.5.4"/>
+ ;;<statusCode code="completed"/>
+ ;;<effectiveTime>
+ ;;<low value="@@PROBLEMDATEOFONSET@@"/>
+ ;;</effectiveTime>
+ ;;<value xsi:type="CD" code="@@PROBLEMCODEVALUE@@" codeSystem="2.16.840.1.113883.6.96" displayName="@@PROBLEMDESCRIPTION@@"/>
+ ;;<entryRelationship typeCode="REFR">
+ ;;<observation classCode="OBS" moodCode="EVN">
+ ;;<templateId root='2.16.840.1.113883.10.20.1.50'/>
+ ;;<code code="33999-4" codeSystem="2.16.840.1.113883.6.1" displayName="Status"/>
+ ;;<statusCode code="completed"/>
+ ;;<value xsi:type="CE" code="55561003" codeSystem="2.16.840.1.113883.6.96" displayName="Active"/>
+ ;;</observation>
+ ;;</entryRelationship>
+ ;;</observation>
+ ;;</entryRelationship>
+ ;;</act>
+ ;;</entry>
+ ;;</section>
+ ;;</component>
+ ;;</Problems>
+ ;;<FamilyHistory>
+ ;;</FamilyHistory>
+ ;;<SocialHistory>
+ ;;</SocialHistory>
+ ;;<Alerts>
+ ;;</Alerts>
+ ;;<Medications>
+ ;;</Medications>
+ ;;<VitalSigns>
+ ;;</VitalSigns>
+ ;;<Results>
+ ;;</Results>
+ ;;</Body>
+ ;;</ClinicalDocument>
+ ;</TEMPLATE>

ccr/trunk/p/C0CCCR.m

@@ -1 @@
-C0CCCR    ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008,2009 George Lilly, University of Minnesota.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        ; EXPORT A CCR
-        ;
-EXPORT    ; EXPORT ENTRY POINT FOR CCR
-        ; Select a patient.
-        S DIC=2,DIC(0)="AEMQ" D ^DIC
-        I Y<1 Q  ; EXIT
-        S DFN=$P(Y,U,1) ; SET THE PATIENT
-        D XPAT(DFN) ; EXPORT TO A FILE
-        Q
-        ;
-XPAT(DFN,XPARMS,DIR,FN) ; EXPORT ONE PATIENT TO A FILE
-        ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR")
-        ; FN IS FILE NAME, DEFAULTS IF NULL
-        N CCRGLO,UDIR,UFN
-        S C0CNRPC=1 ; FLAG FOR NOT AN RPC CALL - FOR DEBUGGING THE RPC
-        I '$D(DIR) S UDIR=""
-        E  S UDIR=DIR
-        I '$D(FN) S UFN="" ; IF FILENAME IS NOT PASSED
-        E  S UFN=FN
-        I '$D(XPARMS) S XPARMS=""
-        N C0CRTN  ; RETURN ARRAY
-        D CCRRPC(.C0CRTN,DFN,XPARMS,"CCR")
-        S OARY=$NA(^TMP("C0CCUR",$J,DFN,"CCR",1))
-        S ONAM=UFN
-        I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_0.xml"
-        S ODIRGLB=$NA(^TMP("C0CCCR","ODIR"))
-        S ^TMP("C0CCCR","FNAME",DFN)=ONAM ; FILE NAME FOR BATCH USE
-        I $D(^TMP("GPLCCR","ODIR")) S @ODIRGLB=^TMP("GPLCCR","ODIR")
-        I '$D(@ODIRGLB) D  ; IF NOT ODIR HAS BEEN SET
-        . W "Warning.. please set ^TMP(""C0CCCR"",""ODIR"")=""output path""",! Q
-        . ;S @ODIRGLB="/home/glilly/CCROUT"
-        . ;S @ODIRGLB="/home/cedwards/"
-        . S @ODIRGLB="/opt/wv/p/"
-        S ODIR=UDIR
-        I UDIR="" S ODIR=@ODIRGLB
-        N ZY
-        S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR)
-        W !,$P(ZY,U,2),!
-        Q
-        ;
-DCCR(DFN)       ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED
-        ;
-        N G1
-        S G1=$NA(^TMP("C0CCUR",$J,DFN,"CCR"))
-        I $D(@G1@(0)) D  ; CCR EXISTS
-        . D PARY^C0CXPATH(G1)
-        E  W "CCR NOT CREATED, RUN D XPAT^C0CCCR(DFN,"""","""") FIRST",!
-        Q
-        ;
-CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART)     ;RPC ENTRY POINT FOR CCR OUTPUT
-        ; CCRGRTN IS RETURN ARRAY PASSED BY REFERENCE
-        ; DFN IS PATIENT IEN
-        ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART
-        ;   OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC
-        ; CCRPARMS ARE PARAMETERS THAT AFFECT THE EXTRACTION
-        ; IN THE FORM "PARM1:VALUE1^PARM2:VALUE2"
-        ; EXAMPLE: "LABLIMIT:T-60" TO LIMIT LAB EXTRACTION TO THE LAST 60 DAYS
-        ; SEE C0CPARMS FOR A COMPLETE LIST OF SUPPORTED PARAMETERS
-        K ^TMP("C0CCCR",$J) ; CLEAN UP THE GLOBAL BEFORE WE USE IT
-        M ^TMP("C0CSAV",$J)=^TMP($J) ; SAVING CALLER'S TMP SETTINGS
-        K ^TMP($J) ; START CLEAN
-        I '$D(DEBUG) S DEBUG=0
-        S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD
-        I '$D(CCRPARMS) S CCRPARMS=""
-        I '$D(CCRPART) S CCRPART="CCR"
-        I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"CALL",DFN)=""
-        D SET^C0CPARMS(CCRPARMS) ;SET PARAMETERS WITH CCRPARMS AS OVERRIDES
-        I '$D(TESTVIT) S TESTVIT=0 ; FLAG FOR TESTING VITALS
-        I '$D(TESTLAB) S TESTLAB=0 ; FLAG FOR TESTING RESULTS SECTION
-        I '$D(TESTALERT) S TESTALERT=1 ; FLAG FOR TESTING ALERTS SECTION
-        I '$D(TESTMEDS) S TESTMEDS=0 ; FLAG FOR TESTING C0CMED SECTION
-        S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE
-        S CCRGLO=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR
-        S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS
-        ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC
-        ;M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART OR ALL
-        D LOAD^C0CCCR0(TGLOBAL)  ; LOAD THE CCR TEMPLATE
-        D CP^C0CXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL
-        ;
-        ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL
-        ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES
-        D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body")
-        D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors")
-        D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures")
-        D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Comments")
-        I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),!
-        ;
-        D HDRMAP(CCRGLO,DFN) ; MAP HEADER VARIABLES
-        ;
-        K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT
-        S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS
-        D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS
-        N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD
-        F PROCI=1:1:@CCRXTAB@(0) D  ; PROCESS THE CCR BODY SECTIONS
-        . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE
-        . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL
-        . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL
-        . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE
-        . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS
-        . S IXML="INXML"
-        . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES
-        . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY
-        . ; W OXML,!
-        . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL
-        . W "RUNNING ",CALL,!
-        . X CALL
-        . ; NOW INSERT THE RESULTS IN THE CCR BUFFER
-        . I $G(@OXML@(0))>0 D  ; THERE IS A RESULT
-        . . D INSERT^C0CXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body")
-        . . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),!
-        N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING
-        D ACTLST^C0CCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST
-        D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT")
-        D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2")
-        D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors")
-        K ACTT,ACTT2
-        ;D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT")
-        ;D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2")
-        ;D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments")
-        ; gpl - turned off Comments for Certification
-        K CMTT,CMTT2
-        N TRIMI,J,DONE S DONE=0
-        F TRIMI=0:0 D  Q:DONE  ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE
-        . S J=$$TRIM^C0CXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS
-        . I DEBUG W "TRIMMED",J,!
-        . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE
-        ;S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLOBAL OF PART OR ALL
-        I CCRPART="CCR" M CCRGRTN=@CCRGLO ; ENTIRE CCR
-        E  M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART
-        I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"RESULT",CCRGRTN(0))=""
-        K ^TMP("C0CCCR",$J) ; BEGIN TO CLEAN UP
-        K ^TMP($J) ; REALLY CLEAN UP
-        M ^TMP($J)=^TMP("C0CSAV",$J) ; RESTORE CALLER'S $J
-        Q
-        ;
-INITSTPS(TAB)    ; INITIALIZE CCR PROCESSING STEPS
-        ; TAB IS PASSED BY NAME
-        I DEBUG W "TAB= ",TAB,!
-        ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS
-        D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")")
-        I TESTALERT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""C0CCCR"",$J,DFN,""ALERTS"")")
-        D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")")
-        D PUSH^C0CXPATH(TAB,"MAP;C0CIMMU;//ContinuityOfCareRecord/Body/Immunizations;^TMP(""C0CCCR"",$J,DFN,""IMMUNE"")")
-        I TESTVIT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVIT2;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")")
-        E  D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")")
-        D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")")
-        D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROC;//ContinuityOfCareRecord/Body/Procedures;^TMP(""C0CCCR"",$J,DFN,""PROCEDURES"")")
-        ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
-        ; gpl - turned off Encounters for Certification
-        Q
-        ;
-HDRMAP(CXML,DFN)        ; MAP HEADER VARIABLES: FROM, TO ECT
-        N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER"))
-        ; K @VMAP
-        S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT")
-        ; I IHDR="" D  ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS
-        D  ; ALWAYS MAP THESE VARIABLES
-        . S @VMAP@("CCRDOCOBJECTID")=$$UUID^C0CUTIL ; UUID FOR THIS CCR
-        . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN
-        . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - FROM PROVIDER
-        . ;S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ???
-        . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM
-        . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES
-        . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR"  ; FOR TEST PURPOSES
-        . S @VMAP@("ACTORTOTEXT")="Patient"  ; FOR TEST PURPOSES
-        . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT
-        ;I IHDR'="" D  ; HEADER VALUES ARE PROVIDED
-        ;. D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY
-        N CTMP
-        D MAP^C0CXPATH(CXML,VMAP,"CTMP")
-        D CP^C0CXPATH("CTMP",CXML)
-        N HRIMVARS ;
-        S HRIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"HEADER")) ; TO PERSIST VARS
-        M @HRIMVARS@(1)=@VMAP ; PERSIST THE HEADER VARIABLES IN RIM TABLE
-        S @HRIMVARS@(0)=1 ; ONLY ONE SET OF HEADERS PER PATIENT
-        Q
-        ;
-ACTLST(AXML,ACTRTN)     ; RETURN THE ACTOR LIST FOR THE XML IN AXML
-        ; AXML AND ACTRTN ARE PASSED BY NAME
-        ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2
-        ; P1= OBJECTID - ACTORPATIENT_2
-        ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE
-        ;OR INSTITUTION
-        ;  OR PERSON(IN PATIENT FILE IE NOK)
-        ; P3= IEN RECORD NUMBER FOR ACTOR - 2
-        N I,J,K,L
-        K @ACTRTN ; CLEAR RETURN ARRAY
-        F I=1:1:@AXML@(0) D  ; FIRST FIX MISSING LINKS
-        . I @AXML@(I)?.E1"_<".E D  ;
-        . . N ZA,ZB
-        . . S ZA=$P(@AXML@(I),">",1)_">"
-        . . S ZB="<"_$P(@AXML@(I),"<",3)
-        . . S @AXML@(I)=ZA_"ACTORORGANIZATION_1"_ZB
-        F I=1:1:@AXML@(0) D  ; SCAN ALL LINES
-        . I @AXML@(I)?.E1"<ActorID>".E D  ; THERE IS AN ACTOR THIS LINE
-        . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1)
-        . . I $G(LINKDEBUG) W "<ActorID>=>",J,!
-        . . I J'="" S K(J)="" ; HASHING ACTOR
-        . I @AXML@(I)?.E1"<LinkID>".E D  ; THERE IS AN ACTOR THIS LINE
-        . . S J=$P($P(@AXML@(I),"<LinkID>",2),"</LinkID>",1)
-        . . I $G(LINKDEBUG) W "<LinkID>=>",J,!
-        . . I J'="" S K(J)="" ; HASHING ACTOR
-        . . ;  TO GET RID OF DUPLICATES
-        S I="" ; GOING TO $O THROUGH THE HASH
-        F J=0:0 D  Q:$O(K(I))=""
-        . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS
-        . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID
-        . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE
-        . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR
-        . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY
-        Q
-        ;
-TEST    ; RUN ALL THE TEST CASES
-        D TESTALL^C0CUNIT("C0CCCR")
-        Q
-        ;
-ZTEST(WHICH)     ; RUN ONE SET OF TESTS
-        N ZTMP
-        D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
-        D ZTEST^C0CUNIT(.ZTMP,WHICH)
-        Q
-        ;
-TLIST    ; LIST THE TESTS
-        N ZTMP
-        D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
-        D TLIST^C0CUNIT(.ZTMP)
-        Q
-        ;
-        ;;><TEST>
-        ;;><PROBLEMS>
-        ;;>>>K C0C S C0C=""
-        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","")
-        ;;>>?@C0C@(@C0C@(0))["</Problems>"
-        ;;><VITALS>
-        ;;>>>K C0C S C0C=""
-        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","")
-        ;;>>?@C0C@(@C0C@(0))["</VitalSigns>"
-        ;;><CCR>
-        ;;>>>K C0C S C0C=""
-        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","")
-        ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>"
-        ;;><ACTLST>
-        ;;>>>K C0C S C0C=""
-        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","")
-        ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST")
-        ;;><ACTORS>
-        ;;>>>D ZTEST^C0CCCR("ACTLST")
-        ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2")
-        ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3")
-        ;;>>?G3(G3(0))["</Actors>"
-        ;;><TRIM>
-        ;;>>>D ZTEST^C0CCCR("CCR")
-        ;;>>>W $$TRIM^C0CXPATH(CCRGLO)
-        ;;><ALERTS>
-        ;;>>>S TESTALERT=1
-        ;;>>>K C0C S C0C=""
-        ;;>>>D CCRRPC^C0CCCR(.C0C,"2","ALERTS","")
-        ;;>>?@C0C@(@C0C@(0))["</Alerts>"
-        
-        
+C0CCCR   ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008,2009 George Lilly, University of Minnesota.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ ; EXPORT A CCR
+ ;
+EXPORT   ; EXPORT ENTRY POINT FOR CCR
+ ; Select a patient.
+ S DIC=2,DIC(0)="AEMQ" D ^DIC
+ I Y<1 Q  ; EXIT
+ S DFN=$P(Y,U,1) ; SET THE PATIENT
+ D XPAT(DFN) ; EXPORT TO A FILE
+ Q
+ ;
+XPAT(DFN,XPARMS,DIR,FN) ; EXPORT ONE PATIENT TO A FILE
+ ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR")
+ ; FN IS FILE NAME, DEFAULTS IF NULL
+ N CCRGLO,UDIR,UFN
+ S C0CNRPC=1 ; FLAG FOR NOT AN RPC CALL - FOR DEBUGGING THE RPC
+ I '$D(DIR) S UDIR=""
+ E  S UDIR=DIR
+ I '$D(FN) S UFN="" ; IF FILENAME IS NOT PASSED
+ E  S UFN=FN
+ I '$D(XPARMS) S XPARMS=""
+ N C0CRTN  ; RETURN ARRAY
+ D CCRRPC(.C0CRTN,DFN,XPARMS,"CCR")
+ S OARY=$NA(^TMP("C0CCUR",$J,DFN,"CCR",1))
+ S ONAM=UFN
+ I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_0.xml"
+ S ODIRGLB=$NA(^TMP("C0CCCR","ODIR"))
+ S ^TMP("C0CCCR","FNAME",DFN)=ONAM ; FILE NAME FOR BATCH USE
+ I $D(^TMP("GPLCCR","ODIR")) S @ODIRGLB=^TMP("GPLCCR","ODIR")
+ I '$D(@ODIRGLB) D  ; IF NOT ODIR HAS BEEN SET
+ . W "Warning.. please set ^TMP(""C0CCCR"",""ODIR"")=""output path""",! Q
+ . ;S @ODIRGLB="/home/glilly/CCROUT"
+ . ;S @ODIRGLB="/home/cedwards/"
+ . S @ODIRGLB="/opt/wv/p/"
+ S ODIR=UDIR
+ I UDIR="" S ODIR=@ODIRGLB
+ N ZY
+ S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR)
+ W !,$P(ZY,U,2),!
+ Q
+ ;
+DCCR(DFN) ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED
+ ;
+ N G1
+ S G1=$NA(^TMP("C0CCUR",$J,DFN,"CCR"))
+ I $D(@G1@(0)) D  ; CCR EXISTS
+ . D PARY^C0CXPATH(G1)
+ E  W "CCR NOT CREATED, RUN D XPAT^C0CCCR(DFN,"""","""") FIRST",!
+ Q
+ ;
+CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART)  ;RPC ENTRY POINT FOR CCR OUTPUT
+ ; CCRGRTN IS RETURN ARRAY PASSED BY REFERENCE
+ ; DFN IS PATIENT IEN
+ ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART
+ ;   OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC
+ ; CCRPARMS ARE PARAMETERS THAT AFFECT THE EXTRACTION
+ ; IN THE FORM "PARM1:VALUE1^PARM2:VALUE2"
+ ; EXAMPLE: "LABLIMIT:T-60" TO LIMIT LAB EXTRACTION TO THE LAST 60 DAYS
+ ; SEE C0CPARMS FOR A COMPLETE LIST OF SUPPORTED PARAMETERS
+ K ^TMP("C0CCCR",$J) ; CLEAN UP THE GLOBAL BEFORE WE USE IT
+ M ^TMP("C0CSAV",$J)=^TMP($J) ; SAVING CALLER'S TMP SETTINGS
+ K ^TMP($J) ; START CLEAN
+ I '$D(DEBUG) S DEBUG=0
+ S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD
+ I '$D(CCRPARMS) S CCRPARMS=""
+ I '$D(CCRPART) S CCRPART="CCR"
+ I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"CALL",DFN)=""
+ D SET^C0CPARMS(CCRPARMS) ;SET PARAMETERS WITH CCRPARMS AS OVERRIDES
+ I '$D(TESTVIT) S TESTVIT=0 ; FLAG FOR TESTING VITALS
+ I '$D(TESTLAB) S TESTLAB=0 ; FLAG FOR TESTING RESULTS SECTION
+ I '$D(TESTALERT) S TESTALERT=1 ; FLAG FOR TESTING ALERTS SECTION
+ I '$D(TESTMEDS) S TESTMEDS=0 ; FLAG FOR TESTING C0CMED SECTION
+ S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE
+ S CCRGLO=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR
+ S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS
+ ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC
+ ;M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART OR ALL
+ D LOAD^C0CCCR0(TGLOBAL)  ; LOAD THE CCR TEMPLATE
+ D CP^C0CXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL
+ ;
+ ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL
+ ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES
+ D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body")
+ D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors")
+ D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures")
+ D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Comments")
+ I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),!
+ ;
+ D HDRMAP(CCRGLO,DFN) ; MAP HEADER VARIABLES
+ ;
+ K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT
+ S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS
+ D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS
+ N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD
+ F PROCI=1:1:@CCRXTAB@(0) D  ; PROCESS THE CCR BODY SECTIONS
+ . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE
+ . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL
+ . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL
+ . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE
+ . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS
+ . S IXML="INXML"
+ . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES
+ . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY
+ . ; W OXML,!
+ . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL
+ . W "RUNNING ",CALL,!
+ . X CALL
+ . ; NOW INSERT THE RESULTS IN THE CCR BUFFER
+ . I $G(@OXML@(0))>0 D  ; THERE IS A RESULT
+ . . D INSERT^C0CXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body")
+ . . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),!
+ N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING
+ D ACTLST^C0CCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST
+ D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT")
+ D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2")
+ D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors")
+ K ACTT,ACTT2
+ ;D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT")
+ ;D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2")
+ ;D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments")
+ ; gpl - turned off Comments for Certification
+ K CMTT,CMTT2
+ N TRIMI,J,DONE S DONE=0
+ F TRIMI=0:0 D  Q:DONE  ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE
+ . S J=$$TRIM^C0CXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS
+ . I DEBUG W "TRIMMED",J,!
+ . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE
+ ;S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLOBAL OF PART OR ALL
+ I CCRPART="CCR" M CCRGRTN=@CCRGLO ; ENTIRE CCR
+ E  M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART
+ I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"RESULT",CCRGRTN(0))=""
+ K ^TMP("C0CCCR",$J) ; BEGIN TO CLEAN UP
+ K ^TMP($J) ; REALLY CLEAN UP
+ M ^TMP($J)=^TMP("C0CSAV",$J) ; RESTORE CALLER'S $J
+ Q
+ ;
+INITSTPS(TAB)  ; INITIALIZE CCR PROCESSING STEPS
+ ; TAB IS PASSED BY NAME
+ I DEBUG W "TAB= ",TAB,!
+ ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS
+ D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")")
+ I TESTALERT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""C0CCCR"",$J,DFN,""ALERTS"")")
+ D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")")
+ D PUSH^C0CXPATH(TAB,"MAP;C0CIMMU;//ContinuityOfCareRecord/Body/Immunizations;^TMP(""C0CCCR"",$J,DFN,""IMMUNE"")")
+ I TESTVIT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVIT2;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")")
+ E  D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")")
+ D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")")
+ D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROC;//ContinuityOfCareRecord/Body/Procedures;^TMP(""C0CCCR"",$J,DFN,""PROCEDURES"")")
+ ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
+ ; gpl - turned off Encounters for Certification
+ Q
+ ;
+HDRMAP(CXML,DFN) ; MAP HEADER VARIABLES: FROM, TO ECT
+ N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER"))
+ ; K @VMAP
+ S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT")
+ ; I IHDR="" D  ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS
+ D  ; ALWAYS MAP THESE VARIABLES
+ . S @VMAP@("CCRDOCOBJECTID")=$$UUID^C0CUTIL ; UUID FOR THIS CCR
+ . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN
+ . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - FROM PROVIDER
+ . ;S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ???
+ . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM
+ . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES
+ . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR"  ; FOR TEST PURPOSES
+ . S @VMAP@("ACTORTOTEXT")="Patient"  ; FOR TEST PURPOSES
+ . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT
+ ;I IHDR'="" D  ; HEADER VALUES ARE PROVIDED
+ ;. D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY
+ N CTMP
+ D MAP^C0CXPATH(CXML,VMAP,"CTMP")
+ D CP^C0CXPATH("CTMP",CXML)
+ N HRIMVARS ;
+ S HRIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"HEADER")) ; TO PERSIST VARS
+ M @HRIMVARS@(1)=@VMAP ; PERSIST THE HEADER VARIABLES IN RIM TABLE
+ S @HRIMVARS@(0)=1 ; ONLY ONE SET OF HEADERS PER PATIENT
+ Q
+ ;
+ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML
+ ; AXML AND ACTRTN ARE PASSED BY NAME
+ ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2
+ ; P1= OBJECTID - ACTORPATIENT_2
+ ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE
+ ;OR INSTITUTION
+ ;  OR PERSON(IN PATIENT FILE IE NOK)
+ ; P3= IEN RECORD NUMBER FOR ACTOR - 2
+ N I,J,K,L
+ K @ACTRTN ; CLEAR RETURN ARRAY
+ F I=1:1:@AXML@(0) D  ; FIRST FIX MISSING LINKS
+ . I @AXML@(I)?.E1"_<".E D  ;
+ . . N ZA,ZB
+ . . S ZA=$P(@AXML@(I),">",1)_">"
+ . . S ZB="<"_$P(@AXML@(I),"<",3)
+ . . S @AXML@(I)=ZA_"ACTORORGANIZATION_1"_ZB
+ F I=1:1:@AXML@(0) D  ; SCAN ALL LINES
+ . I @AXML@(I)?.E1"<ActorID>".E D  ; THERE IS AN ACTOR THIS LINE
+ . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1)
+ . . I $G(LINKDEBUG) W "<ActorID>=>",J,!
+ . . I J'="" S K(J)="" ; HASHING ACTOR
+ . I @AXML@(I)?.E1"<LinkID>".E D  ; THERE IS AN ACTOR THIS LINE
+ . . S J=$P($P(@AXML@(I),"<LinkID>",2),"</LinkID>",1)
+ . . I $G(LINKDEBUG) W "<LinkID>=>",J,!
+ . . I J'="" S K(J)="" ; HASHING ACTOR
+ . . ;  TO GET RID OF DUPLICATES
+ S I="" ; GOING TO $O THROUGH THE HASH
+ F J=0:0 D  Q:$O(K(I))=""
+ . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS
+ . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID
+ . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE
+ . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR
+ . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY
+ Q
+ ;
+TEST ; RUN ALL THE TEST CASES
+ D TESTALL^C0CUNIT("C0CCCR")
+ Q
+ ;
+ZTEST(WHICH)  ; RUN ONE SET OF TESTS
+ N ZTMP
+ D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
+ D ZTEST^C0CUNIT(.ZTMP,WHICH)
+ Q
+ ;
+TLIST  ; LIST THE TESTS
+ N ZTMP
+ D ZLOAD^C0CUNIT("ZTMP","C0CCCR")
+ D TLIST^C0CUNIT(.ZTMP)
+ Q
+ ;
+ ;;><TEST>
+ ;;><PROBLEMS>
+ ;;>>>K C0C S C0C=""
+ ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","")
+ ;;>>?@C0C@(@C0C@(0))["</Problems>"
+ ;;><VITALS>
+ ;;>>>K C0C S C0C=""
+ ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","")
+ ;;>>?@C0C@(@C0C@(0))["</VitalSigns>"
+ ;;><CCR>
+ ;;>>>K C0C S C0C=""
+ ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","")
+ ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>"
+ ;;><ACTLST>
+ ;;>>>K C0C S C0C=""
+ ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","")
+ ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST")
+ ;;><ACTORS>
+ ;;>>>D ZTEST^C0CCCR("ACTLST")
+ ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2")
+ ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3")
+ ;;>>?G3(G3(0))["</Actors>"
+ ;;><TRIM>
+ ;;>>>D ZTEST^C0CCCR("CCR")
+ ;;>>>W $$TRIM^C0CXPATH(CCRGLO)
+ ;;><ALERTS>
+ ;;>>>S TESTALERT=1
+ ;;>>>K C0C S C0C=""
+ ;;>>>D CCRRPC^C0CCCR(.C0C,"2","ALERTS","")
+ ;;>>?@C0C@(@C0C@(0))["</Alerts>"
+ 
+ 

ccr/trunk/p/C0CCCR0.m

@@ -1 @@
-C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008,2009 George Lilly, University of Minnesota.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "This is a CCR TEMPLATE with processing routines",!
-        W !
-        Q
-        ;
-ZT(ZARY,BAT,LINE)             ; private routine to add a line to the ZARY array
-        ; ZARY IS PASSED BY NAME
-        ; BAT is a string identifying the section
-        ; LINE is a test which will evaluate to true or false
-        ; I '$G(@ZARY) D  ;
-        ; . S @ZARY@(0)=0 ; initially there are no elements
-        ; . W "GOT HERE LOADING "_LINE,!
-        N CNT ; count of array elements
-        S CNT=@ZARY@(0) ; contains array count
-        S CNT=CNT+1 ; increment count
-        S @ZARY@(CNT)=LINE ; put the line in the array
-        ; S @ZARY@(BAT,CNT)="" ; index the test by battery
-        S @ZARY@(0)=CNT ; update the array counter
-        Q
-        ;
-ZLOAD(ZARY,ROUTINE)          ; load tests into ZARY which is passed by reference
-        ; ZARY IS PASSED BY NAME
-        ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
-        ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
-        K @ZARY S @ZARY=""
-        S @ZARY@(0)=0 ; initialize array count
-        N LINE,LABEL,BODY
-        N INTEST S INTEST=0 ; switch for in the TEMPLATE section
-        N SECTION S SECTION="[anonymous]" ; NO section LABEL
-        ;
-        N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
-        . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section
-        . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section
-        . I INTEST  D  ; within the section
-        . . I LINE?." "1";><".E  D  ; sub-section name found
-        . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name
-        . . I LINE?." "1";;".E  D  ; line found
-        . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array
-        Q
-        ;
-LOAD(ARY)       ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME
-        D ZLOAD(ARY,"C0CCCR0")
-        ; ZWR @ARY
-        Q
-        ;
-        ;<TEMPLATE>
-        ;;<?xml version="1.0" encoding="UTF-8"?>
-        ;;<?xml-stylesheet type="text/xsl" href="ccr.xsl"?>
-        ;;<ContinuityOfCareRecord xmlns="urn:astm-org:CCR">
-        ;;<CCRDocumentObjectID>@@CCRDOCOBJECTID@@</CCRDocumentObjectID>
-        ;;<Language>
-        ;;<Text>English</Text>
-        ;;</Language>
-        ;;<Version>V1.0</Version>
-        ;;<DateTime>
-        ;;<ExactDateTime>@@DATETIME@@</ExactDateTime>
-        ;;</DateTime>
-        ;;<Patient>
-        ;;<ActorID>@@ACTORPATIENT@@</ActorID>
-        ;;</Patient>
-        ;;<From>
-        ;;<ActorLink>
-        ;;<ActorID>@@ACTORFROM@@</ActorID>
-        ;;</ActorLink>
-        ;;<ActorLink>
-        ;;<ActorID>@@ACTORFROM2@@</ActorID>
-        ;;</ActorLink>
-        ;;</From>
-        ;;<To>
-        ;;<ActorLink>
-        ;;<ActorID>@@ACTORTO@@</ActorID>
-        ;;<ActorRole>
-        ;;<Text>@@ACTORTOTEXT@@</Text>
-        ;;</ActorRole>
-        ;;</ActorLink>
-        ;;</To>
-        ;;<Purpose>
-        ;;<Description>
-        ;;<Text>@@PURPOSEDESCRIPTION@@</Text>
-        ;;</Description>
-        ;;</Purpose>
-        ;;<Body>
-        ;;<Problems>
-        ;;<Problem>
-        ;;<CCRDataObjectID>@@PROBLEMOBJECTID@@</CCRDataObjectID>
-        ;;<DateTime>
-        ;;<ExactDateTime>@@PROBLEMDATEMOD@@</ExactDateTime>
-        ;;</DateTime>
-        ;;<Type>
-        ;;<Text>Problem</Text>
-        ;;</Type>
-        ;;<Description>
-        ;;<Text>@@PROBLEMDESCRIPTION@@</Text>
-        ;;<Code>
-        ;;<Value>@@PROBLEMCODEVALUE@@</Value>
-        ;;<CodingSystem>ICD9CM</CodingSystem>
-        ;;<Version>@@PROBLEMCODINGVERSION@@</Version>
-        ;;</Code>
-        ;;</Description>
-        ;;<Status>
-        ;;<Text>@@PROBLEMSTATUS@@</Text>
-        ;;</Status>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@PROBLEMSOURCEACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</Problem>
-        ;;</Problems>
-        ;;<Immunizations>
-        ;;<Immunization>
-        ;;<CCRDataObjectID>@@IMMUNEOBJECTID@@</CCRDataObjectID>
-        ;;<DateTime>
-        ;;<Type>
-        ;;<Text>@@IMMUNEDATETIMETYPETEXT@@</Text>
-        ;;</Type>
-        ;;<ExactDateTime>@@IMMUNEDATETIME@@</ExactDateTime>
-        ;;</DateTime>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@IMMUNESOURCEACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;<Product>
-        ;;<ProductName>
-        ;;<Text>@@IMMUNEPRODUCTNAMETEXT@@</Text>
-        ;;<Code>
-        ;;<Value>@@IMMUNEPRODUCTCODE@@</Value>
-        ;;<CodingSystem>@@IMMUNEPRODUCTCODESYSTEM@@</CodingSystem>
-        ;;</Code>
-        ;;</ProductName>
-        ;;</Product>
-        ;;</Immunization>
-        ;;</Immunizations>
-        ;;<FamilyHistory>
-        ;;<FamilyProblemHistory>
-        ;;<CCRDataObjectID>@@FAMILYHISTORYOBJECTID@@</CCRDataObjectID>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@FAMILYHISTORYACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;<FamilyMember>
-        ;;<ActorID>@@FAMILYMEMBERACTORID@@</ActorID>
-        ;;<ActorRole>
-        ;;<Text>@@FAMILYMEMBERACTORROLETEXT@@</Text>
-        ;;</ActorRole>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@FAMILYMEMBERSOURCACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</FamilyMember>
-        ;;<Problem>
-        ;;<Type>
-        ;;<Text>Problem</Text>
-        ;;</Type>
-        ;;<Description>
-        ;;<Text>@@FAMILYMEMBERPROBLEMDESCRIPTION@@</Text>
-        ;;<Code>
-        ;;<Value>@@FAMILYMEMBERPROBLEMCODE@@</Value>
-        ;;<CodingSystem>@@FAMILYMEMBERCODESYSTEM@@</CodingSystem>
-        ;;<Version>@@FAMILYMEMBERCODEVERSION@@</Version>
-        ;;</Code>
-        ;;</Description>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@FAMILYMEMBERPROBLEMSOURCEID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</Problem>
-        ;;</FamilyProblemHistory>
-        ;;</FamilyHistory>
-        ;;<SocialHistory>
-        ;;<SocialHistoryElement>
-        ;;<CCRDataObjectID>@@SOCIALHISTORYOBJECTID@@</CCRDataObjectID>
-        ;;<Type>
-        ;;<Text>@@SOCIALHISTORYTYPETEXT@@</Text>
-        ;;</Type>
-        ;;<Description>
-        ;;<Text>@@SOCIALHISTORYDESCRIPTIONTEXT@@</Text>
-        ;;</Description>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@SOCIALHISTORYSOURCACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</SocialHistoryElement>
-        ;;<SocialHistoryElement>
-        ;;<CCRDataObjectID>BB0005</CCRDataObjectID>
-        ;;<Type>
-        ;;<Text>Ethnic Origin</Text>
-        ;;</Type>
-        ;;<Description>
-        ;;<Text>Not Hispanic or Latino</Text>
-        ;;</Description>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>AA0001</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</SocialHistoryElement>
-        ;;<SocialHistoryElement>
-        ;;<CCRDataObjectID>BB0006</CCRDataObjectID>
-        ;;<Type>
-        ;;<Text>Race</Text>
-        ;;</Type>
-        ;;<Description>
-        ;;<Text>White</Text>
-        ;;</Description>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>AA0001</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</SocialHistoryElement>
-        ;;<SocialHistoryElement>
-        ;;<CCRDataObjectID>BB0007</CCRDataObjectID>
-        ;;<Type>
-        ;;<Text>Occupation</Text>
-        ;;</Type>
-        ;;<Description>
-        ;;<Text>Physician</Text>
-        ;;</Description>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>AA0001</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</SocialHistoryElement>
-        ;;</SocialHistory>
-        ;;<Alerts>
-        ;;<Alert>
-        ;;<CCRDataObjectID>@@ALERTOBJECTID@@</CCRDataObjectID>
-        ;;<DateTime>
-        ;;<ExactDateTime>@@ALERTDATETIME@@</ExactDateTime>
-        ;;</DateTime>
-        ;;<Type>
-        ;;<Text>@@ALERTTYPE@@</Text>
-        ;;</Type>
-        ;;<Status>
-        ;;<Text>@@ALERTSTATUSTEXT@@</Text>
-        ;;</Status>
-        ;;<Description>
-        ;;<Text>@@ALERTDESCRIPTIONTEXT@@</Text>
-        ;;<Code>
-        ;;<Value>@@ALERTCODEVALUE@@</Value>
-        ;;<CodingSystem>@@ALERTCODESYSTEM@@</CodingSystem>
-        ;;</Code>
-        ;;</Description>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@ALERTSOURCEID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;<Agent>
-        ;;<Products>
-        ;;<Product>
-        ;;<CCRDataObjectID>@@ALERTAGENTPRODUCTOBJECTID@@</CCRDataObjectID>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@ALERTSOURCEID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;<Product>
-        ;;<ProductName>
-        ;;<Text>@@ALERTAGENTPRODUCTNAMETEXT@@</Text>
-        ;;<Code>
-        ;;<Value>@@ALERTAGENTPRODUCTCODEVALUE@@</Value>
-        ;;<CodingSystem>@@ALERTAGENTPRODUCTCODESYSTEM@@</CodingSystem>
-        ;;</Code>
-        ;;</ProductName>
-        ;;</Product>
-        ;;</Product>
-        ;;</Products>
-        ;;</Agent>
-        ;;<Reaction>
-        ;;<Description>
-        ;;<Text>@@ALERTREACTIOINDESCRIPTIONTEXT@@</Text>
-        ;;<Code>
-        ;;<Value>@@ALERTREACTIONCODEVALUE@@</Value>
-        ;;<CodingSystem>@@ALERTREACTIONCODESYSTEM@@</CodingSystem>
-        ;;</Code>
-        ;;</Description>
-        ;;</Reaction>
-        ;;</Alert>
-        ;;</Alerts>
-        ;;<Medications>
-        ;;<Medication>
-        ;;<CCRDataObjectID>@@MEDOBJECTID@@</CCRDataObjectID>
-        ;;<DateTime>
-        ;;<Type>
-        ;;<Text>@@MEDISSUEDATETXT@@</Text>
-        ;;</Type>
-        ;;<ExactDateTime>@@MEDISSUEDATE@@</ExactDateTime>
-        ;;</DateTime>
-        ;;<DateTime>
-        ;;<Type>
-        ;;<Text>@@MEDLASTFILLDATETXT@@</Text>
-        ;;</Type>
-        ;;<ExactDateTime>@@MEDLASTFILLDATE@@</ExactDateTime>
-        ;;</DateTime>
-        ;;<IDs>
-        ;;<Type>
-        ;;<Text>@@MEDRXNOTXT@@</Text>
-        ;;</Type>
-        ;;<ID>@@MEDRXNO@@</ID>
-        ;;</IDs>
-        ;;<Type>
-        ;;<Text>@@MEDTYPETEXT@@</Text>
-        ;;</Type>
-        ;;<Description>
-        ;;<Text>@@MEDDETAILUNADORNED@@</Text>
-        ;;</Description>
-        ;;<Status>
-        ;;<Text>@@MEDSTATUSTEXT@@</Text>
-        ;;</Status>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@MEDSOURCEACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;<Product>
-        ;;<ProductName>
-        ;;<Text>@@MEDPRODUCTNAMETEXT@@</Text>
-        ;;<Code>
-        ;;<Value>@@MEDPRODUCTNAMECODEVALUE@@</Value>
-        ;;<CodingSystem>@@MEDPRODUCTNAMECODINGINGSYSTEM@@</CodingSystem>
-        ;;<Version>@@MEDPRODUCTNAMECODEVERSION@@</Version>
-        ;;</Code>
-        ;;</ProductName>
-        ;;<BrandName>
-        ;;<Text>@@MEDBRANDNAMETEXT@@</Text>
-        ;;</BrandName>
-        ;;<Strength>
-        ;;<Value>@@MEDSTRENGTHVALUE@@</Value>
-        ;;<Units>
-        ;;<Unit>@@MEDSTRENGTHUNIT@@</Unit>
-        ;;</Units>
-        ;;</Strength>
-        ;;<Form>
-        ;;<Text>@@MEDFORMTEXT@@</Text>
-        ;;</Form>
-        ;;<Concentration>
-        ;;<Value>@@MEDCONCVALUE@@</Value>
-        ;;<Units>
-        ;;<Unit>@@MEDCONCUNIT@@</Unit>
-        ;;</Units>
-        ;;</Concentration>
-        ;;</Product>
-        ;;<Quantity>
-        ;;<Value>@@MEDQUANTITYVALUE@@</Value>
-        ;;<Units>
-        ;;<Unit>@@MEDQUANTITYUNIT@@</Unit>
-        ;;</Units>
-        ;;</Quantity>
-        ;;<Directions>
-        ;;<Direction>
-        ;;<Description>
-        ;;<Text>@@MEDDIRECTIONDESCRIPTIONTEXT@@</Text>
-        ;;</Description>
-        ;;<DoseIndicator>
-        ;;<Text>@@MEDDOSEINDICATOR@@</Text>
-        ;;</DoseIndicator>
-        ;;<DeliveryMethod>
-        ;;<Text>@@MEDDELIVERYMETHOD@@</Text>
-        ;;</DeliveryMethod>
-        ;;<Dose>
-        ;;<Value>@@MEDDOSEVALUE@@</Value>
-        ;;<Units>
-        ;;<Unit>@@MEDDOSEUNIT@@</Unit>
-        ;;</Units>
-        ;;<Rate>
-        ;;<Value>@@MEDRATEVALUE@@</Value>
-        ;;<Units>
-        ;;<Unit>@@MEDRATEUNIT@@</Unit>
-        ;;</Units>
-        ;;</Rate>
-        ;;</Dose>
-        ;;<Vehicle>
-        ;;<Text>@@MEDVEHICLETEXT@@</Text>
-        ;;</Vehicle>
-        ;;<Route>
-        ;;<Text>@@MEDDIRECTIONROUTETEXT@@</Text>
-        ;;</Route>
-        ;;<Frequency>
-        ;;<Value>@@MEDFREQUENCYVALUE@@</Value>
-        ;;</Frequency>
-        ;;<Interval>
-        ;;<Value>@@MEDINTERVALVALUE@@</Value>
-        ;;<Units>
-        ;;<Unit>@@MEDINTERVALUNIT@@</Unit>
-        ;;</Units>
-        ;;</Interval>
-        ;;<Duration>
-        ;;<Value>@@MEDDURATIONVALUE@@</Value>
-        ;;<Units>
-        ;;<Unit>@@MEDDURATIONUNIT@@</Unit>
-        ;;</Units>
-        ;;</Duration>
-        ;;<Indication>
-        ;;<PRNFlag>
-        ;;<Text>@@MEDPRNFLAG@@</Text>
-        ;;</PRNFlag>
-        ;;<Problem>
-        ;;<CCRDataObjectID>@@MEDPROBLEMOBJECTID@@</CCRDataObjectID>
-        ;;<Type>
-        ;;<Text>@@MEDPROBLEMTYPETXT@@</Text>
-        ;;</Type>
-        ;;<Description>
-        ;;<Text>@@MEDPROBLEMDESCRIPTION@@</Text>
-        ;;<Code>
-        ;;<Value>@@MEDPROBLEMCODEVALUE@@</Value>
-        ;;<CodingSystem>@@MEDPROBLEMCODINGSYSTEM@@</CodingSystem>
-        ;;<Version>@@MEDPROBLEMCODINGVERSION@@</Version>
-        ;;</Code>
-        ;;</Description>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@MEDPROBLEMSOURCEACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</Problem>
-        ;;</Indication>
-        ;;<StopIndicator>
-        ;;<Text>@@MEDSTOPINDICATOR@@</Text>
-        ;;</StopIndicator>
-        ;;<DirectionSequenceModifier>@@MEDDIRSEQ@@</DirectionSequenceModifier>
-        ;;<MultipleDirectionModifier>
-        ;;<Text>@@MEDMULDIRMOD@@</Text>
-        ;;</MultipleDirectionModifier>
-        ;;</Direction>
-        ;;</Directions>
-        ;;<PatientInstructions>
-        ;;<Instruction>
-        ;;<Text>@@MEDPTINSTRUCTIONS@@</Text>
-        ;;</Instruction>
-        ;;</PatientInstructions>
-        ;;<FullfillmentInstructions>
-        ;;<Text>@@MEDFULLFILLMENTINSTRUCTIONS@@</Text>
-        ;;</FullfillmentInstructions>
-        ;;<Refills>
-        ;;<Refill>
-        ;;<Number>@@MEDRFNO@@</Number>
-        ;;</Refill>
-        ;;</Refills>
-        ;;</Medication>
-        ;;</Medications>
-        ;;<VitalSigns>
-        ;;<Result>
-        ;;<CCRDataObjectID>@@VITALSIGNSDATAOBJECTID@@</CCRDataObjectID>
-        ;;<DateTime>
-        ;;<Type>
-        ;;<Text>@@VITALSIGNSDATETIMETYPETEXT@@</Text>
-        ;;</Type>
-        ;;<ExactDateTime>@@VITALSIGNSEXACTDATETIME@@</ExactDateTime>
-        ;;</DateTime>
-        ;;<Description>
-        ;;<Text>@@VITALSIGNSDESCRIPTIONTEXT@@</Text>
-        ;;</Description>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@VITALSIGNSSOURCEACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;<Test>
-        ;;<CCRDataObjectID>@@VITALSIGNSTESTOBJECTID@@</CCRDataObjectID>
-        ;;<Type>
-        ;;<Text>@@VITALSIGNSTESTTYPETEXT@@</Text>
-        ;;</Type>
-        ;;<Description>
-        ;;<Text>@@VITALSIGNSDESCRIPTIONTEXT@@</Text>
-        ;;<Code>
-        ;;<Value>@@VITALSIGNSDESCCODEVALUE@@</Value>
-        ;;<CodingSystem>@@VITALSIGNSDESCCODINGSYSTEM@@</CodingSystem>
-        ;;<Version>@@VITALSIGNSCODEVERSION@@</Version>
-        ;;</Code>
-        ;;</Description>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@VITALSIGNSTESTSOURCEACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;<TestResult>
-        ;;<Value>@@VITALSIGNSTESTRESULTVALUE@@</Value>
-        ;;<Units>
-        ;;<Unit>@@VITALSIGNSTESTRESULTUNIT@@</Unit>
-        ;;</Units>
-        ;;</TestResult>
-        ;;</Test>
-        ;;</Result>
-        ;;</VitalSigns>
-        ;;<Results>
-        ;;<Result>
-        ;;<CCRDataObjectID>@@RESULTOBJECTID@@</CCRDataObjectID>
-        ;;<DateTime>
-        ;;<Type>
-        ;;<Text>Assessment Time</Text>
-        ;;</Type>
-        ;;<ExactDateTime>@@RESULTASSESSMENTDATETIME@@</ExactDateTime>
-        ;;</DateTime>
-        ;;<Description>
-        ;;<Text>@@RESULTDESCRIPTIONTEXT@@</Text>
-        ;;<Code>
-        ;;<Value>@@RESULTCODE@@</Value>
-        ;;<CodingSystem>@@RESULTCODINGSYSTEM@@</CodingSystem>
-        ;;</Code>
-        ;;</Description>
-        ;;<Status>
-        ;;<Text>@@RESULTSTATUS@@</Text>
-        ;;</Status>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@RESULTSOURCEACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;<Test>
-        ;;<CCRDataObjectID>@@RESULTTESTOBJECTID@@</CCRDataObjectID>
-        ;;<DateTime>
-        ;;<Type>
-        ;;<Text>Assessment Time</Text>
-        ;;</Type>
-        ;;<ExactDateTime>@@RESULTTESTDATETIME@@</ExactDateTime>
-        ;;</DateTime>
-        ;;<Description>
-        ;;<Text>@@RESULTTESTDESCRIPTIONTEXT@@</Text>
-        ;;<Code>
-        ;;<Value>@@RESULTTESTCODEVALUE@@</Value>
-        ;;<CodingSystem>@@RESULTTESTCODINGSYSTEM@@</CodingSystem>
-        ;;</Code>
-        ;;</Description>
-        ;;<Status>
-        ;;<Text>@@RESULTTESTSTATUSTEXT@@</Text>
-        ;;</Status>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@RESULTTESTSOURCEACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;<TestResult>
-        ;;<Value>@@RESULTTESTVALUE@@</Value>
-        ;;<Units>
-        ;;<Unit>@@RESULTTESTUNITS@@</Unit>
-        ;;</Units>
-        ;;</TestResult>
-        ;;<NormalResult>
-        ;;<Normal>
-        ;;<Description>
-        ;;<Text>@@RESULTTESTNORMALDESCTEXT@@</Text>
-        ;;</Description>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@RESULTTESTNORMALSOURCEACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</Normal>
-        ;;</NormalResult>
-        ;;<Flag>
-        ;;<Text>@@RESULTTESTFLAG@@</Text>
-        ;;</Flag>
-        ;;</Test>
-        ;;</Result>
-        ;;</Results>
-        ;;<Procedures>
-        ;;<Procedure>
-        ;;<CCRDataObjectID>@@PROCOBJECTID@@</CCRDataObjectID>
-        ;;<DateTime>
-        ;;<Type>
-        ;;<Text>@@PROCDATETEXT@@</Text>
-        ;;</Type>
-        ;;<ExactDateTime>@@PROCDATETIME@@</ExactDateTime>
-        ;;</DateTime>
-        ;;<Description>
-        ;;<Text>@@PROCDESCTEXT@@</Text>
-        ;;<ObjectAttribute>
-        ;;<Attribute>@@PROCDESCOBJATTR@@</Attribute>
-        ;;<AttributeValue>
-        ;;<Value>@@PROCDESCOBJATTRVAL@@</Value>
-        ;;<Code>
-        ;;<Value>@@PROCDESCOBJATTRCODE@@</Value>
-        ;;<CodingSystem>@@PROCDESCOBJATTRCODESYS@@</CodingSystem>
-        ;;</Code>
-        ;;</AttributeValue>
-        ;;</ObjectAttribute>
-        ;;<Code>
-        ;;<Value>@@PROCCODE@@</Value>
-        ;;<CodingSystem>@@PROCCODESYS@@</CodingSystem>
-        ;;</Code>
-        ;;</Description>
-        ;;<Status>
-        ;;<Text>@@PROCSTATUS@@</Text>
-        ;;</Status>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@PROCACTOROBJID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;<InternalCCRLink>
-        ;;<LinkID>@@PROCLINKID@@</LinkID>
-        ;;<LinkRelationship>@@PROCLINKREL@@</LinkRelationship>
-        ;;</InternalCCRLink>
-        ;;</Procedure>
-        ;;</Procedures>
-        ;;<Encounters>
-        ;;<Encounter>
-        ;;<CCRDataObjectID>@@ENCOBJECTID@@</CCRDataObjectID>
-        ;;<DateTime>
-        ;;<ExactDateTime>@@ENCDATETIME@@</ExactDateTime>
-        ;;</DateTime>
-        ;;<Type>
-        ;;<Text>@@ENCTYPETXT@@</Text>
-        ;;<Code>
-        ;;<Value>@@ENCTYPECODE@@</Value>
-        ;;<CodingSystem>@@ENCTYPECODESYS@@</CodingSystem>
-        ;;</Code>
-        ;;</Type>
-        ;;<Description>
-        ;;<Text>@@ENCDESCTXT@@</Text>
-        ;;<Code>
-        ;;<Value>@@ENCDESCCODE@@</Value>
-        ;;<CodingSystem>@@ENCDESCCODESYS@@</CodingSystem>
-        ;;</Code>
-        ;;</Description>
-        ;;<Location>
-        ;;<Actor>
-        ;;<ActorID>@@ENCLOCACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Location>
-        ;;<Practioner>
-        ;;<Actor>
-        ;;<ActorID>@@ENCPRVACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Practioner>
-        ;;<Indication>
-        ;;<Text>@@ENCINDTXT@@</Text>
-        ;;<Code>
-        ;;<Value>@@ENCINDCODE@@</Value>
-        ;;<CodingSystem>@@ENCINDCODESYS@@</CodingSystem>
-        ;;</Code>
-        ;;</Indication>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@ENCACTORID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;<CommentID>@@ENCCOMMENTID@@</CommentID>
-        ;;</Encounter>
-        ;;</Encounters>
-        ;;<HealthCareProviders>
-        ;;<Provider>
-        ;;<ActorID>AA0005</ActorID>
-        ;;<ActorRole>
-        ;;<Text>Primary Provider</Text>
-        ;;</ActorRole>
-        ;;</Provider>
-        ;;</HealthCareProviders>
-        ;;</Body>
-        ;;<Actors>
-        ;;<ACTOR-PATIENT>
-        ;;<Actor>
-        ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
-        ;;<Person>
-        ;;<Name>
-        ;;<CurrentName>
-        ;;<Given>@@ACTORGIVENNAME@@</Given>
-        ;;<Middle>@@ACTORMIDDLENAME@@</Middle>
-        ;;<Family>@@ACTORFAMILYNAME@@</Family>
-        ;;</CurrentName>
-        ;;</Name>
-        ;;<DateOfBirth>
-        ;;<ExactDateTime>@@ACTORDATEOFBIRTH@@</ExactDateTime>
-        ;;</DateOfBirth>
-        ;;<Gender>
-        ;;<Text>@@ACTORGENDER@@</Text>
-        ;;<Code>
-        ;;<Value>@@ACTORGENDERCODE@@</Value>
-        ;;<CodingSystem>HL7 AdministrativeGender</CodingSystem>
-        ;;</Code>
-        ;;</Gender>
-        ;;</Person>
-        ;;<IDs>
-        ;;<Type>
-        ;;<Text>@@ACTORSSNTEXT@@</Text>
-        ;;</Type>
-        ;;<ID>@@ACTORSSN@@</ID>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@ACTORSSNSOURCEID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</IDs>
-        ;;<Address>
-        ;;<Type>
-        ;;<Text>@@ACTORADDRESSTYPE@@</Text>
-        ;;</Type>
-        ;;<Line1>@@ACTORADDRESSLINE1@@</Line1>
-        ;;<Line2>@@ACTORADDRESSLINE2@@</Line2>
-        ;;<City>@@ACTORADDRESSCITY@@</City>
-        ;;<State>@@ACTORADDRESSSTATE@@</State>
-        ;;<PostalCode>@@ACTORADDRESSZIPCODE@@</PostalCode>
-        ;;</Address>
-        ;;<Telephone>
-        ;;<Value>@@ACTORRESTEL@@</Value>
-        ;;<Type>
-        ;;<Text>@@ACTORRESTELTEXT@@</Text>
-        ;;</Type>
-        ;;</Telephone>
-        ;;<Telephone>
-        ;;<Value>@@ACTORWORKTEL@@</Value>
-        ;;<Type>
-        ;;<Text>@@ACTORWORKTELTEXT@@</Text>
-        ;;</Type>
-        ;;</Telephone>
-        ;;<Telephone>
-        ;;<Value>@@ACTORCELLTEL@@</Value>
-        ;;<Type>
-        ;;<Text>@@ACTORCELLTELTEXT@@</Text>
-        ;;</Type>
-        ;;</Telephone>
-        ;;<EMail>
-        ;;<Value>@@ACTOREMAIL@@</Value>
-        ;;</EMail>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@ACTORADDRESSSOURCEID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</Actor>
-        ;;</ACTOR-PATIENT>
-        ;;<ACTOR-SYSTEM>
-        ;;<Actor>
-        ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
-        ;;<InformationSystem>
-        ;;<Name>@@ACTORINFOSYSNAME@@</Name>
-        ;;<Version>@@ACTORINFOSYSVER@@</Version>
-        ;;</InformationSystem>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@ACTORINFOSYSSOURCEID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</Actor>
-        ;;</ACTOR-SYSTEM>
-        ;;<ACTOR-NOK>
-        ;;<Actor>
-        ;;<ActorObjectID>AA0003</ActorObjectID>
-        ;;<Person>
-        ;;<Name>
-        ;;<DisplayName>@@ACTORDISPLAYNAME@@</DisplayName>
-        ;;</Name>
-        ;;</Person>
-        ;;<Relation>
-        ;;<Text>@@ACTORRELATION@@</Text>
-        ;;</Relation>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@ACTORRELATIONSOURCEID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</Actor>
-        ;;</ACTOR-NOK>
-        ;;<ACTOR-PROVIDER>
-        ;;<Actor>
-        ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
-        ;;<Person>
-        ;;<Name>
-        ;;<CurrentName>
-        ;;<Given>@@ACTORGIVENNAME@@</Given>
-        ;;<Middle>@@ACTORMIDDLENAME@@</Middle>
-        ;;<Family>@@ACTORFAMILYNAME@@</Family>
-        ;;<Title>@@ACTORTITLE@@</Title>
-        ;;</CurrentName>
-        ;;</Name>
-        ;;</Person>
-        ;;<Specialty>
-        ;;<Text>@@ACTORSPECIALITY@@</Text>
-        ;;</Specialty>
-        ;;<Address>
-        ;;<Type>
-        ;;<Text>@@ACTORADDRESSTYPE@@</Text>
-        ;;</Type>
-        ;;<Line1>@@ACTORADDRESSLINE1@@</Line1>
-        ;;<City>@@ACTORADDRESSCITY@@</City>
-        ;;<State>@@ACTORADDRESSSTATE@@</State>
-        ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode>
-        ;;</Address>
-        ;;<Telephone>
-        ;;<Value>@@ACTORTELEPHONE@@</Value>
-        ;;<Type>
-        ;;<Text>@@ACTORTELEPHONETYPE@@</Text>
-        ;;</Type>
-        ;;</Telephone>
-        ;;<Email>
-        ;;<Value>@@ACTOREMAIL@@</Value>
-        ;;</Email>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@ACTORSOURCEID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;<InternalCCRLink>
-        ;;<LinkID>@@ACTORORGLINK@@</LinkID>
-        ;;<LinkRelationship>representedOrganization</LinkRelationship>
-        ;;</InternalCCRLink>
-        ;;</Actor>
-        ;;</ACTOR-PROVIDER>
-        ;;<ACTOR-ORG>
-        ;;<Actor>
-        ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
-        ;;<Organization>
-        ;;<Name>@@ORGANIZATIONNAME@@</Name>
-        ;;</Organization>
-        ;;<Address>
-        ;;<Type>
-        ;;<Text>@@ACTORADDRESSTYPE@@</Text>
-        ;;</Type>
-        ;;<Line1>@@ACTORADDRESSLINE1@@</Line1>
-        ;;<City>@@ACTORADDRESSCITY@@</City>
-        ;;<State>@@ACTORADDRESSSTATE@@</State>
-        ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode>
-        ;;</Address>
-        ;;<Telephone>
-        ;;<Value>@@ACTORTELEPHONE@@</Value>
-        ;;<Type>
-        ;;<Text>@@ACTORTELEPHONETYPE@@</Text>
-        ;;</Type>
-        ;;</Telephone>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@ACTORSOURCEID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</Actor>
-        ;;</ACTOR-ORG>
-        ;;</Actors>
-        ;;<Signatures>
-        ;;<CCRSignature>
-        ;;<SignatureObjectID>S0001</SignatureObjectID>
-        ;;<ExactDateTime>2008-03-18T23:10:58Z</ExactDateTime>
-        ;;<Source>
-        ;;<ActorID>AA0001</ActorID>
-        ;;</Source>
-        ;;<Signature>
-        ;;<Signature xmlns="http://www.w3.org/2000/09/xmldsig#">
-        ;;<SignedInfo>
-        ;;<CanonicalizationMethod Algorithm="http://www.w3.org/TR/2001/REC-xml-c14n-20010315"/>
-        ;;<SignatureMethod Algorithm="http://www.w3.org/2000/09/xmldsig#rsa-sha1"/>
-        ;;<Reference URI="">
-        ;;<Transforms>
-        ;;<Transform Algorithm="http://www.w3.org/2000/09/xmldsig#enveloped-signature"/>
-        ;;</Transforms>
-        ;;<DigestMethod Algorithm="http://www.w3.org/2000/09/xmldsig#sha1"/>
-        ;;<DigestValue>YFveLLyo+75P7rSciv0/m1O6Ot4=</DigestValue>
-        ;;</Reference>
-        ;;</SignedInfo>
-        ;;<SignatureValue>Bj6sACXl74hrlbUYnu8HqnRab5VGy69BOYjOH7dETxgppXMEd7AoVYaePZvgJft78JR4oQY76hbFyGcIslYauPpJxx2hCd5d56xFeaQg01R6AQOvGnhjlq63TbpFdUq0B4tYsmiibJPbQJhTQe+TcWTBvWaQt8Fkk5blO571YvI=</SignatureValue>
-        ;;<KeyInfo>
-        ;;<KeyValue>
-        ;;<RSAKeyValue>
-        ;;<Modulus>meH817QYol+/uUEg6j8Mg89s7GTlaN9B+/CGlzrtnQH+swMigZRnEPxHVO8PhEymP/W9nlhAjTScV/CUzA9yJ9WiaOn17c+KReKhfBqL24DX9BpbJ+kLYVz7mBO5Qydk5AzUT2hFwW93irD8iRKP+/t+2Mi2CjNfj8VTjJpHpm0=</Modulus>
-        ;;<Exponent>AQAB</Exponent>
-        ;;</RSAKeyValue>
-        ;;</KeyValue>
-        ;;</KeyInfo>
-        ;;</Signature>
-        ;;</Signature>
-        ;;</CCRSignature>
-        ;;</Signatures>
-        ;;<Comments>
-        ;;<Comment>
-        ;;<CommentObjectID>@@COMMENTOBJECTID@@</CommentObjectID>
-        ;;<DateTime>
-        ;;<ExactDateTime>@@CMTDATETIME@@</ExactDateTime>
-        ;;</DateTime>
-        ;;<Description>
-        ;;<Text>
-        ;;</Text>
-        ;;</Description>
-        ;;<Source>
-        ;;<Actor>
-        ;;<ActorID>@@ACTORSOURCEID@@</ActorID>
-        ;;</Actor>
-        ;;</Source>
-        ;;</Comment>
-        ;;</Comments>
-        ;;</ContinuityOfCareRecord>
-        ;</TEMPLATE>
+C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008,2009 George Lilly, University of Minnesota.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "This is a CCR TEMPLATE with processing routines",!
+ W !
+ Q
+ ;
+ZT(ZARY,BAT,LINE)       ; private routine to add a line to the ZARY array
+ ; ZARY IS PASSED BY NAME
+ ; BAT is a string identifying the section
+ ; LINE is a test which will evaluate to true or false
+ ; I '$G(@ZARY) D  ;
+ ; . S @ZARY@(0)=0 ; initially there are no elements
+ ; . W "GOT HERE LOADING "_LINE,!
+ N CNT ; count of array elements
+ S CNT=@ZARY@(0) ; contains array count
+ S CNT=CNT+1 ; increment count
+ S @ZARY@(CNT)=LINE ; put the line in the array
+ ; S @ZARY@(BAT,CNT)="" ; index the test by battery
+ S @ZARY@(0)=CNT ; update the array counter
+ Q
+ ;
+ZLOAD(ZARY,ROUTINE)      ; load tests into ZARY which is passed by reference
+ ; ZARY IS PASSED BY NAME
+ ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
+ ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
+ K @ZARY S @ZARY=""
+ S @ZARY@(0)=0 ; initialize array count
+ N LINE,LABEL,BODY
+ N INTEST S INTEST=0 ; switch for in the TEMPLATE section
+ N SECTION S SECTION="[anonymous]" ; NO section LABEL
+ ;
+ N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
+ . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section
+ . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section
+ . I INTEST  D  ; within the section
+ . . I LINE?." "1";><".E  D  ; sub-section name found
+ . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name
+ . . I LINE?." "1";;".E  D  ; line found
+ . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array
+ Q
+ ;
+LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME
+ D ZLOAD(ARY,"C0CCCR0")
+ ; ZWR @ARY
+ Q
+ ;
+ ;<TEMPLATE>
+ ;;<?xml version="1.0" encoding="UTF-8"?>
+ ;;<?xml-stylesheet type="text/xsl" href="ccr.xsl"?>
+ ;;<ContinuityOfCareRecord xmlns="urn:astm-org:CCR">
+ ;;<CCRDocumentObjectID>@@CCRDOCOBJECTID@@</CCRDocumentObjectID>
+ ;;<Language>
+ ;;<Text>English</Text>
+ ;;</Language>
+ ;;<Version>V1.0</Version>
+ ;;<DateTime>
+ ;;<ExactDateTime>@@DATETIME@@</ExactDateTime>
+ ;;</DateTime>
+ ;;<Patient>
+ ;;<ActorID>@@ACTORPATIENT@@</ActorID>
+ ;;</Patient>
+ ;;<From>
+ ;;<ActorLink>
+ ;;<ActorID>@@ACTORFROM@@</ActorID>
+ ;;</ActorLink>
+ ;;<ActorLink>
+ ;;<ActorID>@@ACTORFROM2@@</ActorID>
+ ;;</ActorLink>
+ ;;</From>
+ ;;<To>
+ ;;<ActorLink>
+ ;;<ActorID>@@ACTORTO@@</ActorID>
+ ;;<ActorRole>
+ ;;<Text>@@ACTORTOTEXT@@</Text>
+ ;;</ActorRole>
+ ;;</ActorLink>
+ ;;</To>
+ ;;<Purpose>
+ ;;<Description>
+ ;;<Text>@@PURPOSEDESCRIPTION@@</Text>
+ ;;</Description>
+ ;;</Purpose>
+ ;;<Body>
+ ;;<Problems>
+ ;;<Problem>
+ ;;<CCRDataObjectID>@@PROBLEMOBJECTID@@</CCRDataObjectID>
+ ;;<DateTime>
+ ;;<ExactDateTime>@@PROBLEMDATEMOD@@</ExactDateTime>
+ ;;</DateTime>
+ ;;<Type>
+ ;;<Text>Problem</Text>
+ ;;</Type>
+ ;;<Description>
+ ;;<Text>@@PROBLEMDESCRIPTION@@</Text>
+ ;;<Code>
+ ;;<Value>@@PROBLEMCODEVALUE@@</Value>
+ ;;<CodingSystem>ICD9CM</CodingSystem>
+ ;;<Version>@@PROBLEMCODINGVERSION@@</Version>
+ ;;</Code>
+ ;;</Description>
+ ;;<Status>
+ ;;<Text>@@PROBLEMSTATUS@@</Text>
+ ;;</Status>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@PROBLEMSOURCEACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</Problem>
+ ;;</Problems>
+ ;;<Immunizations>
+ ;;<Immunization>
+ ;;<CCRDataObjectID>@@IMMUNEOBJECTID@@</CCRDataObjectID>
+ ;;<DateTime>
+ ;;<Type>
+ ;;<Text>@@IMMUNEDATETIMETYPETEXT@@</Text>
+ ;;</Type>
+ ;;<ExactDateTime>@@IMMUNEDATETIME@@</ExactDateTime>
+ ;;</DateTime>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@IMMUNESOURCEACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;<Product>
+ ;;<ProductName>
+ ;;<Text>@@IMMUNEPRODUCTNAMETEXT@@</Text>
+ ;;<Code>
+ ;;<Value>@@IMMUNEPRODUCTCODE@@</Value>
+ ;;<CodingSystem>@@IMMUNEPRODUCTCODESYSTEM@@</CodingSystem>
+ ;;</Code>
+ ;;</ProductName>
+ ;;</Product>
+ ;;</Immunization>
+ ;;</Immunizations>
+ ;;<FamilyHistory>
+ ;;<FamilyProblemHistory>
+ ;;<CCRDataObjectID>@@FAMILYHISTORYOBJECTID@@</CCRDataObjectID>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@FAMILYHISTORYACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;<FamilyMember>
+ ;;<ActorID>@@FAMILYMEMBERACTORID@@</ActorID>
+ ;;<ActorRole>
+ ;;<Text>@@FAMILYMEMBERACTORROLETEXT@@</Text>
+ ;;</ActorRole>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@FAMILYMEMBERSOURCACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</FamilyMember>
+ ;;<Problem>
+ ;;<Type>
+ ;;<Text>Problem</Text>
+ ;;</Type>
+ ;;<Description>
+ ;;<Text>@@FAMILYMEMBERPROBLEMDESCRIPTION@@</Text>
+ ;;<Code>
+ ;;<Value>@@FAMILYMEMBERPROBLEMCODE@@</Value>
+ ;;<CodingSystem>@@FAMILYMEMBERCODESYSTEM@@</CodingSystem>
+ ;;<Version>@@FAMILYMEMBERCODEVERSION@@</Version>
+ ;;</Code>
+ ;;</Description>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@FAMILYMEMBERPROBLEMSOURCEID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</Problem>
+ ;;</FamilyProblemHistory>
+ ;;</FamilyHistory>
+ ;;<SocialHistory>
+ ;;<SocialHistoryElement>
+ ;;<CCRDataObjectID>@@SOCIALHISTORYOBJECTID@@</CCRDataObjectID>
+ ;;<Type>
+ ;;<Text>@@SOCIALHISTORYTYPETEXT@@</Text>
+ ;;</Type>
+ ;;<Description>
+ ;;<Text>@@SOCIALHISTORYDESCRIPTIONTEXT@@</Text>
+ ;;</Description>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@SOCIALHISTORYSOURCACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</SocialHistoryElement>
+ ;;<SocialHistoryElement>
+ ;;<CCRDataObjectID>BB0005</CCRDataObjectID>
+ ;;<Type>
+ ;;<Text>Ethnic Origin</Text>
+ ;;</Type>
+ ;;<Description>
+ ;;<Text>Not Hispanic or Latino</Text>
+ ;;</Description>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>AA0001</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</SocialHistoryElement>
+ ;;<SocialHistoryElement>
+ ;;<CCRDataObjectID>BB0006</CCRDataObjectID>
+ ;;<Type>
+ ;;<Text>Race</Text>
+ ;;</Type>
+ ;;<Description>
+ ;;<Text>White</Text>
+ ;;</Description>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>AA0001</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</SocialHistoryElement>
+ ;;<SocialHistoryElement>
+ ;;<CCRDataObjectID>BB0007</CCRDataObjectID>
+ ;;<Type>
+ ;;<Text>Occupation</Text>
+ ;;</Type>
+ ;;<Description>
+ ;;<Text>Physician</Text>
+ ;;</Description>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>AA0001</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</SocialHistoryElement>
+ ;;</SocialHistory>
+ ;;<Alerts>
+ ;;<Alert>
+ ;;<CCRDataObjectID>@@ALERTOBJECTID@@</CCRDataObjectID>
+ ;;<DateTime>
+ ;;<ExactDateTime>@@ALERTDATETIME@@</ExactDateTime>
+ ;;</DateTime>
+ ;;<Type>
+ ;;<Text>@@ALERTTYPE@@</Text>
+ ;;</Type>
+ ;;<Status>
+ ;;<Text>@@ALERTSTATUSTEXT@@</Text>
+ ;;</Status>
+ ;;<Description>
+ ;;<Text>@@ALERTDESCRIPTIONTEXT@@</Text>
+ ;;<Code>
+ ;;<Value>@@ALERTCODEVALUE@@</Value>
+ ;;<CodingSystem>@@ALERTCODESYSTEM@@</CodingSystem>
+ ;;</Code>
+ ;;</Description>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@ALERTSOURCEID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;<Agent>
+ ;;<Products>
+ ;;<Product>
+ ;;<CCRDataObjectID>@@ALERTAGENTPRODUCTOBJECTID@@</CCRDataObjectID>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@ALERTSOURCEID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;<Product>
+ ;;<ProductName>
+ ;;<Text>@@ALERTAGENTPRODUCTNAMETEXT@@</Text>
+ ;;<Code>
+ ;;<Value>@@ALERTAGENTPRODUCTCODEVALUE@@</Value>
+ ;;<CodingSystem>@@ALERTAGENTPRODUCTCODESYSTEM@@</CodingSystem>
+ ;;</Code>
+ ;;</ProductName>
+ ;;</Product>
+ ;;</Product>
+ ;;</Products>
+ ;;</Agent>
+ ;;<Reaction>
+ ;;<Description>
+ ;;<Text>@@ALERTREACTIOINDESCRIPTIONTEXT@@</Text>
+ ;;<Code>
+ ;;<Value>@@ALERTREACTIONCODEVALUE@@</Value>
+ ;;<CodingSystem>@@ALERTREACTIONCODESYSTEM@@</CodingSystem>
+ ;;</Code>
+ ;;</Description>
+ ;;</Reaction>
+ ;;</Alert>
+ ;;</Alerts>
+ ;;<Medications>
+ ;;<Medication>
+ ;;<CCRDataObjectID>@@MEDOBJECTID@@</CCRDataObjectID>
+ ;;<DateTime>
+ ;;<Type>
+ ;;<Text>@@MEDISSUEDATETXT@@</Text>
+ ;;</Type>
+ ;;<ExactDateTime>@@MEDISSUEDATE@@</ExactDateTime>
+ ;;</DateTime>
+ ;;<DateTime>
+ ;;<Type>
+ ;;<Text>@@MEDLASTFILLDATETXT@@</Text>
+ ;;</Type>
+ ;;<ExactDateTime>@@MEDLASTFILLDATE@@</ExactDateTime>
+ ;;</DateTime>
+ ;;<IDs>
+ ;;<Type>
+ ;;<Text>@@MEDRXNOTXT@@</Text>
+ ;;</Type>
+ ;;<ID>@@MEDRXNO@@</ID>
+ ;;</IDs>
+ ;;<Type>
+ ;;<Text>@@MEDTYPETEXT@@</Text>
+ ;;</Type>
+ ;;<Description>
+ ;;<Text>@@MEDDETAILUNADORNED@@</Text>
+ ;;</Description>
+ ;;<Status>
+ ;;<Text>@@MEDSTATUSTEXT@@</Text>
+ ;;</Status>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@MEDSOURCEACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;<Product>
+ ;;<ProductName>
+ ;;<Text>@@MEDPRODUCTNAMETEXT@@</Text>
+ ;;<Code>
+ ;;<Value>@@MEDPRODUCTNAMECODEVALUE@@</Value>
+ ;;<CodingSystem>@@MEDPRODUCTNAMECODINGINGSYSTEM@@</CodingSystem>
+ ;;<Version>@@MEDPRODUCTNAMECODEVERSION@@</Version>
+ ;;</Code>
+ ;;</ProductName>
+ ;;<BrandName>
+ ;;<Text>@@MEDBRANDNAMETEXT@@</Text>
+ ;;</BrandName>
+ ;;<Strength>
+ ;;<Value>@@MEDSTRENGTHVALUE@@</Value>
+ ;;<Units>
+ ;;<Unit>@@MEDSTRENGTHUNIT@@</Unit>
+ ;;</Units>
+ ;;</Strength>
+ ;;<Form>
+ ;;<Text>@@MEDFORMTEXT@@</Text>
+ ;;</Form>
+ ;;<Concentration>
+ ;;<Value>@@MEDCONCVALUE@@</Value>
+ ;;<Units>
+ ;;<Unit>@@MEDCONCUNIT@@</Unit>
+ ;;</Units>
+ ;;</Concentration>
+ ;;</Product>
+ ;;<Quantity>
+ ;;<Value>@@MEDQUANTITYVALUE@@</Value>
+ ;;<Units>
+ ;;<Unit>@@MEDQUANTITYUNIT@@</Unit>
+ ;;</Units>
+ ;;</Quantity>
+ ;;<Directions>
+ ;;<Direction>
+ ;;<Description>
+ ;;<Text>@@MEDDIRECTIONDESCRIPTIONTEXT@@</Text>
+ ;;</Description>
+ ;;<DoseIndicator>
+ ;;<Text>@@MEDDOSEINDICATOR@@</Text>
+ ;;</DoseIndicator>
+ ;;<DeliveryMethod>
+ ;;<Text>@@MEDDELIVERYMETHOD@@</Text>
+ ;;</DeliveryMethod>
+ ;;<Dose>
+ ;;<Value>@@MEDDOSEVALUE@@</Value>
+ ;;<Units>
+ ;;<Unit>@@MEDDOSEUNIT@@</Unit>
+ ;;</Units>
+ ;;<Rate>
+ ;;<Value>@@MEDRATEVALUE@@</Value>
+ ;;<Units>
+ ;;<Unit>@@MEDRATEUNIT@@</Unit>
+ ;;</Units>
+ ;;</Rate>
+ ;;</Dose>
+ ;;<Vehicle>
+ ;;<Text>@@MEDVEHICLETEXT@@</Text>
+ ;;</Vehicle>
+ ;;<Route>
+ ;;<Text>@@MEDDIRECTIONROUTETEXT@@</Text>
+ ;;</Route>
+ ;;<Frequency>
+ ;;<Value>@@MEDFREQUENCYVALUE@@</Value>
+ ;;</Frequency>
+ ;;<Interval>
+ ;;<Value>@@MEDINTERVALVALUE@@</Value>
+ ;;<Units>
+ ;;<Unit>@@MEDINTERVALUNIT@@</Unit>
+ ;;</Units>
+ ;;</Interval>
+ ;;<Duration>
+ ;;<Value>@@MEDDURATIONVALUE@@</Value>
+ ;;<Units>
+ ;;<Unit>@@MEDDURATIONUNIT@@</Unit>
+ ;;</Units>
+ ;;</Duration>
+ ;;<Indication>
+ ;;<PRNFlag>
+ ;;<Text>@@MEDPRNFLAG@@</Text>
+ ;;</PRNFlag>
+ ;;<Problem>
+ ;;<CCRDataObjectID>@@MEDPROBLEMOBJECTID@@</CCRDataObjectID>
+ ;;<Type>
+ ;;<Text>@@MEDPROBLEMTYPETXT@@</Text>
+ ;;</Type>
+ ;;<Description>
+ ;;<Text>@@MEDPROBLEMDESCRIPTION@@</Text>
+ ;;<Code>
+ ;;<Value>@@MEDPROBLEMCODEVALUE@@</Value>
+ ;;<CodingSystem>@@MEDPROBLEMCODINGSYSTEM@@</CodingSystem>
+ ;;<Version>@@MEDPROBLEMCODINGVERSION@@</Version>
+ ;;</Code>
+ ;;</Description>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@MEDPROBLEMSOURCEACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</Problem>
+ ;;</Indication>
+ ;;<StopIndicator>
+ ;;<Text>@@MEDSTOPINDICATOR@@</Text>
+ ;;</StopIndicator>
+ ;;<DirectionSequenceModifier>@@MEDDIRSEQ@@</DirectionSequenceModifier>
+ ;;<MultipleDirectionModifier>
+ ;;<Text>@@MEDMULDIRMOD@@</Text>
+ ;;</MultipleDirectionModifier>
+ ;;</Direction>
+ ;;</Directions>
+ ;;<PatientInstructions>
+ ;;<Instruction>
+ ;;<Text>@@MEDPTINSTRUCTIONS@@</Text>
+ ;;</Instruction>
+ ;;</PatientInstructions>
+ ;;<FullfillmentInstructions>
+ ;;<Text>@@MEDFULLFILLMENTINSTRUCTIONS@@</Text>
+ ;;</FullfillmentInstructions>
+ ;;<Refills>
+ ;;<Refill>
+ ;;<Number>@@MEDRFNO@@</Number>
+ ;;</Refill>
+ ;;</Refills>
+ ;;</Medication>
+ ;;</Medications>
+ ;;<VitalSigns>
+ ;;<Result>
+ ;;<CCRDataObjectID>@@VITALSIGNSDATAOBJECTID@@</CCRDataObjectID>
+ ;;<DateTime>
+ ;;<Type>
+ ;;<Text>@@VITALSIGNSDATETIMETYPETEXT@@</Text>
+ ;;</Type>
+ ;;<ExactDateTime>@@VITALSIGNSEXACTDATETIME@@</ExactDateTime>
+ ;;</DateTime>
+ ;;<Description>
+ ;;<Text>@@VITALSIGNSDESCRIPTIONTEXT@@</Text>
+ ;;</Description>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@VITALSIGNSSOURCEACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;<Test>
+ ;;<CCRDataObjectID>@@VITALSIGNSTESTOBJECTID@@</CCRDataObjectID>
+ ;;<Type>
+ ;;<Text>@@VITALSIGNSTESTTYPETEXT@@</Text>
+ ;;</Type>
+ ;;<Description>
+ ;;<Text>@@VITALSIGNSDESCRIPTIONTEXT@@</Text>
+ ;;<Code>
+ ;;<Value>@@VITALSIGNSDESCCODEVALUE@@</Value>
+ ;;<CodingSystem>@@VITALSIGNSDESCCODINGSYSTEM@@</CodingSystem>
+ ;;<Version>@@VITALSIGNSCODEVERSION@@</Version>
+ ;;</Code>
+ ;;</Description>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@VITALSIGNSTESTSOURCEACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;<TestResult>
+ ;;<Value>@@VITALSIGNSTESTRESULTVALUE@@</Value>
+ ;;<Units>
+ ;;<Unit>@@VITALSIGNSTESTRESULTUNIT@@</Unit>
+ ;;</Units>
+ ;;</TestResult>
+ ;;</Test>
+ ;;</Result>
+ ;;</VitalSigns>
+ ;;<Results>
+ ;;<Result>
+ ;;<CCRDataObjectID>@@RESULTOBJECTID@@</CCRDataObjectID>
+ ;;<DateTime>
+ ;;<Type>
+ ;;<Text>Assessment Time</Text>
+ ;;</Type>
+ ;;<ExactDateTime>@@RESULTASSESSMENTDATETIME@@</ExactDateTime>
+ ;;</DateTime>
+ ;;<Description>
+ ;;<Text>@@RESULTDESCRIPTIONTEXT@@</Text>
+ ;;<Code>
+ ;;<Value>@@RESULTCODE@@</Value>
+ ;;<CodingSystem>@@RESULTCODINGSYSTEM@@</CodingSystem>
+ ;;</Code>
+ ;;</Description>
+ ;;<Status>
+ ;;<Text>@@RESULTSTATUS@@</Text>
+ ;;</Status>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@RESULTSOURCEACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;<Test>
+ ;;<CCRDataObjectID>@@RESULTTESTOBJECTID@@</CCRDataObjectID>
+ ;;<DateTime>
+ ;;<Type>
+ ;;<Text>Assessment Time</Text>
+ ;;</Type>
+ ;;<ExactDateTime>@@RESULTTESTDATETIME@@</ExactDateTime>
+ ;;</DateTime>
+ ;;<Description>
+ ;;<Text>@@RESULTTESTDESCRIPTIONTEXT@@</Text>
+ ;;<Code>
+ ;;<Value>@@RESULTTESTCODEVALUE@@</Value>
+ ;;<CodingSystem>@@RESULTTESTCODINGSYSTEM@@</CodingSystem>
+ ;;</Code>
+ ;;</Description>
+ ;;<Status>
+ ;;<Text>@@RESULTTESTSTATUSTEXT@@</Text>
+ ;;</Status>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@RESULTTESTSOURCEACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;<TestResult>
+ ;;<Value>@@RESULTTESTVALUE@@</Value>
+ ;;<Units>
+ ;;<Unit>@@RESULTTESTUNITS@@</Unit>
+ ;;</Units>
+ ;;</TestResult>
+ ;;<NormalResult>
+ ;;<Normal>
+ ;;<Description>
+ ;;<Text>@@RESULTTESTNORMALDESCTEXT@@</Text>
+ ;;</Description>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@RESULTTESTNORMALSOURCEACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</Normal>
+ ;;</NormalResult>
+ ;;<Flag>
+ ;;<Text>@@RESULTTESTFLAG@@</Text>
+ ;;</Flag>
+ ;;</Test>
+ ;;</Result>
+ ;;</Results>
+ ;;<Procedures>
+ ;;<Procedure>
+ ;;<CCRDataObjectID>@@PROCOBJECTID@@</CCRDataObjectID>
+ ;;<DateTime>
+ ;;<Type>
+ ;;<Text>@@PROCDATETEXT@@</Text>
+ ;;</Type>
+ ;;<ExactDateTime>@@PROCDATETIME@@</ExactDateTime>
+ ;;</DateTime>
+ ;;<Description>
+ ;;<Text>@@PROCDESCTEXT@@</Text>
+ ;;<ObjectAttribute>
+ ;;<Attribute>@@PROCDESCOBJATTR@@</Attribute>
+ ;;<AttributeValue>
+ ;;<Value>@@PROCDESCOBJATTRVAL@@</Value>
+ ;;<Code>
+ ;;<Value>@@PROCDESCOBJATTRCODE@@</Value>
+ ;;<CodingSystem>@@PROCDESCOBJATTRCODESYS@@</CodingSystem>
+ ;;</Code>
+ ;;</AttributeValue>
+ ;;</ObjectAttribute>
+ ;;<Code>
+ ;;<Value>@@PROCCODE@@</Value>
+ ;;<CodingSystem>@@PROCCODESYS@@</CodingSystem>
+ ;;</Code>
+ ;;</Description>
+ ;;<Status>
+ ;;<Text>@@PROCSTATUS@@</Text>
+ ;;</Status>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@PROCACTOROBJID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;<InternalCCRLink>
+ ;;<LinkID>@@PROCLINKID@@</LinkID>
+ ;;<LinkRelationship>@@PROCLINKREL@@</LinkRelationship>
+ ;;</InternalCCRLink>
+ ;;</Procedure>
+ ;;</Procedures>
+ ;;<Encounters>
+ ;;<Encounter>
+ ;;<CCRDataObjectID>@@ENCOBJECTID@@</CCRDataObjectID>
+ ;;<DateTime>
+ ;;<ExactDateTime>@@ENCDATETIME@@</ExactDateTime>
+ ;;</DateTime>
+ ;;<Type>
+ ;;<Text>@@ENCTYPETXT@@</Text>
+ ;;<Code>
+ ;;<Value>@@ENCTYPECODE@@</Value>
+ ;;<CodingSystem>@@ENCTYPECODESYS@@</CodingSystem>
+ ;;</Code>
+ ;;</Type>
+ ;;<Description>
+ ;;<Text>@@ENCDESCTXT@@</Text>
+ ;;<Code>
+ ;;<Value>@@ENCDESCCODE@@</Value>
+ ;;<CodingSystem>@@ENCDESCCODESYS@@</CodingSystem>
+ ;;</Code>
+ ;;</Description>
+ ;;<Location>
+ ;;<Actor>
+ ;;<ActorID>@@ENCLOCACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Location>
+ ;;<Practioner>
+ ;;<Actor>
+ ;;<ActorID>@@ENCPRVACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Practioner>
+ ;;<Indication>
+ ;;<Text>@@ENCINDTXT@@</Text>
+ ;;<Code>
+ ;;<Value>@@ENCINDCODE@@</Value>
+ ;;<CodingSystem>@@ENCINDCODESYS@@</CodingSystem>
+ ;;</Code>
+ ;;</Indication>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@ENCACTORID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;<CommentID>@@ENCCOMMENTID@@</CommentID>
+ ;;</Encounter>
+ ;;</Encounters>
+ ;;<HealthCareProviders>
+ ;;<Provider>
+ ;;<ActorID>AA0005</ActorID>
+ ;;<ActorRole>
+ ;;<Text>Primary Provider</Text>
+ ;;</ActorRole>
+ ;;</Provider>
+ ;;</HealthCareProviders>
+ ;;</Body>
+ ;;<Actors>
+ ;;<ACTOR-PATIENT>
+ ;;<Actor>
+ ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
+ ;;<Person>
+ ;;<Name>
+ ;;<CurrentName>
+ ;;<Given>@@ACTORGIVENNAME@@</Given>
+ ;;<Middle>@@ACTORMIDDLENAME@@</Middle>
+ ;;<Family>@@ACTORFAMILYNAME@@</Family>
+ ;;</CurrentName>
+ ;;</Name>
+ ;;<DateOfBirth>
+ ;;<ExactDateTime>@@ACTORDATEOFBIRTH@@</ExactDateTime>
+ ;;</DateOfBirth>
+ ;;<Gender>
+ ;;<Text>@@ACTORGENDER@@</Text>
+ ;;<Code>
+ ;;<Value>@@ACTORGENDERCODE@@</Value>
+ ;;<CodingSystem>HL7 AdministrativeGender</CodingSystem>
+ ;;</Code>
+ ;;</Gender>
+ ;;</Person>
+ ;;<IDs>
+ ;;<Type>
+ ;;<Text>@@ACTORSSNTEXT@@</Text>
+ ;;</Type>
+ ;;<ID>@@ACTORSSN@@</ID>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@ACTORSSNSOURCEID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</IDs>
+ ;;<Address>
+ ;;<Type>
+ ;;<Text>@@ACTORADDRESSTYPE@@</Text>
+ ;;</Type>
+ ;;<Line1>@@ACTORADDRESSLINE1@@</Line1>
+ ;;<Line2>@@ACTORADDRESSLINE2@@</Line2>
+ ;;<City>@@ACTORADDRESSCITY@@</City>
+ ;;<State>@@ACTORADDRESSSTATE@@</State>
+ ;;<PostalCode>@@ACTORADDRESSZIPCODE@@</PostalCode>
+ ;;</Address>
+ ;;<Telephone>
+ ;;<Value>@@ACTORRESTEL@@</Value>
+ ;;<Type>
+ ;;<Text>@@ACTORRESTELTEXT@@</Text>
+ ;;</Type>
+ ;;</Telephone>
+ ;;<Telephone>
+ ;;<Value>@@ACTORWORKTEL@@</Value>
+ ;;<Type>
+ ;;<Text>@@ACTORWORKTELTEXT@@</Text>
+ ;;</Type>
+ ;;</Telephone>
+ ;;<Telephone>
+ ;;<Value>@@ACTORCELLTEL@@</Value>
+ ;;<Type>
+ ;;<Text>@@ACTORCELLTELTEXT@@</Text>
+ ;;</Type>
+ ;;</Telephone>
+ ;;<EMail>
+ ;;<Value>@@ACTOREMAIL@@</Value>
+ ;;</EMail>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@ACTORADDRESSSOURCEID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</Actor>
+ ;;</ACTOR-PATIENT>
+ ;;<ACTOR-SYSTEM>
+ ;;<Actor>
+ ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
+ ;;<InformationSystem>
+ ;;<Name>@@ACTORINFOSYSNAME@@</Name>
+ ;;<Version>@@ACTORINFOSYSVER@@</Version>
+ ;;</InformationSystem>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@ACTORINFOSYSSOURCEID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</Actor>
+ ;;</ACTOR-SYSTEM>
+ ;;<ACTOR-NOK>
+ ;;<Actor>
+ ;;<ActorObjectID>AA0003</ActorObjectID>
+ ;;<Person>
+ ;;<Name>
+ ;;<DisplayName>@@ACTORDISPLAYNAME@@</DisplayName>
+ ;;</Name>
+ ;;</Person>
+ ;;<Relation>
+ ;;<Text>@@ACTORRELATION@@</Text>
+ ;;</Relation>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@ACTORRELATIONSOURCEID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</Actor>
+ ;;</ACTOR-NOK>
+ ;;<ACTOR-PROVIDER>
+ ;;<Actor>
+ ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
+ ;;<Person>
+ ;;<Name>
+ ;;<CurrentName>
+ ;;<Given>@@ACTORGIVENNAME@@</Given>
+ ;;<Middle>@@ACTORMIDDLENAME@@</Middle>
+ ;;<Family>@@ACTORFAMILYNAME@@</Family>
+ ;;<Title>@@ACTORTITLE@@</Title>
+ ;;</CurrentName>
+ ;;</Name>
+ ;;</Person>
+ ;;<Specialty>
+ ;;<Text>@@ACTORSPECIALITY@@</Text>
+ ;;</Specialty>
+ ;;<Address>
+ ;;<Type>
+ ;;<Text>@@ACTORADDRESSTYPE@@</Text>
+ ;;</Type>
+ ;;<Line1>@@ACTORADDRESSLINE1@@</Line1>
+ ;;<City>@@ACTORADDRESSCITY@@</City>
+ ;;<State>@@ACTORADDRESSSTATE@@</State>
+ ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode>
+ ;;</Address>
+ ;;<Telephone>
+ ;;<Value>@@ACTORTELEPHONE@@</Value>
+ ;;<Type>
+ ;;<Text>@@ACTORTELEPHONETYPE@@</Text>
+ ;;</Type>
+ ;;</Telephone>
+ ;;<Email>
+ ;;<Value>@@ACTOREMAIL@@</Value>
+ ;;</Email>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@ACTORSOURCEID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;<InternalCCRLink>
+ ;;<LinkID>@@ACTORORGLINK@@</LinkID>
+ ;;<LinkRelationship>representedOrganization</LinkRelationship>
+ ;;</InternalCCRLink>
+ ;;</Actor>
+ ;;</ACTOR-PROVIDER>
+ ;;<ACTOR-ORG>
+ ;;<Actor>
+ ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID>
+ ;;<Organization>
+ ;;<Name>@@ORGANIZATIONNAME@@</Name>
+ ;;</Organization>
+ ;;<Address>
+ ;;<Type>
+ ;;<Text>@@ACTORADDRESSTYPE@@</Text>
+ ;;</Type>
+ ;;<Line1>@@ACTORADDRESSLINE1@@</Line1>
+ ;;<City>@@ACTORADDRESSCITY@@</City>
+ ;;<State>@@ACTORADDRESSSTATE@@</State>
+ ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode>
+ ;;</Address>
+ ;;<Telephone>
+ ;;<Value>@@ACTORTELEPHONE@@</Value>
+ ;;<Type>
+ ;;<Text>@@ACTORTELEPHONETYPE@@</Text>
+ ;;</Type>
+ ;;</Telephone>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@ACTORSOURCEID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</Actor>
+ ;;</ACTOR-ORG>
+ ;;</Actors>
+ ;;<Signatures>
+ ;;<CCRSignature>
+ ;;<SignatureObjectID>S0001</SignatureObjectID>
+ ;;<ExactDateTime>2008-03-18T23:10:58Z</ExactDateTime>
+ ;;<Source>
+ ;;<ActorID>AA0001</ActorID>
+ ;;</Source>
+ ;;<Signature>
+ ;;<Signature xmlns="http://www.w3.org/2000/09/xmldsig#">
+ ;;<SignedInfo>
+ ;;<CanonicalizationMethod Algorithm="http://www.w3.org/TR/2001/REC-xml-c14n-20010315"/>
+ ;;<SignatureMethod Algorithm="http://www.w3.org/2000/09/xmldsig#rsa-sha1"/>
+ ;;<Reference URI="">
+ ;;<Transforms>
+ ;;<Transform Algorithm="http://www.w3.org/2000/09/xmldsig#enveloped-signature"/>
+ ;;</Transforms>
+ ;;<DigestMethod Algorithm="http://www.w3.org/2000/09/xmldsig#sha1"/>
+ ;;<DigestValue>YFveLLyo+75P7rSciv0/m1O6Ot4=</DigestValue>
+ ;;</Reference>
+ ;;</SignedInfo>
+ ;;<SignatureValue>Bj6sACXl74hrlbUYnu8HqnRab5VGy69BOYjOH7dETxgppXMEd7AoVYaePZvgJft78JR4oQY76hbFyGcIslYauPpJxx2hCd5d56xFeaQg01R6AQOvGnhjlq63TbpFdUq0B4tYsmiibJPbQJhTQe+TcWTBvWaQt8Fkk5blO571YvI=</SignatureValue>
+ ;;<KeyInfo>
+ ;;<KeyValue>
+ ;;<RSAKeyValue>
+ ;;<Modulus>meH817QYol+/uUEg6j8Mg89s7GTlaN9B+/CGlzrtnQH+swMigZRnEPxHVO8PhEymP/W9nlhAjTScV/CUzA9yJ9WiaOn17c+KReKhfBqL24DX9BpbJ+kLYVz7mBO5Qydk5AzUT2hFwW93irD8iRKP+/t+2Mi2CjNfj8VTjJpHpm0=</Modulus>
+ ;;<Exponent>AQAB</Exponent>
+ ;;</RSAKeyValue>
+ ;;</KeyValue>
+ ;;</KeyInfo>
+ ;;</Signature>
+ ;;</Signature>
+ ;;</CCRSignature>
+ ;;</Signatures>
+ ;;<Comments>
+ ;;<Comment>
+ ;;<CommentObjectID>@@COMMENTOBJECTID@@</CommentObjectID>
+ ;;<DateTime>
+ ;;<ExactDateTime>@@CMTDATETIME@@</ExactDateTime>
+ ;;</DateTime>
+ ;;<Description>
+ ;;<Text>
+ ;;</Text>
+ ;;</Description>
+ ;;<Source>
+ ;;<Actor>
+ ;;<ActorID>@@ACTORSOURCEID@@</ActorID>
+ ;;</Actor>
+ ;;</Source>
+ ;;</Comment>
+ ;;</Comments>
+ ;;</ContinuityOfCareRecord>
+ ;</TEMPLATE>

ccr/trunk/p/C0CCMT.m

@@ -1 @@
-C0CCMT   ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10
-        ;;1.0;C0C;;May 21, 2010;Build 38
-        ;Copyright 2010 George Lilly, University of Minnesota and others.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "NO ENTRY FROM TOP",!
-        Q
-        ;
-EXTRACT(NOTEXML,DFN,NOTEOUT)    ; EXTRACT NOTES INTO  XML TEMPLATE
-        ; NOTEXML AND NOTEOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
-        ;
-        D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES
-        ;I '$D(@C0CNTE) Q  ; NO NOTES AVAILABLE
-        D MAP(NOTEXML,C0CNTE,NOTEOUT) ;MAP RESULTS FOR NOTES
-        Q
-        ;
-MAP(NOTEXML,C0CNTE,NOTEOUT)     ; MAP PROCEDURES XML 
-        ;
-        N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"NOTETEMP")) ;WORK AREA FOR TEMPLATE
-        K @ZTEMP
-        N ZBLD
-        S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"NOTEBLD")) ; BUILD LIST AREA
-        D QUEUE^C0CXPATH(ZBLD,NOTEXML,1,1) ; FIRST LINE
-        N ZINNER
-        D QUERY^C0CXPATH(NOTEXML,"//Comments/Comment","ZINNER") ;ONE NOTE
-        N ZTMP,ZVAR,ZI
-        S ZI=""
-        F  S ZI=$O(@C0CNTE@(ZI)) Q:ZI=""  D  ;FOR EACH NOTE
-        . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS NOTE XML
-        . S ZVAR=$NA(@C0CNTE@(ZI)) ;THIS NOTE VARIABLES
-        . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE
-        . N ZNOTE,ZN
-        . D CLEAN($NA(@C0CNTE@(ZI,"TEXT"))) ;REMOVE CONTROL CHARS AND XML RESERVED
-        . M ZNOTE=@C0CNTE@(ZI,"TEXT") ;THE NOTE TO ADD TO THE BUILD
-        . S ZNOTE(0)=$O(ZNOTE(""),-1) ;LENGTH OF THE NOTE
-        . D INSERT^C0CXPATH(ZTMP,"ZNOTE","//Comment/Description/Text")
-        . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD
-        D QUEUE^C0CXPATH(ZBLD,NOTEXML,@NOTEXML@(0),@NOTEXML@(0))
-        N ZZTMP
-        D BUILD^C0CXPATH(ZBLD,NOTEOUT) ;BUILD FINAL XML
-        K @ZTEMP,@ZBLD,@C0CNTE
-        Q
-        ;  
-CLEAN(INARY)    ; INARY IS PASSED BY NAME
-        ; REMOVE CONTROL CHARACTERS AND XML RESERVED SYMBOLS FROM THE ARRAY
-        N ZI,ZJ S ZI=""
-        F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ;
-        . S @INARY@(ZI)=$$CLEAN^C0CXPATH(@INARY@(ZI)) ; CONTROL CHARS
-        . S @INARY@(ZI)=$$SYMENC^MXMLUTL(@INARY@(ZI)) ; XML RESERVED SYMBOLS
-        Q
-        ;
+C0CCMT  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10
+ ;;1.0;C0C;;May 21, 2010;Build 38
+ ;Copyright 2010 George Lilly, University of Minnesota and others.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "NO ENTRY FROM TOP",!
+ Q
+ ;
+EXTRACT(NOTEXML,DFN,NOTEOUT) ; EXTRACT NOTES INTO  XML TEMPLATE
+ ; NOTEXML AND NOTEOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
+ ;
+ D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES
+ ;I '$D(@C0CNTE) Q  ; NO NOTES AVAILABLE
+ D MAP(NOTEXML,C0CNTE,NOTEOUT) ;MAP RESULTS FOR NOTES
+ Q
+ ;
+MAP(NOTEXML,C0CNTE,NOTEOUT) ; MAP PROCEDURES XML 
+ ;
+ N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"NOTETEMP")) ;WORK AREA FOR TEMPLATE
+ K @ZTEMP
+ N ZBLD
+ S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"NOTEBLD")) ; BUILD LIST AREA
+ D QUEUE^C0CXPATH(ZBLD,NOTEXML,1,1) ; FIRST LINE
+ N ZINNER
+ D QUERY^C0CXPATH(NOTEXML,"//Comments/Comment","ZINNER") ;ONE NOTE
+ N ZTMP,ZVAR,ZI
+ S ZI=""
+ F  S ZI=$O(@C0CNTE@(ZI)) Q:ZI=""  D  ;FOR EACH NOTE
+ . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS NOTE XML
+ . S ZVAR=$NA(@C0CNTE@(ZI)) ;THIS NOTE VARIABLES
+ . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE
+ . N ZNOTE,ZN
+ . D CLEAN($NA(@C0CNTE@(ZI,"TEXT"))) ;REMOVE CONTROL CHARS AND XML RESERVED
+ . M ZNOTE=@C0CNTE@(ZI,"TEXT") ;THE NOTE TO ADD TO THE BUILD
+ . S ZNOTE(0)=$O(ZNOTE(""),-1) ;LENGTH OF THE NOTE
+ . D INSERT^C0CXPATH(ZTMP,"ZNOTE","//Comment/Description/Text")
+ . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD
+ D QUEUE^C0CXPATH(ZBLD,NOTEXML,@NOTEXML@(0),@NOTEXML@(0))
+ N ZZTMP
+ D BUILD^C0CXPATH(ZBLD,NOTEOUT) ;BUILD FINAL XML
+ K @ZTEMP,@ZBLD,@C0CNTE
+ Q
+ ;  
+CLEAN(INARY) ; INARY IS PASSED BY NAME
+ ; REMOVE CONTROL CHARACTERS AND XML RESERVED SYMBOLS FROM THE ARRAY
+ N ZI,ZJ S ZI=""
+ F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ;
+ . S @INARY@(ZI)=$$CLEAN^C0CXPATH(@INARY@(ZI)) ; CONTROL CHARS
+ . S @INARY@(ZI)=$$SYMENC^MXMLUTL(@INARY@(ZI)) ; XML RESERVED SYMBOLS
+ Q
+ ;

ccr/trunk/p/C0CCPT.m

@@ -1 @@
-C0CCPT  ;;BSL;RETURN CPT DATA;
-        ;Sequence Managers Software GPL;;;;;Build 38
-        ;Copied into C0C namespace from SQMCPT with permission from
-        ;Brian Lord - and with our thanks. gpl 01/20/2010
-ENTRY(DFN,STDT,ENDDT,TXT)       ;BUILD TOTAL ARRAY OF ALL IEN'S FOR TIU NOTES
-        ;DFN=PATIENT IEN
-        ;STDT=START DATE IN 3100101 FORMAT (VA YEAR YYYMMDD)
-        ;ENDDT=END DATE IN 3100101 FORMAT
-        ;TXT=INCLUDE TEXT FROM ENCOUNTER NOTE
-        ;THAT FALL INSIDE DATA RANGE. IF NO STDT OR ENDDT ASSUME 
-               ;ALL INCLUSIVE IN THAT DIRECTION
-               ;LIST OF TIU DOCS IN ^TIU(8925,"ACLPT",3,DFN)
-               ;BUILD INTO NOTE(Y)=""
-               S U="^",X=""
-               F  S X=$O(^TIU(8925,"ACLPT",3,DFN,X)) Q:X=""  D
-               . S Y=""
-               . F  S Y=$O(^TIU(8925,"ACLPT",3,DFN,X,Y)) Q:Y=""  D
-               .. S NOTE(Y)=""
-               ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE
-               ;GET DATE OF NOTE
-               S Z=""
-               F  S Z=$O(NOTE(Z)) Q:Z=""  D
-               . S DT=$P(^TIU(8925,Z,0),U,7)
-               . I $G(STDT)]"" D
-               .. I STDT>DT S NOTE(Z)="D"  ;SET NOTE TO BE DELETED
-               . I $G(ENDDT)]"" D
-               .. I ENDDT<DT S NOTE(Z)="D"
-               . I NOTE(Z)="D" K NOTE(Z)
-        D VISIT
-               Q
-VISIT     ;GET VISIT INFO FOR A GIVEN NOTE. BUILD INTO RETURN ARRAY .VISIT
-        S ILST=1,X0="",X12="",VISIT="",LST="",X811=""
-        S IEN=""  F  S IEN=$O(NOTE(IEN)) Q:IEN=""  D
-        . S X0=^TIU(8925,IEN,0),X12=$G(^(12))
-        . S VISIT=$P(X12,U,7)
-        . I 'VISIT S VISIT=$P(X0,U,3)
-        . K ^TMP("PXKENC",$J)
-        . Q:VISIT=""!(VISIT'>0)
-        . D ENCEVENT^PXKENC(VISIT,1)
-        . I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q
-        . S IPRV=0 F  S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV  D
-        .. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0)
-        .. ;Q:$P(X0,U,4)'="P"
-        .. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U)
-        .. S PRIM=($P(X0,U,4)="P")
-        .. S ILST=ILST+1
-        .. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM
-        .. S VISIT(IEN,"PRV",ILST)=CODE_"^^^"_NARR_"^"_PRIM
-        . S IPOV=0 F  S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV  D
-        .. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811))
-        .. S CODE=$P(X0,U)
-        .. S:CODE CODE=$P(^ICD9(CODE,0),U)
-        .. S CAT=$P(X802,U)
-        .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
-        .. S NARR=$P(X0,U,4)
-        .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
-        .. S PRIM=($P(X0,U,12)="P")
-        .. S PRV=$P(X12,U,4)
-        .. S ILST=ILST+1
-        .. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV
-        .. S VISIT(IEN,"POV",ILST)=CODE_U_CAT_U_NARR_U_PRIM_U_PRV
-        . S ICPT=0 F  S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT  D
-        .. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811))
-        .. ;S CODE=$P(X0,U)
-        .. S CODE=$O(^ICPT("B",$P(X0,U),0))
-        .. S:CODE CODE=$P(^ICPT(CODE,0),U)
-        .. S CAT=$P(X802,U)
-        .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
-        .. S NARR=$P(X0,U,4)
-        .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
-        .. S QTY=$P(X0,U,16)
-        .. S PRV=$P(X12,U,4)
-        .. S MCNT=0,MIDX=0,MODS=""
-        .. F  S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX  D
-        ... S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0))
-        ... I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN
-        .. I +MCNT S MODS=MCNT_MODS
-        .. S ILST=ILST+1
-        .. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
-        .. S VISIT(IEN,"CPT",ILST)=CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
-        . S VISIT(IEN,"DATE",0)=$P($P(^TIU(8925,IEN,0),U,7),".")
-        . S VISIT(IEN,"CLASS")=$$GET1^DIQ(8925,IEN_",",.04) ;GPL 5/21/10
-        . I $G(TXT)=1 D GETNOTE(IEN)
-        Q
-GETNOTE(IEN)    ;GET THE TEXT THAT GOES WITH VISIT
-        ;EXTRACT NOTE TEXT FROM ^TIU(8925,IEN,"TEXT"
-        Q:'$D(VISIT(IEN,"CPT"))
-        S TXTCNT=0
-        F  S TXTCNT=TXTCNT+1 Q:'$D(^TIU(8925,IEN,"TEXT",TXTCNT,0))  D
-        . S VISIT(IEN,"TEXT",TXTCNT)=^TIU(8925,IEN,"TEXT",TXTCNT,0)
-        Q
+C0CCPT ;;BSL;RETURN CPT DATA;
+ ;Sequence Managers Software GPL;;;;;Build 38
+ ;Copied into C0C namespace from SQMCPT with permission from
+ ;Brian Lord - and with our thanks. gpl 01/20/2010
+ENTRY(DFN,STDT,ENDDT,TXT) ;BUILD TOTAL ARRAY OF ALL IEN'S FOR TIU NOTES
+ ;DFN=PATIENT IEN
+ ;STDT=START DATE IN 3100101 FORMAT (VA YEAR YYYMMDD)
+ ;ENDDT=END DATE IN 3100101 FORMAT
+ ;TXT=INCLUDE TEXT FROM ENCOUNTER NOTE
+ ;THAT FALL INSIDE DATA RANGE. IF NO STDT OR ENDDT ASSUME 
+        ;ALL INCLUSIVE IN THAT DIRECTION
+        ;LIST OF TIU DOCS IN ^TIU(8925,"ACLPT",3,DFN)
+        ;BUILD INTO NOTE(Y)=""
+        S U="^",X=""
+        F  S X=$O(^TIU(8925,"ACLPT",3,DFN,X)) Q:X=""  D
+        . S Y=""
+        . F  S Y=$O(^TIU(8925,"ACLPT",3,DFN,X,Y)) Q:Y=""  D
+        .. S NOTE(Y)=""
+        ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE
+        ;GET DATE OF NOTE
+        S Z=""
+        F  S Z=$O(NOTE(Z)) Q:Z=""  D
+        . S DT=$P(^TIU(8925,Z,0),U,7)
+        . I $G(STDT)]"" D
+        .. I STDT>DT S NOTE(Z)="D"  ;SET NOTE TO BE DELETED
+        . I $G(ENDDT)]"" D
+        .. I ENDDT<DT S NOTE(Z)="D"
+        . I NOTE(Z)="D" K NOTE(Z)
+ D VISIT
+        Q
+VISIT   ;GET VISIT INFO FOR A GIVEN NOTE. BUILD INTO RETURN ARRAY .VISIT
+ S ILST=1,X0="",X12="",VISIT="",LST="",X811=""
+ S IEN=""  F  S IEN=$O(NOTE(IEN)) Q:IEN=""  D
+ . S X0=^TIU(8925,IEN,0),X12=$G(^(12))
+ . S VISIT=$P(X12,U,7)
+ . I 'VISIT S VISIT=$P(X0,U,3)
+ . K ^TMP("PXKENC",$J)
+ . Q:VISIT=""!(VISIT'>0)
+ . D ENCEVENT^PXKENC(VISIT,1)
+ . I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q
+ . S IPRV=0 F  S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV  D
+ .. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0)
+ .. ;Q:$P(X0,U,4)'="P"
+ .. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U)
+ .. S PRIM=($P(X0,U,4)="P")
+ .. S ILST=ILST+1
+ .. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM
+ .. S VISIT(IEN,"PRV",ILST)=CODE_"^^^"_NARR_"^"_PRIM
+ . S IPOV=0 F  S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV  D
+ .. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811))
+ .. S CODE=$P(X0,U)
+ .. S:CODE CODE=$P(^ICD9(CODE,0),U)
+ .. S CAT=$P(X802,U)
+ .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
+ .. S NARR=$P(X0,U,4)
+ .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
+ .. S PRIM=($P(X0,U,12)="P")
+ .. S PRV=$P(X12,U,4)
+ .. S ILST=ILST+1
+ .. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV
+ .. S VISIT(IEN,"POV",ILST)=CODE_U_CAT_U_NARR_U_PRIM_U_PRV
+ . S ICPT=0 F  S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT  D
+ .. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811))
+ .. ;S CODE=$P(X0,U)
+ .. S CODE=$O(^ICPT("B",$P(X0,U),0))
+ .. S:CODE CODE=$P(^ICPT(CODE,0),U)
+ .. S CAT=$P(X802,U)
+ .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U)
+ .. S NARR=$P(X0,U,4)
+ .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
+ .. S QTY=$P(X0,U,16)
+ .. S PRV=$P(X12,U,4)
+ .. S MCNT=0,MIDX=0,MODS=""
+ .. F  S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX  D
+ ... S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0))
+ ... I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN
+ .. I +MCNT S MODS=MCNT_MODS
+ .. S ILST=ILST+1
+ .. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
+ .. S VISIT(IEN,"CPT",ILST)=CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS
+ . S VISIT(IEN,"DATE",0)=$P($P(^TIU(8925,IEN,0),U,7),".")
+ . S VISIT(IEN,"CLASS")=$$GET1^DIQ(8925,IEN_",",.04) ;GPL 5/21/10
+ . I $G(TXT)=1 D GETNOTE(IEN)
+ Q
+GETNOTE(IEN) ;GET THE TEXT THAT GOES WITH VISIT
+ ;EXTRACT NOTE TEXT FROM ^TIU(8925,IEN,"TEXT"
+ Q:'$D(VISIT(IEN,"CPT"))
+ S TXTCNT=0
+ F  S TXTCNT=TXTCNT+1 Q:'$D(^TIU(8925,IEN,"TEXT",TXTCNT,0))  D
+ . S VISIT(IEN,"TEXT",TXTCNT)=^TIU(8925,IEN,"TEXT",TXTCNT,0)
+ Q

ccr/trunk/p/C0CDPT.m

@@ -1 @@
-C0CDPT  ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;
-        ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
-        ; General Public License. 
-        ; 
-        ; This program is distributed in the hope that it will be useful,
-        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ; GNU General Public License for more details.
-        ; 
-        ; You should have received a copy of the GNU General Public License along
-        ; with this program; if not, write to the Free Software Foundation, Inc.,
-        ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        ; FAMILY       Family Name
-        ; GIVEN        Given Name
-        ; MIDDLE       Middle Name
-        ; SUFFIX       Suffix Name
-        ; DISPNAME     Display Name
-        ; DOB          Date of Birth
-        ; GENDER       Get Gender
-        ; SSN          Get SSN for ID
-        ; ADDRTYPE     Get Home Address
-        ; ADDR1        Get Home Address line 1
-        ; ADDR2        Get Home Address line 2
-        ; CITY         Get City for Home Address
-        ; STATE        Get State for Home Address
-        ; ZIP          Get Zip code for Home Address
-        ; COUNTY       Get County for our Address
-        ; COUNTRY      Get Country for our Address
-        ; RESTEL       Residential Telephone
-        ; WORKTEL      Work Telephone
-        ; EMAIL        Email Adddress
-        ; CELLTEL      Cell Phone
-        ; NOK1FAM      Next of Kin 1 (NOK1) Family Name
-        ; NOK1GIV      NOK1 Given Name
-        ; NOK1MID      NOK1 Middle Name
-        ; NOK1SUF      NOK1 Suffi Name
-        ; NOK1DISP     NOK1 Display Name
-        ; NOK1REL      NOK1 Relationship to the patient
-        ; NOK1ADD1     NOK1 Address 1
-        ; NOK1ADD2     NOK1 Address 2
-        ; NOK1CITY     NOK1 City
-        ; NOK1STAT     NOK1 State
-        ; NOK1ZIP      NOK1 Zip Code
-        ; NOK1HTEL     NOK1 Home Telephone
-        ; NOK1WTEL     NOK1 Work Telephone
-        ; NOK1SAME     Is NOK1's Address the same the patient?
-        ; NOK2FAM      NOK2 Family Name
-        ; NOK2GIV      NOK2 Given Name
-        ; NOK2MID      NOK2 Middle Name
-        ; NOK2SUF      NOK2 Suffi Name
-        ; NOK2DISP     NOK2 Display Name
-        ; NOK2REL      NOK2 Relationship to the patient
-        ; NOK2ADD1     NOK2 Address 1
-        ; NOK2ADD2     NOK2 Address 2
-        ; NOK2CITY     NOK2 City
-        ; NOK2STAT     NOK2 State
-        ; NOK2ZIP      NOK2 Zip Code
-        ; NOK2HTEL     NOK2 Home Telephone
-        ; NOK2WTEL     NOK2 Work Telephone
-        ; NOK2SAME     Is NOK2's Address the same the patient?
-        ; EMERFAM      Emergency Contact (EMER) Family Name
-        ; EMERGIV      EMER Given Name
-        ; EMERMID      EMER Middle Name
-        ; EMERSUF      EMER Suffi Name
-        ; EMERDISP     EMER Display Name
-        ; EMERREL      EMER Relationship to the patient
-        ; EMERADD1     EMER Address 1
-        ; EMERADD2     EMER Address 2
-        ; EMERCITY     EMER City
-        ; EMERSTAT     EMER State
-        ; EMERZIP      EMER Zip Code
-        ; EMERHTEL     EMER Home Telephone
-        ; EMERWTEL     EMER Work Telephone
-        ; EMERSAME     Is EMER's Address the same the NOK?
-        ;
-        W "No Entry at top!" Q
-        ;
-        ;**Revision History**
-        ; - June 15, 08: v0.1 using merged global
-        ; - Oct 3, 08: v0.2 using fileman calls, many formatting changes.
-        ;
-        ; All methods are Public and Extrinsic
-        ; All calls use Fileman file 2 (Patient).
-        ; You can obtain field numbers using the data dictionary
-        ;
-FAMILY(DFN)     ; Family Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("FAMILY")
-GIVEN(DFN)      ; Given Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("GIVEN")
-MIDDLE(DFN)     ; Middle Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("MIDDLE")
-SUFFIX(DFN)     ; Suffi Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("SUFFIX")
-DISPNAME(DFN)   ; Display Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
-        ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
-        Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
-DOB(DFN)        ; Date of Birth
-        N DOB S DOB=$$GET1^DIQ(2,DFN,.03,"I")
-        ; Date in FM Date Format. Convert to UTC/ISO 8601.
-        Q $$FMDTOUTC^C0CUTIL(DOB,"D")
-GENDER(DFN)     ; Gender/Sex
-        Q $$GET1^DIQ(2,DFN,.02,"I")_"^"_$$GET1^DIQ(2,DFN,.02,"E") ;
-SSN(DFN)        ; SSN
-        Q $$GET1^DIQ(2,DFN,.09)
-ADDRTYPE(DFN)   ; Address Type
-        ; Vista only stores a home address for the patient.
-        Q "Home"
-ADDR1(DFN)      ; Get Home Address line 1
-        Q $$GET1^DIQ(2,DFN,.111)
-ADDR2(DFN)      ; Get Home Address line 2
-        ; Vista has Lines 2,3; CCR has only line 1,2; so compromise
-        N ADDLN2,ADDLN3
-        S ADDLN2=$$GET1^DIQ(2,DFN,.112),ADDLN3=$$GET1^DIQ(2,DFN,.113)
-        Q:ADDLN3="" ADDLN2
-        Q ADDLN2_", "_ADDLN3
-CITY(DFN)       ; Get City for Home Address
-        Q $$GET1^DIQ(2,DFN,.114)
-STATE(DFN)      ; Get State for Home Address
-        Q $$GET1^DIQ(2,DFN,.115)
-ZIP(DFN)        ; Get Zip code for Home Address
-        Q $$GET1^DIQ(2,DFN,.116)
-COUNTY(DFN)     ; Get County for our Address
-        Q $$GET1^DIQ(2,DFN,.117)
-COUNTRY(DFN)    ; Get Country for our Address
-        ; Unfortunately, it's not stored anywhere in Vista, so the inevitable...
-        Q "USA"
-RESTEL(DFN)     ; Residential Telephone
-        Q $$GET1^DIQ(2,DFN,.131)
-WORKTEL(DFN)    ; Work Telephone
-        Q $$GET1^DIQ(2,DFN,.132)
-EMAIL(DFN)      ; Email Adddress
-        Q $$GET1^DIQ(2,DFN,.133)
-CELLTEL(DFN)    ; Cell Phone
-        Q $$GET1^DIQ(2,DFN,.134)
-NOK1FAM(DFN)    ; Next of Kin 1 (NOK1) Family Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("FAMILY")
-NOK1GIV(DFN)    ; NOK1 Given Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("GIVEN")
-NOK1MID(DFN)    ; NOK1 Middle Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("MIDDLE")
-NOK1SUF(DFN)    ; NOK1 Suffi Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("SUFFIX")
-NOK1DISP(DFN)   ; NOK1 Display Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
-        ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
-        Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
-NOK1REL(DFN)    ; NOK1 Relationship to the patient
-        Q $$GET1^DIQ(2,DFN,.212)
-NOK1ADD1(DFN)   ; NOK1 Address 1
-        Q $$GET1^DIQ(2,DFN,.213)
-NOK1ADD2(DFN)   ; NOK1 Address 2 
-        N ADDLN2,ADDLN3
-        S ADDLN2=$$GET1^DIQ(2,DFN,.214),ADDLN3=$$GET1^DIQ(2,DFN,.215)
-        Q:ADDLN3="" ADDLN2
-        Q ADDLN2_", "_ADDLN3
-NOK1CITY(DFN)   ; NOK1 City
-        Q $$GET1^DIQ(2,DFN,.216)
-NOK1STAT(DFN)   ; NOK1 State
-        Q $$GET1^DIQ(2,DFN,.217)
-NOK1ZIP(DFN)    ; NOK1 Zip Code
-        Q $$GET1^DIQ(2,DFN,.218)
-NOK1HTEL(DFN)   ; NOK1 Home Telephone
-        Q $$GET1^DIQ(2,DFN,.219)
-NOK1WTEL(DFN)   ; NOK1 Work Telephone
-        Q $$GET1^DIQ(2,DFN,.21011)
-NOK1SAME(DFN)   ; Is NOK1's Address the same the patient?
-        Q $$GET1^DIQ(2,DFN,.2125)
-NOK2FAM(DFN)    ; NOK2 Family Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("FAMILY")
-NOK2GIV(DFN)    ; NOK2 Given Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("GIVEN")
-NOK2MID(DFN)    ; NOK2 Middle Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("MIDDLE")
-NOK2SUF(DFN)    ; NOK2 Suffi Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("SUFFIX")
-NOK2DISP(DFN)   ; NOK2 Display Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
-        ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
-        Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
-NOK2REL(DFN)    ; NOK2 Relationship to the patient
-        Q $$GET1^DIQ(2,DFN,.2192)
-NOK2ADD1(DFN)   ; NOK2 Address 1
-        Q $$GET1^DIQ(2,DFN,.2193)
-NOK2ADD2(DFN)   ; NOK2 Address 2
-        N ADDLN2,ADDLN3
-        S ADDLN2=$$GET1^DIQ(2,DFN,.2194),ADDLN3=$$GET1^DIQ(2,DFN,.2195)
-        Q:ADDLN3="" ADDLN2
-        Q ADDLN2_", "_ADDLN3
-NOK2CITY(DFN)   ; NOK2 City
-        Q $$GET1^DIQ(2,DFN,.2196)
-NOK2STAT(DFN)   ; NOK2 State
-        Q $$GET1^DIQ(2,DFN,.2197)
-NOK2ZIP(DFN)    ; NOK2 Zip Code
-        Q $$GET1^DIQ(2,DFN,.2198)
-NOK2HTEL(DFN)   ; NOK2 Home Telephone
-        Q $$GET1^DIQ(2,DFN,.2199)
-NOK2WTEL(DFN)   ; NOK2 Work Telephone
-        Q $$GET1^DIQ(2,DFN,.211011)
-NOK2SAME(DFN)   ; Is NOK2's Address the same the patient?
-        Q $$GET1^DIQ(2,DFN,.21925)
-EMERFAM(DFN)    ; Emergency Contact (EMER) Family Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("FAMILY")
-EMERGIV(DFN)    ; EMER Given Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("GIVEN")
-EMERMID(DFN)    ; EMER Middle Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("MIDDLE")
-EMERSUF(DFN)    ; EMER Suffi Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
-        D NAMECOMP^XLFNAME(.NAME)
-        Q NAME("SUFFIX")
-EMERDISP(DFN)   ; EMER Display Name
-        N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
-        ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
-        Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
-EMERREL(DFN)    ; EMER Relationship to the patient
-        Q $$GET1^DIQ(2,DFN,.331)
-EMERADD1(DFN)   ; EMER Address 1
-        Q $$GET1^DIQ(2,DFN,.333)
-EMERADD2(DFN)   ; EMER Address 2
-        N ADDLN2,ADDLN3
-        S ADDLN2=$$GET1^DIQ(2,DFN,.334),ADDLN3=$$GET1^DIQ(2,DFN,.335)
-        Q:ADDLN3="" ADDLN2
-        Q ADDLN2_", "_ADDLN3
-EMERCITY(DFN)   ; EMER City
-        Q $$GET1^DIQ(2,DFN,.336)
-EMERSTAT(DFN)   ; EMER State
-        Q $$GET1^DIQ(2,DFN,.337)
-EMERZIP(DFN)    ; EMER Zip Code
-        Q $$GET1^DIQ(2,DFN,.338)
-EMERHTEL(DFN)   ; EMER Home Telephone
-        Q $$GET1^DIQ(2,DFN,.339)
-EMERWTEL(DFN)   ; EMER Work Telephone
-        Q $$GET1^DIQ(2,DFN,.33011)
-EMERSAME(DFN)   ; Is EMER's Address the same the NOK?
-        Q $$GET1^DIQ(2,DFN,.3305)
+C0CDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;
+ ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ; General Public License. 
+ ; 
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ; 
+ ; You should have received a copy of the GNU General Public License along
+ ; with this program; if not, write to the Free Software Foundation, Inc.,
+ ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ ; FAMILY       Family Name
+ ; GIVEN        Given Name
+ ; MIDDLE       Middle Name
+ ; SUFFIX       Suffix Name
+ ; DISPNAME     Display Name
+ ; DOB          Date of Birth
+ ; GENDER       Get Gender
+ ; SSN          Get SSN for ID
+ ; ADDRTYPE     Get Home Address
+ ; ADDR1        Get Home Address line 1
+ ; ADDR2        Get Home Address line 2
+ ; CITY         Get City for Home Address
+ ; STATE        Get State for Home Address
+ ; ZIP          Get Zip code for Home Address
+ ; COUNTY       Get County for our Address
+ ; COUNTRY      Get Country for our Address
+ ; RESTEL       Residential Telephone
+ ; WORKTEL      Work Telephone
+ ; EMAIL        Email Adddress
+ ; CELLTEL      Cell Phone
+ ; NOK1FAM      Next of Kin 1 (NOK1) Family Name
+ ; NOK1GIV      NOK1 Given Name
+ ; NOK1MID      NOK1 Middle Name
+ ; NOK1SUF      NOK1 Suffi Name
+ ; NOK1DISP     NOK1 Display Name
+ ; NOK1REL      NOK1 Relationship to the patient
+ ; NOK1ADD1     NOK1 Address 1
+ ; NOK1ADD2     NOK1 Address 2
+ ; NOK1CITY     NOK1 City
+ ; NOK1STAT     NOK1 State
+ ; NOK1ZIP      NOK1 Zip Code
+ ; NOK1HTEL     NOK1 Home Telephone
+ ; NOK1WTEL     NOK1 Work Telephone
+ ; NOK1SAME     Is NOK1's Address the same the patient?
+ ; NOK2FAM      NOK2 Family Name
+ ; NOK2GIV      NOK2 Given Name
+ ; NOK2MID      NOK2 Middle Name
+ ; NOK2SUF      NOK2 Suffi Name
+ ; NOK2DISP     NOK2 Display Name
+ ; NOK2REL      NOK2 Relationship to the patient
+ ; NOK2ADD1     NOK2 Address 1
+ ; NOK2ADD2     NOK2 Address 2
+ ; NOK2CITY     NOK2 City
+ ; NOK2STAT     NOK2 State
+ ; NOK2ZIP      NOK2 Zip Code
+ ; NOK2HTEL     NOK2 Home Telephone
+ ; NOK2WTEL     NOK2 Work Telephone
+ ; NOK2SAME     Is NOK2's Address the same the patient?
+ ; EMERFAM      Emergency Contact (EMER) Family Name
+ ; EMERGIV      EMER Given Name
+ ; EMERMID      EMER Middle Name
+ ; EMERSUF      EMER Suffi Name
+ ; EMERDISP     EMER Display Name
+ ; EMERREL      EMER Relationship to the patient
+ ; EMERADD1     EMER Address 1
+ ; EMERADD2     EMER Address 2
+ ; EMERCITY     EMER City
+ ; EMERSTAT     EMER State
+ ; EMERZIP      EMER Zip Code
+ ; EMERHTEL     EMER Home Telephone
+ ; EMERWTEL     EMER Work Telephone
+ ; EMERSAME     Is EMER's Address the same the NOK?
+ ;
+ W "No Entry at top!" Q
+ ;
+ ;**Revision History**
+ ; - June 15, 08: v0.1 using merged global
+ ; - Oct 3, 08: v0.2 using fileman calls, many formatting changes.
+ ;
+ ; All methods are Public and Extrinsic
+ ; All calls use Fileman file 2 (Patient).
+ ; You can obtain field numbers using the data dictionary
+ ;
+FAMILY(DFN) ; Family Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("FAMILY")
+GIVEN(DFN) ; Given Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("GIVEN")
+MIDDLE(DFN) ; Middle Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("MIDDLE")
+SUFFIX(DFN) ; Suffi Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("SUFFIX")
+DISPNAME(DFN) ; Display Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
+ ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
+ Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
+DOB(DFN) ; Date of Birth
+ N DOB S DOB=$$GET1^DIQ(2,DFN,.03,"I")
+ ; Date in FM Date Format. Convert to UTC/ISO 8601.
+ Q $$FMDTOUTC^C0CUTIL(DOB,"D")
+GENDER(DFN) ; Gender/Sex
+ Q $$GET1^DIQ(2,DFN,.02,"I")_"^"_$$GET1^DIQ(2,DFN,.02,"E") ;
+SSN(DFN) ; SSN
+ Q $$GET1^DIQ(2,DFN,.09)
+ADDRTYPE(DFN) ; Address Type
+ ; Vista only stores a home address for the patient.
+ Q "Home"
+ADDR1(DFN) ; Get Home Address line 1
+ Q $$GET1^DIQ(2,DFN,.111)
+ADDR2(DFN) ; Get Home Address line 2
+ ; Vista has Lines 2,3; CCR has only line 1,2; so compromise
+ N ADDLN2,ADDLN3
+ S ADDLN2=$$GET1^DIQ(2,DFN,.112),ADDLN3=$$GET1^DIQ(2,DFN,.113)
+ Q:ADDLN3="" ADDLN2
+ Q ADDLN2_", "_ADDLN3
+CITY(DFN) ; Get City for Home Address
+ Q $$GET1^DIQ(2,DFN,.114)
+STATE(DFN) ; Get State for Home Address
+ Q $$GET1^DIQ(2,DFN,.115)
+ZIP(DFN) ; Get Zip code for Home Address
+ Q $$GET1^DIQ(2,DFN,.116)
+COUNTY(DFN) ; Get County for our Address
+ Q $$GET1^DIQ(2,DFN,.117)
+COUNTRY(DFN) ; Get Country for our Address
+ ; Unfortunately, it's not stored anywhere in Vista, so the inevitable...
+ Q "USA"
+RESTEL(DFN) ; Residential Telephone
+ Q $$GET1^DIQ(2,DFN,.131)
+WORKTEL(DFN) ; Work Telephone
+ Q $$GET1^DIQ(2,DFN,.132)
+EMAIL(DFN) ; Email Adddress
+ Q $$GET1^DIQ(2,DFN,.133)
+CELLTEL(DFN) ; Cell Phone
+ Q $$GET1^DIQ(2,DFN,.134)
+NOK1FAM(DFN) ; Next of Kin 1 (NOK1) Family Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("FAMILY")
+NOK1GIV(DFN) ; NOK1 Given Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("GIVEN")
+NOK1MID(DFN) ; NOK1 Middle Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("MIDDLE")
+NOK1SUF(DFN) ; NOK1 Suffi Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("SUFFIX")
+NOK1DISP(DFN) ; NOK1 Display Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
+ ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
+ Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
+NOK1REL(DFN) ; NOK1 Relationship to the patient
+ Q $$GET1^DIQ(2,DFN,.212)
+NOK1ADD1(DFN) ; NOK1 Address 1
+ Q $$GET1^DIQ(2,DFN,.213)
+NOK1ADD2(DFN) ; NOK1 Address 2 
+ N ADDLN2,ADDLN3
+ S ADDLN2=$$GET1^DIQ(2,DFN,.214),ADDLN3=$$GET1^DIQ(2,DFN,.215)
+ Q:ADDLN3="" ADDLN2
+ Q ADDLN2_", "_ADDLN3
+NOK1CITY(DFN) ; NOK1 City
+ Q $$GET1^DIQ(2,DFN,.216)
+NOK1STAT(DFN) ; NOK1 State
+ Q $$GET1^DIQ(2,DFN,.217)
+NOK1ZIP(DFN) ; NOK1 Zip Code
+ Q $$GET1^DIQ(2,DFN,.218)
+NOK1HTEL(DFN) ; NOK1 Home Telephone
+ Q $$GET1^DIQ(2,DFN,.219)
+NOK1WTEL(DFN) ; NOK1 Work Telephone
+ Q $$GET1^DIQ(2,DFN,.21011)
+NOK1SAME(DFN) ; Is NOK1's Address the same the patient?
+ Q $$GET1^DIQ(2,DFN,.2125)
+NOK2FAM(DFN) ; NOK2 Family Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("FAMILY")
+NOK2GIV(DFN) ; NOK2 Given Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("GIVEN")
+NOK2MID(DFN) ; NOK2 Middle Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("MIDDLE")
+NOK2SUF(DFN) ; NOK2 Suffi Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("SUFFIX")
+NOK2DISP(DFN) ; NOK2 Display Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
+ ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
+ Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
+NOK2REL(DFN) ; NOK2 Relationship to the patient
+ Q $$GET1^DIQ(2,DFN,.2192)
+NOK2ADD1(DFN) ; NOK2 Address 1
+ Q $$GET1^DIQ(2,DFN,.2193)
+NOK2ADD2(DFN) ; NOK2 Address 2
+ N ADDLN2,ADDLN3
+ S ADDLN2=$$GET1^DIQ(2,DFN,.2194),ADDLN3=$$GET1^DIQ(2,DFN,.2195)
+ Q:ADDLN3="" ADDLN2
+ Q ADDLN2_", "_ADDLN3
+NOK2CITY(DFN) ; NOK2 City
+ Q $$GET1^DIQ(2,DFN,.2196)
+NOK2STAT(DFN) ; NOK2 State
+ Q $$GET1^DIQ(2,DFN,.2197)
+NOK2ZIP(DFN) ; NOK2 Zip Code
+ Q $$GET1^DIQ(2,DFN,.2198)
+NOK2HTEL(DFN) ; NOK2 Home Telephone
+ Q $$GET1^DIQ(2,DFN,.2199)
+NOK2WTEL(DFN) ; NOK2 Work Telephone
+ Q $$GET1^DIQ(2,DFN,.211011)
+NOK2SAME(DFN) ; Is NOK2's Address the same the patient?
+ Q $$GET1^DIQ(2,DFN,.21925)
+EMERFAM(DFN) ; Emergency Contact (EMER) Family Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("FAMILY")
+EMERGIV(DFN) ; EMER Given Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("GIVEN")
+EMERMID(DFN) ; EMER Middle Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("MIDDLE")
+EMERSUF(DFN) ; EMER Suffi Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
+ D NAMECOMP^XLFNAME(.NAME)
+ Q NAME("SUFFIX")
+EMERDISP(DFN) ; EMER Display Name
+ N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
+ ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
+ Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
+EMERREL(DFN) ; EMER Relationship to the patient
+ Q $$GET1^DIQ(2,DFN,.331)
+EMERADD1(DFN) ; EMER Address 1
+ Q $$GET1^DIQ(2,DFN,.333)
+EMERADD2(DFN) ; EMER Address 2
+ N ADDLN2,ADDLN3
+ S ADDLN2=$$GET1^DIQ(2,DFN,.334),ADDLN3=$$GET1^DIQ(2,DFN,.335)
+ Q:ADDLN3="" ADDLN2
+ Q ADDLN2_", "_ADDLN3
+EMERCITY(DFN) ; EMER City
+ Q $$GET1^DIQ(2,DFN,.336)
+EMERSTAT(DFN) ; EMER State
+ Q $$GET1^DIQ(2,DFN,.337)
+EMERZIP(DFN) ; EMER Zip Code
+ Q $$GET1^DIQ(2,DFN,.338)
+EMERHTEL(DFN) ; EMER Home Telephone
+ Q $$GET1^DIQ(2,DFN,.339)
+EMERWTEL(DFN) ; EMER Work Telephone
+ Q $$GET1^DIQ(2,DFN,.33011)
+EMERSAME(DFN) ; Is EMER's Address the same the NOK?
+ Q $$GET1^DIQ(2,DFN,.3305)

ccr/trunk/p/C0CENC.m

@@ -1 @@
-C0CENC   ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10
-        ;;1.0;C0C;;May 21, 2010;Build 38
-        ;Copyright 2010 George Lilly, University of Minnesota and others.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "NO ENTRY FROM TOP",!
-        Q
-        ;
-EXTRACT(ENCXML,DFN,ENCOUT)      ; EXTRACT ENCOUNTERS INTO  XML TEMPLATE
-        ; ENCXML AND ENCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
-        ;
-        D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES
-        ;I '$D(@C0CENC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE
-        K @C0CENC
-        D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET ENCOUNTERS
-        D MAP(ENCXML,C0CENC,ENCOUT) ;MAP RESULTS FOR ENCOUNTERS
-        Q
-        ;
-TIUGET(DFN,C0CENC,C0CPRC,C0CNTE)        ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, 
-        ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
-        ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES
-        ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT
-        ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 
-        ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM
-        ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS
-        ;
-        ;K VISIT,LST,NOTE
-        I '$D(C0CPRC) D SETVARS^C0CPROC ; INITIALIZE WORK AREAS IF NOT ALREADY THERE
-        I '$D(VISIT) D ENTRY^C0CCPT(DFN,,,1) ; RETURNS VISIT LOCAL VARIABLE
-        ; NEED TO ADD START AND END DATES FROM PARAMETERS
-        N ZI S ZI=""
-        N PREVCPT,PREVDT S (PREVCPT,PREVDT)=""
-        F  S ZI=$O(VISIT(ZI),-1) Q:ZI=""  D  ; REVERSE TIME ORDER - MOST RECENT FIRST
-        . N ZDATE
-        . S ZDATE=$$DATE(VISIT(ZI,"DATE",0))
-        . S ZPRVARY=$NA(VISIT(ZI,"PRV"))
-        . N ZPRV
-        . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM
-        . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON 
-        . ; ENCOBJECTID - ENCOUNTER OBJECT ID
-        . ; ENCDATETIME - ENCOUNTER DATE TIME
-        . ; ENCTYPETXT - ENCOUNTER TYPE (PLANNING TO USE ADMINISTRATIVE CPT IF AVAIL)
-        . ; ENCTYPECODE - CODE OF TYPE - PLANNING CPT CODE
-        . ; ENCTYPECODESYS - CODING SYSTEM OF TYPE - CPT-4
-        . ; ENCDESCTXT - ENCOUNTER DESCRIPTION TEXT
-        . ; ENCDESCCODE - ENCOUNTER DESCRIPTION CODE
-        . ; ENCDESCCODESYS - ENCOUNTER DESCRIPTION CODE SYSTEM
-        . ; ENCLOCACTORID - ENCOUNTER LOCATION ACTOR ID
-        . ; ENCPRVACTORID - ENCOUNTER PRACTIONER ACTOR ID
-        . ; ENCINDTXT - ENCOUNTER INDICATION TEXT
-        . ; ENCINDCODE - ENCOUNTER INDICATION CODE
-        . ; ENCINDCODESYS - ENCOUNTER INDICATION CODE SYSTEM
-        . ; ENCACTORID - ENCOUNTER SOURCE ACTOR ID
-        . ; ENCCOMMENTID - ENCOUNTER COMMENT ID - POINTER TO NOTE IN COMMENT SECTION
-        . S ZRNF("ENCOBJECTID")="ENCOUNTER_"_ZI
-        . S ZRNF("ENCDATETIME")=ZDATE ; ENCOUNTER DATE TIME
-        . S ZRNF("ENCTYPETXT")=""
-        . S ZRNF("ENCTYPECODE")=""
-        . S ZRNF("ENCTYPECODESYS")=""
-        . S ZRNF("ENCDESCTXT")=""
-        . S ZRNF("ENCDESCCODE")=""
-        . S ZRNF("ENCDESCCODESYS")=""
-        . N TYPTXT,TYPCDE,TYPSYS  ; WILL BE UPDATED BY GETTYPE CALL
-        . I $$GETTYPE("VISIT(ZI)",.TYPTXT,.TYPCDE,.TYPSYS) D  ; RETURNS FALSE IF NO TYPE
-        . . S ZRNF("ENCTYPETXT")=TYPTXT
-        . . S ZRNF("ENCTYPECODE")=TYPCDE
-        . . S ZRNF("ENCTYPECODESYS")=TYPSYS
-        . . S ZRNF("ENCDESCTXT")=TYPTXT ; FOR NOW, DESCRIPTION IS SAME AS TYPE
-        . . S ZRNF("ENCDESCCODE")=TYPCDE ; DESCRIPTION IS REQUIRED (TYPE IS NOT)
-        . . S ZRNF("ENCDESCCODESYS")=TYPSYS ; NEED TO CLARIFY FOR VISTA
-        . S ZRNF("ENCLOCACTORID")="ACTORORGANIZATION_1"
-        . S ZRNF("ENCPRVACTORID")=ZPRV ; PRIMARY PROVIDER LISTED FOR THE ENCOUNTER
-        . S ZRNF("ENCINDTXT")="" ; WE WILL PUT POINTERS TO PROBLEMS HERE
-        . S ZRNF("ENCINDCODE")=""
-        . S ZRNF("ENCINDCODESYS")=""
-        . S ZRNF("ENCACTORID")=ZPRV ; SOURCE WILL BE PRIMARY PROVIDER
-        . S ZRNF("ENCCOMMENTID")=""
-        . I $G(VISIT(ZI,"TEXT",1))'="" D  ; THERE IS A NOTE
-        . . M @C0CNTE@(ZI,"TEXT")=VISIT(ZI,"TEXT") ; COPY THE TEXT OF THE NOTE
-        . . S @C0CNTE@(ZI,"COMMENTOBJECTID")="NOTE_"_ZI
-        . . S @C0CNTE@(ZI,"CMTDATETIME")=ZDATE ; DATE OF THE NOTE
-        . . S @C0CNTE@(ZI,"ACTORSOURCEID")=ZPRV ; SOURCE OF THE NOTE
-        . . S ZRNF("ENCCOMMENTID")="NOTE_"_ZI ; POINT TO THE NOTE FROM THE ENCOUNTER
-        . D RNF1TO2^C0CRNF(C0CENC,"ZRNF") ; ADD THIS ROW TO THE ARRAY
-        . ;S PREVCPT=ZCPT
-        . ;S PREVDT=ZDATE
-        N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"ENCOUNTERS"))
-        M @ZRIM=@C0CENC@("V")
-        K VISIT,LST,NOTE
-        Q
-        ;
-GETTYPE(ZARY,ZTXT,ZCDE,ZSYS)    ; EXTRINSIC WHICH RETURNS FALSE IF NO ENCOUNTER TYPE
-        ; UPDATES ZTXT WITH ENCOUNTER TYPE TEXT, ZCDE WITH ENCOUNTER TYPE CODE
-        ; AND ZSYS WITH ENCOUNTER TYPE CODING SYSTEM
-        ; THIS ROUTINE SHOULD BE UPDATED TO SEARCH FOR AN ADMINISTRATIVE CPT CODE
-        ; INSTEAD OF JUST THE FIRST ONE IN THE LIST - GPL 1/23/10
-        N ZS,ZC
-        S ZC="" S ZS=""
-        S (ZTXT,ZCDE,ZSYS)=""
-        F  S ZC=$O(@ZARY@("CPT",ZC)) Q:ZC=""  D  ; TRY AND FIND A "99" CPT CODE
-        . N ZT
-        . S ZT=$$CPT^C0CPROC(@ZARY@("CPT",ZC)) ; VALUES IN A CPT MULTIPLE
-        . I $E($P(ZT,U,1),1,2)="99" S ZS=ZT ; IS IT AN ADMIN CPT CODE?
-        I ZS'="" D  ; CODED ENCOUNTER TYPE FOUND
-        . S ZTXT=$P(ZS,U,2)_" "_$P(ZS,U,3) ; USE BOTH PIECES FOR THE TYPE
-        . S ZCDE=$P($$CPT^C0CPROC(ZS),U,1) ; CPT CODE FOR ENCOUTER
-        . S ZSYS=""
-        . I ZCDE'="" S ZSYS="CPT-4" ; ONLY HAVE A CODING SYSTEM IF THERE IS A CODE
-        I ZS="" S ZTXT=$$ANYTXT(ZARY) ; TRY AND GET FREE FORM TEXT FROM CPT MULTIPLES
-        I ZTXT="" Q 0 ; FAILED
-        W !,ZTXT
-        Q 1 ; SUCCESS
-        ;
-ANYTXT(ZVST)    ; EXTRINSIC WHICH RETURNS TEXT FROM THE CPT MULTIPLE
-        ; OF A VISIT ARRAY WITHOUT CHECKING THE CPT CODE (THAT HAVING FAILED)
-        ; ZVST IS THE VISIT ARRAY AND IS PASSED BY NAME
-        ; RETURNS TEXT TO USE AS ENCOUNTER TYPE IF ANY
-        N ZK,ZL
-        S ZK="" S ZL=""
-        F  S ZK=$O(@ZVST@("CPT",ZK)) Q:ZK=""  D  ; LOOK FOR SOME TEXT TO USE
-        . N ZT
-        . S ZT=$G(@ZVST@("CPT",ZK)) ; LOOK AT THIS CPT MULTIPLE
-        . I $P(ZT,U,2)_" "_$P(ZT,U,3)'=" " S ZL=$P(ZT,U,2)_" "_$P(ZT,U,3)
-        . ; CONCATENATE PIECE 2 AND 3 OF THE CPT MULTIPLE FOR A TYPE
-        I ZL="" S ZL=$G(@ZVST@("CLASS")) ; USE THE NOTE DOCUMENT CLASS FOR ENCOUTNER TYPE
-        Q ZL
-        ;
-PRV(IARY)       ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME
-        N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN=""
-        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH PRV SEG
-        . I ZR'="" Q  ;ONLY WANT THE FIRST PRIMARY PROVIDER
-        . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1)
-        I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR
-        Q ZRTN
-        ;
-DATE(ISTR)      ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT
-        Q $$FMDTOUTC^C0CUTIL(ISTR,"DT")
-        ;
-CPT(ISTR)       ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS
-        ; CPT^CATEGORY^TEXT
-        N Z1,Z2,Z3,ZRTN
-        S Z1=$P(ISTR,U,1) 
-        I Z1="" D  ;
-        . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1)
-        I Z1'="" D  ; IF THERE IS A CPT CODE IN THERE
-        . ;S Z1=$P(ISTR,U,1)
-        . S Z2=$P(ISTR,U,2)
-        . S Z3=$P(ISTR,U,3)
-        . S ZRTN=Z1_U_Z2_U_Z3
-        E  S ZRTN=""
-        Q ZRTN
-        ;
-MAP(ENCXML,C0CENC,ENCOUT)       ; MAP PROCEDURES XML 
-        ;
-        N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"ENCTEMP")) ;WORK AREA FOR TEMPLATE
-        K @ZTEMP
-        N ZBLD
-        S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"ENCBLD")) ; BUILD LIST AREA
-        D QUEUE^C0CXPATH(ZBLD,ENCXML,1,1) ; FIRST LINE
-        N ZINNER
-        D QUERY^C0CXPATH(ENCXML,"//Encounters/Encounter","ZINNER") ;ONE ENCOUNTER
-        N ZTMP,ZVAR,ZI
-        S ZI=""
-        F  S ZI=$O(@C0CENC@("V",ZI)) Q:ZI=""  D  ;FOR EACH ENCOUNTER
-        . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS ENCOUNTER XML
-        . S ZVAR=$NA(@C0CENC@("V",ZI)) ;THIS ENCOUNTER VARIABLES
-        . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE
-        . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD
-        D QUEUE^C0CXPATH(ZBLD,ENCXML,@ENCXML@(0),@ENCXML@(0))
-        N ZZTMP
-        D BUILD^C0CXPATH(ZBLD,ENCOUT) ;BUILD FINAL XML
-        K @ZTEMP,@ZBLD,@C0CENC
-        Q
-        ;  
+C0CENC  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10
+ ;;1.0;C0C;;May 21, 2010;Build 38
+ ;Copyright 2010 George Lilly, University of Minnesota and others.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "NO ENTRY FROM TOP",!
+ Q
+ ;
+EXTRACT(ENCXML,DFN,ENCOUT) ; EXTRACT ENCOUNTERS INTO  XML TEMPLATE
+ ; ENCXML AND ENCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
+ ;
+ D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES
+ ;I '$D(@C0CENC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE
+ K @C0CENC
+ D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET ENCOUNTERS
+ D MAP(ENCXML,C0CENC,ENCOUT) ;MAP RESULTS FOR ENCOUNTERS
+ Q
+ ;
+TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, 
+ ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
+ ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES
+ ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT
+ ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 
+ ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM
+ ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS
+ ;
+ ;K VISIT,LST,NOTE
+ I '$D(C0CPRC) D SETVARS^C0CPROC ; INITIALIZE WORK AREAS IF NOT ALREADY THERE
+ I '$D(VISIT) D ENTRY^C0CCPT(DFN,,,1) ; RETURNS VISIT LOCAL VARIABLE
+ ; NEED TO ADD START AND END DATES FROM PARAMETERS
+ N ZI S ZI=""
+ N PREVCPT,PREVDT S (PREVCPT,PREVDT)=""
+ F  S ZI=$O(VISIT(ZI),-1) Q:ZI=""  D  ; REVERSE TIME ORDER - MOST RECENT FIRST
+ . N ZDATE
+ . S ZDATE=$$DATE(VISIT(ZI,"DATE",0))
+ . S ZPRVARY=$NA(VISIT(ZI,"PRV"))
+ . N ZPRV
+ . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM
+ . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON 
+ . ; ENCOBJECTID - ENCOUNTER OBJECT ID
+ . ; ENCDATETIME - ENCOUNTER DATE TIME
+ . ; ENCTYPETXT - ENCOUNTER TYPE (PLANNING TO USE ADMINISTRATIVE CPT IF AVAIL)
+ . ; ENCTYPECODE - CODE OF TYPE - PLANNING CPT CODE
+ . ; ENCTYPECODESYS - CODING SYSTEM OF TYPE - CPT-4
+ . ; ENCDESCTXT - ENCOUNTER DESCRIPTION TEXT
+ . ; ENCDESCCODE - ENCOUNTER DESCRIPTION CODE
+ . ; ENCDESCCODESYS - ENCOUNTER DESCRIPTION CODE SYSTEM
+ . ; ENCLOCACTORID - ENCOUNTER LOCATION ACTOR ID
+ . ; ENCPRVACTORID - ENCOUNTER PRACTIONER ACTOR ID
+ . ; ENCINDTXT - ENCOUNTER INDICATION TEXT
+ . ; ENCINDCODE - ENCOUNTER INDICATION CODE
+ . ; ENCINDCODESYS - ENCOUNTER INDICATION CODE SYSTEM
+ . ; ENCACTORID - ENCOUNTER SOURCE ACTOR ID
+ . ; ENCCOMMENTID - ENCOUNTER COMMENT ID - POINTER TO NOTE IN COMMENT SECTION
+ . S ZRNF("ENCOBJECTID")="ENCOUNTER_"_ZI
+ . S ZRNF("ENCDATETIME")=ZDATE ; ENCOUNTER DATE TIME
+ . S ZRNF("ENCTYPETXT")=""
+ . S ZRNF("ENCTYPECODE")=""
+ . S ZRNF("ENCTYPECODESYS")=""
+ . S ZRNF("ENCDESCTXT")=""
+ . S ZRNF("ENCDESCCODE")=""
+ . S ZRNF("ENCDESCCODESYS")=""
+ . N TYPTXT,TYPCDE,TYPSYS  ; WILL BE UPDATED BY GETTYPE CALL
+ . I $$GETTYPE("VISIT(ZI)",.TYPTXT,.TYPCDE,.TYPSYS) D  ; RETURNS FALSE IF NO TYPE
+ . . S ZRNF("ENCTYPETXT")=TYPTXT
+ . . S ZRNF("ENCTYPECODE")=TYPCDE
+ . . S ZRNF("ENCTYPECODESYS")=TYPSYS
+ . . S ZRNF("ENCDESCTXT")=TYPTXT ; FOR NOW, DESCRIPTION IS SAME AS TYPE
+ . . S ZRNF("ENCDESCCODE")=TYPCDE ; DESCRIPTION IS REQUIRED (TYPE IS NOT)
+ . . S ZRNF("ENCDESCCODESYS")=TYPSYS ; NEED TO CLARIFY FOR VISTA
+ . S ZRNF("ENCLOCACTORID")="ACTORORGANIZATION_1"
+ . S ZRNF("ENCPRVACTORID")=ZPRV ; PRIMARY PROVIDER LISTED FOR THE ENCOUNTER
+ . S ZRNF("ENCINDTXT")="" ; WE WILL PUT POINTERS TO PROBLEMS HERE
+ . S ZRNF("ENCINDCODE")=""
+ . S ZRNF("ENCINDCODESYS")=""
+ . S ZRNF("ENCACTORID")=ZPRV ; SOURCE WILL BE PRIMARY PROVIDER
+ . S ZRNF("ENCCOMMENTID")=""
+ . I $G(VISIT(ZI,"TEXT",1))'="" D  ; THERE IS A NOTE
+ . . M @C0CNTE@(ZI,"TEXT")=VISIT(ZI,"TEXT") ; COPY THE TEXT OF THE NOTE
+ . . S @C0CNTE@(ZI,"COMMENTOBJECTID")="NOTE_"_ZI
+ . . S @C0CNTE@(ZI,"CMTDATETIME")=ZDATE ; DATE OF THE NOTE
+ . . S @C0CNTE@(ZI,"ACTORSOURCEID")=ZPRV ; SOURCE OF THE NOTE
+ . . S ZRNF("ENCCOMMENTID")="NOTE_"_ZI ; POINT TO THE NOTE FROM THE ENCOUNTER
+ . D RNF1TO2^C0CRNF(C0CENC,"ZRNF") ; ADD THIS ROW TO THE ARRAY
+ . ;S PREVCPT=ZCPT
+ . ;S PREVDT=ZDATE
+ N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"ENCOUNTERS"))
+ M @ZRIM=@C0CENC@("V")
+ K VISIT,LST,NOTE
+ Q
+ ;
+GETTYPE(ZARY,ZTXT,ZCDE,ZSYS) ; EXTRINSIC WHICH RETURNS FALSE IF NO ENCOUNTER TYPE
+ ; UPDATES ZTXT WITH ENCOUNTER TYPE TEXT, ZCDE WITH ENCOUNTER TYPE CODE
+ ; AND ZSYS WITH ENCOUNTER TYPE CODING SYSTEM
+ ; THIS ROUTINE SHOULD BE UPDATED TO SEARCH FOR AN ADMINISTRATIVE CPT CODE
+ ; INSTEAD OF JUST THE FIRST ONE IN THE LIST - GPL 1/23/10
+ N ZS,ZC
+ S ZC="" S ZS=""
+ S (ZTXT,ZCDE,ZSYS)=""
+ F  S ZC=$O(@ZARY@("CPT",ZC)) Q:ZC=""  D  ; TRY AND FIND A "99" CPT CODE
+ . N ZT
+ . S ZT=$$CPT^C0CPROC(@ZARY@("CPT",ZC)) ; VALUES IN A CPT MULTIPLE
+ . I $E($P(ZT,U,1),1,2)="99" S ZS=ZT ; IS IT AN ADMIN CPT CODE?
+ I ZS'="" D  ; CODED ENCOUNTER TYPE FOUND
+ . S ZTXT=$P(ZS,U,2)_" "_$P(ZS,U,3) ; USE BOTH PIECES FOR THE TYPE
+ . S ZCDE=$P($$CPT^C0CPROC(ZS),U,1) ; CPT CODE FOR ENCOUTER
+ . S ZSYS=""
+ . I ZCDE'="" S ZSYS="CPT-4" ; ONLY HAVE A CODING SYSTEM IF THERE IS A CODE
+ I ZS="" S ZTXT=$$ANYTXT(ZARY) ; TRY AND GET FREE FORM TEXT FROM CPT MULTIPLES
+ I ZTXT="" Q 0 ; FAILED
+ W !,ZTXT
+ Q 1 ; SUCCESS
+ ;
+ANYTXT(ZVST) ; EXTRINSIC WHICH RETURNS TEXT FROM THE CPT MULTIPLE
+ ; OF A VISIT ARRAY WITHOUT CHECKING THE CPT CODE (THAT HAVING FAILED)
+ ; ZVST IS THE VISIT ARRAY AND IS PASSED BY NAME
+ ; RETURNS TEXT TO USE AS ENCOUNTER TYPE IF ANY
+ N ZK,ZL
+ S ZK="" S ZL=""
+ F  S ZK=$O(@ZVST@("CPT",ZK)) Q:ZK=""  D  ; LOOK FOR SOME TEXT TO USE
+ . N ZT
+ . S ZT=$G(@ZVST@("CPT",ZK)) ; LOOK AT THIS CPT MULTIPLE
+ . I $P(ZT,U,2)_" "_$P(ZT,U,3)'=" " S ZL=$P(ZT,U,2)_" "_$P(ZT,U,3)
+ . ; CONCATENATE PIECE 2 AND 3 OF THE CPT MULTIPLE FOR A TYPE
+ I ZL="" S ZL=$G(@ZVST@("CLASS")) ; USE THE NOTE DOCUMENT CLASS FOR ENCOUTNER TYPE
+ Q ZL
+ ;
+PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME
+ N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN=""
+ F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH PRV SEG
+ . I ZR'="" Q  ;ONLY WANT THE FIRST PRIMARY PROVIDER
+ . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1)
+ I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR
+ Q ZRTN
+ ;
+DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT
+ Q $$FMDTOUTC^C0CUTIL(ISTR,"DT")
+ ;
+CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS
+ ; CPT^CATEGORY^TEXT
+ N Z1,Z2,Z3,ZRTN
+ S Z1=$P(ISTR,U,1) 
+ I Z1="" D  ;
+ . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1)
+ I Z1'="" D  ; IF THERE IS A CPT CODE IN THERE
+ . ;S Z1=$P(ISTR,U,1)
+ . S Z2=$P(ISTR,U,2)
+ . S Z3=$P(ISTR,U,3)
+ . S ZRTN=Z1_U_Z2_U_Z3
+ E  S ZRTN=""
+ Q ZRTN
+ ;
+MAP(ENCXML,C0CENC,ENCOUT) ; MAP PROCEDURES XML 
+ ;
+ N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"ENCTEMP")) ;WORK AREA FOR TEMPLATE
+ K @ZTEMP
+ N ZBLD
+ S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"ENCBLD")) ; BUILD LIST AREA
+ D QUEUE^C0CXPATH(ZBLD,ENCXML,1,1) ; FIRST LINE
+ N ZINNER
+ D QUERY^C0CXPATH(ENCXML,"//Encounters/Encounter","ZINNER") ;ONE ENCOUNTER
+ N ZTMP,ZVAR,ZI
+ S ZI=""
+ F  S ZI=$O(@C0CENC@("V",ZI)) Q:ZI=""  D  ;FOR EACH ENCOUNTER
+ . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS ENCOUNTER XML
+ . S ZVAR=$NA(@C0CENC@("V",ZI)) ;THIS ENCOUNTER VARIABLES
+ . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE
+ . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD
+ D QUEUE^C0CXPATH(ZBLD,ENCXML,@ENCXML@(0),@ENCXML@(0))
+ N ZZTMP
+ D BUILD^C0CXPATH(ZBLD,ENCOUT) ;BUILD FINAL XML
+ K @ZTEMP,@ZBLD,@C0CENC
+ Q
+ ;  

ccr/trunk/p/C0CEWD.m

@@ -1 @@
-C0CEWD    ; CCDCCR/GPL - CCR EWD utilities; 1/6/11
-        ;;0.1;CCDCCR;nopatch;noreleasedate;Build 77
-        ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        Q
-        ;
-TOKEN() ; EXTRINSIC WHICH RETURNS A NEW RANDOM TOKEN
-        Q $$UUID^C0CUTIL ; USE THE UUID FUNCTION IN THE CCR PACKAGE
-        ;
-STORE(ZARY)     ; STORE AN ARRAY OF VALUES INDEXED BY A NEW TOKEN
-        ; IN ^TMP("C0E","TOKEN") FOR LATER RETRIEVAL FROM INSIDE AN EWD SESSION
-        ; RETURNS THE TOKEN. ZARY IS PASSED BY NAME
-        N ZT
-        S ZT=$$TOKEN ; GET A NEW TOKEN
-        M ^TMP("C0E","TOKEN",ZT)=@ZARY ;
-        Q ZT
-        ;
-GET(C0ERTN,C0ETOKEN,NOKILL)     ; RETRIEVE A STORED ARRAY INDEXED BY ZTOKEN
-        ; KILL THE ARRAY AFTER RETRIEVAL UNLESS NOKILL=1
-        ; C0ERTN IS PASSED BY NAME
-        I '$D(^TMP("C0E","TOKEN",C0ETOKEN)) D  Q  ; DOESN'T EXIST
-        . S @C0ERTN="" ; PASS BACK NULL
-        M @C0ERTN=^TMP("C0E","TOKEN",C0ETOKEN) ; RETRIEVE
-        I $G(NOKILL)'=1 K ^TMP("C0E","TOKEN",C0ETOKEN) ; DELETE
-        Q
-        ;
-URLTOKEN(sessid)        ; EXTRINSIC WHICH RETRIEVES THE TOKEN PASSED ON THE URL
-        ; IN EWD EXAMPLE: https://example.com/ewd/myApp/index.ewd?token="12345"
-        N token
-        S token=""
-        s token=$$getRequestValue^%zewdAPI("token",sessid)
-        s token=$tr(token,"""") ; strip out quotes
-        Q token
-        ;
-cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options)   
-        ;
-        n maxNo,noFound
-        ;
-        s maxNo=50
-        s noFound=0
-        f  s seedValue=$o(^DPT("B",seedValue)) q:seedValue=""  q:noFound=maxNo  d
-        . s lastSeedValue=seedValue
-        . i prefix'="",$e(seedValue,1,$l(prefix))'=prefix q
-        . s optionNo=optionNo+1
-        . s noFound=noFound+1
-        . s options(optionNo)=seedValue
-        QUIT
-        ;
-set1    ;
-        s ^zewd("comboPlus","methodMap","test")="cbTestMethod^C0PEREW"
-        q
-        ;
-test1(sessid)   ;
-        d setSessionValue^%zewdAPI("testing","ZZ",sessid)
-        q 0
-        ;
+C0CEWD   ; CCDCCR/GPL - CCR EWD utilities; 1/6/11
+ ;;0.1;CCDCCR;nopatch;noreleasedate;Build 77
+ ;Copyright 2011 George Lilly.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ Q
+ ;
+TOKEN() ; EXTRINSIC WHICH RETURNS A NEW RANDOM TOKEN
+ Q $$UUID^C0CUTIL ; USE THE UUID FUNCTION IN THE CCR PACKAGE
+ ;
+STORE(ZARY) ; STORE AN ARRAY OF VALUES INDEXED BY A NEW TOKEN
+ ; IN ^TMP("C0E","TOKEN") FOR LATER RETRIEVAL FROM INSIDE AN EWD SESSION
+ ; RETURNS THE TOKEN. ZARY IS PASSED BY NAME
+ N ZT
+ S ZT=$$TOKEN ; GET A NEW TOKEN
+ M ^TMP("C0E","TOKEN",ZT)=@ZARY ;
+ Q ZT
+ ;
+GET(C0ERTN,C0ETOKEN,NOKILL) ; RETRIEVE A STORED ARRAY INDEXED BY ZTOKEN
+ ; KILL THE ARRAY AFTER RETRIEVAL UNLESS NOKILL=1
+ ; C0ERTN IS PASSED BY NAME
+ I '$D(^TMP("C0E","TOKEN",C0ETOKEN)) D  Q  ; DOESN'T EXIST
+ . S @C0ERTN="" ; PASS BACK NULL
+ M @C0ERTN=^TMP("C0E","TOKEN",C0ETOKEN) ; RETRIEVE
+ I $G(NOKILL)'=1 K ^TMP("C0E","TOKEN",C0ETOKEN) ; DELETE
+ Q
+ ;
+URLTOKEN(sessid) ; EXTRINSIC WHICH RETRIEVES THE TOKEN PASSED ON THE URL
+ ; IN EWD EXAMPLE: https://example.com/ewd/myApp/index.ewd?token="12345"
+ N token
+ S token=""
+ s token=$$getRequestValue^%zewdAPI("token",sessid)
+ s token=$tr(token,"""") ; strip out quotes
+ Q token
+ ;
+cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options) 
+ ;
+ n maxNo,noFound
+ ;
+ s maxNo=50
+ s noFound=0
+ f  s seedValue=$o(^DPT("B",seedValue)) q:seedValue=""  q:noFound=maxNo  d
+ . s lastSeedValue=seedValue
+ . i prefix'="",$e(seedValue,1,$l(prefix))'=prefix q
+ . s optionNo=optionNo+1
+ . s noFound=noFound+1
+ . s options(optionNo)=seedValue
+ QUIT
+ ;
+set1 ;
+ s ^zewd("comboPlus","methodMap","test")="cbTestMethod^C0PEREW"
+ q
+ ;
+test1(sessid) ;
+ d setSessionValue^%zewdAPI("testing","ZZ",sessid)
+ q 0
+ ;

ccr/trunk/p/C0CFM1.m

@@ -1 @@
-C0CFM1    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "This is the CCR FILEMAN Utility Library ",!
-        W !
-        Q
-        ;
-PUTRIM(DFN,ZWHICH)      ;DFN IS PATIENT , WHICH IS ELEMENT TYPE
-        ;
-        S C0CGLB=$NA(^TMP("GPLRIM","VARS",DFN))
-        I '$D(ZWHICH) S ZWHICH="ALL"
-        I ZWHICH'="ALL" D  ; SINGLE SECTION REQUESTED
-        . S C0CVARS=$NA(@C0CGLB@(ZWHICH))
-        . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION
-        E  D  ; MULTIPLE SECTIONS
-        . S C0CVARS=$NA(@C0CGLB)
-        . S C0CI=""
-        . F  S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI=""  D  ;FOR EACH SECTION
-        . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION
-        . . D PUTRIM1(DFN,C0CI,C0CVARSN)
-        Q
-        ;
-PUTRIM1(DFN,ZZTYP,ZVARS)        ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS
-        ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1"
-        S C0CX=0
-        F  S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX=""  D  ; FOR EACH OCCURANCE
-        . W "ZOCC=",C0CX,!
-        . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE
-        . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE
-        Q
-        ;
-PUTELS(DFN,ZTYPE,ZOCC,ZVALS)    ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
-        ; ^C0C(171.201,   DFN IS THE PATIENT IEN PASSED BY VALUE
-        ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
-        ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
-        ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
-        ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
-        ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
-        ;
-        S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
-        ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
-        N ZF,ZFV S ZF=171.201 S ZFV=171.2012
-        S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS
-        N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER
-        N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
-        W "ZTYPE: ",ZTYPE," ",ZTYPN,!
-        N ZVARN ; IEN OF VARIABLE BEING PROCESSED
-        ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
-        S C0CFDA(ZF,"?+1,",.01)=DFN
-        S C0CFDA(ZF,"?+1,",.02)=ZSRC
-        S C0CFDA(ZF,"?+1,",.03)=ZTYPN
-        S C0CFDA(ZF,"?+1,",.04)=ZOCC ;CREATE OCCURANCE
-        K ZERR
-        D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER
-        I $D(ZERR) B  ;OOPS
-        K C0CFDA
-        S ZD0=$O(^C0C(ZF,"C",DFN,ZSRC,ZTYPN,ZOCC,""))
-        W "RECORD NUMBER: ",ZD0,!
-        ;B
-        S ZCNT=0
-        S ZC0CI="" ;
-        F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
-        . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
-        . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
-        . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
-        . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
-        . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN
-        . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI)
-        . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN
-        . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI)
-        ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT"
-        ;S GT1(170,"?+1,",12)="DIR"
-        ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT"
-        ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT"
-        D CLEAN^DILF
-        D UPDATE^DIE("","C0CFDA","","ZERR")
-        Q
-        ;
-VARPTR(ZVAR,ZTYP)       ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
-        ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
-        ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
-        ;
-        N ZCCRD,ZVARN,C0CFDA2
-        S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
-        S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
-        I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
-        . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
-        . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
-        . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
-        . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
-        . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
-        . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
-        . I $D(ZERR) D  ; LAYGO ERROR
-        . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
-        . E  D  ;
-        . . D CLEAN^DILF ; CLEAN UP
-        . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
-        . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
-        Q ZVARN
-        ;
-BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,)
-        ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED
-        ;
-        N C0CDIC,C0CNODE ;
-        S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY
-        S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE
-        Q
-        ;
-FIXSEC  ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED
-        ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET
-        ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS
-        ; CONVERSION
-        ;N C0CC,C0CI,C0CJ,C0CN,C0CZX
-        D FIELDS^C0CRNF("C0CC",170)
-        S C0CI=""
-        F  S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI=""  D  ; EACH SECTION
-        . S C0CZX=""
-        . F  S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX=""  D  ; EACH VARIABLE
-        . . W "SECTION ",C0CI," VAR ",C0CZX
-        . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,""))
-        . . W " TYPE: ",C0CV,!
-        . . D SETFDA("SECTION",C0CV)
-        . . ;ZWR C0CFDA
-        Q
-        ;
-SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
-        ; TO SET TO VALUE C0CSV.
-        ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
-        ; C0CSN,C0CSV ARE PASSED BY VALUE
-        ;
-        N C0CSI,C0CSJ
-        S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
-        S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
-        S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
-        Q
-ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
-        E  S ZR=""
-        Q ZR
-ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
-        E  S ZR=""
-        Q ZR
-        ;
-ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
-        E  S ZR=""
-        Q ZR
-        ;
+C0CFM1   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "This is the CCR FILEMAN Utility Library ",!
+ W !
+ Q
+ ;
+PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE
+ ;
+ S C0CGLB=$NA(^TMP("GPLRIM","VARS",DFN))
+ I '$D(ZWHICH) S ZWHICH="ALL"
+ I ZWHICH'="ALL" D  ; SINGLE SECTION REQUESTED
+ . S C0CVARS=$NA(@C0CGLB@(ZWHICH))
+ . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION
+ E  D  ; MULTIPLE SECTIONS
+ . S C0CVARS=$NA(@C0CGLB)
+ . S C0CI=""
+ . F  S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI=""  D  ;FOR EACH SECTION
+ . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION
+ . . D PUTRIM1(DFN,C0CI,C0CVARSN)
+ Q
+ ;
+PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS
+ ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1"
+ S C0CX=0
+ F  S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX=""  D  ; FOR EACH OCCURANCE
+ . W "ZOCC=",C0CX,!
+ . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE
+ . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE
+ Q
+ ;
+PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
+ ; ^C0C(171.201,   DFN IS THE PATIENT IEN PASSED BY VALUE
+ ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
+ ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
+ ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
+ ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
+ ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
+ ;
+ S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
+ ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
+ N ZF,ZFV S ZF=171.201 S ZFV=171.2012
+ S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS
+ N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER
+ N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
+ W "ZTYPE: ",ZTYPE," ",ZTYPN,!
+ N ZVARN ; IEN OF VARIABLE BEING PROCESSED
+ ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
+ S C0CFDA(ZF,"?+1,",.01)=DFN
+ S C0CFDA(ZF,"?+1,",.02)=ZSRC
+ S C0CFDA(ZF,"?+1,",.03)=ZTYPN
+ S C0CFDA(ZF,"?+1,",.04)=ZOCC ;CREATE OCCURANCE
+ K ZERR
+ D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER
+ I $D(ZERR) B  ;OOPS
+ K C0CFDA
+ S ZD0=$O(^C0C(ZF,"C",DFN,ZSRC,ZTYPN,ZOCC,""))
+ W "RECORD NUMBER: ",ZD0,!
+ ;B
+ S ZCNT=0
+ S ZC0CI="" ;
+ F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
+ . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
+ . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
+ . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
+ . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
+ . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN
+ . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI)
+ . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN
+ . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI)
+ ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT"
+ ;S GT1(170,"?+1,",12)="DIR"
+ ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT"
+ ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT"
+ D CLEAN^DILF
+ D UPDATE^DIE("","C0CFDA","","ZERR")
+ Q
+ ;
+VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
+ ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
+ ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
+ ;
+ N ZCCRD,ZVARN,C0CFDA2
+ S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
+ S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
+ I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
+ . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
+ . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
+ . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
+ . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
+ . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
+ . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
+ . I $D(ZERR) D  ; LAYGO ERROR
+ . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
+ . E  D  ;
+ . . D CLEAN^DILF ; CLEAN UP
+ . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
+ . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
+ Q ZVARN
+ ;
+BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,)
+ ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED
+ ;
+ N C0CDIC,C0CNODE ;
+ S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY
+ S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE
+ Q
+ ;
+FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED
+ ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET
+ ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS
+ ; CONVERSION
+ ;N C0CC,C0CI,C0CJ,C0CN,C0CZX
+ D FIELDS^C0CRNF("C0CC",170)
+ S C0CI=""
+ F  S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI=""  D  ; EACH SECTION
+ . S C0CZX=""
+ . F  S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX=""  D  ; EACH VARIABLE
+ . . W "SECTION ",C0CI," VAR ",C0CZX
+ . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,""))
+ . . W " TYPE: ",C0CV,!
+ . . D SETFDA("SECTION",C0CV)
+ . . ;ZWR C0CFDA
+ Q
+ ;
+SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
+ ; TO SET TO VALUE C0CSV.
+ ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
+ ; C0CSN,C0CSV ARE PASSED BY VALUE
+ ;
+ N C0CSI,C0CSJ
+ S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
+ S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
+ S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
+ Q
+ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
+ E  S ZR=""
+ Q ZR
+ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
+ E  S ZR=""
+ Q ZR
+ ;
+ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
+ E  S ZR=""
+ Q ZR
+ ;

ccr/trunk/p/C0CFM2.m

@@ -1 @@
-C0CFM2    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "This is the CCR FILEMAN Utility Library ",!
-        ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF
-        ; CCR ELEMENTS (^C0C(179.201,
-        ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE
-        ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT
-        ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS
-        ; ALL SUB-VARIABLES HAVE BEEN REMOVED
-        W !
-        Q
-        ;
-RIMTBL(ZWHICH)  ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE
-        ;
-        I '$D(RIMBASE) D ASETUP^C0CRIMA ; FOR COMMAND LINE CALLS
-        N ZI,ZJ,ZC,ZPATBASE
-        S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH))
-        S ZI=""
-        F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
-        . S ZI=$O(@ZPATBASE@(ZI))
-        . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE
-        Q
-        ;
-PUTRIM(DFN,ZWHICH)      ;DFN IS PATIENT , WHICH IS ELEMENT TYPE
-        ;
-        S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN))
-        I '$D(ZWHICH) S ZWHICH="ALL"
-        I ZWHICH'="ALL" D  ; SINGLE SECTION REQUESTED
-        . S C0CVARS=$NA(@C0CGLB@(ZWHICH))
-        . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION
-        E  D  ; MULTIPLE SECTIONS
-        . S C0CVARS=$NA(@C0CGLB)
-        . S C0CI=""
-        . F  S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI=""  D  ;FOR EACH SECTION
-        . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION
-        . . D PUTRIM1(DFN,C0CI,C0CVARSN)
-        Q
-        ;
-PUTRIM1(DFN,ZZTYP,ZVARS)        ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS
-        ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1"
-        S C0CX=0
-        F  S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX=""  D  ; FOR EACH OCCURANCE
-        . W "ZOCC=",C0CX,!
-        . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME
-        . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE
-        . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE
-        . I $D(C0CMDO) D  ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :()
-        . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
-        . . S ZZCNT=0
-        . . S ZZC0CI=0
-        . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE
-        . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
-        . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
-        . . W "MULTIPLE:",ZZVALS,!
-        . . ;B
-        . . F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
-        . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
-        . . . W "COUNT:",ZZCNT,!
-        . . . S ZV=$NA(@ZZVALS@(ZZC0CI))
-        . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV)
-        Q
-        ;
-PUTELS(DFN,ZTYPE,ZOCC,ZVALS)    ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
-        ; 171.101, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
-        ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
-        ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
-        ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
-        ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
-        ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
-        ;
-        N PATN,ZTYPN,XD0,ZTYP
-        I '$D(ZSRC) S ZSRC=1 ; CCR SOURCE IS ASSUMED, 1 IF NOT SET
-        ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
-        N C0CFPAT S C0CFPAT=171.101 ; FILE AT PATIENT LEVEL
-        N C0CFSRC S C0CFSRC=171.111 ; FILE AT CCR SOURCE LVL
-        N C0CFTYP S C0CFTYP=171.121 ; FILE AT ELEMENT TYPE LVL
-        N C0CFOCC S C0CFOCC=171.131 ; FILE AT OCCURANCE LVL
-        N C0CFVAR S C0CFVAR=171.1311 ; FILE AT VARIABLE LVL
-        ;FILE IS ^C0CE(PAT,1,SCR,1,TYP,1,OCC,1,VAR,1, ...
-        ; AND WE HAVE TO ADD THEM LEVEL AT A TIME I THINK
-        N C0CFDA
-        S C0CFDA(C0CFPAT,"?+1,",.01)=DFN
-        D UPDIE ; ADD THE PATIENT
-        S PATN=$O(^C0CE("B",DFN,"")) ; IEN FOR THE PATIENT
-        S C0CFDA(C0CFSRC,"?+1,"_PATN_",",.01)=ZSRC
-        D UPDIE ; ADD THE CCR SOURCE
-        N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) ; FIND THE ELE TYPE
-        S C0CFDA(C0CFTYP,"?+1,"_ZSRC_","_PATN_",",.01)=ZTYPN
-        D UPDIE ; ADD THE ELEMENT TYPE
-        S ZTYP=$O(^C0CE(PATN,1,ZSRC,1,"B",ZTYPN,"")) ; IEN OF ELEMENT TYPE
-        S C0CFDA(C0CFOCC,"?+1,"_ZTYP_","_ZSRC_","_PATN_",",.01)=ZOCC ; STRING OCC
-        ; OCC IS PRECEDED BY " " TO FORCE STRING STORAGE AND PRESERVE
-        ; STRING COLLATION ON THE INDEX
-        D UPDIE ; ADD THE OCCURANCE
-        S ZD0=$O(^C0CE(PATN,1,ZSRC,1,ZTYP,1,"B",ZOCC,""))
-        W "RECORD NUMBER: ",ZD0,!
-        ;I ZD0=32 B
-        ;I ZD0=31 B
-        N ZCNT,ZC0CI,ZVARN,C0CZ1
-        S ZCNT=0
-        S ZC0CI="" ;
-        F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
-        . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
-        . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
-        . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
-        . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
-        . . S C0CZ1=ZTYP_","_ZSRC_","_PATN_","
-        . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,.01)=ZVARN
-        . . S ZZVAL=$TR(@ZVALS@(ZC0CI),"^","|")
-        . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,1)=ZZVAL
-        . E  D  ; THIS IS A SUBELEMENT
-        . . ;PUT THE FOLLOWING BACK TO USE RECURSION
-        . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
-        . . ;S ZZCNT=0
-        . . ;S ZZC0CI=0
-        . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE
-        . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
-        . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
-        . . ;W "MULTIPLE:",ZZVALS,!
-        . . ;B
-        . . ;F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
-        . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
-        . . ;. W "COUNT:",ZZCNT,!
-        . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI))
-        . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION
-        . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION)
-        D UPDIE ; UPDATE
-        Q
-        ;
-UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
-        K ZERR
-        D CLEAN^DILF
-        D UPDATE^DIE("","C0CFDA","","ZERR")
-        I $D(ZERR) D  ;
-        . W "ERROR",!
-        . ZWR ZERR
-        . B
-        K C0CFDA
-        Q
-        ;
-CHECK   ; CHECKSUM EXPERIMENTS
-        ;
-        ;B
-        S ZG=$NA(^C0CE(DA(2),1,DA(1),1,DA))
-        ;S G2=$NA(^C0CE(8,1,1,1,2,1,6))
-        S X=$$CHKSUM^XUSESIG1(ZG)
-        W G1,!
-        Q
-        ;
-CHKELS(DFN)     ; CHECKSUM ALL ELEMENTS FOR  A PATIENT
-        ;
-        S ZGLB=$NA(^TMP("C0CCHK"))
-        S ZPAT=$O(^C0CE("B",DFN,""))
-        K @ZGLB@(ZPAT) ; CLEAR PREVIOUS CHECKSUMS
-        S ZSRC=""
-        F  S ZSRC=$O(^C0CE(ZPAT,1,"B",ZSRC)) Q:ZSRC=""  D  ;
-        . W "PAT:",ZPAT," SRC:",ZSRC,!
-        . S ZEL=""
-        . F  S ZEL=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL)) Q:ZEL=""  D  ;ELEMENTS
-        . . W "ELEMENT:",ZEL," "
-        . . S ZELE=$$GET1^DIQ(170.101,ZEL,.01,"E") ;ELEMENT NAME
-        . . W ZELE," "
-        . . S ZELI=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL,""))
-        . . S ZG=$NA(^C0CE(ZPAT,1,ZSRC,1,ZELI))
-        . . S ZCHK=$$CHKSUM^XUSESIG1(ZG) ; CHECKSUM FOR THE ELEMENT
-        . . W ZCHK,!
-        . . S @ZGLB@(ZPAT,ZELE,ZSRC)=ZCHK
-        ZWR ^TMP("C0CCHK",ZPAT,*)
-        Q
-        ;
-DOIT(DFN)       ; EXPERIMENT FOR TIMING CALLS USING mumps -dir DOIT^C0CFM2(DFN)
-        D SETXUP
-        D CHKELS(DFN)
-        Q
-        ;
-SETXUP  ; SET UP ENVIRONMENT
-        S DISYS=19
-        S DT=3090325
-        S DTIME=300
-        S DUZ=1
-        S DUZ(0)="@"
-        S DUZ(1)=""
-        S DUZ(2)=7247
-        S DUZ("AG")="I"
-        S DUZ("BUF")=1
-        S DUZ("LANG")=""
-        S IO="/dev/pts/20"
-        S IO(0)="/dev/pts/20"
-        S IO(1,"/dev/pts/20")=""
-        S IO("ERROR")=""
-        S IO("HOME")="344^/dev/pts/20"
-        S IO("ZIO")="/dev/pts/20"
-        S IOBS="$C(8)"
-        S IOF="#,$C(27,91,50,74,27,91,72)"
-        S IOM=80
-        S ION="TELNET"
-        S IOS=344
-        S IOSL=24
-        S IOST="C-VT100"
-        S IOST(0)=9
-        S IOT="VTRM"
-        S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)"
-        S U="^"
-        S X="216;DIC(4.2,"
-        S XPARSYS="216;DIC(4.2,"
-        S XQXFLG="^^XUP"
-        Q
-        ; 
-PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
-        ; 171.101, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
-        ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
-        ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
-        ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
-        ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
-        ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
-        ;
-        S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
-        ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
-        N ZF,ZFV S ZF=171.101 S ZFV=171.1011
-        ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS
-        ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER
-        N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
-        W "ZTYPE: ",ZTYPE," ",ZTYPN,!
-        N ZVARN ; IEN OF VARIABLE BEING PROCESSED
-        ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
-        K C0CFDA
-        S C0CFDA(ZF,"?+1,",.01)=DFN
-        S C0CFDA(ZF,"?+1,",.02)=ZSRC
-        S C0CFDA(ZF,"?+1,",.03)=ZTYPN
-        S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE
-        K ZERR
-        ;B
-        D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER
-        I $D(ZERR) B  ;OOPS
-        K C0CFDA
-        S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,""))
-        W "RECORD NUMBER: ",ZD0,!
-        ;B
-        S ZCNT=0
-        S ZC0CI="" ;
-        F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
-        . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
-        . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
-        . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
-        . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
-        . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN
-        . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI)
-        . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN
-        . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI)
-        ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT"
-        ;S GT1(170,"?+1,",12)="DIR"
-        ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT"
-        ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT"
-        D CLEAN^DILF
-        D UPDATE^DIE("","C0CFDA","","ZERR")
-        I $D(ZERR) D  ;
-        . W "ERROR",!
-        . ZWR ZERR
-        . B
-        K C0CFDA
-        Q
-        ;
-VARPTR(ZVAR,ZTYP)       ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
-        ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
-        ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
-        ;
-        N ZCCRD,ZVARN,C0CFDA2
-        S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
-        S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
-        I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
-        . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
-        . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
-        . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
-        . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
-        . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
-        . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
-        . I $D(ZERR) D  ; LAYGO ERROR
-        . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
-        . E  D  ;
-        . . D CLEAN^DILF ; CLEAN UP
-        . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
-        . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
-        Q ZVARN
-        ;
-BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,)
-        ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED
-        ;
-        N C0CDIC,C0CNODE ;
-        S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY
-        S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE
-        Q
-        ;
-FIXSEC  ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED
-        ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET
-        ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS
-        ; CONVERSION
-        ;N C0CC,C0CI,C0CJ,C0CN,C0CZX
-        D FIELDS^C0CRNF("C0CC",170)
-        S C0CI=""
-        F  S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI=""  D  ; EACH SECTION
-        . S C0CZX=""
-        . F  S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX=""  D  ; EACH VARIABLE
-        . . W "SECTION ",C0CI," VAR ",C0CZX
-        . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,""))
-        . . W " TYPE: ",C0CV,!
-        . . D SETFDA("SECTION",C0CV)
-        . . ;ZWR C0CFDA
-        Q
-        ;
-SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
-        ; TO SET TO VALUE C0CSV.
-        ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
-        ; C0CSN,C0CSV ARE PASSED BY VALUE
-        ;
-        N C0CSI,C0CSJ
-        S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
-        S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
-        S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
-        Q
-ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
-        E  S ZR=""
-        Q ZR
-ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
-        E  S ZR=""
-        Q ZR
-        ;
-ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
-        E  S ZR=""
-        Q ZR
-        ;
+C0CFM2   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "This is the CCR FILEMAN Utility Library ",!
+ ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF
+ ; CCR ELEMENTS (^C0C(179.201,
+ ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE
+ ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT
+ ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS
+ ; ALL SUB-VARIABLES HAVE BEEN REMOVED
+ W !
+ Q
+ ;
+RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE
+ ;
+ I '$D(RIMBASE) D ASETUP^C0CRIMA ; FOR COMMAND LINE CALLS
+ N ZI,ZJ,ZC,ZPATBASE
+ S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH))
+ S ZI=""
+ F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
+ . S ZI=$O(@ZPATBASE@(ZI))
+ . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE
+ Q
+ ;
+PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE
+ ;
+ S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN))
+ I '$D(ZWHICH) S ZWHICH="ALL"
+ I ZWHICH'="ALL" D  ; SINGLE SECTION REQUESTED
+ . S C0CVARS=$NA(@C0CGLB@(ZWHICH))
+ . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION
+ E  D  ; MULTIPLE SECTIONS
+ . S C0CVARS=$NA(@C0CGLB)
+ . S C0CI=""
+ . F  S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI=""  D  ;FOR EACH SECTION
+ . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION
+ . . D PUTRIM1(DFN,C0CI,C0CVARSN)
+ Q
+ ;
+PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS
+ ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1"
+ S C0CX=0
+ F  S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX=""  D  ; FOR EACH OCCURANCE
+ . W "ZOCC=",C0CX,!
+ . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME
+ . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE
+ . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE
+ . I $D(C0CMDO) D  ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :()
+ . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
+ . . S ZZCNT=0
+ . . S ZZC0CI=0
+ . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE
+ . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
+ . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
+ . . W "MULTIPLE:",ZZVALS,!
+ . . ;B
+ . . F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
+ . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
+ . . . W "COUNT:",ZZCNT,!
+ . . . S ZV=$NA(@ZZVALS@(ZZC0CI))
+ . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV)
+ Q
+ ;
+PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
+ ; 171.101, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
+ ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
+ ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
+ ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
+ ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
+ ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
+ ;
+ N PATN,ZTYPN,XD0,ZTYP
+ I '$D(ZSRC) S ZSRC=1 ; CCR SOURCE IS ASSUMED, 1 IF NOT SET
+ ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
+ N C0CFPAT S C0CFPAT=171.101 ; FILE AT PATIENT LEVEL
+ N C0CFSRC S C0CFSRC=171.111 ; FILE AT CCR SOURCE LVL
+ N C0CFTYP S C0CFTYP=171.121 ; FILE AT ELEMENT TYPE LVL
+ N C0CFOCC S C0CFOCC=171.131 ; FILE AT OCCURANCE LVL
+ N C0CFVAR S C0CFVAR=171.1311 ; FILE AT VARIABLE LVL
+ ;FILE IS ^C0CE(PAT,1,SCR,1,TYP,1,OCC,1,VAR,1, ...
+ ; AND WE HAVE TO ADD THEM LEVEL AT A TIME I THINK
+ N C0CFDA
+ S C0CFDA(C0CFPAT,"?+1,",.01)=DFN
+ D UPDIE ; ADD THE PATIENT
+ S PATN=$O(^C0CE("B",DFN,"")) ; IEN FOR THE PATIENT
+ S C0CFDA(C0CFSRC,"?+1,"_PATN_",",.01)=ZSRC
+ D UPDIE ; ADD THE CCR SOURCE
+ N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) ; FIND THE ELE TYPE
+ S C0CFDA(C0CFTYP,"?+1,"_ZSRC_","_PATN_",",.01)=ZTYPN
+ D UPDIE ; ADD THE ELEMENT TYPE
+ S ZTYP=$O(^C0CE(PATN,1,ZSRC,1,"B",ZTYPN,"")) ; IEN OF ELEMENT TYPE
+ S C0CFDA(C0CFOCC,"?+1,"_ZTYP_","_ZSRC_","_PATN_",",.01)=ZOCC ; STRING OCC
+ ; OCC IS PRECEDED BY " " TO FORCE STRING STORAGE AND PRESERVE
+ ; STRING COLLATION ON THE INDEX
+ D UPDIE ; ADD THE OCCURANCE
+ S ZD0=$O(^C0CE(PATN,1,ZSRC,1,ZTYP,1,"B",ZOCC,""))
+ W "RECORD NUMBER: ",ZD0,!
+ ;I ZD0=32 B
+ ;I ZD0=31 B
+ N ZCNT,ZC0CI,ZVARN,C0CZ1
+ S ZCNT=0
+ S ZC0CI="" ;
+ F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
+ . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
+ . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
+ . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
+ . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
+ . . S C0CZ1=ZTYP_","_ZSRC_","_PATN_","
+ . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,.01)=ZVARN
+ . . S ZZVAL=$TR(@ZVALS@(ZC0CI),"^","|")
+ . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,1)=ZZVAL
+ . E  D  ; THIS IS A SUBELEMENT
+ . . ;PUT THE FOLLOWING BACK TO USE RECURSION
+ . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV
+ . . ;S ZZCNT=0
+ . . ;S ZZC0CI=0
+ . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE
+ . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE
+ . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR
+ . . ;W "MULTIPLE:",ZZVALS,!
+ . . ;B
+ . . ;F  S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI=""  D  ; EACH MULTIPLE
+ . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT
+ . . ;. W "COUNT:",ZZCNT,!
+ . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI))
+ . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION
+ . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION)
+ D UPDIE ; UPDATE
+ Q
+ ;
+UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
+ K ZERR
+ D CLEAN^DILF
+ D UPDATE^DIE("","C0CFDA","","ZERR")
+ I $D(ZERR) D  ;
+ . W "ERROR",!
+ . ZWR ZERR
+ . B
+ K C0CFDA
+ Q
+ ;
+CHECK ; CHECKSUM EXPERIMENTS
+ ;
+ ;B
+ S ZG=$NA(^C0CE(DA(2),1,DA(1),1,DA))
+ ;S G2=$NA(^C0CE(8,1,1,1,2,1,6))
+ S X=$$CHKSUM^XUSESIG1(ZG)
+ W G1,!
+ Q
+ ;
+CHKELS(DFN) ; CHECKSUM ALL ELEMENTS FOR  A PATIENT
+ ;
+ S ZGLB=$NA(^TMP("C0CCHK"))
+ S ZPAT=$O(^C0CE("B",DFN,""))
+ K @ZGLB@(ZPAT) ; CLEAR PREVIOUS CHECKSUMS
+ S ZSRC=""
+ F  S ZSRC=$O(^C0CE(ZPAT,1,"B",ZSRC)) Q:ZSRC=""  D  ;
+ . W "PAT:",ZPAT," SRC:",ZSRC,!
+ . S ZEL=""
+ . F  S ZEL=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL)) Q:ZEL=""  D  ;ELEMENTS
+ . . W "ELEMENT:",ZEL," "
+ . . S ZELE=$$GET1^DIQ(170.101,ZEL,.01,"E") ;ELEMENT NAME
+ . . W ZELE," "
+ . . S ZELI=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL,""))
+ . . S ZG=$NA(^C0CE(ZPAT,1,ZSRC,1,ZELI))
+ . . S ZCHK=$$CHKSUM^XUSESIG1(ZG) ; CHECKSUM FOR THE ELEMENT
+ . . W ZCHK,!
+ . . S @ZGLB@(ZPAT,ZELE,ZSRC)=ZCHK
+ ZWR ^TMP("C0CCHK",ZPAT,*)
+ Q
+ ;
+DOIT(DFN) ; EXPERIMENT FOR TIMING CALLS USING mumps -dir DOIT^C0CFM2(DFN)
+ D SETXUP
+ D CHKELS(DFN)
+ Q
+ ;
+SETXUP ; SET UP ENVIRONMENT
+ S DISYS=19
+ S DT=3090325
+ S DTIME=300
+ S DUZ=1
+ S DUZ(0)="@"
+ S DUZ(1)=""
+ S DUZ(2)=7247
+ S DUZ("AG")="I"
+ S DUZ("BUF")=1
+ S DUZ("LANG")=""
+ S IO="/dev/pts/20"
+ S IO(0)="/dev/pts/20"
+ S IO(1,"/dev/pts/20")=""
+ S IO("ERROR")=""
+ S IO("HOME")="344^/dev/pts/20"
+ S IO("ZIO")="/dev/pts/20"
+ S IOBS="$C(8)"
+ S IOF="#,$C(27,91,50,74,27,91,72)"
+ S IOM=80
+ S ION="TELNET"
+ S IOS=344
+ S IOSL=24
+ S IOST="C-VT100"
+ S IOST(0)=9
+ S IOT="VTRM"
+ S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)"
+ S U="^"
+ S X="216;DIC(4.2,"
+ S XPARSYS="216;DIC(4.2,"
+ S XQXFLG="^^XUP"
+ Q
+ ; 
+PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE
+ ; 171.101, ^C0CE  DFN IS THE PATIENT IEN PASSED BY VALUE
+ ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE
+ ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC
+ ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM
+ ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT
+ ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES
+ ;
+ S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1
+ ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE
+ N ZF,ZFV S ZF=171.101 S ZFV=171.1011
+ ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS
+ ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER
+ N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,""))
+ W "ZTYPE: ",ZTYPE," ",ZTYPN,!
+ N ZVARN ; IEN OF VARIABLE BEING PROCESSED
+ ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE
+ K C0CFDA
+ S C0CFDA(ZF,"?+1,",.01)=DFN
+ S C0CFDA(ZF,"?+1,",.02)=ZSRC
+ S C0CFDA(ZF,"?+1,",.03)=ZTYPN
+ S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE
+ K ZERR
+ ;B
+ D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER
+ I $D(ZERR) B  ;OOPS
+ K C0CFDA
+ S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,""))
+ W "RECORD NUMBER: ",ZD0,!
+ ;B
+ S ZCNT=0
+ S ZC0CI="" ;
+ F  S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI=""  D  ;
+ . I ZC0CI'="M" D  ; NOT A SUBVARIABLE
+ . . S ZCNT=ZCNT+1 ;INCREMENT COUNT
+ . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT
+ . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND
+ . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN
+ . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI)
+ . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN
+ . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI)
+ ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT"
+ ;S GT1(170,"?+1,",12)="DIR"
+ ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT"
+ ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT"
+ D CLEAN^DILF
+ D UPDATE^DIE("","C0CFDA","","ZERR")
+ I $D(ZERR) D  ;
+ . W "ERROR",!
+ . ZWR ZERR
+ . B
+ K C0CFDA
+ Q
+ ;
+VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
+ ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
+ ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
+ ;
+ N ZCCRD,ZVARN,C0CFDA2
+ S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
+ S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
+ I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
+ . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
+ . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
+ . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
+ . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
+ . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
+ . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
+ . I $D(ZERR) D  ; LAYGO ERROR
+ . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
+ . E  D  ;
+ . . D CLEAN^DILF ; CLEAN UP
+ . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
+ . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
+ Q ZVARN
+ ;
+BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,)
+ ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED
+ ;
+ N C0CDIC,C0CNODE ;
+ S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY
+ S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE
+ Q
+ ;
+FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED
+ ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET
+ ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS
+ ; CONVERSION
+ ;N C0CC,C0CI,C0CJ,C0CN,C0CZX
+ D FIELDS^C0CRNF("C0CC",170)
+ S C0CI=""
+ F  S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI=""  D  ; EACH SECTION
+ . S C0CZX=""
+ . F  S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX=""  D  ; EACH VARIABLE
+ . . W "SECTION ",C0CI," VAR ",C0CZX
+ . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,""))
+ . . W " TYPE: ",C0CV,!
+ . . D SETFDA("SECTION",C0CV)
+ . . ;ZWR C0CFDA
+ Q
+ ;
+SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
+ ; TO SET TO VALUE C0CSV.
+ ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
+ ; C0CSN,C0CSV ARE PASSED BY VALUE
+ ;
+ N C0CSI,C0CSJ
+ S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
+ S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
+ S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
+ Q
+ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
+ E  S ZR=""
+ Q ZR
+ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
+ E  S ZR=""
+ Q ZR
+ ;
+ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
+ E  S ZR=""
+ Q ZR
+ ;

ccr/trunk/p/C0CIM2.m

@@ -1 @@
-C0CIM2   ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10
-        ;;1.0;C0C;;Feb 16, 2010;Build 38
-        ;Copyright 2010 George Lilly, University of Minnesota and others.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "NO ENTRY FROM TOP",!
-        Q
-        ;
-EXTRACT(IMMXML,DFN,IMMOUT)      ; EXTRACT PROCEDURES INTO XML TEMPLATE
-        ; IMMXML AND IMMOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
-        ;
-        ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS
-        ; THAT GET PASSED TO *GET ROUTINES
-        ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME))
-        N C0CIMM
-        S C0CIMM=$NA(^TMP("C0CCCR",$J,DFN,"C0CIMM"))
-        ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS
-        ; THAT GET INSERTED INTO THE XML TEMPLATE
-        ; I '$D(@C0CIMM) D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS IF NOT THERE
-        D GETRPMS(DFN,C0CIMM) ; GET VARS IF NOT THERE
-        ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE
-        ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES
-        D MAP(IMMXML,C0CIMM,IMMOUT) ;MAP RESULTS FOR PROCEDURES
-        Q
-        ;
-GETRPMS(DFN,C0CIMM)     ; CALLS GET^BGOVIMM TO GET IMMUNIZATIONS. 
-        ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
-        ; C0CIMM: IMMUNIZATIONS
-        ; READY TO BE MAPPED TO XML BY MAP^C0CIMM
-        ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 
-        ; EXIST.
-        ;
-        ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J))
-        ;
-        ; SETUP RPC/API CALL HERE
-        ; USE START AND END DATES FROM PARAMETERS IF REQUIRED
-        N IMMA
-        D GET^BGOVIMM(.IMMA,DFN) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
-        ; PREFORM SORT HERE IF NEEDED
-        ;
-        ; NO SORT REQUIRED FOR IMMUNIZATIONS
-        ;
-        ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY
-        ; RNF1 ARRAY FORMAT:
-        ; VAR("NAME_OF_RIM_VARIABLE")=VALUE
-        ;
-        ; IMMUNIZATIONS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF IMMUNIZATION RESULTS
-        ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD
-        ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS
-        N C0CIM,C0CC,ZRNF
-        S C0CIM="" ; INITIALIZE FOR $O
-        F C0CC=1:1 S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM=""  D  ; FOR EACH IMMUNE TYPE IN THE LIST
-        . I DEBUG W @IMMA@(C0CIM),!
-        . ; FIGURE OUT WHICH TYPE OF IMMUNIZATION IT IS (IMMUNIZATION, FORECAST, CONTRAINDICATIONS, REFUSALS)
-        . D:$P(@IMMA@(C0CIM),U,1)="I" IMMUN
-        . D:$P(@IMMA@(C0CIM),U,1)="F" FORECAST
-        . D:$P(@IMMA@(C0CIM),U,1)="C" CONTRA
-        . D:$P(@IMMA@(C0CIM),U,1)="R" REFUSE
-        . D RNF1TO2^C0CRNF(C0CIMM,"ZRNF") ;ADD THIS ROW TO THE ARRAY
-        . K ZRNF
-        ; SAVE RIM VARIABLES SEE C0CRIMA
-        N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE"))
-        M @ZRIM=@C0CIMM@("V")
-        Q
-        ;
-IMMUN   ; PARSES IMMUNIZATION TYPE ROWS FOR RPMS
-        ; RPC FORMAT
-        ;    I ^ Imm Name [2] ^ Visit Date [3] ^ V File IEN [4] ^ Other Location [5] ^ Group [6] ^ Imm IEN [7] ^ Lot [8] ^
-        ;     Reaction [9] ^ VIS Date [10] ^ Age [11] ^ Visit Date [12] ^ Provider IEN~Name [13] ^ Inj Site [14] ^
-        ;     Volume [15] ^ Visit IEN [16] ^ Visit Category [17] ^ Full Name [18] ^ Location IEN~Name [19] ^ Visit Locked [20]
-        ; RETRIEVE IMMUNIZATION RECORD FROM IMMUNIZATION FILE (9999999.14) FOR THIS IMMUNIZATION
-        D GETN^C0CRNF("C0CZIM",9999999.14,$P(@IMMA@(C0CIM),U,7)) ; GET IMMUNIZATION RECORD
-        ; RETIREVE IMMUNIZATION RECORD FROM V IMMUNIZATION FILE (9000010.11) FOR THIS IMMUNIZATION
-        D GETN^C0CRNF("C0CZVI",9000010.11,$P(@IMMA@(C0CIM),U,4)) ; GET V IMMUNIZATION RECORD
-        S ZRNF("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID
-        S ZRNF("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME
-        S ZRNF("IMMUNEDATETIME")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("EVENT DATE AND TIME","C0CZVI"),"DT")
-        S ZRNF("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_$P($P(@IMMA@(C0CIM),U,13),"~",1)
-        S ZRNF("IMMUNEPRODUCTNAMETEXT")=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD
-        S ZRNF("IMMUNEPRODUCTCODE")=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE
-        I $$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM")'="" S ZRNF("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code"
-        E  S ZRNF("IMMUNEPRODUCTCODESYSTEM")="" ;NULL
-        ;CLEANUP FROM C0CRNF CALLS
-        K C0CZIM,C0CZVI
-        Q
-FORECAST        ; PARSES FORECAST TYPE ROWS FOR RPMS
-        ; CURRENTLY DISABLED
-        Q
-CONTRA  ; PARSES FORECAST TYPE ROWS FOR RPMS
-        ; CURRENTLY DISABLED
-        Q
-REFUSE  ; PARSES FORECAST TYPE ROWS FOR RPMS
-        ; CURRENTLY DISABLED
-        Q
-        ;
-MAP(IMMXML,C0CIMM,IMMOUT)       ; MAP IMMUNIZATION XML 
-        ;
-        N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"IMMTEMP")) ;WORK AREA FOR TEMPLATE
-        K @ZTEMP
-        N ZBLD
-        S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"IMMBLD")) ; BUILD LIST AREA
-        D QUEUE^C0CXPATH(ZBLD,IMMXML,1,1) ; FIRST LINE
-        N ZINNER
-        ; XPATH NEEDS TO MATCH YOUR SECTION
-        D QUERY^C0CXPATH(IMMXML,"//Immunizations/Immunization","ZINNER") ;ONE PROC
-        N ZTMP,ZVAR,ZI
-        S ZI=""
-        F  S ZI=$O(@C0CIMM@("V",ZI)) Q:ZI=""  D  ;FOR EACH IMMUNIZATION
-        . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS IMMUNIZATION XML
-        . S ZVAR=$NA(@C0CIMM@("V",ZI)) ;THIS IMMUNIZATION VARIABLES
-        . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE IMMUNIZATION
-        . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD
-        D QUEUE^C0CXPATH(ZBLD,IMMXML,@IMMXML@(0),@IMMXML@(0))
-        N ZZTMP ; IS THIS NEEDED?
-        D BUILD^C0CXPATH(ZBLD,IMMOUT) ;BUILD FINAL XML
-        K @ZTEMP,@ZBLD
-        Q
-        ;  
+C0CIM2  ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10
+ ;;1.0;C0C;;Feb 16, 2010;Build 38
+ ;Copyright 2010 George Lilly, University of Minnesota and others.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "NO ENTRY FROM TOP",!
+ Q
+ ;
+EXTRACT(IMMXML,DFN,IMMOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE
+ ; IMMXML AND IMMOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
+ ;
+ ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS
+ ; THAT GET PASSED TO *GET ROUTINES
+ ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME))
+ N C0CIMM
+ S C0CIMM=$NA(^TMP("C0CCCR",$J,DFN,"C0CIMM"))
+ ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS
+ ; THAT GET INSERTED INTO THE XML TEMPLATE
+ ; I '$D(@C0CIMM) D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS IF NOT THERE
+ D GETRPMS(DFN,C0CIMM) ; GET VARS IF NOT THERE
+ ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE
+ ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES
+ D MAP(IMMXML,C0CIMM,IMMOUT) ;MAP RESULTS FOR PROCEDURES
+ Q
+ ;
+GETRPMS(DFN,C0CIMM) ; CALLS GET^BGOVIMM TO GET IMMUNIZATIONS. 
+ ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
+ ; C0CIMM: IMMUNIZATIONS
+ ; READY TO BE MAPPED TO XML BY MAP^C0CIMM
+ ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 
+ ; EXIST.
+ ;
+ ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J))
+ ;
+ ; SETUP RPC/API CALL HERE
+ ; USE START AND END DATES FROM PARAMETERS IF REQUIRED
+ N IMMA
+ D GET^BGOVIMM(.IMMA,DFN) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
+ ; PREFORM SORT HERE IF NEEDED
+ ;
+ ; NO SORT REQUIRED FOR IMMUNIZATIONS
+ ;
+ ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY
+ ; RNF1 ARRAY FORMAT:
+ ; VAR("NAME_OF_RIM_VARIABLE")=VALUE
+ ;
+ ; IMMUNIZATIONS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF IMMUNIZATION RESULTS
+ ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD
+ ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS
+ N C0CIM,C0CC,ZRNF
+ S C0CIM="" ; INITIALIZE FOR $O
+ F C0CC=1:1 S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM=""  D  ; FOR EACH IMMUNE TYPE IN THE LIST
+ . I DEBUG W @IMMA@(C0CIM),!
+ . ; FIGURE OUT WHICH TYPE OF IMMUNIZATION IT IS (IMMUNIZATION, FORECAST, CONTRAINDICATIONS, REFUSALS)
+ . D:$P(@IMMA@(C0CIM),U,1)="I" IMMUN
+ . D:$P(@IMMA@(C0CIM),U,1)="F" FORECAST
+ . D:$P(@IMMA@(C0CIM),U,1)="C" CONTRA
+ . D:$P(@IMMA@(C0CIM),U,1)="R" REFUSE
+ . D RNF1TO2^C0CRNF(C0CIMM,"ZRNF") ;ADD THIS ROW TO THE ARRAY
+ . K ZRNF
+ ; SAVE RIM VARIABLES SEE C0CRIMA
+ N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE"))
+ M @ZRIM=@C0CIMM@("V")
+ Q
+ ;
+IMMUN ; PARSES IMMUNIZATION TYPE ROWS FOR RPMS
+ ; RPC FORMAT
+ ;    I ^ Imm Name [2] ^ Visit Date [3] ^ V File IEN [4] ^ Other Location [5] ^ Group [6] ^ Imm IEN [7] ^ Lot [8] ^
+ ;     Reaction [9] ^ VIS Date [10] ^ Age [11] ^ Visit Date [12] ^ Provider IEN~Name [13] ^ Inj Site [14] ^
+ ;     Volume [15] ^ Visit IEN [16] ^ Visit Category [17] ^ Full Name [18] ^ Location IEN~Name [19] ^ Visit Locked [20]
+ ; RETRIEVE IMMUNIZATION RECORD FROM IMMUNIZATION FILE (9999999.14) FOR THIS IMMUNIZATION
+ D GETN^C0CRNF("C0CZIM",9999999.14,$P(@IMMA@(C0CIM),U,7)) ; GET IMMUNIZATION RECORD
+ ; RETIREVE IMMUNIZATION RECORD FROM V IMMUNIZATION FILE (9000010.11) FOR THIS IMMUNIZATION
+ D GETN^C0CRNF("C0CZVI",9000010.11,$P(@IMMA@(C0CIM),U,4)) ; GET V IMMUNIZATION RECORD
+ S ZRNF("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID
+ S ZRNF("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME
+ S ZRNF("IMMUNEDATETIME")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("EVENT DATE AND TIME","C0CZVI"),"DT")
+ S ZRNF("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_$P($P(@IMMA@(C0CIM),U,13),"~",1)
+ S ZRNF("IMMUNEPRODUCTNAMETEXT")=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD
+ S ZRNF("IMMUNEPRODUCTCODE")=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE
+ I $$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM")'="" S ZRNF("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code"
+ E  S ZRNF("IMMUNEPRODUCTCODESYSTEM")="" ;NULL
+ ;CLEANUP FROM C0CRNF CALLS
+ K C0CZIM,C0CZVI
+ Q
+FORECAST ; PARSES FORECAST TYPE ROWS FOR RPMS
+ ; CURRENTLY DISABLED
+ Q
+CONTRA ; PARSES FORECAST TYPE ROWS FOR RPMS
+ ; CURRENTLY DISABLED
+ Q
+REFUSE ; PARSES FORECAST TYPE ROWS FOR RPMS
+ ; CURRENTLY DISABLED
+ Q
+ ;
+MAP(IMMXML,C0CIMM,IMMOUT) ; MAP IMMUNIZATION XML 
+ ;
+ N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"IMMTEMP")) ;WORK AREA FOR TEMPLATE
+ K @ZTEMP
+ N ZBLD
+ S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"IMMBLD")) ; BUILD LIST AREA
+ D QUEUE^C0CXPATH(ZBLD,IMMXML,1,1) ; FIRST LINE
+ N ZINNER
+ ; XPATH NEEDS TO MATCH YOUR SECTION
+ D QUERY^C0CXPATH(IMMXML,"//Immunizations/Immunization","ZINNER") ;ONE PROC
+ N ZTMP,ZVAR,ZI
+ S ZI=""
+ F  S ZI=$O(@C0CIMM@("V",ZI)) Q:ZI=""  D  ;FOR EACH IMMUNIZATION
+ . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS IMMUNIZATION XML
+ . S ZVAR=$NA(@C0CIMM@("V",ZI)) ;THIS IMMUNIZATION VARIABLES
+ . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE IMMUNIZATION
+ . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD
+ D QUEUE^C0CXPATH(ZBLD,IMMXML,@IMMXML@(0),@IMMXML@(0))
+ N ZZTMP ; IS THIS NEEDED?
+ D BUILD^C0CXPATH(ZBLD,IMMOUT) ;BUILD FINAL XML
+ K @ZTEMP,@ZBLD
+ Q
+ ;  

ccr/trunk/p/C0CIMMU.m

@@ -1 @@
-C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008,2009 George Lilly, University of Minnesota.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        ;
-        ; PROCESS THE IMMUNIZATIONS SECTION OF THE CCR
-        ;
-MAP(IPXML,DFN,OUTXML)   ; MAP IMMUNIZATIONS
-        ;
-        N C0CZV,C0CZVI ; TO STORE MAPPED VARIABLES
-        N C0CZT ; TMP ARRAY OF MAPPED XML
-        S C0CZV=$NA(^TMP("C0CCCR",$J,"IMMUNE")) ; TEMP STORAGE FOR VARIABLES
-        D EXTRACT(IPXML,DFN,OUTXML) ;EXTRACT THE VARIABLES
-        N C0CZI,C0CZIC ; COUNT OF IMMUNIZATIONS
-        S C0CZIC=$G(@C0CZV@(0)) ; TOTAL FROM VARIABLE ARRAY
-        I C0CZIC>0 D  ;IMMUNIZATIONS FOUND
-        . F C0CZI=1:1:C0CZIC D  ;FOR EACH IMMUNIZATION
-        . . S C0CZVI=$NA(@C0CZV@(C0CZI)) ;THIS IMMUNIZATION
-        . . D MAP^C0CXPATH(IPXML,C0CZVI,"C0CZT") ;MAP THE VARIABLES TO XML
-        . . I C0CZI=1 D  ; FIRST ONE
-        . . . D CP^C0CXPATH("C0CZT",OUTXML) ;JUST COPY RESULTS
-        . . E  D  ;NOT THE FIRST
-        . . . D INSINNER^C0CXPATH(OUTXML,"C0CZT")
-        E  S @OUTXML@(0)=0 ; SIGNAL NO IMMUNIZATIONS
-        N IMMUTMP,I
-        D MISSING^C0CXPATH(OUTXML,"IMMUTMP") ; SEARCH XML FOR MISSING VARS
-        I IMMUTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
-        . ; STRINGS MARKED AS @@X@@
-        . W !,"IMMUNE Missing list: ",!
-        . F I=1:1:IMMUTMP(0) W IMMUTMP(I),!
-        Q
-        ;
-EXTRACT(IPXML,DFN,OUTXML)       ; EXTRACT IMMUNIZATIONS INTO VARIABLES
-        ;
-        ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
-        ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE
-        ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE
-        ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS
-        ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT
-        ;
-        N RPCRSLT,J,K,PTMP,X,VMAP,TBU
-        S TVMAP=$NA(^TMP("C0CCCR",$J,"IMMUNE"))
-        S TARYTMP=$NA(^TMP("C0CCCR",$J,"IMMUARYTMP"))
-        S IMMA=$NA(^TMP("PXI",$J)) ;
-        K @IMMA ; CLEAR OUT PREVIOUS RESULTS
-        K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES
-        D IMMUN^PXRHS03(DFN) ;
-        I $O(@IMMA@(""))="" D  Q  ; RPC RETURNS NULL
-        . W "NULL RESULT FROM IMMUN^PXRHS03 ",!
-        . S @TVMAP@(0)=0
-        N C0CIM,C0CC,C0CIMD,C0CIEN,C0CT ;
-        S C0CIM=""
-        S C0CC=0 ; COUNT
-        F  S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM=""  D  ; FOR EACH IMMUNE TYPE IN THE LIST
-        . S C0CC=C0CC+1 ;INCREMENT COUNT
-        . S @TVMAP@(0)=C0CC ; SAVE NEW COUNT TO ARRAY
-        . S VMAP=$NA(@TVMAP@(C0CC)) ; THIS IMMUNE ELEMENT
-        . K @VMAP ; MAKE SURE IT IS CLEARED OUT
-        . W C0CIM,!
-        . S C0CIMD="" ; IMMUNE DATE
-        . F  S C0CIMD=$O(@IMMA@(C0CIM,C0CIMD)) Q:C0CIMD=""  D  ; FOR EACH DATE
-        . . S C0CIEN=$O(@IMMA@(C0CIM,C0CIMD,"")) ;IEN OF IMMUNE RECORD
-        . . D GETN^C0CRNF("C0CI",9000010.11,C0CIEN) ; GET THE FILEMAN RECORD FOR IENS
-        . . W C0CIEN,"_",C0CIMD
-        . . S C0CT=$$FMDTOUTC^C0CUTIL(9999999-C0CIMD,"DT") ; FORMAT DATE/TIME
-        . . W C0CT,!
-        . . S @VMAP@("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID
-        . . S @VMAP@("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME
-        . . S @VMAP@("IMMUNEDATETIME")=C0CT ;FORMATTED DATE/TIME
-        . . S C0CIP=$$ZVALUEI^C0CRNF("ENCOUNTER PROVIDER","C0CI") ;IEN OF PROVIDER
-        . . S @VMAP@("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_C0CIP
-        . . S C0CIIEN=$$ZVALUEI^C0CRNF("IMMUNIZATION","C0CI") ;IEN OF IMMUNIZATION
-        . . I $G(DUZ("AG"))="I" D  ; RUNNING IN RPMS
-        . . . D GETN^C0CRNF("C0CZIM",9999999.14,C0CIIEN) ;GET IMMUNE RECORD
-        . . . S C0CIN=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD
-        . . . ; FOR LOOKING UP THE CODE
-        . . . ; GET IT FROM THE CODE FILE
-        . . . S C0CICD=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE
-        . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME
-        . . . S @VMAP@("IMMUNEPRODUCTCODE")=C0CICD ; CVX CODE
-        . . . I C0CICD'="" S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code" ;
-        . . . E  S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NULL
-        . . E  D  ; NOT IN RPMS
-        . . . S C0CIN=$$ZVALUE^C0CRNF("IMMUNIZATION","C0CI") ;NAME OF IMMUNIZATION
-        . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME
-        . . . S @VMAP@("IMMUNEPRODUCTCODE")="" ; CVX CODE
-        . . . S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NO CODE
-        N C0CIRIM S C0CIRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE"))
-        M @C0CIRIM=@TVMAP ; PERSIST RIM VARIABLES
-        Q
-        ;
+C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008,2009 George Lilly, University of Minnesota.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ ;
+ ; PROCESS THE IMMUNIZATIONS SECTION OF THE CCR
+ ;
+MAP(IPXML,DFN,OUTXML) ; MAP IMMUNIZATIONS
+ ;
+ N C0CZV,C0CZVI ; TO STORE MAPPED VARIABLES
+ N C0CZT ; TMP ARRAY OF MAPPED XML
+ S C0CZV=$NA(^TMP("C0CCCR",$J,"IMMUNE")) ; TEMP STORAGE FOR VARIABLES
+ D EXTRACT(IPXML,DFN,OUTXML) ;EXTRACT THE VARIABLES
+ N C0CZI,C0CZIC ; COUNT OF IMMUNIZATIONS
+ S C0CZIC=$G(@C0CZV@(0)) ; TOTAL FROM VARIABLE ARRAY
+ I C0CZIC>0 D  ;IMMUNIZATIONS FOUND
+ . F C0CZI=1:1:C0CZIC D  ;FOR EACH IMMUNIZATION
+ . . S C0CZVI=$NA(@C0CZV@(C0CZI)) ;THIS IMMUNIZATION
+ . . D MAP^C0CXPATH(IPXML,C0CZVI,"C0CZT") ;MAP THE VARIABLES TO XML
+ . . I C0CZI=1 D  ; FIRST ONE
+ . . . D CP^C0CXPATH("C0CZT",OUTXML) ;JUST COPY RESULTS
+ . . E  D  ;NOT THE FIRST
+ . . . D INSINNER^C0CXPATH(OUTXML,"C0CZT")
+ E  S @OUTXML@(0)=0 ; SIGNAL NO IMMUNIZATIONS
+ N IMMUTMP,I
+ D MISSING^C0CXPATH(OUTXML,"IMMUTMP") ; SEARCH XML FOR MISSING VARS
+ I IMMUTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
+ . ; STRINGS MARKED AS @@X@@
+ . W !,"IMMUNE Missing list: ",!
+ . F I=1:1:IMMUTMP(0) W IMMUTMP(I),!
+ Q
+ ;
+EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT IMMUNIZATIONS INTO VARIABLES
+ ;
+ ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
+ ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE
+ ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE
+ ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS
+ ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT
+ ;
+ N RPCRSLT,J,K,PTMP,X,VMAP,TBU
+ S TVMAP=$NA(^TMP("C0CCCR",$J,"IMMUNE"))
+ S TARYTMP=$NA(^TMP("C0CCCR",$J,"IMMUARYTMP"))
+ S IMMA=$NA(^TMP("PXI",$J)) ;
+ K @IMMA ; CLEAR OUT PREVIOUS RESULTS
+ K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES
+ D IMMUN^PXRHS03(DFN) ;
+ I $O(@IMMA@(""))="" D  Q  ; RPC RETURNS NULL
+ . W "NULL RESULT FROM IMMUN^PXRHS03 ",!
+ . S @TVMAP@(0)=0
+ N C0CIM,C0CC,C0CIMD,C0CIEN,C0CT ;
+ S C0CIM=""
+ S C0CC=0 ; COUNT
+ F  S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM=""  D  ; FOR EACH IMMUNE TYPE IN THE LIST
+ . S C0CC=C0CC+1 ;INCREMENT COUNT
+ . S @TVMAP@(0)=C0CC ; SAVE NEW COUNT TO ARRAY
+ . S VMAP=$NA(@TVMAP@(C0CC)) ; THIS IMMUNE ELEMENT
+ . K @VMAP ; MAKE SURE IT IS CLEARED OUT
+ . W C0CIM,!
+ . S C0CIMD="" ; IMMUNE DATE
+ . F  S C0CIMD=$O(@IMMA@(C0CIM,C0CIMD)) Q:C0CIMD=""  D  ; FOR EACH DATE
+ . . S C0CIEN=$O(@IMMA@(C0CIM,C0CIMD,"")) ;IEN OF IMMUNE RECORD
+ . . D GETN^C0CRNF("C0CI",9000010.11,C0CIEN) ; GET THE FILEMAN RECORD FOR IENS
+ . . W C0CIEN,"_",C0CIMD
+ . . S C0CT=$$FMDTOUTC^C0CUTIL(9999999-C0CIMD,"DT") ; FORMAT DATE/TIME
+ . . W C0CT,!
+ . . S @VMAP@("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID
+ . . S @VMAP@("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME
+ . . S @VMAP@("IMMUNEDATETIME")=C0CT ;FORMATTED DATE/TIME
+ . . S C0CIP=$$ZVALUEI^C0CRNF("ENCOUNTER PROVIDER","C0CI") ;IEN OF PROVIDER
+ . . S @VMAP@("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_C0CIP
+ . . S C0CIIEN=$$ZVALUEI^C0CRNF("IMMUNIZATION","C0CI") ;IEN OF IMMUNIZATION
+ . . I $G(DUZ("AG"))="I" D  ; RUNNING IN RPMS
+ . . . D GETN^C0CRNF("C0CZIM",9999999.14,C0CIIEN) ;GET IMMUNE RECORD
+ . . . S C0CIN=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD
+ . . . ; FOR LOOKING UP THE CODE
+ . . . ; GET IT FROM THE CODE FILE
+ . . . S C0CICD=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE
+ . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME
+ . . . S @VMAP@("IMMUNEPRODUCTCODE")=C0CICD ; CVX CODE
+ . . . I C0CICD'="" S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code" ;
+ . . . E  S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NULL
+ . . E  D  ; NOT IN RPMS
+ . . . S C0CIN=$$ZVALUE^C0CRNF("IMMUNIZATION","C0CI") ;NAME OF IMMUNIZATION
+ . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME
+ . . . S @VMAP@("IMMUNEPRODUCTCODE")="" ; CVX CODE
+ . . . S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NO CODE
+ N C0CIRIM S C0CIRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE"))
+ M @C0CIRIM=@TVMAP ; PERSIST RIM VARIABLES
+ Q
+ ;

ccr/trunk/p/C0CIN.m

@@ -1 @@
-C0CIN     ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08
-        ;;1.0;C0C;;Sep 20, 2009;Build 38
-        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "This is the CCR Import Utility Library ",!
-        Q
-        ;
-TEST    ; TESTS BOTH ROUTINES AT ONCE
-        N ZI,ZJ
-        S ZI="/home/vademo2/CCR" ;directory purposely leaving off the trailing /
-        S ZJ="PAT_358_CCR_V1_0_21.xml" ; random test patient
-        D RPCFIN(.GPL,358,135,"GPLTEST","CCR",ZJ,ZI)
-        Q
-        ;
-RPCAIN(RTN,DFN,DUZ,SOURCE,TYPE,ARY)     ; ARRAY IN RPC - ACCEPT AN XML DOCUMENT
-        ; AND STORE IT IN THE INCOMING XML FILE
-        ; RETURNS THE IEN OF THE RECORD OR TEXT IF THERE IS AN ERROR
-        I $G(DFN)="" S RTN="DFN NOT DEFINED" Q  ;
-        N C0CXF S C0CXF=175 ; FILE NUMBER FOR INCOMING XML FILE
-        N C0CFDA,ZX
-        S C0CFDA(C0CXF,"+1,",.01)=DFN ; PATIENT
-        S C0CFDA(C0CXF,"+1,",.02)=DUZ ; PROVIDER CREATING THE RECORD
-        S C0CFDA(C0CXF,"+1,",1)=$$NOW^XLFDT ;DATE
-        S C0CFDA(C0CXF,"+1,",2)=TYPE  ;TYPE
-        S C0CFDA(C0CXF,"+1,",3)=$$ADDSRC(SOURCE) ;SOURCE
-        S C0CFDA(C0CXF,"+1,",7)="NEW" ; STATUS OF NEW FOR NOT PROCESSED
-        D UPDIE ; CREATE THE RECORD
-        S ZX=C0CIEN(1) ; CAPTURE THE RECORD NUMBER
-        D WP^DIE(C0CXF,ZX_",",4,,ARY,"ZERR")
-        ;W "RECORD:",ZX,!
-        S RTN=ZX ; RETURN IEN OF THE XML FILE
-        Q
-        ;
-ADDSRC(ZSRC)    ;EXTRISIC TO ADD A SOURCE TO THE CCR SOURCE FILE
-        ; RETURNS RECORD NUMBER. IF SOURCE EXISTS, JUST RETURNS IT'S RECORD NUMBER
-        ;
-        N ZX,ZF,C0CFDA
-        S ZF=171.401 ; FILE NUMBER FOR CCR SOURCE FILE
-        S C0CFDA(ZF,"?+1,",.01)=ZSRC
-        D UPDIE
-        Q $O(^C0C(171.401,"B",ZSRC,""))
-        ;
-RPCFIN(RTN,DFN,DUZ,SOURCE,TYPE,FN,FP)   ; FILE IN RPC - READ AN XML DOCUMENT
-        ; FROM A HOST FILE AND STORE IT IN THE INCOMING XML FILE
-        N ZX,ZTMP
-        I $E($RE(FP))'="/" S ZX=FP_"/"
-        E  S ZX=FP
-        S ZX=ZX_FN
-        D LOAD("ZTMP",ZX)
-        I '$D(ZTMP) D  Q  ; NO LUCK
-        . W "FILE NOT LOADED",!
-        D RPCAIN(.RTN,DFN,DUZ,SOURCE,TYPE,"ZTMP")
-        N C0CFDA
-        S C0CFDA(175,RTN_",",5)=FN ; FILE NAME
-        S C0CFDA(175,RTN_",",6)=FP ; FILE PATH
-        D UPDIE ; UPDATE WITH FILE NAME AND PATH
-        Q
-        ;
-RPCLIST(RTN,DFN)        ; CCR LIST - LIST XML DOCUMENTS FOR PATIENT DFN
-        ; THAT ARE STORED IN THE INCOMING XML FILE
-        ; RETURNS AN ARRAY OF THE FORM 
-        ; RTN(x)="IEN^DATE^TYPE^SOURCE^STATUS^CREATEDBY" WHERE
-        ; IEN IS THE RECORD NUMBER OF THE XML DOCUMENT
-        ; DATE IS THE DATE THE DOCUMENT WAS STORED IN THE FILE
-        ; TYPE IS "CCD" OR "CCR" OR "OTHER"
-        ; SOURCE IS THE NAME OF THE DOCUMENT SOURCE FROM THE CCR SOURCE FILE
-        ; STATUS IS THE STATUS OF THE DOCUMENT (VALUES TO BE DEFINED)
-        ; CREATEDBY IS THE NAME OF THE PROVIDER WHO UPLOADED THE XML
-        N ZF S ZF=175 ; FILE NUMBER OF INCOMING XML FILE
-        N ZI S ZI=""
-        N ZN S ZN=0
-        F  S ZI=$O(^C0CIN("B",DFN,ZI),-1) Q:ZI=""  D  ; FOR EACH RECORD FOR THIS PATIENT
-        . S ZN=ZN+1 ;INCREMENT COUNT OF RETURN ARRAY
-        . S $P(RTN(ZN),"^",1)=ZI ; IEN OF RECORD
-        . S $P(RTN(ZN),"^",2)=$$GET1^DIQ(ZF,ZI_",",1,"E") ;DATE
-        . S $P(RTN(ZN),"^",3)=$$GET1^DIQ(ZF,ZI_",",2,"E") ;TYPE
-        . S $P(RTN(ZN),"^",4)=$$GET1^DIQ(ZF,ZI_",",3,"E") ;SOURCE
-        . S $P(RTN(ZN),"^",5)=$$GET1^DIQ(ZF,ZI_",",7,"I") ; STATUS
-        . S $P(RTN(ZN),"^",6)=$$GET1^DIQ(ZF,ZI_",",.02,"E") ; CREATED BY
-        Q
-        ;
-RPCDOC(RTN,IEN) ; RETRIEVE DOCUMENT NUMBER IEN FROM THE INCOMING XML FILE
-        ; RETURNED IN ARRAY RTN
-        N ZI
-        S ZI=$$GET1^DIQ(175,IEN_",",4,,"RTN")
-        Q
-        ;
-EN(INXML,SOURCE,C0CDFN) ; IMPORT A CCR, PASSED BY NAME INXML
-        ; FILE UNDER SOURCE, WHICH IS A POINTER TO THE CCR SOURCE FILE
-        ; FOR PATIENT C0CDFN
-        ;N C0CXP
-        S C0CINB=$NA(^TMP("C0CIN",$J,"VARS",C0CDFN))
-        S C0CDOCID=$$PARSE^C0CMXML(INXML) ;W !,"DocID: ",C0CDOCID
-        ;S REDUX="//ContinuityOfCareRecord/Body"
-        S REDUX=""
-        D XPATH^C0CMXML(1,"/","C0CIDX","C0CXP",,REDUX)
-        ;D INDEX^C0CXPATH(INXML,"C0CXP",-1) ; GENERATE XPATHS FROM THE CCR
-        ;N ZI,ZJ,ZK 
-        S ZI=""
-        F  S ZI=$O(C0CXP(ZI)) Q:ZI=""  D  ; FOR EACH XPATH
-        . D DEMUX^C0CMXP("ZJ",ZI) ;
-        . W ZJ,!
-        . S ZK=$P(ZJ,"^",3) ; PULL OUT THE XPATH
-        . S ZM=$P(ZJ,"^",1) ; PULL OUT THE MULTIPLE
-        . S ZS=$P(ZJ,"^",2) ; PULL OUT THE SUBMULTIPLE
-        . S C0CDICN=$O(^C0CDIC(170,"XPATH",ZK,""))
-        . I C0CDICN="" D  Q  ;
-        . . W "MISSING XPATH:",!,ZK,! ; OOPS, XPATH NOT IN C0CDIC
-        . . S MISSING(ZK)=""
-        . ;D GETS^DIQ(170,C0CDICN_",","*",,"C0CFDA")
-        . S C0CVAR=$$GET1^DIQ(170,C0CDICN_",",.01) ; VARIABLE NAME
-        . S C0CSEC=$$GET1^DIQ(170,C0CDICN_",",12) ;ELEMENT TYPE
-        . W C0CSEC,":",C0CVAR,!
-        Q
-        ; 
-GETACCR(AOUT,C0CDFN)    ; EXTRACT A CCR FOR PATIENT ADFN AND PUT IT IN ARRAY AOUT
-        ;PASSED BY NAME
-        N ZT
-        D CCRRPC^C0CCCR(.ZT,C0CDFN,"LABLIMIT:T-1000")
-        M @AOUT=ZT
-        Q
-        ;
-TEST64  ;TEST BASE64 DECODING FOR IMPORTING CCR FROM THE NHIN
-        W $$FTG^%ZISH("/tmp/","base64_encoded_ccr.txt","G64(1)",1)
-        S G=G64(1)
-        S ZI=""
-        F  S ZI=$O(G64(1,"OVF",ZI)) Q:ZI=""  D  ; FOR EVERY OVERFLOW RECORD
-        . S G=G_G64(1,"OVF",ZI) ;HOPE IT'S NOT TOO BIG
-        S G2=$$DECODE^RGUTUU(G)
-        Q
-        ;
-NORMAL(OUTXML,INXML)    ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
-        ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
-        ;
-        N ZI,ZN,ZTMP
-        S ZN=1
-        S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">"
-        S ZN=ZN+1
-        F  S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)=""  D  ;
-        . S @OUTXML@(ZN)=@OUTXML@(ZN)_">"
-        . S ZN=ZN+1
-        Q
-        ;
-CLEANCR(OUTXML,INXML)   ; USE $C(10) TO SEPARATE THE STRING INXML INTO
-        ;AN ARRAY OUTXML(n) OUTXML AND INXML PASSED BY NAME
-        N ZX,ZY,ZN
-        S ZX=1,ZN=1
-        F  S ZY=$F(@INXML,$C(10),ZX) Q:ZY=0  D  ;
-        . S @OUTXML@(ZN)=$E(G2,ZX,ZY-2)
-        . I @OUTXML@(ZN)'="" S ZN=ZN+1
-        . S ZX=ZY
-        Q
-        ;
-LOAD(ZRTN,filepath)     ; load an xml file into the ZRTN array, passed by name
-        n i
-        D  ;
-        . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)=""
-        . s ztmp=$na(^TMP("C0CLOAD",$J))
-        . k @ztmp
-        . s zfile=$re($p($re(filepath),"/",1)) ;file name
-        . s zpath=$p(filepath,zfile,1) ; file path
-        . s zok=$$FTG^%ZISH(zpath,zfile,$NA(@ztmp@(1)),3) ; import the file incr sub 3
-        . m @ZRTN=@ztmp
-        . k @ztmp
-        . s i=$o(@ZRTN@(""),-1) ; highest line number
-        q
-        ;
-UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
-        K ZERR,C0CIEN
-        D CLEAN^DILF
-        D UPDATE^DIE("","C0CFDA","C0CIEN","ZERR")
-        I $D(ZERR) D  ;
-        . W "ERROR",!
-        . ZWR ZERR
-        . B
-        K C0CFDA
-        Q
-        ; 
+C0CIN   ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08
+ ;;1.0;C0C;;Sep 20, 2009;Build 38
+ ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "This is the CCR Import Utility Library ",!
+ Q
+ ;
+TEST ; TESTS BOTH ROUTINES AT ONCE
+ N ZI,ZJ
+ S ZI="/home/vademo2/CCR" ;directory purposely leaving off the trailing /
+ S ZJ="PAT_358_CCR_V1_0_21.xml" ; random test patient
+ D RPCFIN(.GPL,358,135,"GPLTEST","CCR",ZJ,ZI)
+ Q
+ ;
+RPCAIN(RTN,DFN,DUZ,SOURCE,TYPE,ARY) ; ARRAY IN RPC - ACCEPT AN XML DOCUMENT
+ ; AND STORE IT IN THE INCOMING XML FILE
+ ; RETURNS THE IEN OF THE RECORD OR TEXT IF THERE IS AN ERROR
+ I $G(DFN)="" S RTN="DFN NOT DEFINED" Q  ;
+ N C0CXF S C0CXF=175 ; FILE NUMBER FOR INCOMING XML FILE
+ N C0CFDA,ZX
+ S C0CFDA(C0CXF,"+1,",.01)=DFN ; PATIENT
+ S C0CFDA(C0CXF,"+1,",.02)=DUZ ; PROVIDER CREATING THE RECORD
+ S C0CFDA(C0CXF,"+1,",1)=$$NOW^XLFDT ;DATE
+ S C0CFDA(C0CXF,"+1,",2)=TYPE  ;TYPE
+ S C0CFDA(C0CXF,"+1,",3)=$$ADDSRC(SOURCE) ;SOURCE
+ S C0CFDA(C0CXF,"+1,",7)="NEW" ; STATUS OF NEW FOR NOT PROCESSED
+ D UPDIE ; CREATE THE RECORD
+ S ZX=C0CIEN(1) ; CAPTURE THE RECORD NUMBER
+ D WP^DIE(C0CXF,ZX_",",4,,ARY,"ZERR")
+ ;W "RECORD:",ZX,!
+ S RTN=ZX ; RETURN IEN OF THE XML FILE
+ Q
+ ;
+ADDSRC(ZSRC) ;EXTRISIC TO ADD A SOURCE TO THE CCR SOURCE FILE
+ ; RETURNS RECORD NUMBER. IF SOURCE EXISTS, JUST RETURNS IT'S RECORD NUMBER
+ ;
+ N ZX,ZF,C0CFDA
+ S ZF=171.401 ; FILE NUMBER FOR CCR SOURCE FILE
+ S C0CFDA(ZF,"?+1,",.01)=ZSRC
+ D UPDIE
+ Q $O(^C0C(171.401,"B",ZSRC,""))
+ ;
+RPCFIN(RTN,DFN,DUZ,SOURCE,TYPE,FN,FP) ; FILE IN RPC - READ AN XML DOCUMENT
+ ; FROM A HOST FILE AND STORE IT IN THE INCOMING XML FILE
+ N ZX,ZTMP
+ I $E($RE(FP))'="/" S ZX=FP_"/"
+ E  S ZX=FP
+ S ZX=ZX_FN
+ D LOAD("ZTMP",ZX)
+ I '$D(ZTMP) D  Q  ; NO LUCK
+ . W "FILE NOT LOADED",!
+ D RPCAIN(.RTN,DFN,DUZ,SOURCE,TYPE,"ZTMP")
+ N C0CFDA
+ S C0CFDA(175,RTN_",",5)=FN ; FILE NAME
+ S C0CFDA(175,RTN_",",6)=FP ; FILE PATH
+ D UPDIE ; UPDATE WITH FILE NAME AND PATH
+ Q
+ ;
+RPCLIST(RTN,DFN) ; CCR LIST - LIST XML DOCUMENTS FOR PATIENT DFN
+ ; THAT ARE STORED IN THE INCOMING XML FILE
+ ; RETURNS AN ARRAY OF THE FORM 
+ ; RTN(x)="IEN^DATE^TYPE^SOURCE^STATUS^CREATEDBY" WHERE
+ ; IEN IS THE RECORD NUMBER OF THE XML DOCUMENT
+ ; DATE IS THE DATE THE DOCUMENT WAS STORED IN THE FILE
+ ; TYPE IS "CCD" OR "CCR" OR "OTHER"
+ ; SOURCE IS THE NAME OF THE DOCUMENT SOURCE FROM THE CCR SOURCE FILE
+ ; STATUS IS THE STATUS OF THE DOCUMENT (VALUES TO BE DEFINED)
+ ; CREATEDBY IS THE NAME OF THE PROVIDER WHO UPLOADED THE XML
+ N ZF S ZF=175 ; FILE NUMBER OF INCOMING XML FILE
+ N ZI S ZI=""
+ N ZN S ZN=0
+ F  S ZI=$O(^C0CIN("B",DFN,ZI),-1) Q:ZI=""  D  ; FOR EACH RECORD FOR THIS PATIENT
+ . S ZN=ZN+1 ;INCREMENT COUNT OF RETURN ARRAY
+ . S $P(RTN(ZN),"^",1)=ZI ; IEN OF RECORD
+ . S $P(RTN(ZN),"^",2)=$$GET1^DIQ(ZF,ZI_",",1,"E") ;DATE
+ . S $P(RTN(ZN),"^",3)=$$GET1^DIQ(ZF,ZI_",",2,"E") ;TYPE
+ . S $P(RTN(ZN),"^",4)=$$GET1^DIQ(ZF,ZI_",",3,"E") ;SOURCE
+ . S $P(RTN(ZN),"^",5)=$$GET1^DIQ(ZF,ZI_",",7,"I") ; STATUS
+ . S $P(RTN(ZN),"^",6)=$$GET1^DIQ(ZF,ZI_",",.02,"E") ; CREATED BY
+ Q
+ ;
+RPCDOC(RTN,IEN) ; RETRIEVE DOCUMENT NUMBER IEN FROM THE INCOMING XML FILE
+ ; RETURNED IN ARRAY RTN
+ N ZI
+ S ZI=$$GET1^DIQ(175,IEN_",",4,,"RTN")
+ Q
+ ;
+EN(INXML,SOURCE,C0CDFN) ; IMPORT A CCR, PASSED BY NAME INXML
+ ; FILE UNDER SOURCE, WHICH IS A POINTER TO THE CCR SOURCE FILE
+ ; FOR PATIENT C0CDFN
+ ;N C0CXP
+ S C0CINB=$NA(^TMP("C0CIN",$J,"VARS",C0CDFN))
+ S C0CDOCID=$$PARSE^C0CMXML(INXML) ;W !,"DocID: ",C0CDOCID
+ ;S REDUX="//ContinuityOfCareRecord/Body"
+ S REDUX=""
+ D XPATH^C0CMXML(1,"/","C0CIDX","C0CXP",,REDUX)
+ ;D INDEX^C0CXPATH(INXML,"C0CXP",-1) ; GENERATE XPATHS FROM THE CCR
+ ;N ZI,ZJ,ZK 
+ S ZI=""
+ F  S ZI=$O(C0CXP(ZI)) Q:ZI=""  D  ; FOR EACH XPATH
+ . D DEMUX^C0CMXP("ZJ",ZI) ;
+ . W ZJ,!
+ . S ZK=$P(ZJ,"^",3) ; PULL OUT THE XPATH
+ . S ZM=$P(ZJ,"^",1) ; PULL OUT THE MULTIPLE
+ . S ZS=$P(ZJ,"^",2) ; PULL OUT THE SUBMULTIPLE
+ . S C0CDICN=$O(^C0CDIC(170,"XPATH",ZK,""))
+ . I C0CDICN="" D  Q  ;
+ . . W "MISSING XPATH:",!,ZK,! ; OOPS, XPATH NOT IN C0CDIC
+ . . S MISSING(ZK)=""
+ . ;D GETS^DIQ(170,C0CDICN_",","*",,"C0CFDA")
+ . S C0CVAR=$$GET1^DIQ(170,C0CDICN_",",.01) ; VARIABLE NAME
+ . S C0CSEC=$$GET1^DIQ(170,C0CDICN_",",12) ;ELEMENT TYPE
+ . W C0CSEC,":",C0CVAR,!
+ Q
+ ; 
+GETACCR(AOUT,C0CDFN) ; EXTRACT A CCR FOR PATIENT ADFN AND PUT IT IN ARRAY AOUT
+ ;PASSED BY NAME
+ N ZT
+ D CCRRPC^C0CCCR(.ZT,C0CDFN,"LABLIMIT:T-1000")
+ M @AOUT=ZT
+ Q
+ ;
+TEST64 ;TEST BASE64 DECODING FOR IMPORTING CCR FROM THE NHIN
+ W $$FTG^%ZISH("/tmp/","base64_encoded_ccr.txt","G64(1)",1)
+ S G=G64(1)
+ S ZI=""
+ F  S ZI=$O(G64(1,"OVF",ZI)) Q:ZI=""  D  ; FOR EVERY OVERFLOW RECORD
+ . S G=G_G64(1,"OVF",ZI) ;HOPE IT'S NOT TOO BIG
+ S G2=$$DECODE^RGUTUU(G)
+ Q
+ ;
+NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
+ ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
+ ;
+ N ZI,ZN,ZTMP
+ S ZN=1
+ S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">"
+ S ZN=ZN+1
+ F  S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)=""  D  ;
+ . S @OUTXML@(ZN)=@OUTXML@(ZN)_">"
+ . S ZN=ZN+1
+ Q
+ ;
+CLEANCR(OUTXML,INXML) ; USE $C(10) TO SEPARATE THE STRING INXML INTO
+ ;AN ARRAY OUTXML(n) OUTXML AND INXML PASSED BY NAME
+ N ZX,ZY,ZN
+ S ZX=1,ZN=1
+ F  S ZY=$F(@INXML,$C(10),ZX) Q:ZY=0  D  ;
+ . S @OUTXML@(ZN)=$E(G2,ZX,ZY-2)
+ . I @OUTXML@(ZN)'="" S ZN=ZN+1
+ . S ZX=ZY
+ Q
+ ;
+LOAD(ZRTN,filepath) ; load an xml file into the ZRTN array, passed by name
+ n i
+ D  ;
+ . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)=""
+ . s ztmp=$na(^TMP("C0CLOAD",$J))
+ . k @ztmp
+ . s zfile=$re($p($re(filepath),"/",1)) ;file name
+ . s zpath=$p(filepath,zfile,1) ; file path
+ . s zok=$$FTG^%ZISH(zpath,zfile,$NA(@ztmp@(1)),3) ; import the file incr sub 3
+ . m @ZRTN=@ztmp
+ . k @ztmp
+ . s i=$o(@ZRTN@(""),-1) ; highest line number
+ q
+ ;
+UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
+ K ZERR,C0CIEN
+ D CLEAN^DILF
+ D UPDATE^DIE("","C0CFDA","C0CIEN","ZERR")
+ I $D(ZERR) D  ;
+ . W "ERROR",!
+ . ZWR ZERR
+ . B
+ K C0CFDA
+ Q
+ ; 

ccr/trunk/p/C0CLABS.m

@@ -1 @@
-C0CALABS        ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008,2009 George Lilly, University of Minnesota.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-                  ;
-MAP(MIXML,DFN,MOXML)    ;TO MAKE THIS COMPATIBLE WITH OLD CALLING FOR EXTRACT
-        ; ASSUMES THAT EXTRACT HAS BEEN RUN AND THE VARIABLES STORED IN MIVAR
-        ; MIXML,MIVAR, AND MOXML ARE PASSED BY NAME
-        ; MIXML IS THE TEMPLATE TO USE
-        ; MOXML IS THE OUTPUT XML ARRAY
-        ; DFN IS THE PATIENT RECORD NUMBER
-        N C0COXML,C0CO,C0CV,C0CIXML
-        I '$D(MIVAR) S C0CV="" ;DEFAULT
-        E  S C0CV=MIVAR ;PASSED VARIABLE ARRAY
-        I '$D(MIXML) S C0CIXML="" ;DEFAULT
-        E  S C0CIXML=MIXML ;PASSED INPUT XML
-        D RPCMAP(.C0COXML,DFN,C0CV,C0CIXML) ; CALL RPC TO DO THE WORK
-        I '$D(MOXML) S C0CO=$NA(^TMP("C0CCCR",$J,DFN,"RESULTS")) ;DEFAULT FOR OUTPUT
-        E  S C0CO=MOXML
-        ; ZWR C0COXML
-        M @C0CO=C0COXML ; COPY RESULTS TO OUTPUT
-        Q
-        ;
-RPCMAP(RTN,DFN,RMIVAR,RMIXML)   ; RPC ENTRY POINT FOR MAPPING RESULTS
-        ; RTN IS PASSED BY REFERENCE
-        ;N C0CT0,C0CT,C0CV ; CCR TEMPLATE, RESULTS SUBTEMPLATE, VARIABLES
-        ;N C0CRT,C0CTT ; TEST REQUEST TEMPLATE, TEST RESULT TEMPLATE
-        I '$D(DEBUG) S DEBUG=0 ; DEFAULT NO DEBUGGING
-        I RMIXML="" D  ; INPUT XML NOT PASSED
-        . D LOAD^C0CCCR0("C0CT0") ; LOAD ENTIRE CCR TEMPLATE
-        . D QUERY^C0CXPATH("C0CT0","//ContinuityOfCareRecord/Body/Results","C0CT0R")
-        . S C0CT="C0CT0R" ; NAME OF EXTRACTED RESULTS TEMPLATE
-        E  S C0CT=RMIXML ; WE ARE PASSED THE RESULTS PART OF THE TEMPLATE
-        I RMIVAR="" D  ; LOCATION OF VARIABLES NOT PASSED
-        . S C0CV=$NA(^TMP("C0CCCR",$J,"RESULTS")) ;DEFAULT VARIABLE LOCATION
-        E  S C0CV=RMIVAR ; PASSED LOCATIONS OF VARS
-        D CP^C0CXPATH(C0CT,"C0CRT") ; START MAKING TEST REQUEST TEMPLATE
-        D REPLACE^C0CXPATH("C0CRT","","//Results/Result/Test") ; DELETE TEST FROM REQ
-        D QUERY^C0CXPATH(C0CT,"//Results/Result/Test","C0CTT") ; MAKE TEST TEMPLATE
-        I '$D(C0CQT) S C0CQT=0 ; DEFAULT NOT SILENT
-        I 'C0CQT D  ; WE ARE DEBUGGING
-        . W "I MAPPED",!
-        . W "VARS:",C0CV,!
-        . W "DFN:",DFN,!
-        . ;D PARY^C0CXPATH("C0CT") ; SECTION TEMPLATE
-        . ;D PARY^C0CXPATH("C0CRT") ;REQUEST TEMPLATE (OCR)
-        . ;D PARY^C0CXPATH("C0CTT") ;TEST TEMPLATE (OCX)
-        D EXTRACT("C0CT",DFN,) ; FIRST CALL EXTRACT
-        I '$D(@C0CV@(0)) D  Q  ; NO VARS THERE
-        . S RTN(0)=0 ; PASS BACK NO RESULTS INDICATOR
-        I @C0CV@(0)=0 S RTN(0)=0 Q ; NO RESULTS
-        S RIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"RESULTS"))
-        K @RIMVARS
-        M @RIMVARS=@C0CV ; UPDATE RIMVARS SO THEY STAY IN SYNCH
-        N C0CI,C0CJ,C0CMAP,C0CTMAP,C0CTMP
-        S C0CIN=@C0CV@(0) ; COUNT OF RESULTS (OBR)
-        N C0CRTMP ; AREA TO BUILD ONE RESULT REQUEST AND ALL TESTS FOR IT
-        N C0CRBASE S C0CRBASE=$NA(^TMP($J,"TESTTMP")) ;WORK AREA
-        N C0CRBLD ; BUILD LIST FOR XML - THE BUILD IS DELAYED UNTIL THE END
-        ; TO IMPROVE PERFORMANCE
-        D QUEUE^C0CXPATH("C0CRBLD","C0CRT",1,1) ;<Results>
-        F C0CI=1:1:C0CIN D  ; LOOP THROUGH VARIABLES
-        . K C0CMAP,C0CTMP ;EMPTY OUT LAST BATCH OF VARIABLES
-        . S C0CRTMP=$NA(@C0CRBASE@(C0CI)) ;PARTITION OF WORK AREA FOR EACH TEST
-        . S C0CMAP=$NA(@C0CV@(C0CI)) ;
-        . I 'C0CQT W "MAPOBR:",C0CMAP,!
-        . ;MAPPING FOR TEST REQUEST GOES HERE
-        . D MAP^C0CXPATH("C0CRT",C0CMAP,C0CRTMP) ; MAP OBR DATA
-        . ;D QOPEN^C0CXPATH("C0CRBLD",C0CRTMP,C0CIS) ;1ST PART OF XML
-        . D QUEUE^C0CXPATH("C0CRBLD",C0CRTMP,2,@C0CRTMP@(0)-4) ;UP TO <Test>
-        . I $D(@C0CMAP@("M","TEST",0)) D  ; TESTS EXIST
-        . . S C0CJN=@C0CMAP@("M","TEST",0) ; NUMBER OF TESTS
-        . . K C0CTO ; CLEAR OUTPUT VARIABLE
-        . . F C0CJ=1:1:C0CJN D   ;FOR EACH TEST RESULT
-        . . . K C0CTMAP ; EMPTY MAPS FOR TEST RESULTS
-        . . . S C0CTMP=$NA(@C0CRBASE@(C0CI,C0CJ)) ;WORK AREA FOR TEST RESULTS
-        . . . S C0CTMAP=$NA(@C0CMAP@("M","TEST",C0CJ)) ;
-        . . . I 'C0CQT W "MAPOBX:",C0CTMAP,!
-        . . . D MAP^C0CXPATH("C0CTT",C0CTMAP,C0CTMP) ; MAP TO TMP
-        . . . I C0CJ=1 S C0CJS=2 E  S C0CJS=1 ;FIRST TIME,SKIP THE <Test>
-        . . . I C0CJ=C0CJN S C0CJE=@C0CTMP@(0)-1 E  S C0CJE=@C0CTMP@(0) ;</Test>
-        . . . S C0CJS=1 S C0CJE=@C0CTMP@(0) ; INSERT ALL OF THE TEXT XML
-        . . . D QUEUE^C0CXPATH("C0CRBLD",C0CTMP,C0CJS,C0CJE) ; ADD TO BUILD LIST
-        . . . ;I C0CJ=1 D  ; FIRST TIME, JUST COPY
-        . . . ;. D CP^C0CXPATH("C0CTMP","C0CTO") ; START BUILDING TEST XML
-        . . . ;E  D INSINNER^C0CXPATH("C0CTO","C0CTMP")
-        . . . ;
-        . . . ;D PUSHA^C0CXPATH("C0CTO",C0CTMP) ;ADD THE TEST TO BUFFER
-        . . ; I 'C0CQT D PARY^C0CXPATH("C0CTO")
-        . . ;D INSINNER^C0CXPATH(C0CRTMP,"C0CTO","//Results/Result/Test") ;INSERT TST
-        . ;D QCLOSE^C0CXPATH("C0CRBLD",C0CRTMP,"//Results/Result/Test") ;END OF XML
-        . D QUEUE^C0CXPATH("C0CRBLD","C0CRT",C0CRT(0)-1,C0CRT(0)-1) ;</Result>
-        . ;I C0CI=1 D  ; FIRST TIME, COPY INSTEAD OF INSERT
-        . . ;D CP^C0CXPATH(C0CRTMP,"RTN") ;
-        . ;E  D INSINNER^C0CXPATH("RTN",C0CRTMP) ; INSERT THIS TEST REQUEST
-        D QUEUE^C0CXPATH("C0CRBLD","C0CRT",C0CRT(0),C0CRT(0)) ;</Results>
-        D BUILD^C0CXPATH("C0CRBLD","RTN") ;RENDER THE XML
-        K @C0CRBASE ; CLEAR OUT TEMPORARY STURCTURE
-        Q
-        ;
-EXTRACT(ILXML,DFN,OLXML)        ; EXTRACT LABS INTO THE C0CLVAR GLOBAL
-        ;
-        ; LABXML AND LABOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
-        ;
-        ;
-        ;
-        N C0CNSSN ; IS THERE AN SSN FLAG
-        S C0CNSSN=0
-        S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS
-        D GHL7 ; GET HL7 MESSAGE FOR THIS PATIENT
-        I C0CNSSN=1 D  Q  ; NO SSN, CAN'T GET HL7 FOR THIS PATIENT
-        . S @C0CLB@(0)=0
-        K @C0CLB ; CLEAR OUT OLD VARS IF ANY
-        N QTSAV S QTSAV=C0CQT ;SAVE QUIET FLAG
-        S C0CQT=1 ; SURPRESS LISTING
-        D LIST ; EXTRACT THE VARIABLES
-        ; FOR CERTIFICATION, SEE IF THERE ARE OTHER RESULTS TO ADD
-        D EN^C0CORSLT(C0CLB,DFN) ; LOOKS FOR ECG TESTS
-        S C0CQT=QTSAV ; RESET SILENT FLAG
-        K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT
-        I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^C0CLABS
-        Q
-            ;
-GHL7    ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT
-        ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR
-        ; SET UP FOR LAB API CALL
-        S C0CPTID=$$SSN^C0CDPT(DFN) ; GET THE SSN FOR THIS PATIENT
-        I C0CPTID="" D  Q  ; NO SSN, COMPLAIN AND QUIT
-        . W "LAB LOOKUP FAILED, NO SSN",!
-        . S C0CNSSN=1 ; SET NO SSN FLAG
-        S C0CSPC="*" ; LOOKING FOR ALL LABS
-        ;I $D(^TMP("C0CCCR","RPMS")) D  ; RUNNING RPMS
-        ;. D DT^DILF(,"T-365",.C0CSDT) ; START DATE ONE YEAR AGO TO LIMIT VOLUME
-        ;E  D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING
-        ;D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY
-        S C0CLLMT=$$GET^C0CPARMS("LABLIMIT") ; GET THE LIMIT PARM
-        S C0CLSTRT=$$GET^C0CPARMS("LABSTART") ; GET START PARM
-        D DT^DILF(,C0CLLMT,.C0CSDT) ;
-        W "LAB LIMIT: ",C0CLLMT,!
-        D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM
-        S C0CEDT=$$NOW^XLFDT ; PULL LABS STARTING NOW
-        S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP
-        Q
-        ;
-LIST    ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB
-        ;
-        ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR
-        I '$D(C0CLB) S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS
-        I '$D(C0CQT) S C0CQT=0
-        I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT
-        I '$D(^TMP("C0CCCR","LABTBL",0)) D SETTBL ;INITIALIZE LAB TABLE
-        I ^TMP("C0CCCR","LABTBL",0)'="V3" D SETTBL ;NEED NEWEST VERSION
-        I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE
-        S C0CTAB=$NA(^TMP("C0CCCR","LABTBL")) ; BASE OF OBX TABLE
-        S C0CHB=$NA(^TMP("HLS",$J))
-        S C0CI=""
-        S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT
-        F  S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI=""  D  ; FOR ALL RECORDS IN HL7 MSG
-        . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES
-        . S C0CTYP=$P(@C0CHB@(C0CI),"|",1)
-        . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT)
-        . I $G(C0CVAR("RESULTCODINGSYSTEM"))="LN" D  ; gpl - for certification
-        . . S C0CVAR("RESULTCODINGSYSTEM")="LOINC" ; NEED TO SPELL IT OUT
-        . . N C0CRDT S C0CRDT=C0CVAR("RESULTDESCRIPTIONTEXT") ; THE DESCRIPTION
-        . . N C0CRCD S C0CRCD=C0CVAR("RESULTCODE") ; THE LOINC CODE
-        . . S C0CVAR("RESULTDESCRIPTIONTEXT")=C0CRDT_" LOINC: "_C0CRCD
-        . M XV=C0CVAR ;
-        . I C0CTYP="OBR" D  ; BEGINNING OF NEW SECTION
-        . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT
-        . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT
-        . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS
-        . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI
-        . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR
-        . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1)
-        . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT
-        . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL
-        . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME
-        . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS
-        . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION
-        . I C0CTYP="OBX" D  ; SPECIAL CASE FOR OBX3
-        . . ; RESULTTESTCODEVALUE
-        . . ; RESULTTESTDESCRIPTIONTEXT
-        . . I C0CVAR("C3")="LN" D  ; PRIMARY CODE IS LOINC
-        . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE
-        . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC
-        . . . ;S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESC TXT
-        . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2")_" LOINC: "_C0CVAR("C1")
-        . . E  I C0CVAR("C6")="LN" D  ; SECONDARY CODE IS LOINC
-        . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE
-        . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC
-        . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT
-        . . E  I C0CVAR("C6")'="" D  ; NO LOINC CODES, USE SECONDARY IF PRESENT
-        . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE
-        . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME
-        . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT
-        . . E  D  ; NO SECONDARY, USE PRIMARY
-        . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE
-        . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME
-        . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT
-        . . N C0CZG S C0CZG=XV("RESULTTESTNORMALDESCTEXT") ;
-        . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH
-        . . ;S XV("RESULTTESTNORMALDESCTEXT")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE
-        . . S XV("RESULTTESTNORMALDESCTEXT")=C0CZG
-        . . S C0CZG=XV("RESULTTESTVALUE")
-         . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH
-        . . ;S XV("RESULTTESTVALUE")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE
-        . . S XV("RESULTTESTVALUE")=C0CZG
-        . I C0CTYP="OBX" D  ; PROCESS TEST RESULTS
-        . . I C0CLOBX=0 D  ; FIRST TEST RESULT FOR THIS SECTION
-        . . . S C0CLB2=$NA(@C0CLB@(C0CLI,"M","TEST")) ; INDENT FOR TEST RESULTS
-        . . S C0CLOBX=C0CLOBX+1 ; INCREMENT TEST COUNT
-        . . S @C0CLB2@(0)=C0CLOBX ; STORE THE TEST COUNT
-        . . S XV("RESULTTESTOBJECTID")="RESULTTEST_"_C0CLI_"_"_C0CLOBX
-        . . S C0CX1=XV("RESULTTESTSOURCEACTORID") ; TEST SOURCE
-        . . S C0CX2=$P($P(C0CX1,"^",1),"-",1) ; PULL OUT STATION NUMBER
-        . . S XV("RESULTTESTSOURCEACTORID")="ACTORORGANIZATION_"_C0CX2
-        . . S XV("RESULTTESTNORMALSOURCEACTORID")=XV("RESULTTESTSOURCEACTORID")
-        . . S C0CX1=XV("RESULTTESTDATETIME") ;DATE TIME IN HL7 FORMAT
-        . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL
-        . . S XV("RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME
-        . . ; I 'C0CQT ZWR XV
-        . . M @C0CLB2@(C0CLOBX)=XV ; PERSIST THE TEST RESULT VARIABLES
-        . I 'C0CQT D  ;
-        . . W C0CI," ",C0CTYP,!
-        . ; S C0CI=$O(@C0CHB@(C0CI))
-        ;K ^TMP("C0CRIM","VARS",DFN,"RESULTS")
-        ;M ^TMP("C0CRIM","VARS",DFN,"RESULTS")=@C0CLB
-        Q
-LTYP(OSEG,OTYP,OVARA,OC0CQT)    ;
-        S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE
-        I '$D(OC0CQT) S C0CQT=0 ; NOT C0CQT IS DEFAULT
-        E  S C0CQT=OC0CQT ; ACCEPT C0CQT FLAG
-        I 1 D  ; FOR HL7 SEGMENT TYPE
-        . S OI="" ; INDEX INTO FIELDS IN SEG
-        . F  S OI=$O(@OTAB@(OI)) Q:OI=""  D  ; FOR EACH FIELD OF THE SEGMENT
-        . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX
-        . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED
-        . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE
-        . . I $P(OI,";",2)'="" D  ; THIS IS DEFINING A SUB-VALUE
-        . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX
-        . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE
-        . . I OVAR'="" S OVARA(OVAR)=OV ; PASS BACK VARIABLE AND VALUE
-        . . I 'C0CQT D  ; PRINT OUTPUT IF C0CQT IS FALSE
-        . . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,!
-        Q
-LOBX    ;
-        Q
-        ;
-OUT(DFN)        ; WRITE OUT A CCR THAT HAS JUST BEEN PROCESSED (FOR TESTING)
-        N GA,GF,GD
-        S GA=$NA(^TMP("C0CCCR",$J,DFN,"CCR",1))
-        S GF="RPMS_CCR_"_DFN_"_"_DT_".xml"
-        S GD=^TMP("C0CCCR","ODIR")
-        W $$OUTPUT^C0CXPATH(GA,GF,GD)
-        Q
-        ;
-SETTBL  ;
-        K X ; CLEAR X
-        S X("PID","PID1")="1^00104^Set ID - Patient ID"
-        S X("PID","PID2")="2^00105^Patient ID (External ID)"
-        S X("PID","PID3")="3^00106^Patient ID (Internal ID)"
-        S X("PID","PID4")="4^00107^Alternate Patient ID"
-        S X("PID","PID5")="5^00108^Patient's Name"
-        S X("PID","PID6")="6^00109^Mother's Maiden Name"
-        S X("PID","PID7")="7^00110^Date of Birth"
-        S X("PID","PID8")="8^00111^Sex"
-        S X("PID","PID9")="9^00112^Patient Alias"
-        S X("PID","PID10")="10^00113^Race"
-        S X("PID","PID11")="11^00114^Patient Address"
-        S X("PID","PID12")="12^00115^County Code"
-        S X("PID","PID13")="13^00116^Phone Number - Home"
-        S X("PID","PID14")="14^00117^Phone Number - Business"
-        S X("PID","PID15")="15^00118^Language - Patient"
-        S X("PID","PID16")="16^00119^Marital Status"
-        S X("PID","PID17")="17^00120^Religion"
-        S X("PID","PID18")="18^00121^Patient Account Number"
-        S X("PID","PID19")="19^00122^SSN Number - Patient"
-        S X("PID","PID20")="20^00123^Drivers License - Patient"
-        S X("PID","PID21")="21^00124^Mother's Identifier"
-        S X("PID","PID22")="22^00125^Ethnic Group"
-        S X("PID","PID23")="23^00126^Birth Place"
-        S X("PID","PID24")="24^00127^Multiple Birth Indicator"
-        S X("PID","PID25")="25^00128^Birth Order"
-        S X("PID","PID26")="26^00129^Citizenship"
-        S X("PID","PID27")="27^00130^Veteran.s Military Status"
-        S X("PID","PID28")="28^00739^Nationality"
-        S X("PID","PID29")="29^00740^Patient Death Date/Time"
-        S X("PID","PID30")="30^00741^Patient Death Indicator"
-        S X("NTE","NTE1")="1^00573^Set ID - NTE"
-        S X("NTE","NTE2")="2^00574^Source of Comment"
-        S X("NTE","NTE3")="3^00575^Comment"
-        S X("ORC","ORC1")="1^00215^Order Control"
-        S X("ORC","ORC2")="2^00216^Placer Order Number"
-        S X("ORC","ORC3")="3^00217^Filler Order Number"
-        S X("ORC","ORC4")="4^00218^Placer Order Number"
-        S X("ORC","ORC5")="5^00219^Order Status"
-        S X("ORC","ORC6")="6^00220^Response Flag"
-        S X("ORC","ORC7")="7^00221^Quantity/Timing"
-        S X("ORC","ORC8")="8^00222^Parent"
-        S X("ORC","ORC9")="9^00223^Date/Time of Transaction"
-        S X("ORC","ORC10")="10^00224^Entered By"
-        S X("ORC","ORC11")="11^00225^Verified By"
-        S X("ORC","ORC12")="12^00226^Ordering Provider"
-        S X("ORC","ORC13")="13^00227^Enterer's Location"
-        S X("ORC","ORC14")="14^00228^Call Back Phone Number"
-        S X("ORC","ORC15")="15^00229^Order Effective Date/Time"
-        S X("ORC","ORC16")="16^00230^Order Control Code Reason"
-        S X("ORC","ORC17")="17^00231^Entering Organization"
-        S X("ORC","ORC18")="18^00232^Entering Device"
-        S X("ORC","ORC19")="19^00233^Action By"
-        S X("OBR","OBR1")="1^00237^Set ID - Observation Request"
-        S X("OBR","OBR2")="2^00216^Placer Order Number"
-        S X("OBR","OBR3")="3^00217^Filler Order Number"
-        S X("OBR","OBR4")="4^00238^Universal Service ID"
-        S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE"
-        S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT"
-        S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE^RESULTCODINGSYSTEM"
-        S X("OBR","OBR5")="5^00239^Priority"
-        S X("OBR","OBR6")="6^00240^Requested Date/Time"
-        S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME"
-        S X("OBR","OBR8")="8^00242^Observation End Date/Time"
-        S X("OBR","OBR9")="9^00243^Collection Volume"
-        S X("OBR","OBR10")="10^00244^Collector Identifier"
-        S X("OBR","OBR11")="11^00245^Specimen Action Code"
-        S X("OBR","OBR12")="12^00246^Danger Code"
-        S X("OBR","OBR13")="13^00247^Relevant Clinical Info."
-        S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time"
-        S X("OBR","OBR15")="15^00249^Specimen Source"
-        S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID"
-        S X("OBR","OBR17")="17^00250^Order Callback Phone Number"
-        S X("OBR","OBR18")="18^00251^Placers Field 1"
-        S X("OBR","OBR19")="19^00252^Placers Field 2"
-        S X("OBR","OBR20")="20^00253^Filler Field 1"
-        S X("OBR","OBR21")="21^00254^Filler Field 2"
-        S X("OBR","OBR22")="22^00255^Results Rpt./Status Change"
-        S X("OBR","OBR23")="23^00256^Charge to Practice"
-        S X("OBR","OBR24")="24^00257^Diagnostic Service Sect"
-        S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS"
-        S X("OBR","OBR26")="26^00259^Parent Result"
-        S X("OBR","OBR27")="27^00221^Quantity/Timing"
-        S X("OBR","OBR28")="28^00260^Result Copies to"
-        S X("OBR","OBR29")="29^00261^Parent Number"
-        S X("OBR","OBR30")="30^00262^Transportation Mode"
-        S X("OBR","OBR31")="31^00263^Reason for Study"
-        S X("OBR","OBR32")="32^00264^Principal Result Interpreter"
-        S X("OBR","OBR33")="33^00265^Assistant Result Interpreter"
-        S X("OBR","OBR34")="34^00266^Technician"
-        S X("OBR","OBR35")="35^00267^Transcriptionist"
-        S X("OBR","OBR36")="36^00268^Scheduled Date/Time"
-        S X("OBR","OBR37")="37^01028^Number of Sample Containers"
-        S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample"
-        S X("OBR","OBR39")="39^01030^Collector.s Comment"
-        S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility"
-        S X("OBR","OBR41")="41^01032^Transport Arranged"
-        S X("OBR","OBR42")="42^01033^Escort Required"
-        S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment"
-        S X("OBX","OBX1")="1^00559^Set ID - OBX"
-        S X("OBX","OBX2")="2^00676^Value Type"
-        S X("OBX","OBX3")="3^00560^Observation Identifier"
-        S X("OBX","OBX3;C1")="3;1^00560^Observation Identifier^C1"
-        S X("OBX","OBX3;C2")="3;2^00560^Observation Identifier^C2"
-        S X("OBX","OBX3;C3")="3;3^00560^Observation Identifier^C3"
-        S X("OBX","OBX3;C4")="3;4^00560^Observation Identifier^C4"
-        S X("OBX","OBX3;C5")="3;5^00560^Observation Identifier^C5"
-        S X("OBX","OBX3;C6")="3;6^00560^Observation Identifier^C6"
-        S X("OBX","OBX4")="4^00769^Observation Sub-Id"
-        S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE"
-        S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS"
-        S X("OBX","OBX7")="7^00563^Reference Range^RESULTTESTNORMALDESCTEXT"
-        S X("OBX","OBX8")="8^00564^Abnormal Flags^RESULTTESTFLAG"
-        S X("OBX","OBX9")="9^00639^Probability"
-        S X("OBX","OBX10")="10^00565^Nature of Abnormal Test"
-        S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT"
-        S X("OBX","OBX12")="12^00567^Date Last Normal Value"
-        S X("OBX","OBX13")="13^00581^User Defined Access Checks"
-        S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME"
-        S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID"
-        S X("OBX","OBX16")="16^00584^Responsible Observer"
-        S X("OBX","OBX17")="17^00936^Observation Method"
-        K ^TMP("C0CCCR","LABTBL")
-        M ^TMP("C0CCCR","LABTBL")=X ; SET VALUES IN LAB TBL
-        S ^TMP("C0CCCR","LABTBL",0)="V3"
-        Q
-        ;
+C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008,2009 George Lilly, University of Minnesota.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+           ;
+MAP(MIXML,DFN,MOXML) ;TO MAKE THIS COMPATIBLE WITH OLD CALLING FOR EXTRACT
+ ; ASSUMES THAT EXTRACT HAS BEEN RUN AND THE VARIABLES STORED IN MIVAR
+ ; MIXML,MIVAR, AND MOXML ARE PASSED BY NAME
+ ; MIXML IS THE TEMPLATE TO USE
+ ; MOXML IS THE OUTPUT XML ARRAY
+ ; DFN IS THE PATIENT RECORD NUMBER
+ N C0COXML,C0CO,C0CV,C0CIXML
+ I '$D(MIVAR) S C0CV="" ;DEFAULT
+ E  S C0CV=MIVAR ;PASSED VARIABLE ARRAY
+ I '$D(MIXML) S C0CIXML="" ;DEFAULT
+ E  S C0CIXML=MIXML ;PASSED INPUT XML
+ D RPCMAP(.C0COXML,DFN,C0CV,C0CIXML) ; CALL RPC TO DO THE WORK
+ I '$D(MOXML) S C0CO=$NA(^TMP("C0CCCR",$J,DFN,"RESULTS")) ;DEFAULT FOR OUTPUT
+ E  S C0CO=MOXML
+ ; ZWR C0COXML
+ M @C0CO=C0COXML ; COPY RESULTS TO OUTPUT
+ Q
+ ;
+RPCMAP(RTN,DFN,RMIVAR,RMIXML) ; RPC ENTRY POINT FOR MAPPING RESULTS
+ ; RTN IS PASSED BY REFERENCE
+ ;N C0CT0,C0CT,C0CV ; CCR TEMPLATE, RESULTS SUBTEMPLATE, VARIABLES
+ ;N C0CRT,C0CTT ; TEST REQUEST TEMPLATE, TEST RESULT TEMPLATE
+ I '$D(DEBUG) S DEBUG=0 ; DEFAULT NO DEBUGGING
+ I RMIXML="" D  ; INPUT XML NOT PASSED
+ . D LOAD^C0CCCR0("C0CT0") ; LOAD ENTIRE CCR TEMPLATE
+ . D QUERY^C0CXPATH("C0CT0","//ContinuityOfCareRecord/Body/Results","C0CT0R")
+ . S C0CT="C0CT0R" ; NAME OF EXTRACTED RESULTS TEMPLATE
+ E  S C0CT=RMIXML ; WE ARE PASSED THE RESULTS PART OF THE TEMPLATE
+ I RMIVAR="" D  ; LOCATION OF VARIABLES NOT PASSED
+ . S C0CV=$NA(^TMP("C0CCCR",$J,"RESULTS")) ;DEFAULT VARIABLE LOCATION
+ E  S C0CV=RMIVAR ; PASSED LOCATIONS OF VARS
+ D CP^C0CXPATH(C0CT,"C0CRT") ; START MAKING TEST REQUEST TEMPLATE
+ D REPLACE^C0CXPATH("C0CRT","","//Results/Result/Test") ; DELETE TEST FROM REQ
+ D QUERY^C0CXPATH(C0CT,"//Results/Result/Test","C0CTT") ; MAKE TEST TEMPLATE
+ I '$D(C0CQT) S C0CQT=0 ; DEFAULT NOT SILENT
+ I 'C0CQT D  ; WE ARE DEBUGGING
+ . W "I MAPPED",!
+ . W "VARS:",C0CV,!
+ . W "DFN:",DFN,!
+ . ;D PARY^C0CXPATH("C0CT") ; SECTION TEMPLATE
+ . ;D PARY^C0CXPATH("C0CRT") ;REQUEST TEMPLATE (OCR)
+ . ;D PARY^C0CXPATH("C0CTT") ;TEST TEMPLATE (OCX)
+ D EXTRACT("C0CT",DFN,) ; FIRST CALL EXTRACT
+ I '$D(@C0CV@(0)) D  Q  ; NO VARS THERE
+ . S RTN(0)=0 ; PASS BACK NO RESULTS INDICATOR
+ I @C0CV@(0)=0 S RTN(0)=0 Q ; NO RESULTS
+ S RIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"RESULTS"))
+ K @RIMVARS
+ M @RIMVARS=@C0CV ; UPDATE RIMVARS SO THEY STAY IN SYNCH
+ N C0CI,C0CJ,C0CMAP,C0CTMAP,C0CTMP
+ S C0CIN=@C0CV@(0) ; COUNT OF RESULTS (OBR)
+ N C0CRTMP ; AREA TO BUILD ONE RESULT REQUEST AND ALL TESTS FOR IT
+ N C0CRBASE S C0CRBASE=$NA(^TMP($J,"TESTTMP")) ;WORK AREA
+ N C0CRBLD ; BUILD LIST FOR XML - THE BUILD IS DELAYED UNTIL THE END
+ ; TO IMPROVE PERFORMANCE
+ D QUEUE^C0CXPATH("C0CRBLD","C0CRT",1,1) ;<Results>
+ F C0CI=1:1:C0CIN D  ; LOOP THROUGH VARIABLES
+ . K C0CMAP,C0CTMP ;EMPTY OUT LAST BATCH OF VARIABLES
+ . S C0CRTMP=$NA(@C0CRBASE@(C0CI)) ;PARTITION OF WORK AREA FOR EACH TEST
+ . S C0CMAP=$NA(@C0CV@(C0CI)) ;
+ . I 'C0CQT W "MAPOBR:",C0CMAP,!
+ . ;MAPPING FOR TEST REQUEST GOES HERE
+ . D MAP^C0CXPATH("C0CRT",C0CMAP,C0CRTMP) ; MAP OBR DATA
+ . ;D QOPEN^C0CXPATH("C0CRBLD",C0CRTMP,C0CIS) ;1ST PART OF XML
+ . D QUEUE^C0CXPATH("C0CRBLD",C0CRTMP,2,@C0CRTMP@(0)-4) ;UP TO <Test>
+ . I $D(@C0CMAP@("M","TEST",0)) D  ; TESTS EXIST
+ . . S C0CJN=@C0CMAP@("M","TEST",0) ; NUMBER OF TESTS
+ . . K C0CTO ; CLEAR OUTPUT VARIABLE
+ . . F C0CJ=1:1:C0CJN D   ;FOR EACH TEST RESULT
+ . . . K C0CTMAP ; EMPTY MAPS FOR TEST RESULTS
+ . . . S C0CTMP=$NA(@C0CRBASE@(C0CI,C0CJ)) ;WORK AREA FOR TEST RESULTS
+ . . . S C0CTMAP=$NA(@C0CMAP@("M","TEST",C0CJ)) ;
+ . . . I 'C0CQT W "MAPOBX:",C0CTMAP,!
+ . . . D MAP^C0CXPATH("C0CTT",C0CTMAP,C0CTMP) ; MAP TO TMP
+ . . . I C0CJ=1 S C0CJS=2 E  S C0CJS=1 ;FIRST TIME,SKIP THE <Test>
+ . . . I C0CJ=C0CJN S C0CJE=@C0CTMP@(0)-1 E  S C0CJE=@C0CTMP@(0) ;</Test>
+ . . . S C0CJS=1 S C0CJE=@C0CTMP@(0) ; INSERT ALL OF THE TEXT XML
+ . . . D QUEUE^C0CXPATH("C0CRBLD",C0CTMP,C0CJS,C0CJE) ; ADD TO BUILD LIST
+ . . . ;I C0CJ=1 D  ; FIRST TIME, JUST COPY
+ . . . ;. D CP^C0CXPATH("C0CTMP","C0CTO") ; START BUILDING TEST XML
+ . . . ;E  D INSINNER^C0CXPATH("C0CTO","C0CTMP")
+ . . . ;
+ . . . ;D PUSHA^C0CXPATH("C0CTO",C0CTMP) ;ADD THE TEST TO BUFFER
+ . . ; I 'C0CQT D PARY^C0CXPATH("C0CTO")
+ . . ;D INSINNER^C0CXPATH(C0CRTMP,"C0CTO","//Results/Result/Test") ;INSERT TST
+ . ;D QCLOSE^C0CXPATH("C0CRBLD",C0CRTMP,"//Results/Result/Test") ;END OF XML
+ . D QUEUE^C0CXPATH("C0CRBLD","C0CRT",C0CRT(0)-1,C0CRT(0)-1) ;</Result>
+ . ;I C0CI=1 D  ; FIRST TIME, COPY INSTEAD OF INSERT
+ . . ;D CP^C0CXPATH(C0CRTMP,"RTN") ;
+ . ;E  D INSINNER^C0CXPATH("RTN",C0CRTMP) ; INSERT THIS TEST REQUEST
+ D QUEUE^C0CXPATH("C0CRBLD","C0CRT",C0CRT(0),C0CRT(0)) ;</Results>
+ D BUILD^C0CXPATH("C0CRBLD","RTN") ;RENDER THE XML
+ K @C0CRBASE ; CLEAR OUT TEMPORARY STURCTURE
+ Q
+ ;
+EXTRACT(ILXML,DFN,OLXML) ; EXTRACT LABS INTO THE C0CLVAR GLOBAL
+ ;
+ ; LABXML AND LABOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
+ ;
+ ;
+ ;
+ N C0CNSSN ; IS THERE AN SSN FLAG
+ S C0CNSSN=0
+ S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS
+ D GHL7 ; GET HL7 MESSAGE FOR THIS PATIENT
+ I C0CNSSN=1 D  Q  ; NO SSN, CAN'T GET HL7 FOR THIS PATIENT
+ . S @C0CLB@(0)=0
+ K @C0CLB ; CLEAR OUT OLD VARS IF ANY
+ N QTSAV S QTSAV=C0CQT ;SAVE QUIET FLAG
+ S C0CQT=1 ; SURPRESS LISTING
+ D LIST ; EXTRACT THE VARIABLES
+ ; FOR CERTIFICATION, SEE IF THERE ARE OTHER RESULTS TO ADD
+ D EN^C0CORSLT(C0CLB,DFN) ; LOOKS FOR ECG TESTS
+ S C0CQT=QTSAV ; RESET SILENT FLAG
+ K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT
+ I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^C0CLABS
+ Q
+     ;
+GHL7 ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT
+ ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR
+ ; SET UP FOR LAB API CALL
+ S C0CPTID=$$SSN^C0CDPT(DFN) ; GET THE SSN FOR THIS PATIENT
+ I C0CPTID="" D  Q  ; NO SSN, COMPLAIN AND QUIT
+ . W "LAB LOOKUP FAILED, NO SSN",!
+ . S C0CNSSN=1 ; SET NO SSN FLAG
+ S C0CSPC="*" ; LOOKING FOR ALL LABS
+ ;I $D(^TMP("C0CCCR","RPMS")) D  ; RUNNING RPMS
+ ;. D DT^DILF(,"T-365",.C0CSDT) ; START DATE ONE YEAR AGO TO LIMIT VOLUME
+ ;E  D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING
+ ;D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY
+ S C0CLLMT=$$GET^C0CPARMS("LABLIMIT") ; GET THE LIMIT PARM
+ S C0CLSTRT=$$GET^C0CPARMS("LABSTART") ; GET START PARM
+ D DT^DILF(,C0CLLMT,.C0CSDT) ;
+ W "LAB LIMIT: ",C0CLLMT,!
+ D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM
+ S C0CEDT=$$NOW^XLFDT ; PULL LABS STARTING NOW
+ S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP
+ Q
+ ;
+LIST ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB
+ ;
+ ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR
+ I '$D(C0CLB) S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS
+ I '$D(C0CQT) S C0CQT=0
+ I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT
+ I '$D(^TMP("C0CCCR","LABTBL",0)) D SETTBL ;INITIALIZE LAB TABLE
+ I ^TMP("C0CCCR","LABTBL",0)'="V3" D SETTBL ;NEED NEWEST VERSION
+ I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE
+ S C0CTAB=$NA(^TMP("C0CCCR","LABTBL")) ; BASE OF OBX TABLE
+ S C0CHB=$NA(^TMP("HLS",$J))
+ S C0CI=""
+ S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT
+ F  S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI=""  D  ; FOR ALL RECORDS IN HL7 MSG
+ . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES
+ . S C0CTYP=$P(@C0CHB@(C0CI),"|",1)
+ . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT)
+ . I $G(C0CVAR("RESULTCODINGSYSTEM"))="LN" D  ; gpl - for certification
+ . . S C0CVAR("RESULTCODINGSYSTEM")="LOINC" ; NEED TO SPELL IT OUT
+ . . N C0CRDT S C0CRDT=C0CVAR("RESULTDESCRIPTIONTEXT") ; THE DESCRIPTION
+ . . N C0CRCD S C0CRCD=C0CVAR("RESULTCODE") ; THE LOINC CODE
+ . . S C0CVAR("RESULTDESCRIPTIONTEXT")=C0CRDT_" LOINC: "_C0CRCD
+ . M XV=C0CVAR ;
+ . I C0CTYP="OBR" D  ; BEGINNING OF NEW SECTION
+ . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT
+ . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT
+ . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS
+ . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI
+ . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR
+ . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1)
+ . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT
+ . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL
+ . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME
+ . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS
+ . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION
+ . I C0CTYP="OBX" D  ; SPECIAL CASE FOR OBX3
+ . . ; RESULTTESTCODEVALUE
+ . . ; RESULTTESTDESCRIPTIONTEXT
+ . . I C0CVAR("C3")="LN" D  ; PRIMARY CODE IS LOINC
+ . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE
+ . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC
+ . . . ;S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESC TXT
+ . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2")_" LOINC: "_C0CVAR("C1")
+ . . E  I C0CVAR("C6")="LN" D  ; SECONDARY CODE IS LOINC
+ . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE
+ . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC
+ . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT
+ . . E  I C0CVAR("C6")'="" D  ; NO LOINC CODES, USE SECONDARY IF PRESENT
+ . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE
+ . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME
+ . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT
+ . . E  D  ; NO SECONDARY, USE PRIMARY
+ . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE
+ . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME
+ . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT
+ . . N C0CZG S C0CZG=XV("RESULTTESTNORMALDESCTEXT") ;
+ . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH
+ . . ;S XV("RESULTTESTNORMALDESCTEXT")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE
+ . . S XV("RESULTTESTNORMALDESCTEXT")=C0CZG
+ . . S C0CZG=XV("RESULTTESTVALUE")
+  . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH
+ . . ;S XV("RESULTTESTVALUE")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE
+ . . S XV("RESULTTESTVALUE")=C0CZG
+ . I C0CTYP="OBX" D  ; PROCESS TEST RESULTS
+ . . I C0CLOBX=0 D  ; FIRST TEST RESULT FOR THIS SECTION
+ . . . S C0CLB2=$NA(@C0CLB@(C0CLI,"M","TEST")) ; INDENT FOR TEST RESULTS
+ . . S C0CLOBX=C0CLOBX+1 ; INCREMENT TEST COUNT
+ . . S @C0CLB2@(0)=C0CLOBX ; STORE THE TEST COUNT
+ . . S XV("RESULTTESTOBJECTID")="RESULTTEST_"_C0CLI_"_"_C0CLOBX
+ . . S C0CX1=XV("RESULTTESTSOURCEACTORID") ; TEST SOURCE
+ . . S C0CX2=$P($P(C0CX1,"^",1),"-",1) ; PULL OUT STATION NUMBER
+ . . S XV("RESULTTESTSOURCEACTORID")="ACTORORGANIZATION_"_C0CX2
+ . . S XV("RESULTTESTNORMALSOURCEACTORID")=XV("RESULTTESTSOURCEACTORID")
+ . . S C0CX1=XV("RESULTTESTDATETIME") ;DATE TIME IN HL7 FORMAT
+ . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL
+ . . S XV("RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME
+ . . ; I 'C0CQT ZWR XV
+ . . M @C0CLB2@(C0CLOBX)=XV ; PERSIST THE TEST RESULT VARIABLES
+ . I 'C0CQT D  ;
+ . . W C0CI," ",C0CTYP,!
+ . ; S C0CI=$O(@C0CHB@(C0CI))
+ ;K ^TMP("C0CRIM","VARS",DFN,"RESULTS")
+ ;M ^TMP("C0CRIM","VARS",DFN,"RESULTS")=@C0CLB
+ Q
+LTYP(OSEG,OTYP,OVARA,OC0CQT) ;
+ S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE
+ I '$D(OC0CQT) S C0CQT=0 ; NOT C0CQT IS DEFAULT
+ E  S C0CQT=OC0CQT ; ACCEPT C0CQT FLAG
+ I 1 D  ; FOR HL7 SEGMENT TYPE
+ . S OI="" ; INDEX INTO FIELDS IN SEG
+ . F  S OI=$O(@OTAB@(OI)) Q:OI=""  D  ; FOR EACH FIELD OF THE SEGMENT
+ . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX
+ . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED
+ . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE
+ . . I $P(OI,";",2)'="" D  ; THIS IS DEFINING A SUB-VALUE
+ . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX
+ . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE
+ . . I OVAR'="" S OVARA(OVAR)=OV ; PASS BACK VARIABLE AND VALUE
+ . . I 'C0CQT D  ; PRINT OUTPUT IF C0CQT IS FALSE
+ . . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,!
+ Q
+LOBX ;
+ Q
+ ;
+OUT(DFN) ; WRITE OUT A CCR THAT HAS JUST BEEN PROCESSED (FOR TESTING)
+ N GA,GF,GD
+ S GA=$NA(^TMP("C0CCCR",$J,DFN,"CCR",1))
+ S GF="RPMS_CCR_"_DFN_"_"_DT_".xml"
+ S GD=^TMP("C0CCCR","ODIR")
+ W $$OUTPUT^C0CXPATH(GA,GF,GD)
+ Q
+ ;
+SETTBL ;
+ K X ; CLEAR X
+ S X("PID","PID1")="1^00104^Set ID - Patient ID"
+ S X("PID","PID2")="2^00105^Patient ID (External ID)"
+ S X("PID","PID3")="3^00106^Patient ID (Internal ID)"
+ S X("PID","PID4")="4^00107^Alternate Patient ID"
+ S X("PID","PID5")="5^00108^Patient's Name"
+ S X("PID","PID6")="6^00109^Mother's Maiden Name"
+ S X("PID","PID7")="7^00110^Date of Birth"
+ S X("PID","PID8")="8^00111^Sex"
+ S X("PID","PID9")="9^00112^Patient Alias"
+ S X("PID","PID10")="10^00113^Race"
+ S X("PID","PID11")="11^00114^Patient Address"
+ S X("PID","PID12")="12^00115^County Code"
+ S X("PID","PID13")="13^00116^Phone Number - Home"
+ S X("PID","PID14")="14^00117^Phone Number - Business"
+ S X("PID","PID15")="15^00118^Language - Patient"
+ S X("PID","PID16")="16^00119^Marital Status"
+ S X("PID","PID17")="17^00120^Religion"
+ S X("PID","PID18")="18^00121^Patient Account Number"
+ S X("PID","PID19")="19^00122^SSN Number - Patient"
+ S X("PID","PID20")="20^00123^Drivers License - Patient"
+ S X("PID","PID21")="21^00124^Mother's Identifier"
+ S X("PID","PID22")="22^00125^Ethnic Group"
+ S X("PID","PID23")="23^00126^Birth Place"
+ S X("PID","PID24")="24^00127^Multiple Birth Indicator"
+ S X("PID","PID25")="25^00128^Birth Order"
+ S X("PID","PID26")="26^00129^Citizenship"
+ S X("PID","PID27")="27^00130^Veteran.s Military Status"
+ S X("PID","PID28")="28^00739^Nationality"
+ S X("PID","PID29")="29^00740^Patient Death Date/Time"
+ S X("PID","PID30")="30^00741^Patient Death Indicator"
+ S X("NTE","NTE1")="1^00573^Set ID - NTE"
+ S X("NTE","NTE2")="2^00574^Source of Comment"
+ S X("NTE","NTE3")="3^00575^Comment"
+ S X("ORC","ORC1")="1^00215^Order Control"
+ S X("ORC","ORC2")="2^00216^Placer Order Number"
+ S X("ORC","ORC3")="3^00217^Filler Order Number"
+ S X("ORC","ORC4")="4^00218^Placer Order Number"
+ S X("ORC","ORC5")="5^00219^Order Status"
+ S X("ORC","ORC6")="6^00220^Response Flag"
+ S X("ORC","ORC7")="7^00221^Quantity/Timing"
+ S X("ORC","ORC8")="8^00222^Parent"
+ S X("ORC","ORC9")="9^00223^Date/Time of Transaction"
+ S X("ORC","ORC10")="10^00224^Entered By"
+ S X("ORC","ORC11")="11^00225^Verified By"
+ S X("ORC","ORC12")="12^00226^Ordering Provider"
+ S X("ORC","ORC13")="13^00227^Enterer's Location"
+ S X("ORC","ORC14")="14^00228^Call Back Phone Number"
+ S X("ORC","ORC15")="15^00229^Order Effective Date/Time"
+ S X("ORC","ORC16")="16^00230^Order Control Code Reason"
+ S X("ORC","ORC17")="17^00231^Entering Organization"
+ S X("ORC","ORC18")="18^00232^Entering Device"
+ S X("ORC","ORC19")="19^00233^Action By"
+ S X("OBR","OBR1")="1^00237^Set ID - Observation Request"
+ S X("OBR","OBR2")="2^00216^Placer Order Number"
+ S X("OBR","OBR3")="3^00217^Filler Order Number"
+ S X("OBR","OBR4")="4^00238^Universal Service ID"
+ S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE"
+ S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT"
+ S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE^RESULTCODINGSYSTEM"
+ S X("OBR","OBR5")="5^00239^Priority"
+ S X("OBR","OBR6")="6^00240^Requested Date/Time"
+ S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME"
+ S X("OBR","OBR8")="8^00242^Observation End Date/Time"
+ S X("OBR","OBR9")="9^00243^Collection Volume"
+ S X("OBR","OBR10")="10^00244^Collector Identifier"
+ S X("OBR","OBR11")="11^00245^Specimen Action Code"
+ S X("OBR","OBR12")="12^00246^Danger Code"
+ S X("OBR","OBR13")="13^00247^Relevant Clinical Info."
+ S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time"
+ S X("OBR","OBR15")="15^00249^Specimen Source"
+ S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID"
+ S X("OBR","OBR17")="17^00250^Order Callback Phone Number"
+ S X("OBR","OBR18")="18^00251^Placers Field 1"
+ S X("OBR","OBR19")="19^00252^Placers Field 2"
+ S X("OBR","OBR20")="20^00253^Filler Field 1"
+ S X("OBR","OBR21")="21^00254^Filler Field 2"
+ S X("OBR","OBR22")="22^00255^Results Rpt./Status Change"
+ S X("OBR","OBR23")="23^00256^Charge to Practice"
+ S X("OBR","OBR24")="24^00257^Diagnostic Service Sect"
+ S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS"
+ S X("OBR","OBR26")="26^00259^Parent Result"
+ S X("OBR","OBR27")="27^00221^Quantity/Timing"
+ S X("OBR","OBR28")="28^00260^Result Copies to"
+ S X("OBR","OBR29")="29^00261^Parent Number"
+ S X("OBR","OBR30")="30^00262^Transportation Mode"
+ S X("OBR","OBR31")="31^00263^Reason for Study"
+ S X("OBR","OBR32")="32^00264^Principal Result Interpreter"
+ S X("OBR","OBR33")="33^00265^Assistant Result Interpreter"
+ S X("OBR","OBR34")="34^00266^Technician"
+ S X("OBR","OBR35")="35^00267^Transcriptionist"
+ S X("OBR","OBR36")="36^00268^Scheduled Date/Time"
+ S X("OBR","OBR37")="37^01028^Number of Sample Containers"
+ S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample"
+ S X("OBR","OBR39")="39^01030^Collector.s Comment"
+ S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility"
+ S X("OBR","OBR41")="41^01032^Transport Arranged"
+ S X("OBR","OBR42")="42^01033^Escort Required"
+ S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment"
+ S X("OBX","OBX1")="1^00559^Set ID - OBX"
+ S X("OBX","OBX2")="2^00676^Value Type"
+ S X("OBX","OBX3")="3^00560^Observation Identifier"
+ S X("OBX","OBX3;C1")="3;1^00560^Observation Identifier^C1"
+ S X("OBX","OBX3;C2")="3;2^00560^Observation Identifier^C2"
+ S X("OBX","OBX3;C3")="3;3^00560^Observation Identifier^C3"
+ S X("OBX","OBX3;C4")="3;4^00560^Observation Identifier^C4"
+ S X("OBX","OBX3;C5")="3;5^00560^Observation Identifier^C5"
+ S X("OBX","OBX3;C6")="3;6^00560^Observation Identifier^C6"
+ S X("OBX","OBX4")="4^00769^Observation Sub-Id"
+ S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE"
+ S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS"
+ S X("OBX","OBX7")="7^00563^Reference Range^RESULTTESTNORMALDESCTEXT"
+ S X("OBX","OBX8")="8^00564^Abnormal Flags^RESULTTESTFLAG"
+ S X("OBX","OBX9")="9^00639^Probability"
+ S X("OBX","OBX10")="10^00565^Nature of Abnormal Test"
+ S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT"
+ S X("OBX","OBX12")="12^00567^Date Last Normal Value"
+ S X("OBX","OBX13")="13^00581^User Defined Access Checks"
+ S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME"
+ S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID"
+ S X("OBX","OBX16")="16^00584^Responsible Observer"
+ S X("OBX","OBX17")="17^00936^Observation Method"
+ K ^TMP("C0CCCR","LABTBL")
+ M ^TMP("C0CCCR","LABTBL")=X ; SET VALUES IN LAB TBL
+ S ^TMP("C0CCCR","LABTBL",0)="V3"
+ Q
+ ;

ccr/trunk/p/C0CMAIL2.m

@@ -1 +1 @@
 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
-V ;;0.1;C0C;nopatch;noreleasedate
+ ;;0.1;C0C;nopatch;noreleasedate
  ;Copyright 2011 Chris Richardson, Richardson Computer Research
  ; Modified 3110615@1040

ccr/trunk/p/C0CMAIL3.m

@@ -1 +1 @@
 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
-V ;;0.1;C0C;nopatch;noreleasedate
+ ;;0.1;C0C;nopatch;noreleasedate
  ;Copyright 2011 Chris Richardson, Richardson Computer Research
  ; Modified 3110619@2038

ccr/trunk/p/C0CMED.m

@@ -1 @@
-C0CMED  ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel.
-        ; Licensed under the terms of the GNU General Public License.
-        ; See attached copy of the License.
-        ; 
-        ; This program is free software; you can redistribute it and/or modify
-        ; it under the terms of the GNU General Public License as published by
-        ; the Free Software Foundation; either version 2 of the License, or
-        ; (at your option) any later version.
-        ; 
-        ; This program is distributed in the hope that it will be useful,
-        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ; GNU General Public License for more details.
-        ; 
-        ; You should have received a copy of the GNU General Public License along
-        ; with this program; if not, write to the Free Software Foundation, Inc.,
-        ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        ; --Revision History
-        ; July 2008 - Initial Version/GPL
-        ; July 2008 - March 2009 various revisions
-        ; March 2009 - Reconstruction of routine as driver for other med routines/SMH
-        ;
-        Q
-EXTRACT(MEDXML,DFN,MEDOUTXML)   ; Private; Extract medications into provided XML template
-        ; DFN passed by reference
-        ; MEDXML and MEDOUTXML are passed by Name
-        ; MEDXML is the input template
-        ; MEDOUTXML is the output template
-        ; Both of them refer to ^TMP globals where the XML documents are stored
-        ; 
-        ; -- This ep is the driver for extracting medications into the provided XML template
-        ; 1. VA Outpatient Meds are in C0CMED1
-        ; 2. VA Pending Meds are in C0CMED2
-        ; 3. VA non-VA Meds are in C0CMED3
-        ; 4. VA Inpatient IV Meds are in C0CMED4 (not functional)
-        ; 5. VA Inpatient UD Meds are in C0CMED5 (doesn't exist yet)--March 2009
-        ; 6. RPMS Meds are in C0CMED6. Need to create other routines for subdivisions of RPMS Meds is not known at this time.
-        ;
-        ; --Get parameters for meds
-        S @MEDOUTXML@(0)=0 ; By default, empty.
-        N C0CMFLAG
-        S C0CMFLAG=$$GET^C0CPARMS("MEDALL")_"^"_$$GET^C0CPARMS("MEDLIMIT")_"^"_$$GET^C0CPARMS("MEDACTIVE")_"^"_$$GET^C0CPARMS("MEDPENDING")
-        W:$G(DEBUG) "Med Parameters: ",!
-        W:$G(DEBUG) "ALL: ",+C0CMFLAG,!
-        W:$G(DEBUG) "LIMIT: ",$P(C0CMFLAG,U,2),!
-        W:$G(DEBUG) "ACTIVE: ",$P(C0CMFLAG,U,3),!
-        W:$G(DEBUG) "PEND: ",$P(C0CMFLAG,U,4),!
-        ; --Find out what system we are on and branch out...
-        W:$G(DEBUG) "Agenecy: ",$G(DUZ("AG"))
-        I $$RPMS^C0CUTIL() D RPMS QUIT
-        I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT
-RPMS    
-        ;D EXTRACT^C0CMED6(MEDXML,DFN,MEDOUTXML,C0CMFLAG) QUIT
-        N MEDCOUNT S MEDCOUNT=0
-        K ^TMP($J,"MED")
-        N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed
-        N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds
-        S @HIST@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors)
-        D EXTRACT^C0CMED6(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds
-        D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds 
-        I @HIST@(0)>0 D  
-        . D CP^C0CXPATH(HIST,MEDOUTXML)
-        . W:$G(DEBUG) "HAS ACTIVE OP MEDS",!
-        I @NVA@(0)>0 D 
-        . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,NVA) 
-        . ;E  D CP^C0CXPATH(NVA,MEDOUTXML) 
-        . W:$G(DEBUG) "HAS NON-VA MEDS",!
-        Q
-VISTA   
-        N MEDCOUNT S MEDCOUNT=0
-        K ^TMP($J,"MED")
-        N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed
-        N PEND S PEND=$NA(^TMP($J,"MED","PEND")) ; Pending Meds
-        N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds
-        K @HIST K @PEND K @NVA ; MAKE SURE THEY ARE EMPTY
-        S @HIST@(0)=0,@PEND@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors)
-        ; N IPIV ; Inpatient IV Meds
-        N IPUD S IPUD=$NA(^TMP($J,"MED","IPUD")) ; Inpatient UD Meds
-        K @IPUD
-        S @IPUD@(0)=0
-        ;
-        D EXTRACT^C0CMED1(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds
-        D:$P(C0CMFLAG,U,4) EXTRACT^C0CMED2(MEDXML,DFN,PEND,.MEDCOUNT) ; Pending Meds
-        ;D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds 
-        D EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds GPL
-        D EXTRACT^C0CNMED4(MEDXML,DFN,IPUD,.MEDCOUNT) ; inpatient gpl
-        I @HIST@(0)>0 D  
-        . D CP^C0CXPATH(HIST,MEDOUTXML)
-        . W:$G(DEBUG) "HAS ACTIVE OP MEDS",!
-        I @PEND@(0)>0 D  
-        . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,PEND) ;Add Pending to Historical
-        . E  D CP^C0CXPATH(PEND,MEDOUTXML) ; No historical, just copy
-        . W:$G(DEBUG) "HAS OP PENDING MEDS",!
-        I @NVA@(0)>0 D 
-        . I @HIST@(0)>0!(@PEND@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,NVA) 
-        . E  D CP^C0CXPATH(NVA,MEDOUTXML) 
-        . W:$G(DEBUG) "HAS NON-VA MEDS",!
-        I @IPUD@(0)>0 D 
-        . I @HIST@(0)>0!(@PEND@(0)>0)!(@NVA@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,IPUD) 
-        . E  D CP^C0CXPATH(IPUD,MEDOUTXML) 
-        . W:$G(DEBUG) "HAS INPATIENT MEDS",!
-        N ZI
-        S ZI=$NA(^TMP("C0CCCR",$J,"MEDMAP"))
-        M ^TMP("C0CRIM","VARS",DFN,"MEDS")=@ZI ; PERSIST MEDS VARIABLES
-        K @ZI ; CLEAN UP MED MAP AFTER - GPL 10/10
-        K @PEND
-        K @HIST
-        K @NVA
-        K @IPUD
-        Q
-        
+C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel.
+ ; Licensed under the terms of the GNU General Public License.
+ ; See attached copy of the License.
+ ; 
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ; 
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ; 
+ ; You should have received a copy of the GNU General Public License along
+ ; with this program; if not, write to the Free Software Foundation, Inc.,
+ ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ ; --Revision History
+ ; July 2008 - Initial Version/GPL
+ ; July 2008 - March 2009 various revisions
+ ; March 2009 - Reconstruction of routine as driver for other med routines/SMH
+ ;
+ Q
+EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template
+ ; DFN passed by reference
+ ; MEDXML and MEDOUTXML are passed by Name
+ ; MEDXML is the input template
+ ; MEDOUTXML is the output template
+ ; Both of them refer to ^TMP globals where the XML documents are stored
+ ; 
+ ; -- This ep is the driver for extracting medications into the provided XML template
+ ; 1. VA Outpatient Meds are in C0CMED1
+ ; 2. VA Pending Meds are in C0CMED2
+ ; 3. VA non-VA Meds are in C0CMED3
+ ; 4. VA Inpatient IV Meds are in C0CMED4 (not functional)
+ ; 5. VA Inpatient UD Meds are in C0CMED5 (doesn't exist yet)--March 2009
+ ; 6. RPMS Meds are in C0CMED6. Need to create other routines for subdivisions of RPMS Meds is not known at this time.
+ ;
+ ; --Get parameters for meds
+ S @MEDOUTXML@(0)=0 ; By default, empty.
+ N C0CMFLAG
+ S C0CMFLAG=$$GET^C0CPARMS("MEDALL")_"^"_$$GET^C0CPARMS("MEDLIMIT")_"^"_$$GET^C0CPARMS("MEDACTIVE")_"^"_$$GET^C0CPARMS("MEDPENDING")
+ W:$G(DEBUG) "Med Parameters: ",!
+ W:$G(DEBUG) "ALL: ",+C0CMFLAG,!
+ W:$G(DEBUG) "LIMIT: ",$P(C0CMFLAG,U,2),!
+ W:$G(DEBUG) "ACTIVE: ",$P(C0CMFLAG,U,3),!
+ W:$G(DEBUG) "PEND: ",$P(C0CMFLAG,U,4),!
+ ; --Find out what system we are on and branch out...
+ W:$G(DEBUG) "Agenecy: ",$G(DUZ("AG"))
+ I $$RPMS^C0CUTIL() D RPMS QUIT
+ I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT
+RPMS 
+ ;D EXTRACT^C0CMED6(MEDXML,DFN,MEDOUTXML,C0CMFLAG) QUIT
+ N MEDCOUNT S MEDCOUNT=0
+ K ^TMP($J,"MED")
+ N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed
+ N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds
+ S @HIST@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors)
+ D EXTRACT^C0CMED6(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds
+ D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds 
+ I @HIST@(0)>0 D  
+ . D CP^C0CXPATH(HIST,MEDOUTXML)
+ . W:$G(DEBUG) "HAS ACTIVE OP MEDS",!
+ I @NVA@(0)>0 D 
+ . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,NVA) 
+ . ;E  D CP^C0CXPATH(NVA,MEDOUTXML) 
+ . W:$G(DEBUG) "HAS NON-VA MEDS",!
+ Q
+VISTA 
+ N MEDCOUNT S MEDCOUNT=0
+ K ^TMP($J,"MED")
+ N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed
+ N PEND S PEND=$NA(^TMP($J,"MED","PEND")) ; Pending Meds
+ N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds
+ K @HIST K @PEND K @NVA ; MAKE SURE THEY ARE EMPTY
+ S @HIST@(0)=0,@PEND@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors)
+ ; N IPIV ; Inpatient IV Meds
+ N IPUD S IPUD=$NA(^TMP($J,"MED","IPUD")) ; Inpatient UD Meds
+ K @IPUD
+ S @IPUD@(0)=0
+ ;
+ D EXTRACT^C0CMED1(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds
+ D:$P(C0CMFLAG,U,4) EXTRACT^C0CMED2(MEDXML,DFN,PEND,.MEDCOUNT) ; Pending Meds
+ ;D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds 
+ D EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds GPL
+ D EXTRACT^C0CNMED4(MEDXML,DFN,IPUD,.MEDCOUNT) ; inpatient gpl
+ I @HIST@(0)>0 D  
+ . D CP^C0CXPATH(HIST,MEDOUTXML)
+ . W:$G(DEBUG) "HAS ACTIVE OP MEDS",!
+ I @PEND@(0)>0 D  
+ . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,PEND) ;Add Pending to Historical
+ . E  D CP^C0CXPATH(PEND,MEDOUTXML) ; No historical, just copy
+ . W:$G(DEBUG) "HAS OP PENDING MEDS",!
+ I @NVA@(0)>0 D 
+ . I @HIST@(0)>0!(@PEND@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,NVA) 
+ . E  D CP^C0CXPATH(NVA,MEDOUTXML) 
+ . W:$G(DEBUG) "HAS NON-VA MEDS",!
+ I @IPUD@(0)>0 D 
+ . I @HIST@(0)>0!(@PEND@(0)>0)!(@NVA@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,IPUD) 
+ . E  D CP^C0CXPATH(IPUD,MEDOUTXML) 
+ . W:$G(DEBUG) "HAS INPATIENT MEDS",!
+ N ZI
+ S ZI=$NA(^TMP("C0CCCR",$J,"MEDMAP"))
+ M ^TMP("C0CRIM","VARS",DFN,"MEDS")=@ZI ; PERSIST MEDS VARIABLES
+ K @ZI ; CLEAN UP MED MAP AFTER - GPL 10/10
+ K @PEND
+ K @HIST
+ K @NVA
+ K @IPUD
+ Q
+ 

ccr/trunk/p/C0CMED1.m

@@ -1 @@
-C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;;Last modified Sat Jan 10 21:42:27 PST 2009
-        ; Copyright 2009 WorldVistA.  Licensed under the terms of the GNU
-        ; General Public License See attached copy of the License.
-        ;
-        ; This program is free software; you can redistribute it and/or modify
-        ; it under the terms of the GNU General Public License as published by
-        ; the Free Software Foundation; either version 2 of the License, or
-        ; (at your option) any later version.
-        ;
-        ; This program is distributed in the hope that it will be useful,
-        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ; GNU General Public License for more details.
-        ;
-        ; You should have received a copy of the GNU General Public License along
-        ; with this program; if not, write to the Free Software Foundation, Inc.,
-        ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "NO ENTRY FROM TOP",!
-        Q
-        ;
-EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS)       ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
-        ;
-        ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
-        ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE
-        ;
-        ; MEDS is return array from RPC.
-        ; MAP is a mapping variable map (store result) for each med
-        ; MED is holds each array element from MEDS(J), one medicine
-        ; MEDCOUNT is a counter passed by Reference.
-        ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool)
-        ; FLAGS are set-up in C0CMED.
-        ;
-        ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all
-        ; med data available.
-        ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf
-        ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS).
-        ; D PARY^C0CXPATH(MINXML)
-        N MEDS,MAP
-        K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!!
-        N ALL S ALL=+FLAGS
-        N ACTIVE S ACTIVE=$P(FLAGS,U,3)
-        ; Below, X1 is today; X2 is the number of days we want to go back
-        ; X is the result of this calculation using C^%DTC.
-        N X,X1,X2
-        S X1=DT
-        S X2=-$P($P(FLAGS,U,2),"-",2)
-        D C^%DTC
-        ; I discovered that I shouldn't put an ending date (last parameter)
-        ; because it seems that it will get meds whose beginning is after X but
-        ; whose exipriation is before the ending date.
-        D RX^PSO52API(DFN,"CCDCCR","","","",X,"")
-        M MEDS=^TMP($J,"CCDCCR",DFN)
-        ; @(0) contains the number of meds or -1^NO DATA FOUND
-        ; If it is -1, we quit.
-        I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT
-        ZWRITE:$G(DEBUG) MEDS
-        N RXIEN S RXIEN=0
-        F  S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN=""  D  ; FOR EACH MEDICATION IN THE LIST
-        . N MED M MED=MEDS(RXIEN)
-        . I 'ALL,ACTIVE,$P(MED(100),U,2)'="ACTIVE" QUIT
-        . S MEDCOUNT=MEDCOUNT+1
-        . W:$G(DEBUG) "RXIEN IS ",RXIEN,!
-        . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
-        . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED
-        . W:$G(DEBUG) "MAP= ",MAP,!
-        . S @MAP@("MEDOBJECTID")="MED"_MEDCOUNT ; MEDCOUNT FOR ID
-        . ; S @MAP@("MEDOBJECTID")="MED"_MED(.01) ;Rx Number
-        . S @MAP@("MEDISSUEDATETXT")="Issue Date"
-        . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(1),U))
-        . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date"
-        . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P($G(MED(101)),U))
-        . S @MAP@("MEDRXNOTXT")="Prescription Number"
-        . S @MAP@("MEDRXNO")=MED(.01)
-        . S @MAP@("MEDTYPETEXT")="Medication"
-        . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
-        . S @MAP@("MEDSTATUSTEXT")=$P(MED(100),U,2)
-        . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(4),U)
-        . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(6),U,2)
-        . ; 12/30/08: I will be using RxNorm for coding...
-        . ; 176.001 is the file for Concepts; 176.003 is the file for
-        . ; sources (i.e. for RxNorm Version)
-        . ;
-        . ; We need the VUID first for the National Drug File entry first
-        . ; We get the VUID of the drug, by looking up the VA Product entry
-        . ; (file 50.68) using the call NDF^PSS50, returned in node 22.
-        . ; Field 99.99 is the VUID.
-        . ;
-        . ; We use the VUID to look up the RxNorm in file 176.001; same idea.
-        . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by
-        . ; $$GET1^DIQ.
-        . ;
-        . ; I get the RxNorm name and version from the RxNorm Sources (file
-        . ; 176.003), by searching for "RXNORM", then get the data.
-        . N MEDIEN S MEDIEN=$P(MED(6),U)
-        . D NDF^PSS50(MEDIEN,,,,,"NDF")
-        . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN)
-        . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
-        . N VAPROD S VAPROD=$P(NDFDATA(22),U)
-        . ;
-        . ; NDFIEN is not necessarily defined; it won't be if the drug
-        . ; is not matched to the national drug file (e.g. if the drug is
-        . ; new on the market, compounded, or is a fake drug [blue pill].
-        . ; To protect against failure, I will put an if/else block
-        . ;
-        . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
-        . I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
-        . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
-        . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
-        . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01)
-        . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM")
-        . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
-        . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
-        . ;
-        . E  S (RXNORM,RXNNAME,RXNVER)=""
-        . ; End if/else block
-        . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
-        . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
-        . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
-        . ;
-        . S @MAP@("MEDBRANDNAMETEXT")=MED(6.5)
-        . D DOSE^PSS50(MEDIEN,,,,,"DOSE")
-        . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
-        . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901)
-        . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2)
-        . ; Units, concentration, etc, come from another call
-        . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
-        . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
-        . ; NDF Entry IEN, and VA Product IEN
-        . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
-        . ; These have been collected above.
-        . N CONCDATA
-        . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
-        . ; and this will crash the call. So...
-        . I NDFIEN="" S CONCDATA=""
-        . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
-        . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1)
-        . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3)
-        . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4)
-        . S @MAP@("MEDQUANTITYVALUE")=MED(7)
-        . ; Oddly, there is no easy place to find the dispense unit.
-        . ; It's not included in the original call, so we have to go to the drug file.
-        . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
-        . ; Node 14.5 is the Dispense Unit
-        . D DATA^PSS50(MEDIEN,,,,,"QTY")
-        . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
-        . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
-        . ;
-        . ; --- START OF DIRECTIONS ---
-        . ; Sig data not in any API :-(  Oh yes, you can get the whole thing, but...
-        . ; we want the compoenents.
-        . ; It's in node 6 of ^PSRX(IEN)
-        . ; So, here we go again
-        . ; ^PSRX(D0,6,D1,0)= (#.01) DOSAGE ORDERED [1F] ^ (#1) DISPENSE UNITS PER DOSE
-        . ; ==>[2N] ^ (#2) UNITS [3P:50.607] ^ (#3) NOUN [4F] ^ (#4)
-        . ; ==>DURATION [5F] ^ (#5) CONJUNCTION [6S] ^ (#6) ROUTE
-        . ; ==>[7P:51.2] ^ (#7) SCHEDULE [8F] ^ (#8) VERB [9F] ^
-        . ;
-        . N DIRNUM S DIRNUM=0 ; Sigline number
-        . S DIRCNT=0 ; COUNT OF MULTIPLE DIRECTIONS
-        . F  S DIRNUM=$O(^PSRX(RXIEN,6,DIRNUM)) Q:DIRNUM=""  D
-        . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")=""  ; This is reserved for systems not able to generate the sig in components.
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1"  ; means that we are specifying it. See E2369-05.
-        . . N SIGDATA S SIGDATA=^PSRX(RXIEN,6,DIRNUM,0)
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$P(SIGDATA,U,9)
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$P(SIGDATA,U,1)
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT")
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")=""  ; For inpatient
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")=""  ; For inpatient
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")=""  ; For inpatient
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$$GET1^DIQ(51.2,$P(SIGDATA,U,7),.01)
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$P(SIGDATA,U,8)
-        . . ; Invervals... again another call.
-        . . ; In the wisdom of the original programmers, the schedule is a free text field
-        . . ; However, it gets translated by a call to the administration schedule file
-        . . ; to see if that schedule exists.
-        . . ; That's the same thing I am going to do.
-        . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ).
-        . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO--
-        . . ; I looked), PSSFT is the name, and list is the ^TMP name to store the data in.
-        . . ; So...
-        . . D AP^PSS51P1("PSJ",$P(SIGDATA,U,8),,,"SCHEDULE")
-        . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE")
-        . . N INTERVAL
-        . . I $P(SCHEDATA(0),U)=-1 S INTERVAL=""
-        . . E  D
-        . . . N SUB S SUB=$O(SCHEDATA(0))
-        . . . S INTERVAL=SCHEDATA(SUB,2)
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$P(SIGDATA,U,5)
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$P(SIGDATA,U,8)["PRN"
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM
-        . . N DIRMOD S DIRMOD=$P(SIGDATA,U,6)
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$S(DIRMOD="T":"THEN",DIRMOD="A":"AND",DIRMOD="X":"EXCEPT",1:"")
-        . ;
-        . ; --- END OF DIRECTIONS ---
-        . ;
-        . ; ^PSRX(22,"INS1",1,0)="FOR BLOOD PRESSURE"
-        . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"INS1",1,0))
-        . ; ^PSRX(22,"PRC",1,0)="Pharmacist: you must obey my command"
-        . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PRC",1,0))
-        . S @MAP@("MEDRFNO")=MED(9)
-        . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
-        . K @RESULT
-        . D MAP^C0CXPATH(MINXML,MAP,RESULT)
-        . ; MAPPING DIRECTIONS
-        . N DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
-        . N DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
-        . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
-        . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
-        . ; N MDZ1,MDZNA
-        . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
-        . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
-        . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
-        . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
-        . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
-        . I MEDCOUNT=1 D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
-        . E  D INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML
-        N MEDTMP,MEDI
-        D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
-        I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
-        . W "MEDICATION MISSING ",!
-        . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
-        Q
-        ;
+C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;Last modified Sat Jan 10 21:42:27 PST 2009
+ ; Copyright 2009 WorldVistA.  Licensed under the terms of the GNU
+ ; General Public License See attached copy of the License.
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License along
+ ; with this program; if not, write to the Free Software Foundation, Inc.,
+ ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "NO ENTRY FROM TOP",!
+ Q
+ ;
+EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
+ ;
+ ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
+ ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE
+ ;
+ ; MEDS is return array from RPC.
+ ; MAP is a mapping variable map (store result) for each med
+ ; MED is holds each array element from MEDS(J), one medicine
+ ; MEDCOUNT is a counter passed by Reference.
+ ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool)
+ ; FLAGS are set-up in C0CMED.
+ ;
+ ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all
+ ; med data available.
+ ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf
+ ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS).
+ ; D PARY^C0CXPATH(MINXML)
+ N MEDS,MAP
+ K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!!
+ N ALL S ALL=+FLAGS
+ N ACTIVE S ACTIVE=$P(FLAGS,U,3)
+ ; Below, X1 is today; X2 is the number of days we want to go back
+ ; X is the result of this calculation using C^%DTC.
+ N X,X1,X2
+ S X1=DT
+ S X2=-$P($P(FLAGS,U,2),"-",2)
+ D C^%DTC
+ ; I discovered that I shouldn't put an ending date (last parameter)
+ ; because it seems that it will get meds whose beginning is after X but
+ ; whose exipriation is before the ending date.
+ D RX^PSO52API(DFN,"CCDCCR","","","",X,"")
+ M MEDS=^TMP($J,"CCDCCR",DFN)
+ ; @(0) contains the number of meds or -1^NO DATA FOUND
+ ; If it is -1, we quit.
+ I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT
+ ZWRITE:$G(DEBUG) MEDS
+ N RXIEN S RXIEN=0
+ F  S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN=""  D  ; FOR EACH MEDICATION IN THE LIST
+ . N MED M MED=MEDS(RXIEN)
+ . I 'ALL,ACTIVE,$P(MED(100),U,2)'="ACTIVE" QUIT
+ . S MEDCOUNT=MEDCOUNT+1
+ . W:$G(DEBUG) "RXIEN IS ",RXIEN,!
+ . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
+ . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED
+ . W:$G(DEBUG) "MAP= ",MAP,!
+ . S @MAP@("MEDOBJECTID")="MED"_MEDCOUNT ; MEDCOUNT FOR ID
+ . ; S @MAP@("MEDOBJECTID")="MED"_MED(.01) ;Rx Number
+ . S @MAP@("MEDISSUEDATETXT")="Issue Date"
+ . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(1),U))
+ . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date"
+ . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P($G(MED(101)),U))
+ . S @MAP@("MEDRXNOTXT")="Prescription Number"
+ . S @MAP@("MEDRXNO")=MED(.01)
+ . S @MAP@("MEDTYPETEXT")="Medication"
+ . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
+ . S @MAP@("MEDSTATUSTEXT")=$P(MED(100),U,2)
+ . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(4),U)
+ . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(6),U,2)
+ . ; 12/30/08: I will be using RxNorm for coding...
+ . ; 176.001 is the file for Concepts; 176.003 is the file for
+ . ; sources (i.e. for RxNorm Version)
+ . ;
+ . ; We need the VUID first for the National Drug File entry first
+ . ; We get the VUID of the drug, by looking up the VA Product entry
+ . ; (file 50.68) using the call NDF^PSS50, returned in node 22.
+ . ; Field 99.99 is the VUID.
+ . ;
+ . ; We use the VUID to look up the RxNorm in file 176.001; same idea.
+ . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by
+ . ; $$GET1^DIQ.
+ . ;
+ . ; I get the RxNorm name and version from the RxNorm Sources (file
+ . ; 176.003), by searching for "RXNORM", then get the data.
+ . N MEDIEN S MEDIEN=$P(MED(6),U)
+ . D NDF^PSS50(MEDIEN,,,,,"NDF")
+ . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN)
+ . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
+ . N VAPROD S VAPROD=$P(NDFDATA(22),U)
+ . ;
+ . ; NDFIEN is not necessarily defined; it won't be if the drug
+ . ; is not matched to the national drug file (e.g. if the drug is
+ . ; new on the market, compounded, or is a fake drug [blue pill].
+ . ; To protect against failure, I will put an if/else block
+ . ;
+ . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
+ . I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
+ . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
+ . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
+ . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01)
+ . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM")
+ . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
+ . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
+ . ;
+ . E  S (RXNORM,RXNNAME,RXNVER)=""
+ . ; End if/else block
+ . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
+ . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
+ . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
+ . ;
+ . S @MAP@("MEDBRANDNAMETEXT")=MED(6.5)
+ . D DOSE^PSS50(MEDIEN,,,,,"DOSE")
+ . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
+ . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901)
+ . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2)
+ . ; Units, concentration, etc, come from another call
+ . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
+ . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
+ . ; NDF Entry IEN, and VA Product IEN
+ . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
+ . ; These have been collected above.
+ . N CONCDATA
+ . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
+ . ; and this will crash the call. So...
+ . I NDFIEN="" S CONCDATA=""
+ . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
+ . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1)
+ . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3)
+ . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4)
+ . S @MAP@("MEDQUANTITYVALUE")=MED(7)
+ . ; Oddly, there is no easy place to find the dispense unit.
+ . ; It's not included in the original call, so we have to go to the drug file.
+ . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
+ . ; Node 14.5 is the Dispense Unit
+ . D DATA^PSS50(MEDIEN,,,,,"QTY")
+ . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
+ . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
+ . ;
+ . ; --- START OF DIRECTIONS ---
+ . ; Sig data not in any API :-(  Oh yes, you can get the whole thing, but...
+ . ; we want the compoenents.
+ . ; It's in node 6 of ^PSRX(IEN)
+ . ; So, here we go again
+ . ; ^PSRX(D0,6,D1,0)= (#.01) DOSAGE ORDERED [1F] ^ (#1) DISPENSE UNITS PER DOSE
+ . ; ==>[2N] ^ (#2) UNITS [3P:50.607] ^ (#3) NOUN [4F] ^ (#4)
+ . ; ==>DURATION [5F] ^ (#5) CONJUNCTION [6S] ^ (#6) ROUTE
+ . ; ==>[7P:51.2] ^ (#7) SCHEDULE [8F] ^ (#8) VERB [9F] ^
+ . ;
+ . N DIRNUM S DIRNUM=0 ; Sigline number
+ . S DIRCNT=0 ; COUNT OF MULTIPLE DIRECTIONS
+ . F  S DIRNUM=$O(^PSRX(RXIEN,6,DIRNUM)) Q:DIRNUM=""  D
+ . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")=""  ; This is reserved for systems not able to generate the sig in components.
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1"  ; means that we are specifying it. See E2369-05.
+ . . N SIGDATA S SIGDATA=^PSRX(RXIEN,6,DIRNUM,0)
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$P(SIGDATA,U,9)
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$P(SIGDATA,U,1)
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT")
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")=""  ; For inpatient
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")=""  ; For inpatient
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")=""  ; For inpatient
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$$GET1^DIQ(51.2,$P(SIGDATA,U,7),.01)
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$P(SIGDATA,U,8)
+ . . ; Invervals... again another call.
+ . . ; In the wisdom of the original programmers, the schedule is a free text field
+ . . ; However, it gets translated by a call to the administration schedule file
+ . . ; to see if that schedule exists.
+ . . ; That's the same thing I am going to do.
+ . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ).
+ . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO--
+ . . ; I looked), PSSFT is the name, and list is the ^TMP name to store the data in.
+ . . ; So...
+ . . D AP^PSS51P1("PSJ",$P(SIGDATA,U,8),,,"SCHEDULE")
+ . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE")
+ . . N INTERVAL
+ . . I $P(SCHEDATA(0),U)=-1 S INTERVAL=""
+ . . E  D
+ . . . N SUB S SUB=$O(SCHEDATA(0))
+ . . . S INTERVAL=SCHEDATA(SUB,2)
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$P(SIGDATA,U,5)
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$P(SIGDATA,U,8)["PRN"
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM
+ . . N DIRMOD S DIRMOD=$P(SIGDATA,U,6)
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$S(DIRMOD="T":"THEN",DIRMOD="A":"AND",DIRMOD="X":"EXCEPT",1:"")
+ . ;
+ . ; --- END OF DIRECTIONS ---
+ . ;
+ . ; ^PSRX(22,"INS1",1,0)="FOR BLOOD PRESSURE"
+ . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"INS1",1,0))
+ . ; ^PSRX(22,"PRC",1,0)="Pharmacist: you must obey my command"
+ . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PRC",1,0))
+ . S @MAP@("MEDRFNO")=MED(9)
+ . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
+ . K @RESULT
+ . D MAP^C0CXPATH(MINXML,MAP,RESULT)
+ . ; MAPPING DIRECTIONS
+ . N DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
+ . N DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
+ . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
+ . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
+ . ; N MDZ1,MDZNA
+ . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
+ . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
+ . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
+ . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
+ . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
+ . I MEDCOUNT=1 D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
+ . E  D INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML
+ N MEDTMP,MEDI
+ D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
+ I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
+ . W "MEDICATION MISSING ",!
+ . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
+ Q
+ ;

ccr/trunk/p/C0CMED2.m

@@ -1 @@
-C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;;Last Modified Sat Jan 10 21:41:14 PST 2009
-        ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
-        ; General Public License See attached copy of the License.
-        ;
-        ; This program is free software; you can redistribute it and/or modify
-        ; it under the terms of the GNU General Public License as published by
-        ; the Free Software Foundation; either version 2 of the License, or
-        ; (at your option) any later version.
-        ;
-        ; This program is distributed in the hope that it will be useful,
-        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ; GNU General Public License for more details.
-        ;
-        ; You should have received a copy of the GNU General Public License along
-        ; with this program; if not, write to the Free Software Foundation, Inc.,
-        ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "NO ENTRY FROM TOP",!
-        Q
-        ;
-EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT)               ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
-        ;
-        ; MINXML is the Input XML Template, passed by name
-        ; DFN is Patient IEN (by Value)
-        ; OUTXML is the resultant XML (by Name)
-        ; MEDCOUNT is the current count of extracted meds, passed by Reference
-        ;
-        ; MEDS is return array from RPC.
-        ; MAP is a mapping variable map (store result) for each med
-        ; MED is holds each array element from MEDS, one medicine
-        ;
-        ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending
-        ; meds data available.
-        ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf
-        ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS).
-        ; File for pending meds is 52.41
-        ; Unfortuantely, API does not supply us with any useful info beyond
-        ; the IEN in 52.41, and the Med Name, and route.
-        ; So, most of the info is going to get pulled from 52.41.
-        N MEDS,MAP
-        K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!!
-        D PEN^PSO5241(DFN,"CCDCCR")
-        M MEDS=^TMP($J,"CCDCCR",DFN)
-        ; @(0) contains the number of meds or -1^NO DATA FOUND
-        ; If it is -1, we quit.
-        I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT
-        ZWRITE:$G(DEBUG) MEDS
-        N RXIEN S RXIEN=0
-        N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED IN THIS SECTION FOR MERGING
-        F  S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B"  D  ; FOR EACH MEDICATION IN THE LIST
-        . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT  ; Dont' want refill request as a "pending" order
-        . S MEDCOUNT=MEDCOUNT+1
-        . I DEBUG W "RXIEN IS ",RXIEN,!
-        . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
-        . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN C0CMED
-        . I DEBUG W "MAP= ",MAP,!
-        . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM
-        . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID
-        . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN
-        . S @MAP@("MEDISSUEDATETXT")="Issue Date"
-        . ; Field 6 is "Effective date", and we pull it in timson format w/ I
-        . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($$GET1^DIQ(52.41,RXIEN,6,"I"),"DT")
-        . ; Med never filled; next 4 fields are not applicable.
-        . S @MAP@("MEDLASTFILLDATETXT")=""
-        . S @MAP@("MEDLASTFILLDATE")=""
-        . S @MAP@("MEDRXNOTXT")=""
-        . S @MAP@("MEDRXNO")=""
-        . S @MAP@("MEDTYPETEXT")="Medication"
-        . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
-        . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds
-        . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I")
-        . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2)
-        . ; NDC not supplied in API, but is rather trivial to obtain
-        . ; MED(11) piece 1 has the IEN of the drug (file 50)
-        . ; IEN is field 31 in the drug file.
-        . ;
-        . ; MEDIEN (node 11 in the returned output) might not necessarily be defined
-        . ; It is not defined when a dose in not chosen in CPRS. There is a long
-        . ; series of fields that depend on it. We will use If and Else to deal
-        . ; with that
-        . N MEDIEN S MEDIEN=$P(MED(11),U)
-        . I +MEDIEN>0 D  ; start of if/else block
-        . . ; 12/30/08: I will be using RxNorm for coding...
-        . . ; 176.001 is the file for Concepts; 176.003 is the file for
-        . . ; sources (i.e. for RxNorm Version)
-        . . ;
-        . . ; We need the VUID first for the National Drug File entry first
-        . . ; We get the VUID of the drug, by looking up the VA Product entry
-        . . ; (file 50.68) using the call NDF^PSS50, returned in node 22.
-        . . ; Field 99.99 is the VUID.
-        . . ;
-        . . ; We use the VUID to look up the RxNorm in file 176.001; same idea.
-        . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by
-        . . ; $$GET1^DIQ.
-        . . ;
-        . . ; I get the RxNorm name and version from the RxNorm Sources (file
-        . . ; 176.003), by searching for "RXNORM", then get the data.
-        . . D NDF^PSS50(MEDIEN,,,,,"NDF")
-        . . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN)
-        . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
-        . . N VAPROD S VAPROD=$P(NDFDATA(22),U)
-        . . ;
-        . . ; NDFIEN is not necessarily defined; it won't be if the drug
-        . . ; is not matched to the national drug file (e.g. if the drug is
-        . . ; new on the market, compounded, or is a fake drug [blue pill].
-        . . ; To protect against failure, I will put an if/else block
-        . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
-        . . I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
-        . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
-        . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
-        . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01)
-        . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM")
-        . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
-        . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
-        . . ;
-        . . E  S (RXNORM,RXNNAME,RXNVER)=""
-        . . ; End if/else block
-        . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
-        . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
-        . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
-        . . ;
-        . . S @MAP@("MEDBRANDNAMETEXT")=""
-        . . D DOSE^PSS50(MEDIEN,,,,,"DOSE")
-        . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
-        . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901)
-        . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2)
-        . . ; Units, concentration, etc, come from another call
-        . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
-        . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
-        . . ; NDF Entry IEN, and VA Product Name
-        . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
-        . . ; Documented in the same manual; executed above.
-        . . N CONCDATA
-        . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
-        . . ; and this will crash the call. So...
-        . . I NDFIEN="" S CONCDATA=""
-        . . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
-        . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1)
-        . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3)
-        . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4)
-        . . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12)
-        . . ; Oddly, there is no easy place to find the dispense unit.
-        . . ; It's not included in the original call, so we have to go to the drug file.
-        . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
-        . . ; Node 14.5 is the Dispense Unit
-        . . D DATA^PSS50(MEDIEN,,,,,"QTY")
-        . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
-        . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
-        . E  D
-        . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=""
-        . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=""
-        . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=""
-        . . S @MAP@("MEDBRANDNAMETEXT")=""
-        . . S @MAP@("MEDSTRENGTHVALUE")=""
-        . . S @MAP@("MEDSTRENGTHUNIT")=""
-        . . S @MAP@("MEDFORMTEXT")=""
-        . . S @MAP@("MEDCONCVALUE")=""
-        . . S @MAP@("MEDCONCUNIT")=""
-        . . S @MAP@("MEDSIZETEXT")=""
-        . . S @MAP@("MEDQUANTITYVALUE")=""
-        . . S @MAP@("MEDQUANTITYUNIT")=""
-        . ; end of if/else block
-        . ;
-        . ; --- START OF DIRECTIONS ---
-        . ; Sig data is not in any API. We obtain it using the IEN from
-        . ; the PEN API to file 52.41. It's in field 3, which is a multiple.
-        . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT)
-        . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call
-        . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG")
-        . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman.
-        . ; FMSIGNUM gets outputted as "IEN,RXIEN,".
-        . ; DIRNUM will be first piece for IEN.
-        . ; DIRNUM is the proper Sigline numer.
-        . ; SIGDATA is the simplfied array. Subscripts are really field numbers
-        . ; in subfile 52.413.
-        . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS
-        . F  S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM=""  D
-        . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",")
-        . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT
-        . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM)
-        . . ; If this is an order for a refill; it's not really a new order; move on to next
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")=""  ; This is reserved for systems not able to generate the sig in components.
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1"  ; means that we are specifying it. See E2369-05.
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13)
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8)
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT")
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")=""  ; For inpatient
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")=""  ; For inpatient
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")=""  ; For inpatient
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10)
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1)
-        . . ; Invervals... again another call.
-        . . ; The schedule is a free text field
-        . . ; However, it gets translated by a call to the administration
-        . . ; schedule file to see if that schedule exists.
-        . . ; That's the same thing I am going to do.
-        . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ).
-        . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO--
-        . . ; I looked), PSSFT is the name,
-        . . ; and list is the ^TMP name to store the data in.
-        . . ; Also, freqency may have "PRN" in it, so strip that out
-        . . N FREQ S FREQ=SIGDATA(1)
-        . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp
-        . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE")
-        . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE")
-        . . N INTERVAL
-        . . I $P(SCHEDATA(0),U)=-1 S INTERVAL=""
-        . . E  D
-        . . . N SUB S SUB=$O(SCHEDATA(0))
-        . . . S INTERVAL=SCHEDATA(SUB,2)
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
-        . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months
-        . . N DUR S DUR=SIGDATA(2)
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR))
-        . . N DURUNIT S DURUNIT=$E(DUR)
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"")
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN"
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6)
-        . ;
-        . ; --- END OF DIRECTIONS ---
-        . ;
-        . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
-        . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL
-        . ; W @MAP@("MEDPTINSTRUCTIONS"),!
-        . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9"
-        . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL
-        . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),!
-        . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13)
-        . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
-        . K @RESULT
-        . D MAP^C0CXPATH(MINXML,MAP,RESULT)
-        . ; D PARY^C0CXPATH(RESULT)
-        . ; MAPPING DIRECTIONS
-        . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
-        . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
-        . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
-        . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
-        . ; N MDZ1,MDZNA
-        . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
-        . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
-        . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
-        . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
-        . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
-        . I MEDFIRST D  ;
-        . . S MEDFIRST=0 ; RESET FIRST FLAG
-        . . D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
-        . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER
-        N MEDTMP,MEDI
-        D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
-        I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
-        . W "Pending Medication MISSING ",!
-        . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
-        Q
-        ;
+C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;Last Modified Sat Jan 10 21:41:14 PST 2009
+ ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ; General Public License See attached copy of the License.
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License along
+ ; with this program; if not, write to the Free Software Foundation, Inc.,
+ ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "NO ENTRY FROM TOP",!
+ Q
+ ;
+EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT)           ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
+ ;
+ ; MINXML is the Input XML Template, passed by name
+ ; DFN is Patient IEN (by Value)
+ ; OUTXML is the resultant XML (by Name)
+ ; MEDCOUNT is the current count of extracted meds, passed by Reference
+ ;
+ ; MEDS is return array from RPC.
+ ; MAP is a mapping variable map (store result) for each med
+ ; MED is holds each array element from MEDS, one medicine
+ ;
+ ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending
+ ; meds data available.
+ ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf
+ ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS).
+ ; File for pending meds is 52.41
+ ; Unfortuantely, API does not supply us with any useful info beyond
+ ; the IEN in 52.41, and the Med Name, and route.
+ ; So, most of the info is going to get pulled from 52.41.
+ N MEDS,MAP
+ K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!!
+ D PEN^PSO5241(DFN,"CCDCCR")
+ M MEDS=^TMP($J,"CCDCCR",DFN)
+ ; @(0) contains the number of meds or -1^NO DATA FOUND
+ ; If it is -1, we quit.
+ I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT
+ ZWRITE:$G(DEBUG) MEDS
+ N RXIEN S RXIEN=0
+ N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED IN THIS SECTION FOR MERGING
+ F  S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B"  D  ; FOR EACH MEDICATION IN THE LIST
+ . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT  ; Dont' want refill request as a "pending" order
+ . S MEDCOUNT=MEDCOUNT+1
+ . I DEBUG W "RXIEN IS ",RXIEN,!
+ . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
+ . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN C0CMED
+ . I DEBUG W "MAP= ",MAP,!
+ . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM
+ . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID
+ . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN
+ . S @MAP@("MEDISSUEDATETXT")="Issue Date"
+ . ; Field 6 is "Effective date", and we pull it in timson format w/ I
+ . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($$GET1^DIQ(52.41,RXIEN,6,"I"),"DT")
+ . ; Med never filled; next 4 fields are not applicable.
+ . S @MAP@("MEDLASTFILLDATETXT")=""
+ . S @MAP@("MEDLASTFILLDATE")=""
+ . S @MAP@("MEDRXNOTXT")=""
+ . S @MAP@("MEDRXNO")=""
+ . S @MAP@("MEDTYPETEXT")="Medication"
+ . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
+ . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds
+ . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I")
+ . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2)
+ . ; NDC not supplied in API, but is rather trivial to obtain
+ . ; MED(11) piece 1 has the IEN of the drug (file 50)
+ . ; IEN is field 31 in the drug file.
+ . ;
+ . ; MEDIEN (node 11 in the returned output) might not necessarily be defined
+ . ; It is not defined when a dose in not chosen in CPRS. There is a long
+ . ; series of fields that depend on it. We will use If and Else to deal
+ . ; with that
+ . N MEDIEN S MEDIEN=$P(MED(11),U)
+ . I +MEDIEN>0 D  ; start of if/else block
+ . . ; 12/30/08: I will be using RxNorm for coding...
+ . . ; 176.001 is the file for Concepts; 176.003 is the file for
+ . . ; sources (i.e. for RxNorm Version)
+ . . ;
+ . . ; We need the VUID first for the National Drug File entry first
+ . . ; We get the VUID of the drug, by looking up the VA Product entry
+ . . ; (file 50.68) using the call NDF^PSS50, returned in node 22.
+ . . ; Field 99.99 is the VUID.
+ . . ;
+ . . ; We use the VUID to look up the RxNorm in file 176.001; same idea.
+ . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by
+ . . ; $$GET1^DIQ.
+ . . ;
+ . . ; I get the RxNorm name and version from the RxNorm Sources (file
+ . . ; 176.003), by searching for "RXNORM", then get the data.
+ . . D NDF^PSS50(MEDIEN,,,,,"NDF")
+ . . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN)
+ . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
+ . . N VAPROD S VAPROD=$P(NDFDATA(22),U)
+ . . ;
+ . . ; NDFIEN is not necessarily defined; it won't be if the drug
+ . . ; is not matched to the national drug file (e.g. if the drug is
+ . . ; new on the market, compounded, or is a fake drug [blue pill].
+ . . ; To protect against failure, I will put an if/else block
+ . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
+ . . I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
+ . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
+ . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
+ . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01)
+ . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM")
+ . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
+ . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
+ . . ;
+ . . E  S (RXNORM,RXNNAME,RXNVER)=""
+ . . ; End if/else block
+ . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
+ . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
+ . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
+ . . ;
+ . . S @MAP@("MEDBRANDNAMETEXT")=""
+ . . D DOSE^PSS50(MEDIEN,,,,,"DOSE")
+ . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
+ . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901)
+ . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2)
+ . . ; Units, concentration, etc, come from another call
+ . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
+ . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
+ . . ; NDF Entry IEN, and VA Product Name
+ . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
+ . . ; Documented in the same manual; executed above.
+ . . N CONCDATA
+ . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
+ . . ; and this will crash the call. So...
+ . . I NDFIEN="" S CONCDATA=""
+ . . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
+ . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1)
+ . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3)
+ . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4)
+ . . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12)
+ . . ; Oddly, there is no easy place to find the dispense unit.
+ . . ; It's not included in the original call, so we have to go to the drug file.
+ . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
+ . . ; Node 14.5 is the Dispense Unit
+ . . D DATA^PSS50(MEDIEN,,,,,"QTY")
+ . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
+ . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
+ . E  D
+ . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=""
+ . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=""
+ . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=""
+ . . S @MAP@("MEDBRANDNAMETEXT")=""
+ . . S @MAP@("MEDSTRENGTHVALUE")=""
+ . . S @MAP@("MEDSTRENGTHUNIT")=""
+ . . S @MAP@("MEDFORMTEXT")=""
+ . . S @MAP@("MEDCONCVALUE")=""
+ . . S @MAP@("MEDCONCUNIT")=""
+ . . S @MAP@("MEDSIZETEXT")=""
+ . . S @MAP@("MEDQUANTITYVALUE")=""
+ . . S @MAP@("MEDQUANTITYUNIT")=""
+ . ; end of if/else block
+ . ;
+ . ; --- START OF DIRECTIONS ---
+ . ; Sig data is not in any API. We obtain it using the IEN from
+ . ; the PEN API to file 52.41. It's in field 3, which is a multiple.
+ . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT)
+ . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call
+ . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG")
+ . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman.
+ . ; FMSIGNUM gets outputted as "IEN,RXIEN,".
+ . ; DIRNUM will be first piece for IEN.
+ . ; DIRNUM is the proper Sigline numer.
+ . ; SIGDATA is the simplfied array. Subscripts are really field numbers
+ . ; in subfile 52.413.
+ . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS
+ . F  S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM=""  D
+ . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",")
+ . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT
+ . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM)
+ . . ; If this is an order for a refill; it's not really a new order; move on to next
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")=""  ; This is reserved for systems not able to generate the sig in components.
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1"  ; means that we are specifying it. See E2369-05.
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13)
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8)
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT")
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")=""  ; For inpatient
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")=""  ; For inpatient
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")=""  ; For inpatient
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10)
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1)
+ . . ; Invervals... again another call.
+ . . ; The schedule is a free text field
+ . . ; However, it gets translated by a call to the administration
+ . . ; schedule file to see if that schedule exists.
+ . . ; That's the same thing I am going to do.
+ . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ).
+ . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO--
+ . . ; I looked), PSSFT is the name,
+ . . ; and list is the ^TMP name to store the data in.
+ . . ; Also, freqency may have "PRN" in it, so strip that out
+ . . N FREQ S FREQ=SIGDATA(1)
+ . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp
+ . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE")
+ . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE")
+ . . N INTERVAL
+ . . I $P(SCHEDATA(0),U)=-1 S INTERVAL=""
+ . . E  D
+ . . . N SUB S SUB=$O(SCHEDATA(0))
+ . . . S INTERVAL=SCHEDATA(SUB,2)
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
+ . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months
+ . . N DUR S DUR=SIGDATA(2)
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR))
+ . . N DURUNIT S DURUNIT=$E(DUR)
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"")
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN"
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6)
+ . ;
+ . ; --- END OF DIRECTIONS ---
+ . ;
+ . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
+ . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL
+ . ; W @MAP@("MEDPTINSTRUCTIONS"),!
+ . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9"
+ . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL
+ . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),!
+ . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13)
+ . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
+ . K @RESULT
+ . D MAP^C0CXPATH(MINXML,MAP,RESULT)
+ . ; D PARY^C0CXPATH(RESULT)
+ . ; MAPPING DIRECTIONS
+ . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
+ . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
+ . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
+ . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
+ . ; N MDZ1,MDZNA
+ . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
+ . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
+ . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
+ . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
+ . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
+ . I MEDFIRST D  ;
+ . . S MEDFIRST=0 ; RESET FIRST FLAG
+ . . D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
+ . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER
+ N MEDTMP,MEDI
+ D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
+ I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
+ . W "Pending Medication MISSING ",!
+ . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
+ Q
+ ;

ccr/trunk/p/C0CMED3.m

@@ -1 @@
-C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;;Last Modified: Sun Jan 11 05:45:03 UTC 2009
-        ; Copyright 2009 WorldVistA.  Licensed under the terms of the GNU
-        ; General Public License See attached copy of the License.
-        ;
-        ; This program is free software; you can redistribute it and/or modify
-        ; it under the terms of the GNU General Public License as published by
-        ; the Free Software Foundation; either version 2 of the License, or
-        ; (at your option) any later version.
-        ;
-        ; This program is distributed in the hope that it will be useful,
-        ; but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ; GNU General Public License for more details.
-        ;
-        ; You should have received a copy of the GNU General Public License along
-        ; with this program; if not, write to the Free Software Foundation, Inc.,
-        ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "NO ENTRY FROM TOP",!
-        Q
-        ;
-EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT)     ; Extract medications into provided xml template
-        ;
-        ; MINXML is the Input XML Template, (passed by name)
-        ; DFN is Patient IEN (passed by value)
-        ; OUTXML is the resultant XML (passed by name)
-        ; MEDCOUNT is the number of Meds extracted so far (passed by reference)
-        ;
-        ; MEDS is return array from RPC.
-        ; MAP is a mapping variable map (store result) for each med
-        ; MED is holds each array element from MEDS, one medicine
-        ;
-        ; Non-VA meds don't have an API. They are stored in file 55, subfile 52.2
-        ; Discontinued meds are indicated by the presence of a value in fields
-        ; 5 or 6 (STATUS 1 or 2, and DISCONTINUED DATE)
-        ; Will use Fileman API GETS^DIQ
-        ;
-        N MEDS,MAP
-        K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!!
-        N NVA
-        D GETS^DIQ(55,DFN,"52.2*","IE","NVA") ; Output in NVA in FDA array format.
-        ; If NVA does not exist, then patient has no non-VA meds
-        I $D(NVA)=0 S @OUTXML@(0)=0 QUIT
-        ; Otherwise, we go on...
-        M MEDS=NVA(55.05)
-        ; We are done with NVA
-        K NVA
-        ;
-        I DEBUG ZWRITE MEDS
-        N FDAIEN S FDAIEN=0 ; For use in $Order in the MEDS array.
-        N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED PROCESSED HERE
-        F  S FDAIEN=$O(MEDS(FDAIEN)) Q:FDAIEN=""  D  ; FOR EACH MEDICATION IN THE LIST
-        . N MED M MED=MEDS(FDAIEN)
-        . I MED(5,"I")!MED(6,"I") QUIT  ; If disconinued, we don't want to pull it.
-        . S MEDCOUNT=MEDCOUNT+1
-        . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
-        . N RXIEN S RXIEN=$P(FDAIEN,",") ; First piece of FDAIEN is the number of the med for this patient
-        . I DEBUG W "RXIEN IS ",RXIEN,!
-        . I DEBUG W "MAP= ",MAP,!
-        . S @MAP@("MEDOBJECTID")="MED_OUTSIDE"_MEDCOUNT ; MEDCOUNT FOR ID
-        . S @MAP@("MEDISSUEDATETXT")="Documented Date"
-        . ; Field 6 is "Effective date", and we pull it in timson format w/ I
-        . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL(MED(11,"I"),"DT")
-        . ; Med never filled; next 4 fields are not applicable.
-        . S @MAP@("MEDLASTFILLDATETXT")=""
-        . S @MAP@("MEDLASTFILLDATE")=""
-        . S @MAP@("MEDRXNOTXT")=""
-        . S @MAP@("MEDRXNO")=""
-        . S @MAP@("MEDTYPETEXT")="Medication"
-        . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
-        . S @MAP@("MEDSTATUSTEXT")="Active" ; nearest status for pending meds
-        . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I")
-        . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E")
-        . ; NDC is field 31 in the drug file.
-        . ; The actual drug entry in the drug file (MEDIEN) is not necessarily supplied.
-        . ; It' node 1, internal form.
-        . N MEDIEN S MEDIEN=MED(1,"I")
-        . I +MEDIEN D  ; start of if/else block
-        . . ; 12/30/08: I will be using RxNorm for coding...
-        . . ; 176.001 is the file for Concepts; 176.003 is the file for
-        . . ; sources (i.e. for RxNorm Version)
-        . . ;
-        . . ; We need the VUID first for the National Drug File entry first
-        . . ; We get the VUID of the drug, by looking up the VA Product entry
-        . . ; (file 50.68) using the call NDF^PSS50, returned in node 22.
-        . . ; Field 99.99 is the VUID.
-        . . ;
-        . . ; We use the VUID to look up the RxNorm in file 176.001; same idea.
-        . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by
-        . . ; $$GET1^DIQ.
-        . . ;
-        . . ; I get the RxNorm name and version from the RxNorm Sources (file
-        . . ; 176.003), by searching for "RXNORM", then get the data.
-        . . ; NDF^PSS50 ONLY EXISTS ON VISTA
-        . . N NDFDATA,NDFIEN,VAPROD
-        . . S NDFIEN=""
-        . . I '$$RPMS^C0CUTIL() D
-        . . . D NDF^PSS50(MEDIEN,,,,,"NDF")
-        . . . ;N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN)
-        . . . ;N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
-        . . . ;N VAPROD S VAPROD=$P(NDFDATA(22),U)
-        . . . M NDFDATA=^TMP($J,"NDF",MEDIEN)
-        . . . S NDFIEN=$P(NDFDATA(20),U)
-        . . . S VAPROD=$P(NDFDATA(22),U)
-        . . . S @MAP@("MEDPRODUCTNAMETEXT")=$$GET1^DIQ(50.68,VAPROD,.01) ;
-        . . ; GPL - RESET THE NAME TO THE REAL NAME OF THE DRUG NOW THAT WE
-        . . ;   HAVE IT. 
-        . . ;
-        . . ; NDFIEN is not necessarily defined; it won't be if the drug
-        . . ; is not matched to the national drug file (e.g. if the drug is
-        . . ; new on the market, compounded, or is a fake drug [blue pill].
-        . . ; To protect against failure, I will put an if/else block
-        . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
-        . . ; 
-        . . ; begin changes for systems that have eRx installed
-        . . ; RxNorm is found in the ^C0P("RXN") global - gpl
-        . . ;
-        . . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
-        . . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE
-        . . S (RXNORM,RXNNAME,RXNVER)="" ;INITIALIZE
-        . . I NDFIEN,$D(^C0P("RXN")) D  ; 
-        . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
-        . . . S ZC=$$CODE^C0CUTIL(VUID)
-        . . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
-        . . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
-        . . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
-        . . . S RXNORM=ZCD ; THE CODE
-        . . . S RXNNAME=ZCDS ; THE CODING SYSTEM
-        . . . S RXNVER=ZCDSV ; THE CODING SYSTEM VERSION
-        . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT")
-        . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_ZCDS_": "_ZCD
-        . . E  I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
-        . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
-        . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
-        . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01)
-        . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM")
-        . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
-        . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
-        . . ;
-        . . ;E  S (RXNORM,RXNNAME,RXNVER)=""
-        . . ; End if/else block
-        . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
-        . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
-        . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
-        . . ;
-        . . S @MAP@("MEDBRANDNAMETEXT")=""
-        . . ; DOSE^PSS50 ONLY ESISTS ON VISTA
-        . . I '$$RPMS^C0CUTIL() D
-        . . . D DOSE^PSS50(MEDIEN,,,,,"DOSE")
-        . . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
-        . . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901)
-        . . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2)
-        . . E  S @MAP@("MEDSTRENGTHVALUE")="" S @MAP@("MEDSTRENGTHUNIT")=""
-        . . ; Units, concentration, etc, come from another call
-        . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
-        . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
-        . . ; NDF Entry IEN, and VA Product Name
-        . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
-        . . ; Documented in the same manual; executed above.
-        . . ;
-        . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
-        . . ; and this will crash the call. So...
-        . . I NDFIEN="" S CONCDATA=""
-        . . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
-        . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1)
-        . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3)
-        . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4)
-        . . S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
-        . . ; Oddly, there is no easy place to find the dispense unit.
-        . . ; It's not included in the original call, so we have to go to the drug file.
-        . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
-        . . ; Node 14.5 is the Dispense Unit
-        . . ; PSS50 ONLY EXISTS ON VISTA
-        . . I '$$RPMS^C0CUTIL() D
-        . . . D DATA^PSS50(MEDIEN,,,,,"QTY")
-        . . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
-        . . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
-        . . E  S @MAP@("MEDQUANTITYUNIT")=""
-        . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these
-        . E  D
-        . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=""
-        . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=""
-        . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=""
-        . . S @MAP@("MEDBRANDNAMETEXT")=""
-        . . S @MAP@("MEDSTRENGTHVALUE")=""
-        . . S @MAP@("MEDSTRENGTHUNIT")=""
-        . . S @MAP@("MEDFORMTEXT")=""
-        . . S @MAP@("MEDCONCVALUE")=""
-        . . S @MAP@("MEDCONCUNIT")=""
-        . . S @MAP@("MEDSIZETEXT")=""
-        . . S @MAP@("MEDQUANTITYVALUE")=""
-        . . S @MAP@("MEDQUANTITYUNIT")=""
-        . ; End If/Else
-        . ; --- START OF DIRECTIONS ---
-        . ; Dosage is field 2, route is 3, schedule is 4
-        . ; These are all free text fields, and don't point to any files
-        . ; For that reason, I will use the field I never used before:
-        . ; MEDDIRECTIONDESCRIPTIONTEXT
-        . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS
-        . ;
-        . ; change for eRx meds - gpl 6/25/2011
-        . ;
-        . N ZERX S ZERX=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
-        . I ZERX["|" S ZERX=$P(ZERX,"|",2) ; GET RID OF MED NAME
-        . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=ZERX
-        . N ZERX2 S ZERX2=$P(MED(2,"E"),"|",2) ; sig for quantity
-        . N ZFDBDRUG S ZFDBDRUG=$P(MED(2,"E"),"|",1) ; FDB DRUG NAME
-        . I @MAP@("MEDPRODUCTNAMETEXT")["FREE TXT" D  ; FIX THE DRUG NAME
-        . . S @MAP@("MEDPRODUCTNAMETEXT")=ZFDBDRUG ; USE FDB NAME
-        . . S RXNORM=$P($P($G(MED(14,7)),"RXNORM:",2)," ",1) ; THE RXNORM
-        . . S RXNORM=$$NISTMAP^C0CUTIL(RXNORM) ; CHANGE IF NECESSARY
-        . . I RXNORM'="" D  ;
-        . . . W !,"FOUND FREE TEXT RXNORM:",RXNORM
-        . . . S RXNNAME="RXNORM" ; THE CODING SYSTEM
-        . . . S RXNVER="" ; THE CODING SYSTEM VERSION
-        . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT")
-        . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_RXNNAME_": "_RXNORM
-        . . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
-        . . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
-        . . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
-        . . . I RXNORM["979334" D  ; PATCH FOR CERTIFICATION
-        . . . . S @MAP@("MEDSTRENGTHVALUE")=650
-        . . . . S @MAP@("MEDSTRENGTHUNIT")="mcg"
-        . . . . S @MAP@("MEDFORMTEXT")="INHALER"
-        . S @MAP@("MEDQUANTITYUNIT")=$P(ZERX2," ",3) ; THE UNITS
-        . S @MAP@("MEDQUANTITYVALUE")=$P(ZERX2," ",2) ; THE QUANTITY
-        . I @MAP@("MEDFORMTEXT")="" S @MAP@("MEDFORMTEXT")=$P(ZERX2," ",3) ;
-        . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
-        . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4"  ; means look in description text. See E2369-05.
-        . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")=""
-        . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")=""
-        . ;
-        . ; --- END OF DIRECTIONS ---
-        . ;
-        . S @MAP@("MEDRFNO")=""
-        . I $D(MED(14,1)) D  ;
-        . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
-        . E  S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=""
-        . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" ; don't put in these - gpl
-        . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
-        . K @RESULT
-        . D MAP^C0CXPATH(MINXML,MAP,RESULT)
-        . ; D PARY^C0CXPATH(RESULT)
-        . ; MAPPING DIRECTIONS
-        . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
-        . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
-        . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
-        . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
-        . N MDZ1,MDZNA
-        . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
-        . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
-        . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
-        . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
-        . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
-        . ;
-        . ; MAP PATIENT INSTRUCTIONS - HAVE TO DO THIS AFTER MAPPING DIRECTIONS DUE TO XML SCHEMA VALIDATION
-        . N MEDINT1,INTXML1 S INTXML1="MENINT1" ; VARIABLE AND NAME VARIABLE TEMPLATE
-        . N MEDINT2,INTXML2 S INTXML2="MEDINT2" ; VARIABLE AND NAME VARIABLE RESULT
-        . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/PatientInstructions",INTXML1)
-        . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/PatientInstructions")
-        . ;N MDI1 ; removing the "I" which is not in the protocol gpl 1/2010
-        . ;S MDI1=$NA(@MAP@("I"))
-        . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
-        . I $D(MED(10,1)) D  ;
-        . . ;S @MAP@("I","MEDPTINSTRUCTIONS")=$P(MED(10,1),"  ",1) ; WP Field
-        . . S @MAP@("MEDPTINSTRUCTIONS")=$P(MED(10,1),"  ",1) ; WP Field
-        . E  S @MAP@("MEDPTINSTRUCTIONS")=""
-        . ;E  S @MAP@("I","MEDPTINSTRUCTIONS")=""
-        . ;D MAP^C0CXPATH(INTXML1,MDI1,INTXML2)
-        . D MAP^C0CXPATH(INTXML1,MAP,INTXML2) ; JUST MAP WORKS.. GPL
-        . D INSERT^C0CXPATH(RESULT,INTXML2,"//Medications/Medication")
-        . ;
-        . ; FLAG HAS TO BE RESET OUTSIDE THE IF STATMENT.
-        . ;I MEDFIRST D  ;
-        . ;. S MEDFIRST=0 ; RESET FIRST FLAG
-        . ;. D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
-        . ;D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML
-        . D:MEDFIRST CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
-        . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
-        . I MEDFIRST S MEDFIRST=0
-        N MEDTMP,MEDI
-        D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
-        I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
-        . W "MEDICATION MISSING ",!
-        . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
-        Q
-        ;
+C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;;Last Modified: Sun Jan 11 05:45:03 UTC 2009
+ ; Copyright 2009 WorldVistA.  Licensed under the terms of the GNU
+ ; General Public License See attached copy of the License.
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License along
+ ; with this program; if not, write to the Free Software Foundation, Inc.,
+ ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "NO ENTRY FROM TOP",!
+ Q
+ ;
+EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml template
+ ;
+ ; MINXML is the Input XML Template, (passed by name)
+ ; DFN is Patient IEN (passed by value)
+ ; OUTXML is the resultant XML (passed by name)
+ ; MEDCOUNT is the number of Meds extracted so far (passed by reference)
+ ;
+ ; MEDS is return array from RPC.
+ ; MAP is a mapping variable map (store result) for each med
+ ; MED is holds each array element from MEDS, one medicine
+ ;
+ ; Non-VA meds don't have an API. They are stored in file 55, subfile 52.2
+ ; Discontinued meds are indicated by the presence of a value in fields
+ ; 5 or 6 (STATUS 1 or 2, and DISCONTINUED DATE)
+ ; Will use Fileman API GETS^DIQ
+ ;
+ N MEDS,MAP
+ K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!!
+ N NVA
+ D GETS^DIQ(55,DFN,"52.2*","IE","NVA") ; Output in NVA in FDA array format.
+ ; If NVA does not exist, then patient has no non-VA meds
+ I $D(NVA)=0 S @OUTXML@(0)=0 QUIT
+ ; Otherwise, we go on...
+ M MEDS=NVA(55.05)
+ ; We are done with NVA
+ K NVA
+ ;
+ I DEBUG ZWRITE MEDS
+ N FDAIEN S FDAIEN=0 ; For use in $Order in the MEDS array.
+ N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED PROCESSED HERE
+ F  S FDAIEN=$O(MEDS(FDAIEN)) Q:FDAIEN=""  D  ; FOR EACH MEDICATION IN THE LIST
+ . N MED M MED=MEDS(FDAIEN)
+ . I MED(5,"I")!MED(6,"I") QUIT  ; If disconinued, we don't want to pull it.
+ . S MEDCOUNT=MEDCOUNT+1
+ . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
+ . N RXIEN S RXIEN=$P(FDAIEN,",") ; First piece of FDAIEN is the number of the med for this patient
+ . I DEBUG W "RXIEN IS ",RXIEN,!
+ . I DEBUG W "MAP= ",MAP,!
+ . S @MAP@("MEDOBJECTID")="MED_OUTSIDE"_MEDCOUNT ; MEDCOUNT FOR ID
+ . S @MAP@("MEDISSUEDATETXT")="Documented Date"
+ . ; Field 6 is "Effective date", and we pull it in timson format w/ I
+ . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL(MED(11,"I"),"DT")
+ . ; Med never filled; next 4 fields are not applicable.
+ . S @MAP@("MEDLASTFILLDATETXT")=""
+ . S @MAP@("MEDLASTFILLDATE")=""
+ . S @MAP@("MEDRXNOTXT")=""
+ . S @MAP@("MEDRXNO")=""
+ . S @MAP@("MEDTYPETEXT")="Medication"
+ . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
+ . S @MAP@("MEDSTATUSTEXT")="Active" ; nearest status for pending meds
+ . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I")
+ . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E")
+ . ; NDC is field 31 in the drug file.
+ . ; The actual drug entry in the drug file (MEDIEN) is not necessarily supplied.
+ . ; It' node 1, internal form.
+ . N MEDIEN S MEDIEN=MED(1,"I")
+ . I +MEDIEN D  ; start of if/else block
+ . . ; 12/30/08: I will be using RxNorm for coding...
+ . . ; 176.001 is the file for Concepts; 176.003 is the file for
+ . . ; sources (i.e. for RxNorm Version)
+ . . ;
+ . . ; We need the VUID first for the National Drug File entry first
+ . . ; We get the VUID of the drug, by looking up the VA Product entry
+ . . ; (file 50.68) using the call NDF^PSS50, returned in node 22.
+ . . ; Field 99.99 is the VUID.
+ . . ;
+ . . ; We use the VUID to look up the RxNorm in file 176.001; same idea.
+ . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by
+ . . ; $$GET1^DIQ.
+ . . ;
+ . . ; I get the RxNorm name and version from the RxNorm Sources (file
+ . . ; 176.003), by searching for "RXNORM", then get the data.
+ . . ; NDF^PSS50 ONLY EXISTS ON VISTA
+ . . N NDFDATA,NDFIEN,VAPROD
+ . . S NDFIEN=""
+ . . I '$$RPMS^C0CUTIL() D
+ . . . D NDF^PSS50(MEDIEN,,,,,"NDF")
+ . . . ;N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN)
+ . . . ;N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
+ . . . ;N VAPROD S VAPROD=$P(NDFDATA(22),U)
+ . . . M NDFDATA=^TMP($J,"NDF",MEDIEN)
+ . . . S NDFIEN=$P(NDFDATA(20),U)
+ . . . S VAPROD=$P(NDFDATA(22),U)
+ . . . S @MAP@("MEDPRODUCTNAMETEXT")=$$GET1^DIQ(50.68,VAPROD,.01) ;
+ . . ; GPL - RESET THE NAME TO THE REAL NAME OF THE DRUG NOW THAT WE
+ . . ;   HAVE IT. 
+ . . ;
+ . . ; NDFIEN is not necessarily defined; it won't be if the drug
+ . . ; is not matched to the national drug file (e.g. if the drug is
+ . . ; new on the market, compounded, or is a fake drug [blue pill].
+ . . ; To protect against failure, I will put an if/else block
+ . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER
+ . . ; 
+ . . ; begin changes for systems that have eRx installed
+ . . ; RxNorm is found in the ^C0P("RXN") global - gpl
+ . . ;
+ . . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
+ . . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE
+ . . S (RXNORM,RXNNAME,RXNVER)="" ;INITIALIZE
+ . . I NDFIEN,$D(^C0P("RXN")) D  ; 
+ . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
+ . . . S ZC=$$CODE^C0CUTIL(VUID)
+ . . . S ZCD=$P(ZC,"^",1) ; CODE TO USE
+ . . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID
+ . . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION
+ . . . S RXNORM=ZCD ; THE CODE
+ . . . S RXNNAME=ZCDS ; THE CODING SYSTEM
+ . . . S RXNVER=ZCDSV ; THE CODING SYSTEM VERSION
+ . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT")
+ . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_ZCDS_": "_ZCD
+ . . E  I NDFIEN,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
+ . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99)
+ . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID")
+ . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01)
+ . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM")
+ . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6)
+ . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7)
+ . . ;
+ . . ;E  S (RXNORM,RXNNAME,RXNVER)=""
+ . . ; End if/else block
+ . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
+ . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
+ . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
+ . . ;
+ . . S @MAP@("MEDBRANDNAMETEXT")=""
+ . . ; DOSE^PSS50 ONLY ESISTS ON VISTA
+ . . I '$$RPMS^C0CUTIL() D
+ . . . D DOSE^PSS50(MEDIEN,,,,,"DOSE")
+ . . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
+ . . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901)
+ . . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2)
+ . . E  S @MAP@("MEDSTRENGTHVALUE")="" S @MAP@("MEDSTRENGTHUNIT")=""
+ . . ; Units, concentration, etc, come from another call
+ . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit
+ . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters
+ . . ; NDF Entry IEN, and VA Product Name
+ . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT")
+ . . ; Documented in the same manual; executed above.
+ . . ;
+ . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be ""
+ . . ; and this will crash the call. So...
+ . . I NDFIEN="" S CONCDATA=""
+ . . E  S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD)
+ . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1)
+ . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3)
+ . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4)
+ . . S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
+ . . ; Oddly, there is no easy place to find the dispense unit.
+ . . ; It's not included in the original call, so we have to go to the drug file.
+ . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT")
+ . . ; Node 14.5 is the Dispense Unit
+ . . ; PSS50 ONLY EXISTS ON VISTA
+ . . I '$$RPMS^C0CUTIL() D
+ . . . D DATA^PSS50(MEDIEN,,,,,"QTY")
+ . . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
+ . . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
+ . . E  S @MAP@("MEDQUANTITYUNIT")=""
+ . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these
+ . E  D
+ . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=""
+ . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=""
+ . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=""
+ . . S @MAP@("MEDBRANDNAMETEXT")=""
+ . . S @MAP@("MEDSTRENGTHVALUE")=""
+ . . S @MAP@("MEDSTRENGTHUNIT")=""
+ . . S @MAP@("MEDFORMTEXT")=""
+ . . S @MAP@("MEDCONCVALUE")=""
+ . . S @MAP@("MEDCONCUNIT")=""
+ . . S @MAP@("MEDSIZETEXT")=""
+ . . S @MAP@("MEDQUANTITYVALUE")=""
+ . . S @MAP@("MEDQUANTITYUNIT")=""
+ . ; End If/Else
+ . ; --- START OF DIRECTIONS ---
+ . ; Dosage is field 2, route is 3, schedule is 4
+ . ; These are all free text fields, and don't point to any files
+ . ; For that reason, I will use the field I never used before:
+ . ; MEDDIRECTIONDESCRIPTIONTEXT
+ . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS
+ . ;
+ . ; change for eRx meds - gpl 6/25/2011
+ . ;
+ . N ZERX S ZERX=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
+ . I ZERX["|" S ZERX=$P(ZERX,"|",2) ; GET RID OF MED NAME
+ . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=ZERX
+ . N ZERX2 S ZERX2=$P(MED(2,"E"),"|",2) ; sig for quantity
+ . N ZFDBDRUG S ZFDBDRUG=$P(MED(2,"E"),"|",1) ; FDB DRUG NAME
+ . I @MAP@("MEDPRODUCTNAMETEXT")["FREE TXT" D  ; FIX THE DRUG NAME
+ . . S @MAP@("MEDPRODUCTNAMETEXT")=ZFDBDRUG ; USE FDB NAME
+ . . S RXNORM=$P($P($G(MED(14,7)),"RXNORM:",2)," ",1) ; THE RXNORM
+ . . S RXNORM=$$NISTMAP^C0CUTIL(RXNORM) ; CHANGE IF NECESSARY
+ . . I RXNORM'="" D  ;
+ . . . W !,"FOUND FREE TEXT RXNORM:",RXNORM
+ . . . S RXNNAME="RXNORM" ; THE CODING SYSTEM
+ . . . S RXNVER="" ; THE CODING SYSTEM VERSION
+ . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT")
+ . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_RXNNAME_": "_RXNORM
+ . . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM
+ . . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME
+ . . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER
+ . . . I RXNORM["979334" D  ; PATCH FOR CERTIFICATION
+ . . . . S @MAP@("MEDSTRENGTHVALUE")=650
+ . . . . S @MAP@("MEDSTRENGTHUNIT")="mcg"
+ . . . . S @MAP@("MEDFORMTEXT")="INHALER"
+ . S @MAP@("MEDQUANTITYUNIT")=$P(ZERX2," ",3) ; THE UNITS
+ . S @MAP@("MEDQUANTITYVALUE")=$P(ZERX2," ",2) ; THE QUANTITY
+ . I @MAP@("MEDFORMTEXT")="" S @MAP@("MEDFORMTEXT")=$P(ZERX2," ",3) ;
+ . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
+ . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4"  ; means look in description text. See E2369-05.
+ . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")=""
+ . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")=""
+ . ;
+ . ; --- END OF DIRECTIONS ---
+ . ;
+ . S @MAP@("MEDRFNO")=""
+ . I $D(MED(14,1)) D  ;
+ . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
+ . E  S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=""
+ . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" ; don't put in these - gpl
+ . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED"))
+ . K @RESULT
+ . D MAP^C0CXPATH(MINXML,MAP,RESULT)
+ . ; D PARY^C0CXPATH(RESULT)
+ . ; MAPPING DIRECTIONS
+ . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE
+ . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT
+ . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
+ . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions")
+ . N MDZ1,MDZNA
+ . I DIRCNT>0 D  ; IF THERE ARE DIRCTIONS
+ . . F MDZ1=1:1:DIRCNT  D  ; FOR EACH DIRECTION
+ . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1))
+ . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
+ . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
+ . ;
+ . ; MAP PATIENT INSTRUCTIONS - HAVE TO DO THIS AFTER MAPPING DIRECTIONS DUE TO XML SCHEMA VALIDATION
+ . N MEDINT1,INTXML1 S INTXML1="MENINT1" ; VARIABLE AND NAME VARIABLE TEMPLATE
+ . N MEDINT2,INTXML2 S INTXML2="MEDINT2" ; VARIABLE AND NAME VARIABLE RESULT
+ . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/PatientInstructions",INTXML1)
+ . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/PatientInstructions")
+ . ;N MDI1 ; removing the "I" which is not in the protocol gpl 1/2010
+ . ;S MDI1=$NA(@MAP@("I"))
+ . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105"
+ . I $D(MED(10,1)) D  ;
+ . . ;S @MAP@("I","MEDPTINSTRUCTIONS")=$P(MED(10,1),"  ",1) ; WP Field
+ . . S @MAP@("MEDPTINSTRUCTIONS")=$P(MED(10,1),"  ",1) ; WP Field
+ . E  S @MAP@("MEDPTINSTRUCTIONS")=""
+ . ;E  S @MAP@("I","MEDPTINSTRUCTIONS")=""
+ . ;D MAP^C0CXPATH(INTXML1,MDI1,INTXML2)
+ . D MAP^C0CXPATH(INTXML1,MAP,INTXML2) ; JUST MAP WORKS.. GPL
+ . D INSERT^C0CXPATH(RESULT,INTXML2,"//Medications/Medication")
+ . ;
+ . ; FLAG HAS TO BE RESET OUTSIDE THE IF STATMENT.
+ . ;I MEDFIRST D  ;
+ . ;. S MEDFIRST=0 ; RESET FIRST FLAG
+ . ;. D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
+ . ;D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML
+ . D:MEDFIRST CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
+ . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
+ . I MEDFIRST S MEDFIRST=0
+ N MEDTMP,MEDI
+ D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS
+ I MEDTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
+ . W "MEDICATION MISSING ",!
+ . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),!
+ Q
+ ;

ccr/trunk/p/C0CMXML.m

@@ -1 @@
-C0CMXML   ; GPL - MXML based XPath utilities;10/13/09  17:05
-        ;;0.1;C0C;nopatch;noreleasedate;Build 38
-        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        Q
-        ; THIS FILE CONTAINS THE XPATH CREATOR, THE PARSE CALL TO THE MXML PARSER
-        ; AND THE OUTXML XML GENERATOR THAT OUTPUTS XML FROM AN MXML DOM
-        ; FOR CCD SPECIFIC ROUTINES, SEE C0CMCCD
-        ; FOR TEMPLATE FILE RELATED ROUTINES, SEE C0CMXP
-        ;
-TEST    ;
-        S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
-        K GARY
-        W $$FTG^%ZISH("/home/vademo2/EHR/p/","mxml-test.xml",$NA(@C0CXMLIN@(1)),3)
-        S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DocID: ",C0CDOCID
-        S REDUX="//ContinuityOfCareRecord/Body"
-        D XPATH(1,"/","GIDX","GARY",,REDUX)
-        D SEPARATE^C0CMCCD("GARY2","GARY")
-        S ZI=""
-        F  S ZI=$O(GARY2(ZI)) Q:ZI=""  D  ;
-        . N GTMP,G2
-        . M G2=GARY2(ZI)
-        . D DEMUX2^C0CMXP("GTMP","G2",2)
-        . M GARY3(ZI)=GTMP
-        Q
-        ;
-TEST2   ;
-        S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail"
-        D XPATH(1,"/","GIDX","GARY","",REDUX)
-        Q
-        ;
-TEST3   
-        S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
-        K GARY,GTMP,GIDX
-        K @C0CXMLIN
-        W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3)
-        D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS
-        K @C0CXMLIN
-        M @C0CXMLIN=GTMP
-        K GTMP
-        D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN)
-        K @C0CXMLIN
-        M @C0CXMLIN=GTMP
-        K GTMP
-        S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID
-        S REDUX="//ClinicalDocument/component/structuredBody"
-        D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS
-        D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS
-        D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS
-        D XPATH(1,"/","GIDX","GARY",,REDUX)
-        K C0CCBK("TAG")
-        D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING
-        D TEST3A
-        Q
-        ;
-TEST3A  ; INTERNAL ROUTINE
-        S ZI=""
-        F  S ZI=$O(GARY2(ZI)) Q:ZI=""  D  ;
-        . N GTMP,G2
-        . M G2=GARY2(ZI)
-        . D DEMUX2^C0CMXP("GTMP","G2",2)
-        . M GARY4(ZI)=GTMP
-        Q
-        ;
-TESTQ   ; TEST OF THE QRDA TEMPLATE GPL 7/8/2010
-        S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
-        K GARY,GTMP,GIDX
-        K @C0CXMLIN
-        W $$FTG^%ZISH("/home/vademo2/","QRDA_CategoryI_WorldVistA1.xml",$NA(@C0CXMLIN@(1)),3)
-        D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS
-        K @C0CXMLIN
-        S GTMP(1)="<"_$P(GTMP(1),"<",2)
-        M @C0CXMLIN=GTMP
-        K GTMP
-        D TESTQ2
-        Q
-        ;
-TESTQ2  ; SECOND PART OF TESTQ
-        D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN)
-        K @C0CXMLIN
-        M @C0CXMLIN=GTMP
-        K GTMP
-        S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID
-        S REDUX="//ClinicalDocument/component/structuredBody"
-        D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS
-        D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS
-        D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS
-        D XPATH(1,"/","GIDX","GARY",,REDUX)
-        K C0CCBK("TAG")
-        D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING
-        D TEST3A
-        Q
-        ;
-TEST4   ; TEST OF OUTPUTING AN XML FILE FROM THE DOM .. this one is the CCR
-        ;
-        D TEST ; SET UP THE DOM
-        D START^C0CMXMLB($$TAG(1),,"G")
-        D NDOUT($$FIRST(1))
-        D END^C0CMXMLB ;END THE DOCUMENT
-        M ZCCR=^TMP("MXMLBLD",$J)
-        ZWR ZCCR
-        Q
-        ;
-TEST5   ; SAME AS TEST4, BUT THIS TIME THE CCD
-        S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
-        K GARY,GTMP,GIDX
-        K @C0CXMLIN
-        W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3)
-        D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS
-        K @C0CXMLIN
-        M @C0CXMLIN=GTMP
-        K GTMP
-        D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN)
-        K @C0CXMLIN
-        M @C0CXMLIN=GTMP
-        K GTMP
-        S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DOCID: ",C0CDOCID  ;CALL REGULAR PARSER
-        ;D XPATH(1,"/","GIDX2","GARY2",,REDUX)
-        D OUTXML("ZCCD",C0CDOCID)
-        ;D START^C0CMXMLB($$TAG(1),,"G")
-        ;D NDOUT($$FIRST(1))
-        ;D END^C0CMXMLB ;EOND THE DOCUMENT
-        ;M ZCCD=^TMP("MXMLBLD",$J)
-        ZWR ZCCD(1:30)
-        Q
-        ; 
-XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX)      ; RECURSIVE ROUTINE TO POPULATE
-        ; THE XPATH INDEX ZXIDX, PASSED BY NAME
-        ; THE XPATH ARRAY XPARY, PASSED BY NAME
-        ; ZOID IS THE STARTING OID
-        ; ZPATH IS THE STARTING XPATH, USUALLY "/"
-        ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
-        ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
-        I $G(ZREDUX)="" S ZREDUX=""
-        N NEWPATH
-        N NEWNUM S NEWNUM=""
-        I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
-        S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
-        I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
-        . N GT S GT=$P(NEWPATH,ZREDUX,2)
-        . I GT'="" S NEWPATH=GT
-        S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
-        N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
-        I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
-        E  I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
-        N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
-        I ZFRST'=0 D  ; THERE IS A CHILD
-        . N ZNUM
-        . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
-        . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD
-        N GNXT S GNXT=$$NXTSIB(ZOID)
-        I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES
-        I GNXT'=0 D  ;
-        . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE?
-        . I (ZNUM="")&(ZMULT) D  ; SIBLING IS FIRST OF MULTIPLES
-        . . N ZNUM S ZNUM=1 ;
-        . . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
-        . E  D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB
-        Q
-        ;
-PARSE(INXML,INDOC)      ;CALL THE MXML PARSER ON INXML, PASSED BY NAME
-        ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW
-        ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML
-        ;Q $$EN^MXMLDOM(INXML)
-        Q $$EN^MXMLDOM(INXML,"W")
-        ;
-ISMULT(ZOID)    ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
-        N ZN
-        ;I $$TAG(ZOID)["entry" B
-        S ZN=$$NXTSIB(ZOID)
-        I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
-        Q 0
-        ;
-FIRST(ZOID)     ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
-        Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
-        ;
-PARENT(ZOID)    ;RETURNS THE OID OF THE PARENT OF ZOID
-        Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
-        ;
-ATT(RTN,NODE)   ;GET ATTRIBUTES FOR ZOID
-        S HANDLE=C0CDOCID
-        K @RTN
-        D GETTXT^MXMLDOM("A")
-        Q
-        ;
-TAG(ZOID)       ; RETURNS THE XML TAG FOR THE NODE
-        ;I ZOID=149 B ;GPLTEST
-        N X,Y
-        S Y=""
-        S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
-        I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
-        I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
-        Q Y
-        ;
-NXTSIB(ZOID)    ; RETURNS THE NEXT SIBLING
-        Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
-        ;
-DATA(ZT,ZOID)   ; RETURNS DATA FOR THE NODE
-        ;N ZT,ZN S ZT=""
-        ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
-        ;Q $G(@C0CDOM@(ZOID,"T",1))
-        S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
-        Q
-        ;
-OUTXML(ZRTN,INID)       ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM
-        ;
-        S C0CDOCID=INID
-        D START^C0CMXMLB($$TAG(1),,"G")
-        D NDOUT($$FIRST(1))
-        D END^C0CMXMLB ;END THE DOCUMENT
-        M @ZRTN=^TMP("MXMLBLD",$J)
-        K ^TMP("MXMLBLD",$J)
-        Q
-        ;
-NDOUT(ZOID)     ;CALLBACK ROUTINE - IT IS RECURSIVE
-        N ZI S ZI=$$FIRST(ZOID)
-        I ZI'=0 D  ; THERE IS A CHILD
-        . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT
-        . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN
-        E  D  ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT
-        . ;W "DOING",ZOID,!
-        . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA
-        . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES
-        . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN
-        I $$NXTSIB(ZOID)'=0 D  ; THERE IS A SIBLING
-        . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS
-        Q
-        ;
-UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
-        K ZERR
-        D CLEAN^DILF
-        D UPDATE^DIE("","C0CFDA","","ZERR")
-        I $D(ZERR) D  ;
-        . W "ERROR",!
-        . ZWR ZERR
-        . B
-        K C0CFDA
-        Q
-        ;
+C0CMXML   ; GPL - MXML based XPath utilities;10/13/09  17:05
+ ;;0.1;C0C;nopatch;noreleasedate;Build 38
+ ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ Q
+ ; THIS FILE CONTAINS THE XPATH CREATOR, THE PARSE CALL TO THE MXML PARSER
+ ; AND THE OUTXML XML GENERATOR THAT OUTPUTS XML FROM AN MXML DOM
+ ; FOR CCD SPECIFIC ROUTINES, SEE C0CMCCD
+ ; FOR TEMPLATE FILE RELATED ROUTINES, SEE C0CMXP
+ ;
+TEST ;
+ S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
+ K GARY
+ W $$FTG^%ZISH("/home/vademo2/EHR/p/","mxml-test.xml",$NA(@C0CXMLIN@(1)),3)
+ S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DocID: ",C0CDOCID
+ S REDUX="//ContinuityOfCareRecord/Body"
+ D XPATH(1,"/","GIDX","GARY",,REDUX)
+ D SEPARATE^C0CMCCD("GARY2","GARY")
+ S ZI=""
+ F  S ZI=$O(GARY2(ZI)) Q:ZI=""  D  ;
+ . N GTMP,G2
+ . M G2=GARY2(ZI)
+ . D DEMUX2^C0CMXP("GTMP","G2",2)
+ . M GARY3(ZI)=GTMP
+ Q
+ ;
+TEST2 ;
+ S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail"
+ D XPATH(1,"/","GIDX","GARY","",REDUX)
+ Q
+ ;
+TEST3 
+ S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
+ K GARY,GTMP,GIDX
+ K @C0CXMLIN
+ W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3)
+ D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS
+ K @C0CXMLIN
+ M @C0CXMLIN=GTMP
+ K GTMP
+ D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN)
+ K @C0CXMLIN
+ M @C0CXMLIN=GTMP
+ K GTMP
+ S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID
+ S REDUX="//ClinicalDocument/component/structuredBody"
+ D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS
+ D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS
+ D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS
+ D XPATH(1,"/","GIDX","GARY",,REDUX)
+ K C0CCBK("TAG")
+ D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING
+ D TEST3A
+ Q
+ ;
+TEST3A ; INTERNAL ROUTINE
+ S ZI=""
+ F  S ZI=$O(GARY2(ZI)) Q:ZI=""  D  ;
+ . N GTMP,G2
+ . M G2=GARY2(ZI)
+ . D DEMUX2^C0CMXP("GTMP","G2",2)
+ . M GARY4(ZI)=GTMP
+ Q
+ ;
+TESTQ ; TEST OF THE QRDA TEMPLATE GPL 7/8/2010
+ S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
+ K GARY,GTMP,GIDX
+ K @C0CXMLIN
+ W $$FTG^%ZISH("/home/vademo2/","QRDA_CategoryI_WorldVistA1.xml",$NA(@C0CXMLIN@(1)),3)
+ D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS
+ K @C0CXMLIN
+ S GTMP(1)="<"_$P(GTMP(1),"<",2)
+ M @C0CXMLIN=GTMP
+ K GTMP
+ D TESTQ2
+ Q
+ ;
+TESTQ2 ; SECOND PART OF TESTQ
+ D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN)
+ K @C0CXMLIN
+ M @C0CXMLIN=GTMP
+ K GTMP
+ S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID
+ S REDUX="//ClinicalDocument/component/structuredBody"
+ D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS
+ D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS
+ D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS
+ D XPATH(1,"/","GIDX","GARY",,REDUX)
+ K C0CCBK("TAG")
+ D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING
+ D TEST3A
+ Q
+ ;
+TEST4 ; TEST OF OUTPUTING AN XML FILE FROM THE DOM .. this one is the CCR
+ ;
+ D TEST ; SET UP THE DOM
+ D START^C0CMXMLB($$TAG(1),,"G")
+ D NDOUT($$FIRST(1))
+ D END^C0CMXMLB ;END THE DOCUMENT
+ M ZCCR=^TMP("MXMLBLD",$J)
+ ZWR ZCCR
+ Q
+ ;
+TEST5 ; SAME AS TEST4, BUT THIS TIME THE CCD
+ S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
+ K GARY,GTMP,GIDX
+ K @C0CXMLIN
+ W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3)
+ D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS
+ K @C0CXMLIN
+ M @C0CXMLIN=GTMP
+ K GTMP
+ D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN)
+ K @C0CXMLIN
+ M @C0CXMLIN=GTMP
+ K GTMP
+ S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DOCID: ",C0CDOCID  ;CALL REGULAR PARSER
+ ;D XPATH(1,"/","GIDX2","GARY2",,REDUX)
+ D OUTXML("ZCCD",C0CDOCID)
+ ;D START^C0CMXMLB($$TAG(1),,"G")
+ ;D NDOUT($$FIRST(1))
+ ;D END^C0CMXMLB ;EOND THE DOCUMENT
+ ;M ZCCD=^TMP("MXMLBLD",$J)
+ ZWR ZCCD(1:30)
+ Q
+ ; 
+XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE
+ ; THE XPATH INDEX ZXIDX, PASSED BY NAME
+ ; THE XPATH ARRAY XPARY, PASSED BY NAME
+ ; ZOID IS THE STARTING OID
+ ; ZPATH IS THE STARTING XPATH, USUALLY "/"
+ ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
+ ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
+ I $G(ZREDUX)="" S ZREDUX=""
+ N NEWPATH
+ N NEWNUM S NEWNUM=""
+ I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
+ S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
+ I $G(ZREDUX)'="" D  ; REDUX PROVIDED?
+ . N GT S GT=$P(NEWPATH,ZREDUX,2)
+ . I GT'="" S NEWPATH=GT
+ S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
+ N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
+ I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
+ E  I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
+ N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
+ I ZFRST'=0 D  ; THERE IS A CHILD
+ . N ZNUM
+ . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
+ . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD
+ N GNXT S GNXT=$$NXTSIB(ZOID)
+ I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES
+ I GNXT'=0 D  ;
+ . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE?
+ . I (ZNUM="")&(ZMULT) D  ; SIBLING IS FIRST OF MULTIPLES
+ . . N ZNUM S ZNUM=1 ;
+ . . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
+ . E  D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB
+ Q
+ ;
+PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME
+ ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW
+ ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML
+ ;Q $$EN^MXMLDOM(INXML)
+ Q $$EN^MXMLDOM(INXML,"W")
+ ;
+ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
+ N ZN
+ ;I $$TAG(ZOID)["entry" B
+ S ZN=$$NXTSIB(ZOID)
+ I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
+ Q 0
+ ;
+FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
+ Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
+ ;
+PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID
+ Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
+ ;
+ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID
+ S HANDLE=C0CDOCID
+ K @RTN
+ D GETTXT^MXMLDOM("A")
+ Q
+ ;
+TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE
+ ;I ZOID=149 B ;GPLTEST
+ N X,Y
+ S Y=""
+ S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE
+ I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y
+ I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID)
+ Q Y
+ ;
+NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING
+ Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID)
+ ;
+DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE
+ ;N ZT,ZN S ZT=""
+ ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
+ ;Q $G(@C0CDOM@(ZOID,"T",1))
+ S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
+ Q
+ ;
+OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM
+ ;
+ S C0CDOCID=INID
+ D START^C0CMXMLB($$TAG(1),,"G")
+ D NDOUT($$FIRST(1))
+ D END^C0CMXMLB ;END THE DOCUMENT
+ M @ZRTN=^TMP("MXMLBLD",$J)
+ K ^TMP("MXMLBLD",$J)
+ Q
+ ;
+NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE
+ N ZI S ZI=$$FIRST(ZOID)
+ I ZI'=0 D  ; THERE IS A CHILD
+ . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT
+ . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN
+ E  D  ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT
+ . ;W "DOING",ZOID,!
+ . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA
+ . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES
+ . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN
+ I $$NXTSIB(ZOID)'=0 D  ; THERE IS A SIBLING
+ . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS
+ Q
+ ;
+UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
+ K ZERR
+ D CLEAN^DILF
+ D UPDATE^DIE("","C0CFDA","","ZERR")
+ I $D(ZERR) D  ;
+ . W "ERROR",!
+ . ZWR ZERR
+ . B
+ K C0CFDA
+ Q
+ ;

ccr/trunk/p/C0CMXP.m

@@ -1 @@
-C0CMXP    ; GPL - MXML based XPath utilities;12/04/09  17:05
-        ;;0.1;C0C;nopatch;noreleasedate;Build 38
-        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        Q
-        ;
-INITXPF(ARY)    ;INITIAL XML/XPATH FILE ARRAY
-        ; DON'T USE THIS ONE ... USE INITFARY^C0CSOAP("FARY") INSTEAD
-        D INITFARY^C0CSOAP(ARY) ;
-        Q
-        S @ARY@("XML FILE NUMBER")=178.101
-        S @ARY@("XML SOURCE FIELD")=2.1
-        S @ARY@("XML TEMPLATE FIELD")=3
-        S @ARY@("XPATH BINDING SUBFILE")=178.1014
-        S @ARY@("REDUX FIELD")=2.5
-        Q
-        ;
-SETXPF(ARY)     ; SET FILE AND FIELD VARIABLES FROM XPF ARRAY
-        ;
-        S C0CXPF=@ARY@("XML FILE NUMBER")
-        S C0CXFLD=@ARY@("XML")
-        S C0CXTFLD=@ARY@("TEMPLATE XML")
-        S C0CXPBF=@ARY@("BINDING SUBFILE NUMBER")
-        S C0CRDUXF=@ARY@("XPATH REDUCTION STRING")
-        Q
-        ;
-ADDXP(INARY,TID,FARY)   ;ADD XPATH .01 FIELD TO BINDING SUBFILE OF TEMPLATE TID
-        I '$D(FARY) D  ;
-        . S FARY="FARY" ; FILE ARRAY
-        . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
-        D SETXPF(FARY) ;SET FILE VARIABLES
-        N C0CA,C0CB
-        S C0CA="" S C0CB=0
-        F  S C0CA=$O(@INARY@(C0CA)) Q:C0CA=""  D  ; FOR EACH XPATH
-        . S C0CB=C0CB+1 ; COUNT OF XPATHS
-        . S C0CFDA(C0CXPBF,"?+"_C0CB_","_TID_",",.01)=C0CA
-        . D UPDIE ; CREATE THE BINDING SUBFILE FOR THIS XPATH
-        Q
-        ;
-FIXICD9 ; FIX THE ICD9RESULT XML 
-        D GETXML("GPL","ICD9RESULT") ; GET SOME BAD XML OUT OF THE FILE
-        S ZI=""
-        S G=""
-        F  S ZI=$O(GPL(ZI)) Q:ZI=""  D  ; FOR EACH LINE
-        . S G=G_GPL(ZI) ; MAKE ONE BIG STRING OF XML
-        D NORMAL^C0CSOAP("G2","G") ;NO NORMALIZE IT BACK INTO AN ARRAY
-        D ADDXML("G2","ICD9RESULT") ; AND PUT IT BACK
-        Q
-ADDXML(INXML,TEMPID,INFARY)     ;ADD XML TO A TEMPLATE ID TEMPID
-        ; INXML IS PASSED BY NAME
-        I '$D(INFARY) D  ;
-        . S INFARY="FARY" ; FILE ARRAY
-        . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
-        I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME
-        D SETXPF(INFARY) ;SET FILE VARIABLES
-        D WP^DIE(C0CXPF,TEMPID_",",C0CXFLD,,INXML)
-        Q
-        ;
-ADDTEMP(INXML,TEMPID,INFARY)    ;ADD XML TEMPLATE TO TEMPLATE RECORD TEMPID
-        ;
-        I '$D(INFARY) D  ;
-        . S INFARY="FARY" ; FILE ARRAY
-        . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
-        I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME
-        D SETXPF(INFARY) ;SET FILE VARIABLES
-        D WP^DIE(C0CXPF,TEMPID_",",C0CXTFLD,,INXML)
-        Q
-        ;
-GETXML(OUTXML,TEMPID,INFARY)    ;GET THE XML FROM TEMPLATE TEMPID
-        ;
-        I '$D(INFARY) D  ;
-        . S INFARY="FARY" ; FILE ARRAY
-        . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
-        D SETXPF(INFARY) ;SET FILE VARIABLES
-        I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME
-        I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXFLD,,OUTXML)'=OUTXML D  Q  ;
-        . W "ERROR RETRIEVING TEMPLATE",!
-        Q
-        ;
-GETTEMP(OUTXML,TEMPID,FARY)     ;GET THE TEMPLATE XML FROM TEMPLATE TEMPID
-        ;
-        I '$D(FARY) D  ;
-        . S FARY="FARY" ; FILE ARRAY
-        . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
-        D SETXPF(FARY) ;SET FILE VARIABLES
-        I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,FARY) ;RESOLVE TEMPLATE NAME
-        I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXTFLD,,OUTXML)'=OUTXML D  Q  ;
-        . W "ERROR RETRIEVING TEMPLATE",!
-        Q
-        ;
-COPYWP(ZFLD,ZSRCREC,ZDESTREC,ZSRCF,ZDESTF)      ; COPIES A WORD PROCESSING FIELD
-        ; FROM ONE RECORD TO ANOTHER RECORD 
-        ; ZFLD IS EITHER A NUMBERIC FIELD OR A NAME IN ZSRCF
-        ; ZSRCF IS THE SOURCE FILE, IN FILE REDIRECT FORMAT
-        ; IF ZSRCF IS OMMITED, THE DEFAULT C0C XML MISC FILE WILL BE ASSUMED
-        ; ZDESTF IS DESTINATION FILE. IF OMMITED, IS ASSUMED TO BE THE SAME
-        ; A ZSRCF
-        I '$D(ZSRCF) D  ;
-        . S ZSRCF="ZSRCF"
-        . D INITFARY^C0CSOAP(ZSRCF)
-        I '$D(ZDESTF) D  ;
-        . S ZDESTF="ZDESTF"
-        . M @ZDESTF=@ZSRCF
-        N ZSF,ZDF,ZSFREF,ZDFREF
-        S ZSF=@ZSRCF@("XML FILE NUMBER")
-        S ZSFREF=$$FILEREF^C0CRNF(ZSF)
-        S ZDF=@ZDESTF@("XML FILE NUMBER")
-        S ZDFREF=$$FILEREF^C0CRNF(ZDF)
-        N ZSIEN,ZDIEN
-        S ZSIEN=$O(@ZSFREF@("B",ZSRCREC,""))
-        I ZSIEN="" W !,"ERROR SOURCE RECORD NOT FOUND" Q  ;
-        S ZDIEN=$O(@ZDFREF@("B",ZDESTREC,""))
-        I ZDIEN="" W !,"ERROR DESTINATION RECORD NOT FOUND" Q  ;
-        N ZFLDNUM
-        I +ZFLD=0 S ZFLDNUM=@ZSRCF@(ZFLD) ; IF FIELD IS PASSED BY NAME
-        E  S ZFLDNUM=ZFLD ; IF FIELD IS PASSED BY NUMBER
-        N ZWP,ZWPN
-        S ZWPN=$$GET1^DIQ(ZSF,ZSIEN_",",ZFLDNUM,,"ZWP") ; GET WP FROM SOURCE
-        I ZWPN'="ZWP" W !,"ERROR SOURCE FIELD EMPTY" Q  ;
-        D WP^DIE(ZDF,ZDIEN_",",ZFLDNUM,,"ZWP") ; PUT WP FIELD TO DEST
-        Q
-        ;
-COMPILE(TID,UFARY)      ; COMPILES AN XML TEMPLATE AND GENERATES XPATH BINDINGS
-        ; UFARY IF SPECIFIED WILL REDIRECT THE XML FILE TO USE
-        ; INTID IS THE IEN OF THE RECORD TO USE IN THE XML FILE
-        ; XML IS PULLED FROM THE "XML" FIELD AND THE COMPILED RESULT PUT
-        ; IN THE "XML TEMPLATE" FIELD. ALL XPATHS USED IN THE TEMPLATE
-        ; WILL BE POPULATED TO THE XPATH BINDINGS SUBFILE AS .01
-        I '$D(UFARY) D  ;
-        . S UFARY="DEFFARY" ; FILE ARRAY
-        . ;D INITXPF("UFARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
-        . D INITFARY^C0CSOAP(UFARY)
-        D SETXPF(UFARY) ;SET FILE VARIABLES
-        I +TID=0 S INTID=$$RESTID^C0CSOAP(TID,UFARY)
-        E  S INTID=TID
-        ;B
-        ;N C0CXML,C0CREDUX,C0CTEMP,C0CIDX
-        D GETXML("C0CXML",INTID,UFARY)
-        S C0CREDUX=$$GET1^DIQ(C0CXPF,INTID_",",C0CRDUXF,"E") ;XPATH REDUCTION STRING
-        D MKTPLATE("C0CTEMP","C0CIDX","C0CXML",C0CREDUX) ; CREATE TEMPLATE AND IDX
-        D ADDTEMP("C0CTEMP",INTID,UFARY) ; WRITE THE TEMPLATE TO FILE
-        D ADDXP("C0CIDX",INTID,UFARY) ;CREATE XPATH SUBFILE ENTRIES FOR EVERY XPATH
-        Q
-        ;
-MKTPLATE(OUTT,OUTIDX,INXML,REDUX)       ;MAKE A TEMPLATE FROM INXML, RETURNED IN OUTT
-        ; BOTH PASSED BY NAME. THE REDUX XPATH REDUCTION STRING IS USED IF PASSED
-        ; OUTIDX IS AN ARRAY OF THE XPATHS USED IN MAKING THE TEMPLATE
-        ;
-        S C0CXLOC=$NA(^TMP("C0CXML",$J))
-        K @C0CXLOC
-        M @C0CXLOC=@INXML
-        S C0CDOCID=$$PARSE^C0CMXML(C0CXLOC,"C0CMKT")
-        K @C0CXLOC
-        S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) 
-        ;N GIDX,GIDX2,GARY,GARY2
-        I '$D(REDUX) S REDUX=""
-        D XPATH^C0CMXML(1,"/","GIDX","GARY",,REDUX)
-        D INVERT("GIDX2","GIDX") ;MAKE ARRAY TO LOOK UP XPATH BY NODE
-        N ZI,ZD S ZI=""
-        F  S ZI=$O(@C0CDOM@(ZI)) Q:ZI=""  D  ; FOR EACH NODE IN THE DOM
-        . K ZD ;FOR DATA
-        . D DATA^C0CMXML("ZD",ZI) ;SEE IF THERE IS DATA FOR THIS NODE
-        . ;I $D(ZD(1)) D  ; IF YES
-        . I $$FIRST^C0CMXML(ZI)=0 D  ; IF THERE ARE NO CHILDREN TO THIS NODE
-        . . ;I ZI<3 B  ;W !,ZD(1)
-        . . K @C0CDOM@(ZI,"T") ; KILL THE DATA
-        . . N ZXPATH
-        . . S ZXPATH=$G(GIDX2(ZI)) ;FIND AN XPATH FOR THIS NODE
-        . . S @C0CDOM@(ZI,"T",1)="@@"_ZXPATH_"@@"
-        . . I ZXPATH'="" S @OUTIDX@(ZXPATH)="" ; PASS BACK XPATH USED IN IDX
-        D OUTXML^C0CMXML(OUTT,C0CDOCID)
-        Q
-        ;
-INVERT(OUTX,INX)        ;INVERTS AN XPATH INDEX RETURNING @OUTX@(x)=XPath from
-        ; @INX@(XPath)=x
-        N ZI S ZI=""
-        F  S ZI=$O(@INX@(ZI)) Q:ZI=""  D  ;FOR EACH XPATH IN THE INPUT
-        . S @OUTX@(@INX@(ZI))=ZI ; SET INVERTED ENTRY
-        Q
-        ;
-DEMUX(OUTX,INX) ;PARSES XPATH PASSED BY VALUE IN INX TO REMOVE [x] MULTIPLES
-        ; RETURNS OUTX: MULTIPLE^SUBMULTIPLE^XPATH 
-        N ZX,ZY,ZZ,ZZ1,ZMULT,ZSUB
-        S (ZMULT,ZSUB)=""
-        S ZX=$P(INX,"[",2)
-        I ZX'="" D  ; THERE IS A [x] MULTIPLE
-        . S ZY=$P(INX,"[",1) ;FIRST PART OF XPATH
-        . S ZMULT=$P(ZX,"]",1) ; NUMBER OF THE MULTIPLE
-        . S ZX=ZY_$P(ZX,"]",2) ; REST OF THE XPATH
-        . I $P(ZX,"[",2)'="" D  ; A SUB MULTIPLE EXISTS
-        . . S ZZ=$P(ZX,"[",1) ; FIRST PART OF XPATH
-        . . S ZX=$P(ZX,"[",2) ; DELETE THE [
-        . . S ZSUB=$P(ZX,"]",1) ; NUMBER OF THE SUBMULTIPLE
-        . . S ZX=ZZ_$P(ZX,"]",2) ; REST OF THE XPATH
-        E  S ZX=INX ;NO MULTIPLE HERE
-        S @OUTX=ZMULT_"^"_ZSUB_"^"_ZX ;RETURN MULTIPLE^SUBMULTIPLE^XPATH
-        Q
-        ;
-DEMUXARY(OARY,IARY,DEPTH)       ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
-        ; FORMAT @OARY@(x,variablename) where x is the first multiple
-        ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED
-        N ZI,ZJ,ZK,ZL,ZM S ZI=""
-        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ;
-        . D DEMUX^C0CMXP("ZJ",ZI)
-        . S ZK=$P(ZJ,"^",3)
-        . S ZM=$RE($P($RE(ZK),"/",1))
-        . I $G(DEPTH)=2 D  ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME
-        . . S ZM=$RE($P($RE(ZK),"/",2))_ZM
-        . S ZL=$P(ZJ,"^",1)
-        . I ZL="" S ZL=1
-        . I $D(@OARY@(ZL,ZM)) D  ;IT'S A DUP
-        . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI)
-        . E  S @OARY@(ZL,ZM)=@IARY@(ZI)
-        Q
-        ;
-DEMUX2(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
-        ; FORMAT @OARY@(x,variablename) where x is the first multiple
-        ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED
-        N ZI,ZJ,ZK,ZL,ZM S ZI=""
-        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ;
-        . D DEMUX^C0CMXP("ZJ",ZI)
-        . S ZK=$P(ZJ,"^",3)
-        . S ZM=$RE($P($RE(ZK),"/",1))
-        . I $G(DEPTH)=2 D  ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME
-        . . S ZM=$RE($P($RE(ZK),"/",2))_"."_ZM
-        . S ZL=$P(ZJ,"^",1)
-        . I ZL="" S ZL=1
-        . I $D(@OARY@(ZL,ZM)) D  ;IT'S A DUP
-        . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI)
-        . E  S @OARY@(ZL,ZM)=@IARY@(ZI)
-        Q
-        ;
-DEMUXXP1(OARY,IARY)     ;IARY IS INCOMING XPATH ARRAY
-        ; BOTH IARY AND OARY ARE PASSED BY NAME
-        ; RETURNS A SIMPLE XPATH ARRAY WITHOUT MULTIPLES. DUPLICATES ARE REMOVED
-        N ZI,ZJ,ZK
-        S ZI=""
-        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH XPATH IN IARY
-        . D DEMUX^C0CMXP("ZJ",ZI)
-        . S ZK=$P(ZJ,"^",3) ;THE XPATH
-        . S @OARY@(ZK)=@IARY@(ZI) ;THE RESULT. DUPLICATES WILL NOT SHOW
-        . ; CAUTION, IF THERE ARE MULTIPLES, ONLY THE DATA FOR THE LAST
-        . ; MULTIPLE WILL BE INCLUDED IN THE OUTPUT ARRAY, ASSIGNED TO THE
-        . ; COMMON XPATH
-        Q
-        ;
-DEMUXXP2(OARY,IARY)     ; IARY AND OARY ARE PASSED BY NAME
-        ; IARY IS AN XPATH ARRAY THAT MAY CONTAIN MULTIPLES
-        ; OARY IS THE OUTPUT ARRAY WHERE MULTIPLES ARE RETURNED IN THE FORM
-        ; @OARY@(x,Xpath)=data or @OARY@(x,y,Xpath)=data WHERE x AND y ARE
-        ; THE MULTIPLES AND Xpath IS THE BASE XPATH WITHOUT [x] AND [y]
-        ; 
-        N ZI,ZJ,ZK,ZX,ZY,ZP
-        S ZI=""
-        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH INPUT XPATH
-        . D DEMUX("ZJ",ZI) ; PULL OUT THE MULTIPLES
-        . S ZX=$P(ZJ,"^",1) ;x
-        . S ZY=$P(ZJ,"^",2) ;y
-        . S ZP=$P(ZJ,"^",3) ;Xpath
-        . I ZX="" S ZX=1 ; NO MULTIPLE WILL STORE IN x=1
-        . I ZY'="" D  ;IS THERE A y?
-        . . S @OARY@(ZX,ZY,ZP)=@IARY@(ZI)
-        . E  D  ;NO y
-        . . S @OARY@(ZX,ZP)=@IARY@(ZI)
-        Q
-        ;
-UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
-        K ZERR
-        D CLEAN^DILF
-        D UPDATE^DIE("","C0CFDA","","ZERR")
-        I $D(ZERR) D  ;
-        . W "ERROR",!
-        . ZWR ZERR
-        . B
-        K C0CFDA
-        Q
-        ;
+C0CMXP   ; GPL - MXML based XPath utilities;12/04/09  17:05
+ ;;0.1;C0C;nopatch;noreleasedate;Build 38
+ ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ Q
+ ;
+INITXPF(ARY) ;INITIAL XML/XPATH FILE ARRAY
+ ; DON'T USE THIS ONE ... USE INITFARY^C0CSOAP("FARY") INSTEAD
+ D INITFARY^C0CSOAP(ARY) ;
+ Q
+ S @ARY@("XML FILE NUMBER")=178.101
+ S @ARY@("XML SOURCE FIELD")=2.1
+ S @ARY@("XML TEMPLATE FIELD")=3
+ S @ARY@("XPATH BINDING SUBFILE")=178.1014
+ S @ARY@("REDUX FIELD")=2.5
+ Q
+ ;
+SETXPF(ARY) ; SET FILE AND FIELD VARIABLES FROM XPF ARRAY
+ ;
+ S C0CXPF=@ARY@("XML FILE NUMBER")
+ S C0CXFLD=@ARY@("XML")
+ S C0CXTFLD=@ARY@("TEMPLATE XML")
+ S C0CXPBF=@ARY@("BINDING SUBFILE NUMBER")
+ S C0CRDUXF=@ARY@("XPATH REDUCTION STRING")
+ Q
+ ;
+ADDXP(INARY,TID,FARY) ;ADD XPATH .01 FIELD TO BINDING SUBFILE OF TEMPLATE TID
+ I '$D(FARY) D  ;
+ . S FARY="FARY" ; FILE ARRAY
+ . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
+ D SETXPF(FARY) ;SET FILE VARIABLES
+ N C0CA,C0CB
+ S C0CA="" S C0CB=0
+ F  S C0CA=$O(@INARY@(C0CA)) Q:C0CA=""  D  ; FOR EACH XPATH
+ . S C0CB=C0CB+1 ; COUNT OF XPATHS
+ . S C0CFDA(C0CXPBF,"?+"_C0CB_","_TID_",",.01)=C0CA
+ . D UPDIE ; CREATE THE BINDING SUBFILE FOR THIS XPATH
+ Q
+ ;
+FIXICD9 ; FIX THE ICD9RESULT XML 
+ D GETXML("GPL","ICD9RESULT") ; GET SOME BAD XML OUT OF THE FILE
+ S ZI=""
+ S G=""
+ F  S ZI=$O(GPL(ZI)) Q:ZI=""  D  ; FOR EACH LINE
+ . S G=G_GPL(ZI) ; MAKE ONE BIG STRING OF XML
+ D NORMAL^C0CSOAP("G2","G") ;NO NORMALIZE IT BACK INTO AN ARRAY
+ D ADDXML("G2","ICD9RESULT") ; AND PUT IT BACK
+ Q
+ADDXML(INXML,TEMPID,INFARY) ;ADD XML TO A TEMPLATE ID TEMPID
+ ; INXML IS PASSED BY NAME
+ I '$D(INFARY) D  ;
+ . S INFARY="FARY" ; FILE ARRAY
+ . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
+ I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME
+ D SETXPF(INFARY) ;SET FILE VARIABLES
+ D WP^DIE(C0CXPF,TEMPID_",",C0CXFLD,,INXML)
+ Q
+ ;
+ADDTEMP(INXML,TEMPID,INFARY) ;ADD XML TEMPLATE TO TEMPLATE RECORD TEMPID
+ ;
+ I '$D(INFARY) D  ;
+ . S INFARY="FARY" ; FILE ARRAY
+ . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
+ I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME
+ D SETXPF(INFARY) ;SET FILE VARIABLES
+ D WP^DIE(C0CXPF,TEMPID_",",C0CXTFLD,,INXML)
+ Q
+ ;
+GETXML(OUTXML,TEMPID,INFARY) ;GET THE XML FROM TEMPLATE TEMPID
+ ;
+ I '$D(INFARY) D  ;
+ . S INFARY="FARY" ; FILE ARRAY
+ . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
+ D SETXPF(INFARY) ;SET FILE VARIABLES
+ I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME
+ I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXFLD,,OUTXML)'=OUTXML D  Q  ;
+ . W "ERROR RETRIEVING TEMPLATE",!
+ Q
+ ;
+GETTEMP(OUTXML,TEMPID,FARY) ;GET THE TEMPLATE XML FROM TEMPLATE TEMPID
+ ;
+ I '$D(FARY) D  ;
+ . S FARY="FARY" ; FILE ARRAY
+ . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
+ D SETXPF(FARY) ;SET FILE VARIABLES
+ I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,FARY) ;RESOLVE TEMPLATE NAME
+ I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXTFLD,,OUTXML)'=OUTXML D  Q  ;
+ . W "ERROR RETRIEVING TEMPLATE",!
+ Q
+ ;
+COPYWP(ZFLD,ZSRCREC,ZDESTREC,ZSRCF,ZDESTF) ; COPIES A WORD PROCESSING FIELD
+ ; FROM ONE RECORD TO ANOTHER RECORD 
+ ; ZFLD IS EITHER A NUMBERIC FIELD OR A NAME IN ZSRCF
+ ; ZSRCF IS THE SOURCE FILE, IN FILE REDIRECT FORMAT
+ ; IF ZSRCF IS OMMITED, THE DEFAULT C0C XML MISC FILE WILL BE ASSUMED
+ ; ZDESTF IS DESTINATION FILE. IF OMMITED, IS ASSUMED TO BE THE SAME
+ ; A ZSRCF
+ I '$D(ZSRCF) D  ;
+ . S ZSRCF="ZSRCF"
+ . D INITFARY^C0CSOAP(ZSRCF)
+ I '$D(ZDESTF) D  ;
+ . S ZDESTF="ZDESTF"
+ . M @ZDESTF=@ZSRCF
+ N ZSF,ZDF,ZSFREF,ZDFREF
+ S ZSF=@ZSRCF@("XML FILE NUMBER")
+ S ZSFREF=$$FILEREF^C0CRNF(ZSF)
+ S ZDF=@ZDESTF@("XML FILE NUMBER")
+ S ZDFREF=$$FILEREF^C0CRNF(ZDF)
+ N ZSIEN,ZDIEN
+ S ZSIEN=$O(@ZSFREF@("B",ZSRCREC,""))
+ I ZSIEN="" W !,"ERROR SOURCE RECORD NOT FOUND" Q  ;
+ S ZDIEN=$O(@ZDFREF@("B",ZDESTREC,""))
+ I ZDIEN="" W !,"ERROR DESTINATION RECORD NOT FOUND" Q  ;
+ N ZFLDNUM
+ I +ZFLD=0 S ZFLDNUM=@ZSRCF@(ZFLD) ; IF FIELD IS PASSED BY NAME
+ E  S ZFLDNUM=ZFLD ; IF FIELD IS PASSED BY NUMBER
+ N ZWP,ZWPN
+ S ZWPN=$$GET1^DIQ(ZSF,ZSIEN_",",ZFLDNUM,,"ZWP") ; GET WP FROM SOURCE
+ I ZWPN'="ZWP" W !,"ERROR SOURCE FIELD EMPTY" Q  ;
+ D WP^DIE(ZDF,ZDIEN_",",ZFLDNUM,,"ZWP") ; PUT WP FIELD TO DEST
+ Q
+ ;
+COMPILE(TID,UFARY) ; COMPILES AN XML TEMPLATE AND GENERATES XPATH BINDINGS
+ ; UFARY IF SPECIFIED WILL REDIRECT THE XML FILE TO USE
+ ; INTID IS THE IEN OF THE RECORD TO USE IN THE XML FILE
+ ; XML IS PULLED FROM THE "XML" FIELD AND THE COMPILED RESULT PUT
+ ; IN THE "XML TEMPLATE" FIELD. ALL XPATHS USED IN THE TEMPLATE
+ ; WILL BE POPULATED TO THE XPATH BINDINGS SUBFILE AS .01
+ I '$D(UFARY) D  ;
+ . S UFARY="DEFFARY" ; FILE ARRAY
+ . ;D INITXPF("UFARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE
+ . D INITFARY^C0CSOAP(UFARY)
+ D SETXPF(UFARY) ;SET FILE VARIABLES
+ I +TID=0 S INTID=$$RESTID^C0CSOAP(TID,UFARY)
+ E  S INTID=TID
+ ;B
+ ;N C0CXML,C0CREDUX,C0CTEMP,C0CIDX
+ D GETXML("C0CXML",INTID,UFARY)
+ S C0CREDUX=$$GET1^DIQ(C0CXPF,INTID_",",C0CRDUXF,"E") ;XPATH REDUCTION STRING
+ D MKTPLATE("C0CTEMP","C0CIDX","C0CXML",C0CREDUX) ; CREATE TEMPLATE AND IDX
+ D ADDTEMP("C0CTEMP",INTID,UFARY) ; WRITE THE TEMPLATE TO FILE
+ D ADDXP("C0CIDX",INTID,UFARY) ;CREATE XPATH SUBFILE ENTRIES FOR EVERY XPATH
+ Q
+ ;
+MKTPLATE(OUTT,OUTIDX,INXML,REDUX) ;MAKE A TEMPLATE FROM INXML, RETURNED IN OUTT
+ ; BOTH PASSED BY NAME. THE REDUX XPATH REDUCTION STRING IS USED IF PASSED
+ ; OUTIDX IS AN ARRAY OF THE XPATHS USED IN MAKING THE TEMPLATE
+ ;
+ S C0CXLOC=$NA(^TMP("C0CXML",$J))
+ K @C0CXLOC
+ M @C0CXLOC=@INXML
+ S C0CDOCID=$$PARSE^C0CMXML(C0CXLOC,"C0CMKT")
+ K @C0CXLOC
+ S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) 
+ ;N GIDX,GIDX2,GARY,GARY2
+ I '$D(REDUX) S REDUX=""
+ D XPATH^C0CMXML(1,"/","GIDX","GARY",,REDUX)
+ D INVERT("GIDX2","GIDX") ;MAKE ARRAY TO LOOK UP XPATH BY NODE
+ N ZI,ZD S ZI=""
+ F  S ZI=$O(@C0CDOM@(ZI)) Q:ZI=""  D  ; FOR EACH NODE IN THE DOM
+ . K ZD ;FOR DATA
+ . D DATA^C0CMXML("ZD",ZI) ;SEE IF THERE IS DATA FOR THIS NODE
+ . ;I $D(ZD(1)) D  ; IF YES
+ . I $$FIRST^C0CMXML(ZI)=0 D  ; IF THERE ARE NO CHILDREN TO THIS NODE
+ . . ;I ZI<3 B  ;W !,ZD(1)
+ . . K @C0CDOM@(ZI,"T") ; KILL THE DATA
+ . . N ZXPATH
+ . . S ZXPATH=$G(GIDX2(ZI)) ;FIND AN XPATH FOR THIS NODE
+ . . S @C0CDOM@(ZI,"T",1)="@@"_ZXPATH_"@@"
+ . . I ZXPATH'="" S @OUTIDX@(ZXPATH)="" ; PASS BACK XPATH USED IN IDX
+ D OUTXML^C0CMXML(OUTT,C0CDOCID)
+ Q
+ ;
+INVERT(OUTX,INX) ;INVERTS AN XPATH INDEX RETURNING @OUTX@(x)=XPath from
+ ; @INX@(XPath)=x
+ N ZI S ZI=""
+ F  S ZI=$O(@INX@(ZI)) Q:ZI=""  D  ;FOR EACH XPATH IN THE INPUT
+ . S @OUTX@(@INX@(ZI))=ZI ; SET INVERTED ENTRY
+ Q
+ ;
+DEMUX(OUTX,INX) ;PARSES XPATH PASSED BY VALUE IN INX TO REMOVE [x] MULTIPLES
+ ; RETURNS OUTX: MULTIPLE^SUBMULTIPLE^XPATH 
+ N ZX,ZY,ZZ,ZZ1,ZMULT,ZSUB
+ S (ZMULT,ZSUB)=""
+ S ZX=$P(INX,"[",2)
+ I ZX'="" D  ; THERE IS A [x] MULTIPLE
+ . S ZY=$P(INX,"[",1) ;FIRST PART OF XPATH
+ . S ZMULT=$P(ZX,"]",1) ; NUMBER OF THE MULTIPLE
+ . S ZX=ZY_$P(ZX,"]",2) ; REST OF THE XPATH
+ . I $P(ZX,"[",2)'="" D  ; A SUB MULTIPLE EXISTS
+ . . S ZZ=$P(ZX,"[",1) ; FIRST PART OF XPATH
+ . . S ZX=$P(ZX,"[",2) ; DELETE THE [
+ . . S ZSUB=$P(ZX,"]",1) ; NUMBER OF THE SUBMULTIPLE
+ . . S ZX=ZZ_$P(ZX,"]",2) ; REST OF THE XPATH
+ E  S ZX=INX ;NO MULTIPLE HERE
+ S @OUTX=ZMULT_"^"_ZSUB_"^"_ZX ;RETURN MULTIPLE^SUBMULTIPLE^XPATH
+ Q
+ ;
+DEMUXARY(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
+ ; FORMAT @OARY@(x,variablename) where x is the first multiple
+ ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED
+ N ZI,ZJ,ZK,ZL,ZM S ZI=""
+ F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ;
+ . D DEMUX^C0CMXP("ZJ",ZI)
+ . S ZK=$P(ZJ,"^",3)
+ . S ZM=$RE($P($RE(ZK),"/",1))
+ . I $G(DEPTH)=2 D  ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME
+ . . S ZM=$RE($P($RE(ZK),"/",2))_ZM
+ . S ZL=$P(ZJ,"^",1)
+ . I ZL="" S ZL=1
+ . I $D(@OARY@(ZL,ZM)) D  ;IT'S A DUP
+ . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI)
+ . E  S @OARY@(ZL,ZM)=@IARY@(ZI)
+ Q
+ ;
+DEMUX2(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
+ ; FORMAT @OARY@(x,variablename) where x is the first multiple
+ ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED
+ N ZI,ZJ,ZK,ZL,ZM S ZI=""
+ F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ;
+ . D DEMUX^C0CMXP("ZJ",ZI)
+ . S ZK=$P(ZJ,"^",3)
+ . S ZM=$RE($P($RE(ZK),"/",1))
+ . I $G(DEPTH)=2 D  ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME
+ . . S ZM=$RE($P($RE(ZK),"/",2))_"."_ZM
+ . S ZL=$P(ZJ,"^",1)
+ . I ZL="" S ZL=1
+ . I $D(@OARY@(ZL,ZM)) D  ;IT'S A DUP
+ . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI)
+ . E  S @OARY@(ZL,ZM)=@IARY@(ZI)
+ Q
+ ;
+DEMUXXP1(OARY,IARY) ;IARY IS INCOMING XPATH ARRAY
+ ; BOTH IARY AND OARY ARE PASSED BY NAME
+ ; RETURNS A SIMPLE XPATH ARRAY WITHOUT MULTIPLES. DUPLICATES ARE REMOVED
+ N ZI,ZJ,ZK
+ S ZI=""
+ F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH XPATH IN IARY
+ . D DEMUX^C0CMXP("ZJ",ZI)
+ . S ZK=$P(ZJ,"^",3) ;THE XPATH
+ . S @OARY@(ZK)=@IARY@(ZI) ;THE RESULT. DUPLICATES WILL NOT SHOW
+ . ; CAUTION, IF THERE ARE MULTIPLES, ONLY THE DATA FOR THE LAST
+ . ; MULTIPLE WILL BE INCLUDED IN THE OUTPUT ARRAY, ASSIGNED TO THE
+ . ; COMMON XPATH
+ Q
+ ;
+DEMUXXP2(OARY,IARY) ; IARY AND OARY ARE PASSED BY NAME
+ ; IARY IS AN XPATH ARRAY THAT MAY CONTAIN MULTIPLES
+ ; OARY IS THE OUTPUT ARRAY WHERE MULTIPLES ARE RETURNED IN THE FORM
+ ; @OARY@(x,Xpath)=data or @OARY@(x,y,Xpath)=data WHERE x AND y ARE
+ ; THE MULTIPLES AND Xpath IS THE BASE XPATH WITHOUT [x] AND [y]
+ ; 
+ N ZI,ZJ,ZK,ZX,ZY,ZP
+ S ZI=""
+ F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH INPUT XPATH
+ . D DEMUX("ZJ",ZI) ; PULL OUT THE MULTIPLES
+ . S ZX=$P(ZJ,"^",1) ;x
+ . S ZY=$P(ZJ,"^",2) ;y
+ . S ZP=$P(ZJ,"^",3) ;Xpath
+ . I ZX="" S ZX=1 ; NO MULTIPLE WILL STORE IN x=1
+ . I ZY'="" D  ;IS THERE A y?
+ . . S @OARY@(ZX,ZY,ZP)=@IARY@(ZI)
+ . E  D  ;NO y
+ . . S @OARY@(ZX,ZP)=@IARY@(ZI)
+ Q
+ ;
+UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
+ K ZERR
+ D CLEAN^DILF
+ D UPDATE^DIE("","C0CFDA","","ZERR")
+ I $D(ZERR) D  ;
+ . W "ERROR",!
+ . ZWR ZERR
+ . B
+ K C0CFDA
+ Q
+ ;

ccr/trunk/p/C0CORSLT.m

@@ -1 +1 @@
 C0CORSLT ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11
-        ;;1.0;C0C;;Jan 21, 2010;Build 38
-        ;Copyright 2011 George Lilly.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "NO ENTRY FROM TOP",!
-        Q
-        ;
+ ;;1.0;C0C;;Jan 21, 2010;Build 38
+ ;Copyright 2011 George Lilly.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "NO ENTRY FROM TOP",!
+ Q
+ ;
 EN(ZVARS,DFN) ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS
  ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE

ccr/trunk/p/C0CPARMS.m

@@ -1 @@
-C0CPARMS        ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-SET(INPARMS)    ;INITIALIZE RUNTIME PARMS USING INPARMS TO OVERRIDE DEFAULTS
-        ; PARAMETERS ARE PASSED AS A STRING: "PARM1:VALUE1^PARM2:VALUE2^ETC"
-        ; THE SAME FORMAT IS USED BY RPC AND COMMAND LINE ENTRY POINTS
-        ;
-        N PTMP ;
-        S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;BASE FOR THIS RUN
-        K @C0CPARMS ;START WITH EMPTY PARMS; MAY NOT WANT TO DO THIS KILL
-        I $G(INPARMS)'="" D  ; OVERRIDES PROVIDED
-        . N C0CI S C0CI=""
-        . N C0CN S C0CN=1
-        . F  S C0CI=$P(INPARMS,"^",C0CN) Q:C0CI=""  D  ;
-        . . S C0CN=C0CN+1 ;NEXT PARM
-        . . N C1,C2
-        . . S C1=$P(C0CI,":",1) ; PARAMETER
-        . . S C2=$P(C0CI,":",2) ; VALUE
-        . . I C2="" S C2=1
-        . . S @C0CPARMS@(C1)=C2
-        . I C0CN=1 S @C0CPARMS@($P(INPARMS,":",1))=$P(C0CI,":",2) ; ONLY ONE
-        ; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS
-        ; IF THEY FAIL, THE FOLLOWING WILL BE HARDCODED DEFAULTS
-        I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH
-        I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
-        I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS
-        I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
-        I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
-        I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS
-        I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
-        I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
-        I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE
-        Q
-        ;
-CHECK   ; CHECK TO SEE IF PARMS ARE PRESENT, ELSE RUN SET
-        ;
-        I '$D(C0CPARMS) S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;SHOULDN'T HAPPEN
-        I '$D(@C0CPARMS) D SET("SETWITHCHECK:1")
-        Q
-        ;
-GET(WHICHP)     ;EXTRINSIC TO RETURN THE VALUE OF PARAMETER WHICHP
-        ;
-        D CHECK ; SHOULDN'T HAPPEN BUT TO BE SAFE
-        N GTMP
-        Q $G(@C0CPARMS@(WHICHP)) ;PULL THE PARM FROM THE TABLE
-        ;
+C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+SET(INPARMS) ;INITIALIZE RUNTIME PARMS USING INPARMS TO OVERRIDE DEFAULTS
+ ; PARAMETERS ARE PASSED AS A STRING: "PARM1:VALUE1^PARM2:VALUE2^ETC"
+ ; THE SAME FORMAT IS USED BY RPC AND COMMAND LINE ENTRY POINTS
+ ;
+ N PTMP ;
+ S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;BASE FOR THIS RUN
+ K @C0CPARMS ;START WITH EMPTY PARMS; MAY NOT WANT TO DO THIS KILL
+ I $G(INPARMS)'="" D  ; OVERRIDES PROVIDED
+ . N C0CI S C0CI=""
+ . N C0CN S C0CN=1
+ . F  S C0CI=$P(INPARMS,"^",C0CN) Q:C0CI=""  D  ;
+ . . S C0CN=C0CN+1 ;NEXT PARM
+ . . N C1,C2
+ . . S C1=$P(C0CI,":",1) ; PARAMETER
+ . . S C2=$P(C0CI,":",2) ; VALUE
+ . . I C2="" S C2=1
+ . . S @C0CPARMS@(C1)=C2
+ . I C0CN=1 S @C0CPARMS@($P(INPARMS,":",1))=$P(C0CI,":",2) ; ONLY ONE
+ ; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS
+ ; IF THEY FAIL, THE FOLLOWING WILL BE HARDCODED DEFAULTS
+ I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH
+ I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
+ I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS
+ I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
+ I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
+ I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS
+ I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES
+ I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO
+ I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE
+ Q
+ ;
+CHECK ; CHECK TO SEE IF PARMS ARE PRESENT, ELSE RUN SET
+ ;
+ I '$D(C0CPARMS) S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;SHOULDN'T HAPPEN
+ I '$D(@C0CPARMS) D SET("SETWITHCHECK:1")
+ Q
+ ;
+GET(WHICHP) ;EXTRINSIC TO RETURN THE VALUE OF PARAMETER WHICHP
+ ;
+ D CHECK ; SHOULDN'T HAPPEN BUT TO BE SAFE
+ N GTMP
+ Q $G(@C0CPARMS@(WHICHP)) ;PULL THE PARM FROM THE TABLE
+ ;

ccr/trunk/p/C0CPROBS.m

@@ -1 @@
-C0CPROBS        ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008,2009 George Lilly, University of Minnesota.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        ;
-        ; PROCESS THE PROBLEMS SECTION OF THE CCR
-        ;
-EXTRACT(IPXML,DFN,OUTXML)       ; EXTRACT PROBLEMS INTO PROVIDED XML TEMPLATE
-        ;
-        ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
-        ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE
-        ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE
-        ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS
-        ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT
-        ;
-        N RPCRSLT,J,K,PTMP,X,VMAP,TBU
-        S TVMAP=$NA(^TMP("C0CCCR",$J,"PROBVALS"))
-        S TARYTMP=$NA(^TMP("C0CCCR",$J,"PROBARYTMP"))
-        K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES
-        I $$RPMS^C0CUTIL() D RPMS ; IF BGOPRB ROUTINE IS MISSING (IE RPMS)
-        I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT
-        Q
-        ;
-RPMS    ; GETS THE PROBLEM LIST FOR RPMS
-        S RPCGLO=$NA(^TMP("BGO",$J))
-        D GET^BGOPROB(.RPCRSLT,DFN) ; CALL THE PROBLEM LIST RPC
-        ; FORMAT OF RPC:
-        ;   Number Code [1] ^ Patient IEN [2] ^ ICD Code [3] ^ Modify Date [4] ^ Class [5] ^ Provider Narrative [6] ^
-        ;   Date Entered [7] ^ Status [8] ^ Date Onset [9] ^ Problem IEN [10] ^ Notes [11] ^ ICD9 IEN [12] ^
-        ;   ICD9 Short Name [13] ^ Provider [14] ^ Facility IEN [15] ^ Priority [16]
-        I '$D(@RPCGLO) W "NULL RESULT FROM GET^BGOPROB ",! S @OUTXML@(0)=0 Q
-        S J=""
-        F  S J=$O(@RPCGLO@(J)) Q:J=""  D  ; FOR EACH PROBLEM IN THE LIST
-        . S VMAP=$NA(@TVMAP@(J))
-        . K @VMAP
-        . I DEBUG W "VMAP= ",VMAP,!
-        . S PTMP=@RPCRSLT@(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY
-        . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL
-        . D GETN1^C0CRNF("C0CG1",9000011,$P(PTMP,U,10),"") ;GET VALUES BY NAME
-        . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM
-        . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,10)
-        . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,8)="A":"Active",$P(PTMP,U,8)="I":"Inactive",1:"")
-        . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,6)
-        . S @VMAP@("PROBLEMCODINGVERSION")=""
-        . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,3)
-        . ; FOR CERTIFICATION - GPL
-        . I @VMAP@("PROBLEMCODEVALUE")=493.90 S @VMAP@("PROBLEMCODEVALUE")=493
-        . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT")
-        . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT")
-        . ;S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) ;UNKNOWN NOT MAPPED IN C0CCCR0
-        . ;S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) ;UNKNOWN NOT MAPPED IN C0CCCR0
-        . ;S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) ;NOT MAPPED IN C0CCCR0
-        . ;S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) ;NOT MAPPED IN C0CCCR0
-        . ;S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) ;NOT MAPPED IN C0CCCR0
-        . ;S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) ;NOT MAPPED IN C0CCCR0
-        . ;S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER
-        . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$$ZVALUEI^C0CRNF("RECORDING PROVIDER","C0CG1")
-        . ;S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) ;NOT MAPPED IN C0CCCR0
-        . ;S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) ;NOT MAPPED IN C0CCCR0
-        . ;S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") ;NOT MAPPED IN C0CCCR0
-        . ;S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") ;NOT MAPPED IN C0CCCR0
-        . S ARYTMP=$NA(@TARYTMP@(J))
-        . ; W "ARYTMP= ",ARYTMP,!
-        . K @ARYTMP
-        . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ;
-        . I J=1 D  ; FIRST ONE IS JUST A COPY
-        . . ; W "FIRST ONE",!
-        . . D CP^C0CXPATH(ARYTMP,OUTXML)
-        . . ; W "OUTXML ",OUTXML,!
-        . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
-        . . D INSINNER^C0CXPATH(OUTXML,ARYTMP)
-        ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*)
-        ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS
-        ; ZWR @OUTXML
-        ; $$HTML^DILF(
-        ; GENERATE THE NARITIVE HTML FOR THE CCD
-        I CCD D CCD ; IF THIS IS FOR A CCD
-        D MISSINGVARS
-        Q
-        ;
-VISTA   ; GETS THE PROBLEM LIST FOR VISTA
-        D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC
-        I '$D(RPCRSLT(1)) D  Q  ; RPC RETURNS NULL
-        . W "NULL RESULT FROM LIST^ORQQPL3 ",!
-        . S @OUTXML@(0)=0
-        . ; Q
-        ; I DEBUG ZWR RPCRSLT
-        S @TVMAP@(0)=RPCRSLT(0) ; SAVE NUMBER OF PROBLEMS
-        F J=1:1:RPCRSLT(0)  D  ; FOR EACH PROBLEM IN THE LIST
-        . S VMAP=$NA(@TVMAP@(J))
-        . K @VMAP
-        . I DEBUG W "VMAP= ",VMAP,!
-        . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY
-        . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM
-        . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1)
-        . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"")
-        . N ZPRIOR S ZPRIOR=$P(PTMP,U,14) ;PRIORITY FLAG
-        . ; turn off acute/chronic for certification gpl
-        . ;S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status
-        . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3)
-        . S @VMAP@("PROBLEMCODINGVERSION")=""
-        . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4)
-        . ; FOR CERTIFICATION - GPL
-        . I @VMAP@("PROBLEMCODEVALUE")["493.90" S @VMAP@("PROBLEMCODEVALUE")=493
-        . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT")
-        . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT")
-        . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7)
-        . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8)
-        . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9)
-        . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10)
-        . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11)
-        . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12)
-        . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER
-        . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1)
-        . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13)
-        . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14)
-        . S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT")
-        . S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT")
-        . S ARYTMP=$NA(@TARYTMP@(J))
-        . ; W "ARYTMP= ",ARYTMP,!
-        . K @ARYTMP
-        . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ;
-        . I J=1 D  ; FIRST ONE IS JUST A COPY
-        . . ; W "FIRST ONE",!
-        . . D CP^C0CXPATH(ARYTMP,OUTXML)
-        . . ; W "OUTXML ",OUTXML,!
-        . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
-        . . D INSINNER^C0CXPATH(OUTXML,ARYTMP)
-        ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*)
-        ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS
-        ; ZWR @OUTXML
-        ; $$HTML^DILF(
-        ; GENERATE THE NARITIVE HTML FOR THE CCD
-        I CCD D CCD ; IF THIS IS FOR A CCD
-        D MISSINGVARS
-        Q
-CCD     
-        N HTMP,HOUT,HTMLO,C0CPROBI,ZX
-        F C0CPROBI=1:1:RPCRSLT(0) D  ; FOR EACH PROBLEM
-        . S VMAP=$NA(@TVMAP@(C0CPROBI))
-        . I DEBUG W "VMAP =",VMAP,!
-        . D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Body/PROBLEMS-HTML","HTMP") ; GET THE HTML FROM THE TEMPLATE
-        . D UNMARK^C0CXPATH("HTMP") ; REMOVE <PROBLEMS-HTML> MARKUP
-        . ; D PARY^C0CXPATH("HTMP") ; PRINT IT
-        . D MAP^C0CXPATH("HTMP",VMAP,"HOUT") ; MAP THE VARIABLES
-        . ; D PARY^C0CXPATH("HOUT") ; PRINT IT AGAIN
-        . I C0CPROBI=1 D  ; FIRST ONE IS JUST A COPY
-        . . D CP^C0CXPATH("HOUT","HTMLO")
-        . I C0CPROBI>1 D  ; AFTER THE FIRST, INSERT INNER HTML
-        . . I DEBUG W "DOING INNER",!
-        . . N HTMLBLD,HTMLTMP
-        . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",1,HTMLO(0)-1)
-        . . D QUEUE^C0CXPATH("HTMLBLD","HOUT",2,HOUT(0)-1)
-        . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",HTMLO(0),HTMLO(0))
-        . . D BUILD^C0CXPATH("HTMLBLD","HTMLTMP")
-        . . D CP^C0CXPATH("HTMLTMP","HTMLO")
-        . . ; D INSINNER^C0CXPATH("HOUT","HTMLO","//")
-        I DEBUG D PARY^C0CXPATH("HTMLO")
-        D INSB4^C0CXPATH(OUTXML,"HTMLO") ; INSERT AT TOP OF SECTION
-        Q
-MISSINGVARS     
-        N PROBSTMP,I
-        D MISSING^C0CXPATH(ARYTMP,"PROBSTMP") ; SEARCH XML FOR MISSING VARS
-        I PROBSTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
-        . ; STRINGS MARKED AS @@X@@
-        . W !,"PROBLEMS Missing list: ",!
-        . F I=1:1:PROBSTMP(0) W PROBSTMP(I),!
-        Q
-        ;
+C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008,2009 George Lilly, University of Minnesota.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ ;
+ ; PROCESS THE PROBLEMS SECTION OF THE CCR
+ ;
+EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT PROBLEMS INTO PROVIDED XML TEMPLATE
+ ;
+ ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
+ ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE
+ ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE
+ ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS
+ ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT
+ ;
+ N RPCRSLT,J,K,PTMP,X,VMAP,TBU
+ S TVMAP=$NA(^TMP("C0CCCR",$J,"PROBVALS"))
+ S TARYTMP=$NA(^TMP("C0CCCR",$J,"PROBARYTMP"))
+ K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES
+ I $$RPMS^C0CUTIL() D RPMS ; IF BGOPRB ROUTINE IS MISSING (IE RPMS)
+ I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT
+ Q
+ ;
+RPMS ; GETS THE PROBLEM LIST FOR RPMS
+ S RPCGLO=$NA(^TMP("BGO",$J))
+ D GET^BGOPROB(.RPCRSLT,DFN) ; CALL THE PROBLEM LIST RPC
+ ; FORMAT OF RPC:
+ ;   Number Code [1] ^ Patient IEN [2] ^ ICD Code [3] ^ Modify Date [4] ^ Class [5] ^ Provider Narrative [6] ^
+ ;   Date Entered [7] ^ Status [8] ^ Date Onset [9] ^ Problem IEN [10] ^ Notes [11] ^ ICD9 IEN [12] ^
+ ;   ICD9 Short Name [13] ^ Provider [14] ^ Facility IEN [15] ^ Priority [16]
+ I '$D(@RPCGLO) W "NULL RESULT FROM GET^BGOPROB ",! S @OUTXML@(0)=0 Q
+ S J=""
+ F  S J=$O(@RPCGLO@(J)) Q:J=""  D  ; FOR EACH PROBLEM IN THE LIST
+ . S VMAP=$NA(@TVMAP@(J))
+ . K @VMAP
+ . I DEBUG W "VMAP= ",VMAP,!
+ . S PTMP=@RPCRSLT@(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY
+ . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL
+ . D GETN1^C0CRNF("C0CG1",9000011,$P(PTMP,U,10),"") ;GET VALUES BY NAME
+ . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM
+ . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,10)
+ . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,8)="A":"Active",$P(PTMP,U,8)="I":"Inactive",1:"")
+ . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,6)
+ . S @VMAP@("PROBLEMCODINGVERSION")=""
+ . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,3)
+ . ; FOR CERTIFICATION - GPL
+ . I @VMAP@("PROBLEMCODEVALUE")=493.90 S @VMAP@("PROBLEMCODEVALUE")=493
+ . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT")
+ . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT")
+ . ;S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) ;UNKNOWN NOT MAPPED IN C0CCCR0
+ . ;S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) ;UNKNOWN NOT MAPPED IN C0CCCR0
+ . ;S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) ;NOT MAPPED IN C0CCCR0
+ . ;S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) ;NOT MAPPED IN C0CCCR0
+ . ;S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) ;NOT MAPPED IN C0CCCR0
+ . ;S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) ;NOT MAPPED IN C0CCCR0
+ . ;S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER
+ . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$$ZVALUEI^C0CRNF("RECORDING PROVIDER","C0CG1")
+ . ;S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) ;NOT MAPPED IN C0CCCR0
+ . ;S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) ;NOT MAPPED IN C0CCCR0
+ . ;S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") ;NOT MAPPED IN C0CCCR0
+ . ;S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") ;NOT MAPPED IN C0CCCR0
+ . S ARYTMP=$NA(@TARYTMP@(J))
+ . ; W "ARYTMP= ",ARYTMP,!
+ . K @ARYTMP
+ . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ;
+ . I J=1 D  ; FIRST ONE IS JUST A COPY
+ . . ; W "FIRST ONE",!
+ . . D CP^C0CXPATH(ARYTMP,OUTXML)
+ . . ; W "OUTXML ",OUTXML,!
+ . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
+ . . D INSINNER^C0CXPATH(OUTXML,ARYTMP)
+ ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*)
+ ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS
+ ; ZWR @OUTXML
+ ; $$HTML^DILF(
+ ; GENERATE THE NARITIVE HTML FOR THE CCD
+ I CCD D CCD ; IF THIS IS FOR A CCD
+ D MISSINGVARS
+ Q
+ ;
+VISTA ; GETS THE PROBLEM LIST FOR VISTA
+ D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC
+ I '$D(RPCRSLT(1)) D  Q  ; RPC RETURNS NULL
+ . W "NULL RESULT FROM LIST^ORQQPL3 ",!
+ . S @OUTXML@(0)=0
+ . ; Q
+ ; I DEBUG ZWR RPCRSLT
+ S @TVMAP@(0)=RPCRSLT(0) ; SAVE NUMBER OF PROBLEMS
+ F J=1:1:RPCRSLT(0)  D  ; FOR EACH PROBLEM IN THE LIST
+ . S VMAP=$NA(@TVMAP@(J))
+ . K @VMAP
+ . I DEBUG W "VMAP= ",VMAP,!
+ . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY
+ . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM
+ . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1)
+ . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"")
+ . N ZPRIOR S ZPRIOR=$P(PTMP,U,14) ;PRIORITY FLAG
+ . ; turn off acute/chronic for certification gpl
+ . ;S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status
+ . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3)
+ . S @VMAP@("PROBLEMCODINGVERSION")=""
+ . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4)
+ . ; FOR CERTIFICATION - GPL
+ . I @VMAP@("PROBLEMCODEVALUE")["493.90" S @VMAP@("PROBLEMCODEVALUE")=493
+ . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT")
+ . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT")
+ . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7)
+ . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8)
+ . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9)
+ . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10)
+ . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11)
+ . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12)
+ . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER
+ . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1)
+ . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13)
+ . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14)
+ . S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT")
+ . S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT")
+ . S ARYTMP=$NA(@TARYTMP@(J))
+ . ; W "ARYTMP= ",ARYTMP,!
+ . K @ARYTMP
+ . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ;
+ . I J=1 D  ; FIRST ONE IS JUST A COPY
+ . . ; W "FIRST ONE",!
+ . . D CP^C0CXPATH(ARYTMP,OUTXML)
+ . . ; W "OUTXML ",OUTXML,!
+ . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
+ . . D INSINNER^C0CXPATH(OUTXML,ARYTMP)
+ ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*)
+ ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS
+ ; ZWR @OUTXML
+ ; $$HTML^DILF(
+ ; GENERATE THE NARITIVE HTML FOR THE CCD
+ I CCD D CCD ; IF THIS IS FOR A CCD
+ D MISSINGVARS
+ Q
+CCD 
+ N HTMP,HOUT,HTMLO,C0CPROBI,ZX
+ F C0CPROBI=1:1:RPCRSLT(0) D  ; FOR EACH PROBLEM
+ . S VMAP=$NA(@TVMAP@(C0CPROBI))
+ . I DEBUG W "VMAP =",VMAP,!
+ . D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Body/PROBLEMS-HTML","HTMP") ; GET THE HTML FROM THE TEMPLATE
+ . D UNMARK^C0CXPATH("HTMP") ; REMOVE <PROBLEMS-HTML> MARKUP
+ . ; D PARY^C0CXPATH("HTMP") ; PRINT IT
+ . D MAP^C0CXPATH("HTMP",VMAP,"HOUT") ; MAP THE VARIABLES
+ . ; D PARY^C0CXPATH("HOUT") ; PRINT IT AGAIN
+ . I C0CPROBI=1 D  ; FIRST ONE IS JUST A COPY
+ . . D CP^C0CXPATH("HOUT","HTMLO")
+ . I C0CPROBI>1 D  ; AFTER THE FIRST, INSERT INNER HTML
+ . . I DEBUG W "DOING INNER",!
+ . . N HTMLBLD,HTMLTMP
+ . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",1,HTMLO(0)-1)
+ . . D QUEUE^C0CXPATH("HTMLBLD","HOUT",2,HOUT(0)-1)
+ . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",HTMLO(0),HTMLO(0))
+ . . D BUILD^C0CXPATH("HTMLBLD","HTMLTMP")
+ . . D CP^C0CXPATH("HTMLTMP","HTMLO")
+ . . ; D INSINNER^C0CXPATH("HOUT","HTMLO","//")
+ I DEBUG D PARY^C0CXPATH("HTMLO")
+ D INSB4^C0CXPATH(OUTXML,"HTMLO") ; INSERT AT TOP OF SECTION
+ Q
+MISSINGVARS 
+ N PROBSTMP,I
+ D MISSING^C0CXPATH(ARYTMP,"PROBSTMP") ; SEARCH XML FOR MISSING VARS
+ I PROBSTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
+ . ; STRINGS MARKED AS @@X@@
+ . W !,"PROBLEMS Missing list: ",!
+ . F I=1:1:PROBSTMP(0) W PROBSTMP(I),!
+ Q
+ ;

ccr/trunk/p/C0CPROC.m

@@ -1 @@
-C0CPROC  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10
-        ;;1.0;C0C;;Jan 21, 2010;Build 38
-        ;Copyright 2010 George Lilly, University of Minnesota and others.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "NO ENTRY FROM TOP",!
-        Q
-        ;
-SETVARS ; SET UP VARIABLES FOR PROCEDURES, ENCOUNTERS, AND NOTES
-        S C0CENC=$NA(^TMP("C0CCCR",$J,"C0CENC",DFN))
-        S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN))
-        S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN))
-        ; ADDITION FOR CERTIFICATION
-        S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN))
-        Q
-        ;
-EXTRACT(PROCXML,DFN,PROCOUT)    ; EXTRACT PROCEDURES INTO  XML TEMPLATE
-        ; PROCXML AND PROCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
-        ;
-        D SETVARS ; SET UP VARIABLES
-        I '$D(@C0CPRC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE
-        D MAP(PROCXML,C0CPRC,PROCOUT) ;MAP RESULTS FOR PROCEDURES
-        Q
-        ;
-TIUGET(DFN,C0CENC,C0CPRC,C0CNTE)        ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, 
-        ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
-        ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES
-        ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT
-        ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 
-        ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM
-        ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS
-        ;
-        K VISIT,LST,NOTE,C0CLPRC
-        ; C0CLPRC IS A LOOKUP TABLE FOR USE IN BUILDING ENCOUNTERS
-        ; FORMAT C0CLPRC(VISITIEN,CPT)=PROCOBJECTID FOR BUILDING LINKS TO PROCEDURES
-        D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
-        ; NEED TO ADD START AND END DATES FROM PARAMETERS
-        N ZI S ZI=""
-        N PREVCPT,PREVDT S (PREVCPT,PREVDT)=""
-        F  S ZI=$O(VISIT(ZI),-1) Q:ZI=""  D  ; REVERSE TIME ORDER - MOST RECENT FIRST
-        . N ZDATE
-        . S ZDATE=$$DATE(VISIT(ZI,"DATE",0))
-        . S ZPRVARY=$NA(VISIT(ZI,"PRV"))
-        . N ZPRV
-        . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM
-        . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON 
-        . N ZJ S ZJ=""
-        . F  S ZJ=$O(VISIT(ZI,"CPT",ZJ)) Q:ZJ=""  D  ;FOR EACH CPT SEG
-        . . N ZRNF
-        . . N ZCPT S ZCPT=$$CPT(VISIT(ZI,"CPT",ZJ)) ;GET CPT CODE AND TEXT
-        . . I ZCPT'="" D  ;IF CPT CODE IS PRESENT
-        . . . I (ZCPT=PREVCPT)&(ZDATE=PREVDT) Q  ; NO DUPS ALLOWED
-        . . . W !,ZCPT," ",ZDATE," ",ZPRV
-        . . . S ZRNF("PROCACTOROBJID")=ZPRV
-        . . . N PROCCODE S PROCCODE=$P(ZCPT,U,1)
-        . . . S ZRNF("PROCCODE")=PROCCODE
-        . . . S ZRNF("PROCCODESYS")="CPT-4"
-        . . . S ZRNF("PROCDATETEXT")="Procedure Date"
-        . . . S ZRNF("PROCDATETIME")=ZDATE
-        . . . S ZRNF("PROCDESCOBJATTRCODE")="" ;NO PROC ATTRIBUTES YET
-        . . . S ZRNF("PROCDESCOBJATTR")=""
-        . . . S ZRNF("PROCDESCOBJATTRCODESYS")="" ;WE DON'T HAVE PROC ATTRIBUTES
-        . . . S ZRNF("PROCDESCOBJATTRVAL")=""
-        . . . S ZRNF("PROCDESCTEXT")=$P(ZCPT,U,3)
-        . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET
-        . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET
-        . . . ; additions for Certification - need to have EKG in Results
-        . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT
-        . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ
-        . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS
-        . . . S ZRNF("PROCSTATUS")="Completed" ; Is this right?
-        . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE
-        . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY
-        . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl
-        . . . W !,"CPT=",ZCPT
-        . . . I ZCPT["93000" D  ; THIS IS AN EKG
-        . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS
-        . . . . M ^GPL("RNF2")=@C0CPRSLT
-        . . . S PREVCPT=ZCPT
-        . . . S PREVDT=ZDATE
-        N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"PROCEDURES"))
-        M @ZRIM=@C0CPRC@("V")
-        Q
-        ;
-PRV(IARY)       ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME
-        N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN=""
-        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH PRV SEG
-        . I ZR'="" Q  ;ONLY WANT THE FIRST PRIMARY PROVIDER
-        . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1)
-        I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR
-        Q ZRTN
-        ;
-DATE(ISTR)      ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT
-        Q $$FMDTOUTC^C0CUTIL(ISTR,"DT")
-        ;
-CPT(ISTR)       ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS
-        ; CPT^CATEGORY^TEXT
-        N Z1,Z2,Z3,ZRTN
-        S Z1=$P(ISTR,U,1) 
-        I Z1="" D  ;
-        . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1)
-        I Z1'="" D  ; IF THERE IS A CPT CODE IN THERE
-        . ;S Z1=$P(ISTR,U,1)
-        . S Z2=$P(ISTR,U,2)
-        . S Z3=$P(ISTR,U,3)
-        . S ZRTN=Z1_U_Z2_U_Z3
-        E  S ZRTN=""
-        Q ZRTN
-        ;
-MAP(PROCXML,C0CPRC,PROCOUT)     ; MAP PROCEDURES XML 
-        ;
-        N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"PROCTEMP")) ;WORK AREA FOR TEMPLATE
-        K @ZTEMP
-        N ZBLD
-        S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"PROCBLD")) ; BUILD LIST AREA
-        D QUEUE^C0CXPATH(ZBLD,PROCXML,1,1) ; FIRST LINE
-        N ZINNER
-        D QUERY^C0CXPATH(PROCXML,"//Procedures/Procedure","ZINNER") ;ONE PROC
-        N ZTMP,ZVAR,ZI
-        S ZI=""
-        F  S ZI=$O(@C0CPRC@("V",ZI)) Q:ZI=""  D  ;FOR EACH PROCEDURE
-        . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS PROCEDURE XML
-        . S ZVAR=$NA(@C0CPRC@("V",ZI)) ;THIS PROCEDURE VARIABLES
-        . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE
-        . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD
-        D QUEUE^C0CXPATH(ZBLD,PROCXML,@PROCXML@(0),@PROCXML@(0))
-        N ZZTMP
-        D BUILD^C0CXPATH(ZBLD,PROCOUT) ;BUILD FINAL XML
-        K @ZTEMP,@ZBLD,@C0CPRC
-        Q
-        ;  
+C0CPROC  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10
+ ;;1.0;C0C;;Jan 21, 2010;Build 38
+ ;Copyright 2010 George Lilly, University of Minnesota and others.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "NO ENTRY FROM TOP",!
+ Q
+ ;
+SETVARS ; SET UP VARIABLES FOR PROCEDURES, ENCOUNTERS, AND NOTES
+ S C0CENC=$NA(^TMP("C0CCCR",$J,"C0CENC",DFN))
+ S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN))
+ S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN))
+ ; ADDITION FOR CERTIFICATION
+ S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN))
+ Q
+ ;
+EXTRACT(PROCXML,DFN,PROCOUT) ; EXTRACT PROCEDURES INTO  XML TEMPLATE
+ ; PROCXML AND PROCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
+ ;
+ D SETVARS ; SET UP VARIABLES
+ I '$D(@C0CPRC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE
+ D MAP(PROCXML,C0CPRC,PROCOUT) ;MAP RESULTS FOR PROCEDURES
+ Q
+ ;
+TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, 
+ ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
+ ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES
+ ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT
+ ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 
+ ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM
+ ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS
+ ;
+ K VISIT,LST,NOTE,C0CLPRC
+ ; C0CLPRC IS A LOOKUP TABLE FOR USE IN BUILDING ENCOUNTERS
+ ; FORMAT C0CLPRC(VISITIEN,CPT)=PROCOBJECTID FOR BUILDING LINKS TO PROCEDURES
+ D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
+ ; NEED TO ADD START AND END DATES FROM PARAMETERS
+ N ZI S ZI=""
+ N PREVCPT,PREVDT S (PREVCPT,PREVDT)=""
+ F  S ZI=$O(VISIT(ZI),-1) Q:ZI=""  D  ; REVERSE TIME ORDER - MOST RECENT FIRST
+ . N ZDATE
+ . S ZDATE=$$DATE(VISIT(ZI,"DATE",0))
+ . S ZPRVARY=$NA(VISIT(ZI,"PRV"))
+ . N ZPRV
+ . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM
+ . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON 
+ . N ZJ S ZJ=""
+ . F  S ZJ=$O(VISIT(ZI,"CPT",ZJ)) Q:ZJ=""  D  ;FOR EACH CPT SEG
+ . . N ZRNF
+ . . N ZCPT S ZCPT=$$CPT(VISIT(ZI,"CPT",ZJ)) ;GET CPT CODE AND TEXT
+ . . I ZCPT'="" D  ;IF CPT CODE IS PRESENT
+ . . . I (ZCPT=PREVCPT)&(ZDATE=PREVDT) Q  ; NO DUPS ALLOWED
+ . . . W !,ZCPT," ",ZDATE," ",ZPRV
+ . . . S ZRNF("PROCACTOROBJID")=ZPRV
+ . . . N PROCCODE S PROCCODE=$P(ZCPT,U,1)
+ . . . S ZRNF("PROCCODE")=PROCCODE
+ . . . S ZRNF("PROCCODESYS")="CPT-4"
+ . . . S ZRNF("PROCDATETEXT")="Procedure Date"
+ . . . S ZRNF("PROCDATETIME")=ZDATE
+ . . . S ZRNF("PROCDESCOBJATTRCODE")="" ;NO PROC ATTRIBUTES YET
+ . . . S ZRNF("PROCDESCOBJATTR")=""
+ . . . S ZRNF("PROCDESCOBJATTRCODESYS")="" ;WE DON'T HAVE PROC ATTRIBUTES
+ . . . S ZRNF("PROCDESCOBJATTRVAL")=""
+ . . . S ZRNF("PROCDESCTEXT")=$P(ZCPT,U,3)
+ . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET
+ . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET
+ . . . ; additions for Certification - need to have EKG in Results
+ . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT
+ . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ
+ . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS
+ . . . S ZRNF("PROCSTATUS")="Completed" ; Is this right?
+ . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE
+ . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY
+ . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl
+ . . . W !,"CPT=",ZCPT
+ . . . I ZCPT["93000" D  ; THIS IS AN EKG
+ . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS
+ . . . . M ^GPL("RNF2")=@C0CPRSLT
+ . . . S PREVCPT=ZCPT
+ . . . S PREVDT=ZDATE
+ N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"PROCEDURES"))
+ M @ZRIM=@C0CPRC@("V")
+ Q
+ ;
+PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME
+ N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN=""
+ F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ; FOR EACH PRV SEG
+ . I ZR'="" Q  ;ONLY WANT THE FIRST PRIMARY PROVIDER
+ . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1)
+ I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR
+ Q ZRTN
+ ;
+DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT
+ Q $$FMDTOUTC^C0CUTIL(ISTR,"DT")
+ ;
+CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS
+ ; CPT^CATEGORY^TEXT
+ N Z1,Z2,Z3,ZRTN
+ S Z1=$P(ISTR,U,1) 
+ I Z1="" D  ;
+ . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1)
+ I Z1'="" D  ; IF THERE IS A CPT CODE IN THERE
+ . ;S Z1=$P(ISTR,U,1)
+ . S Z2=$P(ISTR,U,2)
+ . S Z3=$P(ISTR,U,3)
+ . S ZRTN=Z1_U_Z2_U_Z3
+ E  S ZRTN=""
+ Q ZRTN
+ ;
+MAP(PROCXML,C0CPRC,PROCOUT) ; MAP PROCEDURES XML 
+ ;
+ N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"PROCTEMP")) ;WORK AREA FOR TEMPLATE
+ K @ZTEMP
+ N ZBLD
+ S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"PROCBLD")) ; BUILD LIST AREA
+ D QUEUE^C0CXPATH(ZBLD,PROCXML,1,1) ; FIRST LINE
+ N ZINNER
+ D QUERY^C0CXPATH(PROCXML,"//Procedures/Procedure","ZINNER") ;ONE PROC
+ N ZTMP,ZVAR,ZI
+ S ZI=""
+ F  S ZI=$O(@C0CPRC@("V",ZI)) Q:ZI=""  D  ;FOR EACH PROCEDURE
+ . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS PROCEDURE XML
+ . S ZVAR=$NA(@C0CPRC@("V",ZI)) ;THIS PROCEDURE VARIABLES
+ . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE
+ . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD
+ D QUEUE^C0CXPATH(ZBLD,PROCXML,@PROCXML@(0),@PROCXML@(0))
+ N ZZTMP
+ D BUILD^C0CXPATH(ZBLD,PROCOUT) ;BUILD FINAL XML
+ K @ZTEMP,@ZBLD,@C0CPRC
+ Q
+ ;  

ccr/trunk/p/C0CRIMA.m

@@ -1 @@
-C0CRIMA   ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008,2009 George Lilly, University of Minnesota.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        ; THESE ROUTINES EXAMINE ONE OR MORE, UP TO ALL, OF THE PATIENTS ON THE
-        ; SYSTEM TO DETERMINE HOW COMPLETE THE RESULTING CCR OR CCD WOULD BE FOR
-        ; THESE PATIENTS. IT BEGINS TO MEASURE "HL7 RIM COHERENCE" WHICH IS HOW USEFUL
-        ; THE VARIABLES WILL BE TO A RIM-MODELED APPLICATION AFTER THEY ARE
-        ; CONVEYED VIA THE CCR OR CCD.
-        ; FACTORS THAT AFFECT RIM COHERENCE INCLUDE:
-        ;    1. THE PRESENSE OF CLINICAL DATA IN A SECTION
-        ;    2. ARE THE DATA ELEMENTS TIME-BOUND
-        ;    3. ARE THE DATA ELEMENTS CODED WITH SNOMED OR LOINC ETC
-        ;    4. ARE SOURCE ACTORS ASSOCIATED WITH THE DATA ELEMENTS
-        ;    5. ARE ACTORS IDENTIFIED REGARDING THEIR ROLE
-        ;    .. AND OTHER FACTORS YET TO BE DETERMINED
-        ;
-        ;    SINCE THESE MEASUREMENTS ARE DONE AT THE VARIABLE LEVEL, THEY
-        ;    REFLECT ON RIM COHERENCE WHETHER THE CCR OR THE CCD IS USED FOR
-        ;    CONVEYANCE TO THE RIM APPLICATION.
-        ;
-        ;
-ANALYZE(BEGDFN,DFNCNT,APARMS)   ; RIM COHERANCE ANALYSIS ROUTINE
-           ; BEGINS AT BEGDFN AND GOES FOR DFNCNT PATIENTS
-           ; TO RESUME AT NEXT PATIENT, USE BEGDFN=""
-           ; USE RESET^C0CRIMA TO RESET TO TOP OF PATIENT LIST
-           ; APARMS ARE PARAMETERS TO BE USED IN THE EXTRACTION
-           ; SEE C0CPARMS FOR SUPPORTED PARAMTERS
-           ;
-           N RIMARY,RIMTMP,RIMI,RIMDFN,RATTR
-           N CCRGLO
-           S C0CCHK=0 ; CHECKSUM FLAG
-           D ASETUP ; SET UP VARIABLES AND GLOBALS
-           D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE
-           I '$D(@RIMBASE@("RESUME")) S @RIMBASE@("RESUME")=$O(^DPT(0)) ; FIRST TIME
-           S RESUME=@RIMBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN
-           S RIMDFN=BEGDFN ; BEGIN WITH THE BEGDFN PATIENT
-           I RIMDFN="" S RIMDFN=RESUME
-           I +RIMDFN=0 D  Q  ; AT THE END OF THE PATIENTS
-           . W "END OF PATIENT LIST, CALL RESET^C0CRIMA",!
-           I '$D(APARMS) S APARMS="" ; DEFAULT NO OVERRIDE PARMS
-           F RIMI=1:1:DFNCNT  D  Q:+RIMDFN=0  ; FOR DFNCNT NUMBER OF PATIENTS OR END
-           . K @RIMBASE@("VARS",RIMDFN) ; CLEAR OUT OLD VARS
-           . D CCRRPC^C0CCCR(.CCRGLO,RIMDFN,APARMS,"CCR") ;PROCESS THE CCR
-           . W RIMDFN,!
-           . ;
-           . ; COPY ALL THE VARIABLES TO THE RIM MAP AREA INDEXED BY PATIENT
-           . ;
-           . I $D(^TMP("C0CCCR",$J,"PROBVALS",1)) D  ; PROBLEM VARS EXISTS
-           . . M @RIMBASE@("VARS",RIMDFN,"PROBLEMS")=^TMP("C0CCCR",$J,"PROBVALS")
-           . . S @RIMBASE@("VARS",RIMDFN,"PROBLEMS",0)=$O(^TMP("C0CCCR",$J,"PROBVALS",""),-1)
-           . I $D(^TMP("C0CCCR",$J,"VITALS",1)) D  ; VITALS VARS EXISTS
-           . . M @RIMBASE@("VARS",RIMDFN,"VITALS")=^TMP("C0CCCR",$J,"VITALS")
-           . I $D(^TMP("C0CCCR",$J,"MEDMAP",1)) D  ; MEDS VARS EXISTS
-           . . M @RIMBASE@("VARS",RIMDFN,"MEDS")=^TMP("C0CCCR",$J,"MEDMAP")
-           . I $D(^TMP("C0CCCR",$J,"ALERTS",1,"ALERTOBJECTID")) D  ; ALERTS EXIST
-           . . W "FOUND ALERT VARS",!
-           . . M @RIMBASE@("VARS",RIMDFN,"ALERTS")=^TMP("C0CCCR",$J,"ALERTS")
-           . I $D(^TMP("C0CCCR",$J,"RESULTS",0)) D  ; RESULTS EXIST
-           . . W "FOUND RESULTS VARS",!
-           . . M @RIMBASE@("VARS",RIMDFN,"RESULTS")=^TMP("C0CCCR",$J,"RESULTS")
-           . S C0CCHK=0
-           . I $$CHKSUM(RIMDFN) D  ; CHECKSUM HAS CHANGED
-           . . W "CHECKSUM IS NEW OR HAS CHANGED",!
-           . . ;ZWR ^TMP("C0CRIM","CHKSUM",RIMDFN,*)
-           . . S C0CCHK=1
-           . K ^TMP("C0CCCR",$J) ; KILL WORK AREA FOR CCR BUILDING
-           . ;
-           . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP
-           . ;
-           . S RATTR=$$SETATTR(RIMDFN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS
-           . S @RIMBASE@("ATTR",RIMDFN)=RATTR ; SAVE THE ATRIBUTES FOR THIS PAT
-           . ;
-           . ; INCREMENT THE COUNT OF PATIENTS WITH THESE ATTRIBUTES IN ATTRTBL
-           . ;
-           . ; I '$D(@RIMBASE@("ATTRTBL",RATTR)) D  ; IF FIRST PAT WITH THESE ATTRS
-           . ; . S @RIMBASE@("ATTRTBL",RATTR)=0 ; DEFAULT VALUE TO BE INCREMENTED
-           . ; S @RIMBASE@("ATTRTBL",RATTR)=@RIMBASE@("ATTRTBL",RATTR)+1 ; INCREMENT
-           . ;
-           . N CATNAME,CATTBL
-           . ; S CATBASE=$NA(@RIMBASE@("ANALYSIS"))
-           . S CATNAME=""
-           . D CPUSH(.CATNAME,RIMBASE,"RIMTBL",RIMDFN,RATTR) ; ADD TO CATEGORY
-           . W "CATEGORY NAME: ",CATNAME,!
-           . ;
-           . F  S RIMDFN=$O(^DPT(RIMDFN)) Q:'$$PTST^C0CSYS(RIMDFN) ; NEXT PATIENT
-           . ; PTST TESTS TO SEE IF PATIENT WAS MERGED
-           . ; IF CCRTEST=0, PTST WILL CHECK TO SEE IF THIS IS A TEST PATIENT
-           . ; AND WE SKIP IT
-           . S @RIMBASE@("RESUME")=RIMDFN ; WHERE WE ARE LEAVING OFF THIS RUN
-           ; D PARY^C0CXPATH(@RIMBASE@("ATTRTBL"))
-           Q
-           ;
-SETATTR(SDFN)   ; SET ATTRIBUTES BASED ON VARS
-           N SBASE,SATTR
-           S SBASE=$NA(@RIMBASE@("VARS",SDFN))
-           D APOST("SATTR","RIMTBL","HEADER")
-           I $D(@SBASE@("PROBLEMS",1)) D  ;
-           . D APOST("SATTR","RIMTBL","PROBLEMS")
-           . ; W "POSTING PROBLEMS",!
-           I $D(@SBASE@("VITALS",1)) D APOST("SATTR","RIMTBL","VITALS")
-           I $D(@SBASE@("IMMUNE",1)) D  ;IMMUNIZATIONS PRESENT
-           . D APOST("SATTR","RIMTBL","IMMUNE")
-           . N ZR,ZI
-           . D GETPA(.ZR,SDFN,"IMMUNE","IMMUNEPRODUCTCODE")
-           . I ZR(0)>0 D APOST("SATTR","RIMTBL","IMMUNECODE") ;IMMUNIZATION CODES
-           I $D(@SBASE@("MEDS",1)) D  ; IF THE PATIENT HAS MEDS VARIABLES
-           . D APOST("SATTR","RIMTBL","MEDS")
-           . N ZR,ZI
-           . D GETPA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES
-           . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
-           . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
-           . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","MEDSCODE") ;CODES
-           . ; D PATD^C0CRIMA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES
-           I $D(@SBASE@("ALERTS",1)) D  ; IF THE PATIENT HAS ALERTS
-           . D APOST("SATTR","RIMTBL","ALERTS")
-           . N ZR,ZI
-           . D GETPA(.ZR,SDFN,"ALERTS","ALERTAGENTPRODUCTCODEVALUE") ;REACTANT CODES
-           . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
-           . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
-           . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","ALERTSCODE") ;CODES
-           I $D(@SBASE@("RESULTS",1)) D  ; IF THE PATIENT HAS LABS VARIABLES
-           . D APOST("SATTR","RIMTBL","RESULTS")
-           . N ZR,ZI
-           . S ZR(0)=0 ; INITIALIZE TO NONE
-           . D RPCGV(.ZR,SDFN,"RESULTS") ;CHECK FOR LABS CODES
-           . ; D PARY^C0CXPATH("ZR") ;
-           . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
-           . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
-           . . . I $P(ZR(ZI),"^",2)="RESULTTESTCODINGSYSTEM" D  ; LOINC CODE CHECK
-           . . . . I $P(ZR(ZI),"^",3)="LOINC" D APOST("SATTR","RIMTBL","RESULTSLN") ;
-           ; D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED
-           I $D(@SBASE@("PROCEDURES",1)) D  ;
-           . D APOST("SATTR","RIMTBL","PROCEDURES")
-           W "ATTRIBUTES: ",SATTR,!
-           Q SATTR
-           ;
-RESET   ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES
-           K ^TMP("C0CRIM","RESUME")
-           K ^TMP("C0CRIM")
-           Q
-           ;
-CLIST   ; LIST THE CATEGORIES
-           ;
-           I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
-           N CLBASE,CLNUM,ZI,CLIDX
-           S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS"))
-           S CLNUM=@CLBASE@(0)
-           F ZI=1:1:CLNUM D  ; LOOP THROUGH THE CATEGORIES
-           . S CLIDX=@CLBASE@(ZI)
-           . W "(",$P(@CLBASE@(CLIDX),"^",1)
-           . W ":",$P(@CLBASE@(CLIDX),"^",2),") "
-           . W CLIDX,!
-           ; D PARY^C0CXPATH(CLBASE)
-           Q
-           ;
-CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR)     ; ADD PATIENTS TO CATEGORIES
-           ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT
-           ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE
-           ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME
-           ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES,
-           ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X"
-           ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES
-           ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY
-           ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING
-           ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY
-           ; NUMBER IE CTBL_X(CDFN)=""
-           ;
-           ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST
-           S CCTBL=$NA(@CBASE@(CTBL,"CATS"))
-           W "CBASE: ",CCTBL,!
-           ;
-           I '$D(@CCTBL@(CATTR)) D  ; FIRST PATIENT IN THIS CATEGORY
-           . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY
-           . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY
-           . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT
-           . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY
-           . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME
-           . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0
-           ;
-           S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY
-           S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT
-           S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK
-           ;
-           S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED
-           ;
-           S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT
-           W "PATS BASE: ",CPATLIST,!
-           S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST
-           ;
-           Q
-           ;
-CHKSUM(CKDFN)   ; DOES A CHECKSUM AND STORES IT IN MUMPS GLOBALS
-        ; 
-        S C0CCKB=$NA(^TMP("C0CRIM","CHKSUM")) ;CHECKSUM BASE
-        S C0CGLB=$NA(^TMP("C0CRIM","VARS")) ;CCR VARIABLE BASE
-        S C0CI=""
-        F  S C0CI=$O(@C0CGLB@(CKDFN,C0CI)) Q:C0CI=""  D  ;FOR EACH DOMAIN
-        . ;W "DFN:",CKDFN," DOMAIN:",C0CI,!
-        . S C0CJ=$NA(@C0CGLB@(CKDFN,C0CI))
-        . I C0CI="HEADER" D  ; HAVE TO TAKE OUT THE "DATE GENERATED"
-        . . S C0CDT=@C0CGLB@(CKDFN,C0CI,1,"DATETIME")
-        . . K @C0CGLB@(CKDFN,C0CI,1,"DATETIME")
-        . S C0CCK(C0CI)=$$CHKSUM^XUSESIG1(C0CJ)
-        . I C0CI="HEADER" D  ; PUT IT BACK
-        . . S @C0CGLB@(CKDFN,C0CI,1,"DATETIME")=C0CDT
-        S C0CK="C0CCK" ;
-        S C0CALL=$$CHKSUM^XUSESIG1(C0CK) ;CHECKSUM OF ALL DOMAIN CHECKSUMS
-        S CHKR=0 ; RESULT DEFAULT
-        I $D(^TMP("C0CRIM","CHKSUM",CKDFN,"ALL")) D  ; OLD CHECKSUM EXISTS
-        . I @C0CCKB@(CKDFN,"ALL")'=C0CALL S CHKR=1
-        E  S CHKR=1 ;CHECKSUM IS NEW
-        S @C0CCKB@(CKDFN,"ALL")=C0CALL
-        M @C0CCKB@(CKDFN,"DOMAIN")=C0CCK
-        ;ZWR ^TMP("C0CRIM","CHKSUM",CKDFN,*)
-        Q CHKR
-        ;
-CCOUNT  ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE
-           ;
-           I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
-           N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT
-           S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES
-           S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS
-           S ZTOT=0 ; INITIALIZE OVERALL TOTAL
-           F ZI=1:1:@ZCBASE@(0) D  ; FOR ALL CATS
-           . S ZCNT=0
-           . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY
-           . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME
-           . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST
-           . ; F ZJ=0:0 D  Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS
-           . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT
-           . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,!
-           . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX))
-           . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT)))
-           . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD
-           . S ZTOT=ZTOT+ZCNT
-           W "TOTAL: ",ZTOT,!
-           Q
-           ;
-CNTLST(INLST)   ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST
-           ; INLST IS PASSED BY NAME
-           N ZI,ZDX,ZCOUNT
-           W INLST,!
-           S ZCOUNT=0
-           S ZDX=""
-           F ZI=$O(@INLST@(ZDX)):0 D  Q:$O(@INLST@(ZDX))=""  ; LOOP UNTIL THE END
-           . S ZCOUNT=ZCOUNT+1
-           . S ZDX=$O(@INLST@(ZDX))
-           . W "ZDX:",ZDX," ZCNT:",ZCOUNT,!
-           Q ZCOUNT
-           ;
-XCPAT(CPATCAT,CPATPARM) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT
-           ;
-           I '$D(CPATPARM) S CPATPARM=""
-           I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
-           N ZI,ZJ,ZC,ZPATBASE
-           S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT))
-           S ZI=""
-           F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
-           . S ZI=$O(@ZPATBASE@(ZI))
-           . D XPAT^C0CCCR(ZI,CPATPARM) ; EXPORT THE PATIENT TO A FILE
-           Q
-           ;
-CPAT(CPATCAT)   ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT
-           ;
-           I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
-           N ZI,ZJ,ZC,ZPATBASE
-           S ZC=0 ; COUNT FOR SPACING THE PRINTOUT
-           S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT))
-           S ZI=""
-           F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
-           . S ZI=$O(@ZPATBASE@(ZI))
-           . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT
-           . W ZI," "
-           . I ZC=10 D  ; NEW LINE
-           . . S ZC=0
-           . . W !
-           Q
-           ;
-PATC(DFN)       ; DISPLAY THE CATEGORY FOR THIS PATIENT
-           ;
-           N ATTR S ATTR=""
-           I '$D(^TMP("C0CRIM","ATTR",DFN)) D  ; RIM VARS NOT PRESENT
-           . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT
-           S ATTR=^TMP("C0CRIM","ATTR",DFN)
-           I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q  ;NO ATTRIBUTES FOUND
-           I $D(^TMP("C0CRIM","RIMTBL","CATS",ATTR)) D  ; FOUND A CAT
-           . N CAT
-           . S CAT=$P(^TMP("C0CRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT
-           . W CAT,": ",ATTR,!
-           Q
-           ;
-APUSH(AMAP,AVAL)        ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME)
-           ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT
-           ; AND AMAP(N)=AVAL IS THE NTH AVAL
-           ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE
-           ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE
-           ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED
-           ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED
-           ;
-           I '$D(@AMAP) D  ; IF THE MAP DOES NOT EXIST
-           . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS
-           S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT
-           S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY
-           S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF
-           Q
-           ;
-ASETUP  ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL
-             I '$D(RIMBASE) S RIMBASE=$NA(^TMP("C0CRIM"))
-             I '$D(@RIMBASE) S @RIMBASE=""
-             I '$D(RIMTBL) S RIMTBL=$NA(^TMP("C0CRIM","RIMTBL","TABLE")) ; ATTR TABLE
-             S ^TMP("C0CRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES
-             Q
-             ;
-AINIT   ; INITIALIZE ATTRIBUTE TABLE
-             I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
-             K @RIMTBL
-             D APUSH(RIMTBL,"EXTRACTED")
-             D APUSH(RIMTBL,"NOTEXTRACTED")
-             D APUSH(RIMTBL,"HEADER")
-             D APUSH(RIMTBL,"NOPCP")
-             D APUSH(RIMTBL,"PCP")
-             D APUSH(RIMTBL,"PROBLEMS")
-             D APUSH(RIMTBL,"PROBCODE")
-             D APUSH(RIMTBL,"PROBNOCODE")
-             D APUSH(RIMTBL,"PROBDATE")
-             D APUSH(RIMTBL,"PROBNODATE")
-             D APUSH(RIMTBL,"VITALS")
-             D APUSH(RIMTBL,"VITALSCODE")
-             D APUSH(RIMTBL,"VITALSNOCODE")
-             D APUSH(RIMTBL,"VITALSDATE")
-             D APUSH(RIMTBL,"VITALSNODATE")
-             D APUSH(RIMTBL,"IMMUNE")
-             D APUSH(RIMTBL,"IMMUNECODE")
-             D APUSH(RIMTBL,"MEDS")
-             D APUSH(RIMTBL,"MEDSCODE")
-             D APUSH(RIMTBL,"MEDSNOCODE")
-             D APUSH(RIMTBL,"MEDSDATE")
-             D APUSH(RIMTBL,"MEDSNODATE")
-             D APUSH(RIMTBL,"ALERTS")
-             D APUSH(RIMTBL,"ALERTSCODE")
-             D APUSH(RIMTBL,"RESULTS")
-             D APUSH(RIMTBL,"RESULTSLN")
-             D APUSH(RIMTBL,"PROCEDURES")
-             D APUSH(RIMTBL,"ENCOUNTERS")
-             D APUSH(RIMTBL,"NOTES")
-             Q
-             ;
-APOST(PRSLT,PTBL,PVAL)  ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL
-           ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING
-           ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES
-           ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL))
-           I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING
-           N USETBL
-           I '$D(@RIMBASE@("TABLES",PTBL)) D  Q  ; NO TABLE
-           . W "ERROR NO SUCH TABLE",!
-           S USETBL=@RIMBASE@("TABLES",PTBL)
-           S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL
-           Q
-GETPA(RTN,DFN,ISEC,IVAR)        ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN
-           ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT")
-           ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2
-           ; IN SECTION "MEDS"
-           ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS
-           ; PENDING FOR MED 2 FOR PATIENT 2
-           ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE
-           ; RETURNED. RTN IS PASSED BY REFERENCE
-           ;
-           S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE
-           I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES
-           S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES
-           I '$D(@ZVBASE@(DFN,ISEC,0)) D  Q ; NO VARIABLES IN SECTION
-           . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,!
-           N ZZI,ZZS
-           S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT
-           ; ZWR @ZZS@(1)
-           S RTN(0)=@ZZS@(0)
-           F ZZI=1:1:RTN(0) D  ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS)
-           . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE
-           . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE
-           Q
-           ;
-PATD(DFN,ISEC,IVAR)     ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR
-           ;
-           N ZR
-           D GETPA(.ZR,DFN,ISEC,IVAR)
-           I $D(ZR(0)) D PARY^C0CXPATH("ZR")
-           E  W "NOTHING RETURNED",!
-           Q
-           ;
-CAGET(RTN,IATTR)        ;
-           ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR
-           ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE
-           ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC
-           Q
-           ;
-PCLST(LSTRTN,IATTR)     ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR
-           ;
-           I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES
-           N ZLST
-           S @LSTRTN@(0)=0 ; DEFAULT RETURN NONE
-           S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES
-           S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS
-           N ZNC  ; ZNC IS NUMBER OF CATEGORIES
-           S ZNC=@ZCBASE@(0)
-           I ZNC=0 Q ; NO CATEGORIES TO SEARCH
-           N ZAP  ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE
-           S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR)
-           N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT
-           F ZI=1:1:ZNC D  ; FOR ALL CATEGORIES
-           . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT
-           . I $P(ZATBL,"^",ZAP)'="" D  ; CAT HAS ATTR
-           . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL
-           . . M @LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT
-           S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS
-           S ZPAT=0 ; START AT FIRST PATIENT IN LIST
-           F  S ZPAT=$O(@LSTRTN@(ZPAT)) Q:ZPAT=""  D  ;
-           . S ZCNT=ZCNT+1
-           S @LSTRTN@(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY
-           Q
-           ;
-DCPAT(CATTR)    ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR
-           ;
-           ;N ZR
-           D PCLST("ZR",CATTR)
-           I ZR(0)=0 D  Q  ;
-           . W "NO PATIENTS RETURNED",!
-           E  D  ;
-           . N ZI S ZI=0
-           . F  S ZI=$O(ZR(ZI)) Q:ZI=""  D  ;
-           . . W !,ZI
-           . ;D PARY^C0CXPATH("ZR") ; PRINT ARRAY
-           . W !,"COUNT=",ZR(0)
-           Q
-           ;
-RPCGV(RTN,DFN,WHICH)    ; RPC GET VARS
-        ; RETURNS IN RTN (PASSED BY REFERENCE) THE VARS AND VALUES
-        ; FOUND AT INARY RTN(X)="VAR^VALUE" RTN(0) IS THE COUNT
-        ; DFN IS THE PATIENT NUMBER.
-        ; WHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","IMMUNE"
-        ; OR OTHER SECTIONS AS THEY ARE ADDED
-        ; THIS IS MEANT TO BE AVAILABLE AS AN RPC
-        I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
-        S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES
-        S RTN(0)=0 ; DEFAULT NOTHING IS RETURNED
-        N ZZGI
-        I WHICH="ALL" D  ; VARIABLES FROM ALL SECTIONS
-        . F ZZGI="HEADER","PROBLEMS","VITALS","MEDS","ALERTS","RESULTS","IMMUNE","PROCEDURES" D  ;
-        . . D ZGVWRK(ZZGI) ; DO EACH SECTION
-        . . I $G(DEBUG)'="" W "DID ",ZZGI,!
-        E  D ZGVWRK(WHICH) ; ONLY ONE SECTION ASKED FOR
-        Q
-        ;
-ZGVWRK(ZWHICH)  ; DO ONE SECTION FOR RPCGV
-           ;
-           N ZZGN ; NAME FOR SECTION VARIABLES
-           S ZZGN=$NA(@ZVBASE@(DFN,ZWHICH)) ; BASE OF VARS FOR SECTION
-           ;I '$D(@ZZGN@(0)) Q ; NO VARS FOR THIS SECTION
-           I $O(@ZZGN@(""),-1)=""  D  ;
-           E  D  ; VARS EXIST
-           . N ZGVI,ZGVN
-           . S ZGVN=$O(@ZZGN@(""),-1) ;COUNT OF VARS
-           . F ZGVI=1:1:ZGVN D  ; FOR EACH MULTIPLE IN SECTION
-           . . K ZZGA N ZZGA ; TEMP ARRAY FOR SECTION VARS
-           . . K ZZGN2 N ZZGN2 ; NAME FOR MULTIPLE
-           . . S ZZGN2=$NA(@ZZGN@(ZGVI))
-           . . I $G(DEBUG)'="" W ZZGN2,!,$O(@ZZGN2@("")),!
-           . . D H2ARY^C0CXPATH("ZZGA",ZZGN2,ZGVI) ; CONVERT HASH TO ARRAY
-           . . ; D PARY^C0CXPATH("ZZGA")
-           . . D PUSHA^C0CXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN
-           Q
-           ;
-DPATV(DFN,IWHICH)       ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN C0CRIM
-           ; ALONG WITH SAMPLE VALUES.
-           ; IWHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","HEADER"
-           N GTMP
-           I '$D(^TMP("C0CRIM","ATTR",DFN)) D  ; RIM VARS NOT PRESENT
-           . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES
-           I '$D(IWHICH) S IWHICH="ALL"
-           D RPCGV(.GTMP,DFN,IWHICH)
-           D PARY^C0CXPATH("GTMP")
-           Q
-           ;
-RIM2RNF(R2RTN,DFN,RWHICH)       ; CONVERTS RIM VARIABLES TO RNF2 FORMAT
-        ; RETURN IN R2RTN, WHICH IS PASSED BY NAME
-        ; RWHICH IS RIM SECTION TO RETURN, DEFAULTS TO "ALL"
-        ;
-        I '$D(RWHICH) S RWHICH="ALL"
-        ;N R2TMP
-        I '$D(^TMP("C0CRIM","ATTR",DFN)) D  ; RIM VARS NOT PRESENT
-        . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES
-        D RPCGV(.R2TMP,DFN,RWHICH) ; RETRIEVE ALL THE VARIABLES I AN ARRAY
-        N R2I,R2J,R2X,R2X1,R2X2,R2Y,R2Z
-        F R2I=1:1:R2TMP(0) D  ; FOR EVERY LINE OF THE ARRAY
-        . S R2X=$P(R2TMP(R2I),"^",1) ; OCCURANCE
-        . S R2Y=$P(R2TMP(R2I),"^",2) ; VARIABLE NAME
-        . I $L(R2Y)<4 Q  ; SKIP SHORT VARIABLES (THEY ARE FOR DEBUGGING)
-        . S R2Z=$P(R2TMP(R2I),"^",3) ; VALUE
-        . I R2X[";" D  ; THERES MULTIPLES
-        . . S R2X1=$P(R2X,";",1) ; FIRST INDEX
-        . . S R2X2=$P(R2X,";",2) ; SECOND INDEX
-        . . S R2J=R2Y_"["_R2X2_"]" ; BUILD THE VARIABLE NAME
-        . . S @R2RTN@("F",R2J,1)="" ; PUT VARIABLE NAME IN FIELD MAP
-        . . S @R2RTN@("V",R2X1,R2J,1)=R2Z ; PUT THE VALUE IN THE ARRAY
-        . E  D  ; NO SUB-MULTIPLES
-        . . S @R2RTN@("F",R2Y,1)="" ; PUT VARIABLE NAME IN FIELD MAP
-        . . S @R2RTN@("V",R2X,R2Y,1)=R2Z ; PUT THE VALUE IN THE ARRAY
-        Q
-        ;
-RIM2CSV(DFN)    ; WRITE THE RIM VARIABLES FOR A PATIENT TO A CSV FILE
-        ;
-        N R2CTMP,R2CARY
-        D RIM2RNF("R2CTMP",DFN) ; CONVERT VARIABLES TO RNF FORMAT
-        D RNF2CSV^C0CRNF("R2CARY","R2CTMP","NV") ; CONVERT RNF TO CSV FORMAT
-        D FILEOUT^C0CRNF("R2CARY","VARS-"_DFN_".csv")
-        Q
-        ;
+C0CRIMA   ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008,2009 George Lilly, University of Minnesota.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ ; THESE ROUTINES EXAMINE ONE OR MORE, UP TO ALL, OF THE PATIENTS ON THE
+ ; SYSTEM TO DETERMINE HOW COMPLETE THE RESULTING CCR OR CCD WOULD BE FOR
+ ; THESE PATIENTS. IT BEGINS TO MEASURE "HL7 RIM COHERENCE" WHICH IS HOW USEFUL
+ ; THE VARIABLES WILL BE TO A RIM-MODELED APPLICATION AFTER THEY ARE
+ ; CONVEYED VIA THE CCR OR CCD.
+ ; FACTORS THAT AFFECT RIM COHERENCE INCLUDE:
+ ;    1. THE PRESENSE OF CLINICAL DATA IN A SECTION
+ ;    2. ARE THE DATA ELEMENTS TIME-BOUND
+ ;    3. ARE THE DATA ELEMENTS CODED WITH SNOMED OR LOINC ETC
+ ;    4. ARE SOURCE ACTORS ASSOCIATED WITH THE DATA ELEMENTS
+ ;    5. ARE ACTORS IDENTIFIED REGARDING THEIR ROLE
+ ;    .. AND OTHER FACTORS YET TO BE DETERMINED
+ ;
+ ;    SINCE THESE MEASUREMENTS ARE DONE AT THE VARIABLE LEVEL, THEY
+ ;    REFLECT ON RIM COHERENCE WHETHER THE CCR OR THE CCD IS USED FOR
+ ;    CONVEYANCE TO THE RIM APPLICATION.
+ ;
+ ;
+ANALYZE(BEGDFN,DFNCNT,APARMS) ; RIM COHERANCE ANALYSIS ROUTINE
+    ; BEGINS AT BEGDFN AND GOES FOR DFNCNT PATIENTS
+    ; TO RESUME AT NEXT PATIENT, USE BEGDFN=""
+    ; USE RESET^C0CRIMA TO RESET TO TOP OF PATIENT LIST
+    ; APARMS ARE PARAMETERS TO BE USED IN THE EXTRACTION
+    ; SEE C0CPARMS FOR SUPPORTED PARAMTERS
+    ;
+    N RIMARY,RIMTMP,RIMI,RIMDFN,RATTR
+    N CCRGLO
+    S C0CCHK=0 ; CHECKSUM FLAG
+    D ASETUP ; SET UP VARIABLES AND GLOBALS
+    D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE
+    I '$D(@RIMBASE@("RESUME")) S @RIMBASE@("RESUME")=$O(^DPT(0)) ; FIRST TIME
+    S RESUME=@RIMBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN
+    S RIMDFN=BEGDFN ; BEGIN WITH THE BEGDFN PATIENT
+    I RIMDFN="" S RIMDFN=RESUME
+    I +RIMDFN=0 D  Q  ; AT THE END OF THE PATIENTS
+    . W "END OF PATIENT LIST, CALL RESET^C0CRIMA",!
+    I '$D(APARMS) S APARMS="" ; DEFAULT NO OVERRIDE PARMS
+    F RIMI=1:1:DFNCNT  D  Q:+RIMDFN=0  ; FOR DFNCNT NUMBER OF PATIENTS OR END
+    . K @RIMBASE@("VARS",RIMDFN) ; CLEAR OUT OLD VARS
+    . D CCRRPC^C0CCCR(.CCRGLO,RIMDFN,APARMS,"CCR") ;PROCESS THE CCR
+    . W RIMDFN,!
+    . ;
+    . ; COPY ALL THE VARIABLES TO THE RIM MAP AREA INDEXED BY PATIENT
+    . ;
+    . I $D(^TMP("C0CCCR",$J,"PROBVALS",1)) D  ; PROBLEM VARS EXISTS
+    . . M @RIMBASE@("VARS",RIMDFN,"PROBLEMS")=^TMP("C0CCCR",$J,"PROBVALS")
+    . . S @RIMBASE@("VARS",RIMDFN,"PROBLEMS",0)=$O(^TMP("C0CCCR",$J,"PROBVALS",""),-1)
+    . I $D(^TMP("C0CCCR",$J,"VITALS",1)) D  ; VITALS VARS EXISTS
+    . . M @RIMBASE@("VARS",RIMDFN,"VITALS")=^TMP("C0CCCR",$J,"VITALS")
+    . I $D(^TMP("C0CCCR",$J,"MEDMAP",1)) D  ; MEDS VARS EXISTS
+    . . M @RIMBASE@("VARS",RIMDFN,"MEDS")=^TMP("C0CCCR",$J,"MEDMAP")
+    . I $D(^TMP("C0CCCR",$J,"ALERTS",1,"ALERTOBJECTID")) D  ; ALERTS EXIST
+    . . W "FOUND ALERT VARS",!
+    . . M @RIMBASE@("VARS",RIMDFN,"ALERTS")=^TMP("C0CCCR",$J,"ALERTS")
+    . I $D(^TMP("C0CCCR",$J,"RESULTS",0)) D  ; RESULTS EXIST
+    . . W "FOUND RESULTS VARS",!
+    . . M @RIMBASE@("VARS",RIMDFN,"RESULTS")=^TMP("C0CCCR",$J,"RESULTS")
+    . S C0CCHK=0
+    . I $$CHKSUM(RIMDFN) D  ; CHECKSUM HAS CHANGED
+    . . W "CHECKSUM IS NEW OR HAS CHANGED",!
+    . . ;ZWR ^TMP("C0CRIM","CHKSUM",RIMDFN,*)
+    . . S C0CCHK=1
+    . K ^TMP("C0CCCR",$J) ; KILL WORK AREA FOR CCR BUILDING
+    . ;
+    . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP
+    . ;
+    . S RATTR=$$SETATTR(RIMDFN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS
+    . S @RIMBASE@("ATTR",RIMDFN)=RATTR ; SAVE THE ATRIBUTES FOR THIS PAT
+    . ;
+    . ; INCREMENT THE COUNT OF PATIENTS WITH THESE ATTRIBUTES IN ATTRTBL
+    . ;
+    . ; I '$D(@RIMBASE@("ATTRTBL",RATTR)) D  ; IF FIRST PAT WITH THESE ATTRS
+    . ; . S @RIMBASE@("ATTRTBL",RATTR)=0 ; DEFAULT VALUE TO BE INCREMENTED
+    . ; S @RIMBASE@("ATTRTBL",RATTR)=@RIMBASE@("ATTRTBL",RATTR)+1 ; INCREMENT
+    . ;
+    . N CATNAME,CATTBL
+    . ; S CATBASE=$NA(@RIMBASE@("ANALYSIS"))
+    . S CATNAME=""
+    . D CPUSH(.CATNAME,RIMBASE,"RIMTBL",RIMDFN,RATTR) ; ADD TO CATEGORY
+    . W "CATEGORY NAME: ",CATNAME,!
+    . ;
+    . F  S RIMDFN=$O(^DPT(RIMDFN)) Q:'$$PTST^C0CSYS(RIMDFN) ; NEXT PATIENT
+    . ; PTST TESTS TO SEE IF PATIENT WAS MERGED
+    . ; IF CCRTEST=0, PTST WILL CHECK TO SEE IF THIS IS A TEST PATIENT
+    . ; AND WE SKIP IT
+    . S @RIMBASE@("RESUME")=RIMDFN ; WHERE WE ARE LEAVING OFF THIS RUN
+    ; D PARY^C0CXPATH(@RIMBASE@("ATTRTBL"))
+    Q
+    ;
+SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS
+    N SBASE,SATTR
+    S SBASE=$NA(@RIMBASE@("VARS",SDFN))
+    D APOST("SATTR","RIMTBL","HEADER")
+    I $D(@SBASE@("PROBLEMS",1)) D  ;
+    . D APOST("SATTR","RIMTBL","PROBLEMS")
+    . ; W "POSTING PROBLEMS",!
+    I $D(@SBASE@("VITALS",1)) D APOST("SATTR","RIMTBL","VITALS")
+    I $D(@SBASE@("IMMUNE",1)) D  ;IMMUNIZATIONS PRESENT
+    . D APOST("SATTR","RIMTBL","IMMUNE")
+    . N ZR,ZI
+    . D GETPA(.ZR,SDFN,"IMMUNE","IMMUNEPRODUCTCODE")
+    . I ZR(0)>0 D APOST("SATTR","RIMTBL","IMMUNECODE") ;IMMUNIZATION CODES
+    I $D(@SBASE@("MEDS",1)) D  ; IF THE PATIENT HAS MEDS VARIABLES
+    . D APOST("SATTR","RIMTBL","MEDS")
+    . N ZR,ZI
+    . D GETPA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES
+    . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
+    . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
+    . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","MEDSCODE") ;CODES
+    . ; D PATD^C0CRIMA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES
+    I $D(@SBASE@("ALERTS",1)) D  ; IF THE PATIENT HAS ALERTS
+    . D APOST("SATTR","RIMTBL","ALERTS")
+    . N ZR,ZI
+    . D GETPA(.ZR,SDFN,"ALERTS","ALERTAGENTPRODUCTCODEVALUE") ;REACTANT CODES
+    . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
+    . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
+    . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","ALERTSCODE") ;CODES
+    I $D(@SBASE@("RESULTS",1)) D  ; IF THE PATIENT HAS LABS VARIABLES
+    . D APOST("SATTR","RIMTBL","RESULTS")
+    . N ZR,ZI
+    . S ZR(0)=0 ; INITIALIZE TO NONE
+    . D RPCGV(.ZR,SDFN,"RESULTS") ;CHECK FOR LABS CODES
+    . ; D PARY^C0CXPATH("ZR") ;
+    . I ZR(0)>0 D  ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN
+    . . F ZI=1:1:ZR(0) D  ; LOOP THROUGH RETURNED VAR^VALUE PAIRS
+    . . . I $P(ZR(ZI),"^",2)="RESULTTESTCODINGSYSTEM" D  ; LOINC CODE CHECK
+    . . . . I $P(ZR(ZI),"^",3)="LOINC" D APOST("SATTR","RIMTBL","RESULTSLN") ;
+    ; D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED
+    I $D(@SBASE@("PROCEDURES",1)) D  ;
+    . D APOST("SATTR","RIMTBL","PROCEDURES")
+    W "ATTRIBUTES: ",SATTR,!
+    Q SATTR
+    ;
+RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES
+    K ^TMP("C0CRIM","RESUME")
+    K ^TMP("C0CRIM")
+    Q
+    ;
+CLIST ; LIST THE CATEGORIES
+    ;
+    I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
+    N CLBASE,CLNUM,ZI,CLIDX
+    S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS"))
+    S CLNUM=@CLBASE@(0)
+    F ZI=1:1:CLNUM D  ; LOOP THROUGH THE CATEGORIES
+    . S CLIDX=@CLBASE@(ZI)
+    . W "(",$P(@CLBASE@(CLIDX),"^",1)
+    . W ":",$P(@CLBASE@(CLIDX),"^",2),") "
+    . W CLIDX,!
+    ; D PARY^C0CXPATH(CLBASE)
+    Q
+    ;
+CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES
+    ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT
+    ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE
+    ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME
+    ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES,
+    ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X"
+    ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES
+    ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY
+    ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING
+    ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY
+    ; NUMBER IE CTBL_X(CDFN)=""
+    ;
+    ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST
+    S CCTBL=$NA(@CBASE@(CTBL,"CATS"))
+    W "CBASE: ",CCTBL,!
+    ;
+    I '$D(@CCTBL@(CATTR)) D  ; FIRST PATIENT IN THIS CATEGORY
+    . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY
+    . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY
+    . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT
+    . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY
+    . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME
+    . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0
+    ;
+    S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY
+    S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT
+    S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK
+    ;
+    S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED
+    ;
+    S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT
+    W "PATS BASE: ",CPATLIST,!
+    S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST
+    ;
+    Q
+    ;
+CHKSUM(CKDFN) ; DOES A CHECKSUM AND STORES IT IN MUMPS GLOBALS
+ ; 
+ S C0CCKB=$NA(^TMP("C0CRIM","CHKSUM")) ;CHECKSUM BASE
+ S C0CGLB=$NA(^TMP("C0CRIM","VARS")) ;CCR VARIABLE BASE
+ S C0CI=""
+ F  S C0CI=$O(@C0CGLB@(CKDFN,C0CI)) Q:C0CI=""  D  ;FOR EACH DOMAIN
+ . ;W "DFN:",CKDFN," DOMAIN:",C0CI,!
+ . S C0CJ=$NA(@C0CGLB@(CKDFN,C0CI))
+ . I C0CI="HEADER" D  ; HAVE TO TAKE OUT THE "DATE GENERATED"
+ . . S C0CDT=@C0CGLB@(CKDFN,C0CI,1,"DATETIME")
+ . . K @C0CGLB@(CKDFN,C0CI,1,"DATETIME")
+ . S C0CCK(C0CI)=$$CHKSUM^XUSESIG1(C0CJ)
+ . I C0CI="HEADER" D  ; PUT IT BACK
+ . . S @C0CGLB@(CKDFN,C0CI,1,"DATETIME")=C0CDT
+ S C0CK="C0CCK" ;
+ S C0CALL=$$CHKSUM^XUSESIG1(C0CK) ;CHECKSUM OF ALL DOMAIN CHECKSUMS
+ S CHKR=0 ; RESULT DEFAULT
+ I $D(^TMP("C0CRIM","CHKSUM",CKDFN,"ALL")) D  ; OLD CHECKSUM EXISTS
+ . I @C0CCKB@(CKDFN,"ALL")'=C0CALL S CHKR=1
+ E  S CHKR=1 ;CHECKSUM IS NEW
+ S @C0CCKB@(CKDFN,"ALL")=C0CALL
+ M @C0CCKB@(CKDFN,"DOMAIN")=C0CCK
+ ;ZWR ^TMP("C0CRIM","CHKSUM",CKDFN,*)
+ Q CHKR
+ ;
+CCOUNT ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE
+    ;
+    I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
+    N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT
+    S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES
+    S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS
+    S ZTOT=0 ; INITIALIZE OVERALL TOTAL
+    F ZI=1:1:@ZCBASE@(0) D  ; FOR ALL CATS
+    . S ZCNT=0
+    . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY
+    . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME
+    . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST
+    . ; F ZJ=0:0 D  Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS
+    . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT
+    . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,!
+    . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX))
+    . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT)))
+    . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD
+    . S ZTOT=ZTOT+ZCNT
+    W "TOTAL: ",ZTOT,!
+    Q
+    ;
+CNTLST(INLST) ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST
+    ; INLST IS PASSED BY NAME
+    N ZI,ZDX,ZCOUNT
+    W INLST,!
+    S ZCOUNT=0
+    S ZDX=""
+    F ZI=$O(@INLST@(ZDX)):0 D  Q:$O(@INLST@(ZDX))=""  ; LOOP UNTIL THE END
+    . S ZCOUNT=ZCOUNT+1
+    . S ZDX=$O(@INLST@(ZDX))
+    . W "ZDX:",ZDX," ZCNT:",ZCOUNT,!
+    Q ZCOUNT
+    ;
+XCPAT(CPATCAT,CPATPARM) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT
+    ;
+    I '$D(CPATPARM) S CPATPARM=""
+    I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
+    N ZI,ZJ,ZC,ZPATBASE
+    S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT))
+    S ZI=""
+    F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
+    . S ZI=$O(@ZPATBASE@(ZI))
+    . D XPAT^C0CCCR(ZI,CPATPARM) ; EXPORT THE PATIENT TO A FILE
+    Q
+    ;
+CPAT(CPATCAT) ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT
+    ;
+    I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
+    N ZI,ZJ,ZC,ZPATBASE
+    S ZC=0 ; COUNT FOR SPACING THE PRINTOUT
+    S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT))
+    S ZI=""
+    F ZJ=0:0 D  Q:$O(@ZPATBASE@(ZI))=""  ; TIL END
+    . S ZI=$O(@ZPATBASE@(ZI))
+    . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT
+    . W ZI," "
+    . I ZC=10 D  ; NEW LINE
+    . . S ZC=0
+    . . W !
+    Q
+    ;
+PATC(DFN) ; DISPLAY THE CATEGORY FOR THIS PATIENT
+    ;
+    N ATTR S ATTR=""
+    I '$D(^TMP("C0CRIM","ATTR",DFN)) D  ; RIM VARS NOT PRESENT
+    . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT
+    S ATTR=^TMP("C0CRIM","ATTR",DFN)
+    I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q  ;NO ATTRIBUTES FOUND
+    I $D(^TMP("C0CRIM","RIMTBL","CATS",ATTR)) D  ; FOUND A CAT
+    . N CAT
+    . S CAT=$P(^TMP("C0CRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT
+    . W CAT,": ",ATTR,!
+    Q
+    ;
+APUSH(AMAP,AVAL) ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME)
+    ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT
+    ; AND AMAP(N)=AVAL IS THE NTH AVAL
+    ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE
+    ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE
+    ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED
+    ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED
+    ;
+    I '$D(@AMAP) D  ; IF THE MAP DOES NOT EXIST
+    . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS
+    S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT
+    S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY
+    S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF
+    Q
+    ;
+ASETUP ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL
+      I '$D(RIMBASE) S RIMBASE=$NA(^TMP("C0CRIM"))
+      I '$D(@RIMBASE) S @RIMBASE=""
+      I '$D(RIMTBL) S RIMTBL=$NA(^TMP("C0CRIM","RIMTBL","TABLE")) ; ATTR TABLE
+      S ^TMP("C0CRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES
+      Q
+      ;
+AINIT ; INITIALIZE ATTRIBUTE TABLE
+      I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
+      K @RIMTBL
+      D APUSH(RIMTBL,"EXTRACTED")
+      D APUSH(RIMTBL,"NOTEXTRACTED")
+      D APUSH(RIMTBL,"HEADER")
+      D APUSH(RIMTBL,"NOPCP")
+      D APUSH(RIMTBL,"PCP")
+      D APUSH(RIMTBL,"PROBLEMS")
+      D APUSH(RIMTBL,"PROBCODE")
+      D APUSH(RIMTBL,"PROBNOCODE")
+      D APUSH(RIMTBL,"PROBDATE")
+      D APUSH(RIMTBL,"PROBNODATE")
+      D APUSH(RIMTBL,"VITALS")
+      D APUSH(RIMTBL,"VITALSCODE")
+      D APUSH(RIMTBL,"VITALSNOCODE")
+      D APUSH(RIMTBL,"VITALSDATE")
+      D APUSH(RIMTBL,"VITALSNODATE")
+      D APUSH(RIMTBL,"IMMUNE")
+      D APUSH(RIMTBL,"IMMUNECODE")
+      D APUSH(RIMTBL,"MEDS")
+      D APUSH(RIMTBL,"MEDSCODE")
+      D APUSH(RIMTBL,"MEDSNOCODE")
+      D APUSH(RIMTBL,"MEDSDATE")
+      D APUSH(RIMTBL,"MEDSNODATE")
+      D APUSH(RIMTBL,"ALERTS")
+      D APUSH(RIMTBL,"ALERTSCODE")
+      D APUSH(RIMTBL,"RESULTS")
+      D APUSH(RIMTBL,"RESULTSLN")
+      D APUSH(RIMTBL,"PROCEDURES")
+      D APUSH(RIMTBL,"ENCOUNTERS")
+      D APUSH(RIMTBL,"NOTES")
+      Q
+      ;
+APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL
+    ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING
+    ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES
+    ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL))
+    I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING
+    N USETBL
+    I '$D(@RIMBASE@("TABLES",PTBL)) D  Q  ; NO TABLE
+    . W "ERROR NO SUCH TABLE",!
+    S USETBL=@RIMBASE@("TABLES",PTBL)
+    S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL
+    Q
+GETPA(RTN,DFN,ISEC,IVAR) ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN
+    ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT")
+    ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2
+    ; IN SECTION "MEDS"
+    ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS
+    ; PENDING FOR MED 2 FOR PATIENT 2
+    ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE
+    ; RETURNED. RTN IS PASSED BY REFERENCE
+    ;
+    S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE
+    I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES
+    S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES
+    I '$D(@ZVBASE@(DFN,ISEC,0)) D  Q ; NO VARIABLES IN SECTION
+    . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,!
+    N ZZI,ZZS
+    S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT
+    ; ZWR @ZZS@(1)
+    S RTN(0)=@ZZS@(0)
+    F ZZI=1:1:RTN(0) D  ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS)
+    . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE
+    . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE
+    Q
+    ;
+PATD(DFN,ISEC,IVAR) ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR
+    ;
+    N ZR
+    D GETPA(.ZR,DFN,ISEC,IVAR)
+    I $D(ZR(0)) D PARY^C0CXPATH("ZR")
+    E  W "NOTHING RETURNED",!
+    Q
+    ;
+CAGET(RTN,IATTR) ;
+    ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR
+    ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE
+    ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC
+    Q
+    ;
+PCLST(LSTRTN,IATTR) ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR
+    ;
+    I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES
+    N ZLST
+    S @LSTRTN@(0)=0 ; DEFAULT RETURN NONE
+    S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES
+    S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS
+    N ZNC  ; ZNC IS NUMBER OF CATEGORIES
+    S ZNC=@ZCBASE@(0)
+    I ZNC=0 Q ; NO CATEGORIES TO SEARCH
+    N ZAP  ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE
+    S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR)
+    N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT
+    F ZI=1:1:ZNC D  ; FOR ALL CATEGORIES
+    . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT
+    . I $P(ZATBL,"^",ZAP)'="" D  ; CAT HAS ATTR
+    . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL
+    . . M @LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT
+    S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS
+    S ZPAT=0 ; START AT FIRST PATIENT IN LIST
+    F  S ZPAT=$O(@LSTRTN@(ZPAT)) Q:ZPAT=""  D  ;
+    . S ZCNT=ZCNT+1
+    S @LSTRTN@(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY
+    Q
+    ;
+DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR
+    ;
+    ;N ZR
+    D PCLST("ZR",CATTR)
+    I ZR(0)=0 D  Q  ;
+    . W "NO PATIENTS RETURNED",!
+    E  D  ;
+    . N ZI S ZI=0
+    . F  S ZI=$O(ZR(ZI)) Q:ZI=""  D  ;
+    . . W !,ZI
+    . ;D PARY^C0CXPATH("ZR") ; PRINT ARRAY
+    . W !,"COUNT=",ZR(0)
+    Q
+    ;
+RPCGV(RTN,DFN,WHICH) ; RPC GET VARS
+ ; RETURNS IN RTN (PASSED BY REFERENCE) THE VARS AND VALUES
+ ; FOUND AT INARY RTN(X)="VAR^VALUE" RTN(0) IS THE COUNT
+ ; DFN IS THE PATIENT NUMBER.
+ ; WHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","IMMUNE"
+ ; OR OTHER SECTIONS AS THEY ARE ADDED
+ ; THIS IS MEANT TO BE AVAILABLE AS AN RPC
+ I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS
+ S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES
+ S RTN(0)=0 ; DEFAULT NOTHING IS RETURNED
+ N ZZGI
+ I WHICH="ALL" D  ; VARIABLES FROM ALL SECTIONS
+ . F ZZGI="HEADER","PROBLEMS","VITALS","MEDS","ALERTS","RESULTS","IMMUNE","PROCEDURES" D  ;
+ . . D ZGVWRK(ZZGI) ; DO EACH SECTION
+ . . I $G(DEBUG)'="" W "DID ",ZZGI,!
+ E  D ZGVWRK(WHICH) ; ONLY ONE SECTION ASKED FOR
+ Q
+ ;
+ZGVWRK(ZWHICH) ; DO ONE SECTION FOR RPCGV
+    ;
+    N ZZGN ; NAME FOR SECTION VARIABLES
+    S ZZGN=$NA(@ZVBASE@(DFN,ZWHICH)) ; BASE OF VARS FOR SECTION
+    ;I '$D(@ZZGN@(0)) Q ; NO VARS FOR THIS SECTION
+    I $O(@ZZGN@(""),-1)=""  D  ;
+    E  D  ; VARS EXIST
+    . N ZGVI,ZGVN
+    . S ZGVN=$O(@ZZGN@(""),-1) ;COUNT OF VARS
+    . F ZGVI=1:1:ZGVN D  ; FOR EACH MULTIPLE IN SECTION
+    . . K ZZGA N ZZGA ; TEMP ARRAY FOR SECTION VARS
+    . . K ZZGN2 N ZZGN2 ; NAME FOR MULTIPLE
+    . . S ZZGN2=$NA(@ZZGN@(ZGVI))
+    . . I $G(DEBUG)'="" W ZZGN2,!,$O(@ZZGN2@("")),!
+    . . D H2ARY^C0CXPATH("ZZGA",ZZGN2,ZGVI) ; CONVERT HASH TO ARRAY
+    . . ; D PARY^C0CXPATH("ZZGA")
+    . . D PUSHA^C0CXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN
+    Q
+    ;
+DPATV(DFN,IWHICH) ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN C0CRIM
+    ; ALONG WITH SAMPLE VALUES.
+    ; IWHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","HEADER"
+    N GTMP
+    I '$D(^TMP("C0CRIM","ATTR",DFN)) D  ; RIM VARS NOT PRESENT
+    . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES
+    I '$D(IWHICH) S IWHICH="ALL"
+    D RPCGV(.GTMP,DFN,IWHICH)
+    D PARY^C0CXPATH("GTMP")
+    Q
+    ;
+RIM2RNF(R2RTN,DFN,RWHICH) ; CONVERTS RIM VARIABLES TO RNF2 FORMAT
+ ; RETURN IN R2RTN, WHICH IS PASSED BY NAME
+ ; RWHICH IS RIM SECTION TO RETURN, DEFAULTS TO "ALL"
+ ;
+ I '$D(RWHICH) S RWHICH="ALL"
+ ;N R2TMP
+ I '$D(^TMP("C0CRIM","ATTR",DFN)) D  ; RIM VARS NOT PRESENT
+ . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES
+ D RPCGV(.R2TMP,DFN,RWHICH) ; RETRIEVE ALL THE VARIABLES I AN ARRAY
+ N R2I,R2J,R2X,R2X1,R2X2,R2Y,R2Z
+ F R2I=1:1:R2TMP(0) D  ; FOR EVERY LINE OF THE ARRAY
+ . S R2X=$P(R2TMP(R2I),"^",1) ; OCCURANCE
+ . S R2Y=$P(R2TMP(R2I),"^",2) ; VARIABLE NAME
+ . I $L(R2Y)<4 Q  ; SKIP SHORT VARIABLES (THEY ARE FOR DEBUGGING)
+ . S R2Z=$P(R2TMP(R2I),"^",3) ; VALUE
+ . I R2X[";" D  ; THERES MULTIPLES
+ . . S R2X1=$P(R2X,";",1) ; FIRST INDEX
+ . . S R2X2=$P(R2X,";",2) ; SECOND INDEX
+ . . S R2J=R2Y_"["_R2X2_"]" ; BUILD THE VARIABLE NAME
+ . . S @R2RTN@("F",R2J,1)="" ; PUT VARIABLE NAME IN FIELD MAP
+ . . S @R2RTN@("V",R2X1,R2J,1)=R2Z ; PUT THE VALUE IN THE ARRAY
+ . E  D  ; NO SUB-MULTIPLES
+ . . S @R2RTN@("F",R2Y,1)="" ; PUT VARIABLE NAME IN FIELD MAP
+ . . S @R2RTN@("V",R2X,R2Y,1)=R2Z ; PUT THE VALUE IN THE ARRAY
+ Q
+ ;
+RIM2CSV(DFN) ; WRITE THE RIM VARIABLES FOR A PATIENT TO A CSV FILE
+ ;
+ N R2CTMP,R2CARY
+ D RIM2RNF("R2CTMP",DFN) ; CONVERT VARIABLES TO RNF FORMAT
+ D RNF2CSV^C0CRNF("R2CARY","R2CTMP","NV") ; CONVERT RNF TO CSV FORMAT
+ D FILEOUT^C0CRNF("R2CARY","VARS-"_DFN_".csv")
+ Q
+ ;

ccr/trunk/p/C0CRNF.m

@@ -1 @@
-C0CRNF    ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "This is the Reference Name Format (RNF) Utility Library ",!
-        W !
-        Q
-        ;
-FIELDS(C0CFRTN,C0CF)    ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF,
-        ; C0CFRTN IS PASSED BY NAME, C0CF IS PASSED BY VALUE
-        ;
-        N C0CFI,C0CFJ ;INNER LOOP, OUTER LOOP
-        N C0CFN ; FIELD NAME
-        S C0CFI=0 S C0CFJ=C0CF
-        K @C0CFRTN ; CLEAR THE RETURN ARRAY
-        F  Q:C0CFJ'[C0CF  D ; FOR THE C0CF FILE AND ALL SUBFILES INCLUSIVE
-        . ;W "1: "_C0CFJ," ",C0CFI,!
-        . F  S C0CFI=$O(^DD(C0CFJ,C0CFI)) Q:+C0CFI=0  D  ; EVERY FIELD
-        . . ;W "2: "_C0CFJ," ",C0CFI,!
-        . . S C0CFN=$P($G(^DD(C0CFJ,C0CFI,0)),"^",1) ;PULL FIELD NAME FROM ^DD
-        . . ;W "N: ",C0CFN,!
-        . . ;I C0CFN="STR" W C0CFN," ",C0CFJ,!
-        . . I $D(@C0CFRTN@(C0CFN)) D  ; IS THIS A DUPLICATE?
-        . . . I $G(DEBUG) D  ;
-        . . . . W "DUPLICATE FOUND! ",C0CFJ," ",C0CFI," ",C0CFN,!,@C0CFRTN@(C0CFN),!
-        . . . S @C0CFRTN@(C0CFN_"_"_C0CFJ)=C0CFJ_"^"_C0CFI
-        . . E  S @C0CFRTN@(C0CFN)=C0CFJ_"^"_C0CFI
-        . S C0CFJ=$O(^DD(C0CFJ)) ; NEXT SUBFILE
-        Q
-        ;
-TESTRNF ; TEST THE RNF1TO2 ROUTINE
-        S G1("ONE")=1
-        S G1("TWO")=2
-        S G1("THREE")=3
-        D RNF1TO2("GPL","G1")
-        S G1("ONE")="NOT1"
-        S G1("TWO")="STILL2"
-        S G1("THREE")=3
-        D RNF1TO2("GPL","G1")
-        ZWR GPL
-        Q
-        ;
-RNF1TO2(ZOUT,ZIN)       ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY 
-        ; (ZOUT) BOTH ARE PASSED BY NAME
-        ; RNF1 IS OF THE FORM:
-        ; @ZIN@("VAR1")=VAL1 
-        ; @ZIN@("VAR2")=VAL2 
-        ; RNF2 IS OF THE FORM:
-        ; @ZOUT@("F","VAR1")=""
-        ; @ZOUT@("F","VAR2")=""
-        ; @ZOUT@("V",n,"VAR1")=VAL1
-        ; @ZOUT@("V",n,"VAR2")=VAL2
-        ; WHERE n IS THE "ROW" OF THE ARRAY
-        N ZI S ZI=""
-        N ZN
-        I '$D(@ZOUT@("V",1)) S ZN=1
-        E  S ZN=$O(@ZOUT@("V",""),-1)+1
-        F  S ZI=$O(@ZIN@(ZI)) Q:ZI=""  D  ;
-        . S @ZOUT@("F",ZI)=""
-        . S @ZOUT@("V",ZN,ZI)=@ZIN@(ZI)
-        Q
-        ;
-RNF1TO2B(ZOUT,ZIN)      ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY 
-        ; THE "B" ROUTINE SUPPORTS WP FIELDS IN THE ARRAY
-        ; EVERY "V" VARIABLE IS FOLLOWED BY A "1"
-        ; FOR EXAMPLE @G@("V",n,"VAR1",1)="VALUE1"
-        ; USE THIS ROUTINE IF YOU WANT TO CONVERT THE RESULT TO A CSV 
-        ; WITH RNF2CSV 
-        ; (ZOUT) BOTH ARE PASSED BY NAME
-        ; RNF1 IS OF THE FORM:
-        ; @ZIN@("VAR1")=VAL1 
-        ; @ZIN@("VAR2")=VAL2 
-        ; RNF2 IS OF THE FORM:
-        ; @ZOUT@("F","VAR1")=""
-        ; @ZOUT@("F","VAR2")=""
-        ; @ZOUT@("V",n,"VAR1",1)=VAL1
-        ; @ZOUT@("V",n,"VAR2",1)=VAL2
-        ; WHERE n IS THE "ROW" OF THE ARRAY
-        N ZI S ZI=""
-        N ZN
-        I '$D(@ZOUT@("V",1)) S ZN=1
-        E  S ZN=$O(@ZOUT@("V",""),-1)+1
-        F  S ZI=$O(@ZIN@(ZI)) Q:ZI=""  D  ;
-        . S @ZOUT@("F",ZI)=""
-        . S @ZOUT@("V",ZN,ZI,1)=@ZIN@(ZI)
-        Q
-        ;
-GETNOLD(GRTN,GFILE,GIEN,GNN)    ; GET FIELDS FOR ACCESS BY NAME
-        ; GRTN IS PASSED BY NAME
-        ;
-        N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
-        I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
-        E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
-        S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
-        D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
-        D GETS^DIQ(GFILE,C0CREF,"**","I","C0CTMP")
-        D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
-        S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J ; STRUCTURE SIGNATURE
-        S (C0CI,C0CJ)=""
-        F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
-        . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
-        . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
-        . . ;W C0CJ," ",C0CI,!
-        . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
-        . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI) ;
-        . . I C0CVALUE["C0CTMP" S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,1) ;1ST LINE OF WP
-        . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
-        I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
-        . S C0CI=""
-        . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
-        . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
-        Q
-        ;
-GETN(GRTN,GFILE,GREF,GNDX,GNN)  ; GET BY NAME ; RETURN A FIELD VALUE MAP
-        ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1
-        ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
-        ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN
-        ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
-        ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
-        ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
-        ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
-        ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
-        ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
-        ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
-        ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
-        ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
-        ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
-        ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
-        ; GREF IS THE VALUE FOR THE INDEX
-        ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
-        ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
-        ;
-        ;
-        N GIEN,GF
-        S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE
-        I ('$D(GNDX))!($G(GNDX)="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN
-        E  D  ; WE ARE USING AN INDEX
-        . ;N ZG
-        . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX
-        . I ZG'="" D  ;
-        . . I $QS(ZG,3)=GREF D  ; IS GREF IN INDEX?
-        . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN
-        . . E  S GIEN="" ; NOT FOUND IN INDEX
-        . E  S GIEN="" ;
-        ;W "IEN: ",GIEN,!
-        ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
-        I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
-        E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
-        S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
-        D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
-        K C0CTMP
-        D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP")
-        D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
-        S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE
-        S (C0CI,C0CJ)=""
-        F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
-        . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
-        . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
-        . . ;W C0CJ," ",C0CI,!
-        . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
-        . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ;
-        . . I C0CVALUE["C0CTMP" D  ; WP FIELD
-        . . . N ZT,ZWP S ZWP=0 ;ITERATOR
-        . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE
-        . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE
-        . . . F  S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP  D  ;
-        . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP
-        . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT "
-        . . . . S C0CVALUE=C0CVALUE_ZT ;
-        . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
-        . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I"))
-        I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
-        . S C0CI=""
-        . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
-        . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
-        Q
-        ;
-GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP
-        ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1
-        ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
-        ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN
-        ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
-        ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
-        ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
-        ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
-        ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
-        ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
-        ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
-        ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
-        ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
-        ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
-        ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
-        ; GREF IS THE VALUE FOR THE INDEX
-        ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
-        ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
-        ;
-        ;
-        N GIEN,GF
-        S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE
-        I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN
-        E  D  ; WE ARE USING AN INDEX
-        . ;N ZG
-        . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX
-        . I ZG'="" D  ;
-        . . I $QS(ZG,3)=GREF D  ; IS GREF IN INDEX?
-        . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN
-        . . E  S GIEN="" ; NOT FOUND IN INDEX
-        . E  S GIEN="" ;
-        ;W "IEN: ",GIEN,!
-        ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
-        I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
-        E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
-        S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
-        D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
-        K C0CTMP
-        D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP")
-        D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
-        S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE
-        S (C0CI,C0CJ)=""
-        F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
-        . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
-        . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
-        . . ;W C0CJ," ",C0CI,!
-        . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
-        . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ;
-        . . I C0CVALUE["C0CTMP" D  ; WP FIELD
-        . . . N ZT,ZWP S ZWP=0 ;ITERATOR
-        . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE
-        . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE
-        . . . F  S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP  D  ;
-        . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP
-        . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT "
-        . . . . S C0CVALUE=C0CVALUE_ZT ;
-        . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
-        . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I"))
-        I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
-        . S C0CI=""
-        . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
-        . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
-        Q
-        ;
-GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN)     ; RETURN FIELD MAP AND VALUES
-        ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
-        ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#"
-        ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
-        ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE
-        ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES
-        ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
-        ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
-        ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
-        ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
-        ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE
-        ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN
-        ; .. OF THE FILE WILL BE USED
-        ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE
-        ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED
-        ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE
-        ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD
-        ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
-        ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL
-        ;N GATMP,GAI,GAF
-        S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE
-        I '$D(GAIDX) S GAIDX="" ;DEFAULT
-        I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED
-        I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX
-        W GAF,!
-        W $O(@GAF@(0)) ;
-        S GAI=0 ;ITERATOR
-        F  S GAI=$O(@GAF@(GAI)) Q:GAI=""  D  ;
-        . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD
-        . N GAX S GAX=0
-        . F  S GAX=$O(GATMP(GAX)) Q:GAX=""  D  ;PULL OUT THE FIELDS
-        . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN
-        Q
-        ;
-ADDNV(GNV,GNVN,GNVF,GNVV)       ; CREATE AN ELEMENT OF THE MATRIX
-        ;
-        S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD#
-        S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE
-        Q
-        ;
-RNF2CSV(RNRTN,RNIN,RNSTY)       ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT
-        ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES
-        ; RNSTY IS STYLE OF THE OUTPUT -
-        ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES
-        ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES
-        ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES
-        N RNR,RNC ;ROW ROOT,COL ROOT
-        N RNI,RNJ,RNX
-        I '$D(RNSTY) S RNSTY="NV" ;DEFAULT
-        I RNSTY="NV" D NV(RNRTN,RNIN)  ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION
-        E  D VN(RNRTN,RNIN) ;
-        Q
-        ;
-NV(RNRTN,RNIN)  ;
-        S RNR=$NA(@RNIN@("F"))
-        S RNC=$NA(@RNIN@("V"))
-        ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
-        S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD"
-        S RNI=""
-        F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
-        . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
-        S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
-        D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
-        S RNI=""
-        F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
-        . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
-        . S RNJ=""
-        . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
-        . . I $D(@RNC@(RNJ,RNI,1)) D  ; THIS ROW HAS THIS COLUMN
-        . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA
-        . . E  S RNX=RNX_"," ; NUL COLUMN
-        . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
-        . D PUSH^C0CXPATH(RNRTN,RNX)
-        Q
-        ;
-VN(RNRTN,RNIN)  ;
-        S RNR=$NA(@RNIN@("V"))
-        S RNC=$NA(@RNIN@("F"))
-        ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
-        S RNX="""ROW"""_"," ; FIRST COLUMN NAME IS "ROW"
-        S RNI=""
-        F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
-        . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
-        S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
-        D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
-        S RNI=""
-        F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
-        . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
-        . S RNJ=""
-        . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
-        . . I $D(@RNR@(RNI,RNJ,1)) D  ; THIS ROW HAS THIS COLUMN
-        . . . S RNV=$TR(@RNR@(RNI,RNJ,1),"""","")
-        . . . S RNV=$TR(RNV,",","")
-        . . . S RNX=RNX_""""_RNV_""""_"," ; ADD THE ELEMENT PLUS A COMMA
-        . . E  S RNX=RNX_"," ; NUL COLUMN
-        . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
-        . D PUSH^C0CXPATH(RNRTN,RNX)
-        Q
-        ;
-READCSV(PATH,NAME,GLB)  ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME
-        ;
-        Q $$FTG^%ZISH(PATH,NAME,GLB,1)
-        ;
-FILE2CSV(FNUM,FVN)      ; WRITES OUT A FILEMAN FILE TO CSV
-        ;
-        ;N G1,G2
-        I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE
-        S G1=$NA(^TMP($J,"C0CCSV",1))
-        S G2=$NA(^TMP($J,"C0CCSV",2))
-        D GETN2(G1,FNUM) ; GET THE MATRIX
-        D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE
-        K @G1
-        D FILEOUT(G2,"FILE_"_FNUM_".csv")
-        K @G2
-        Q
-        ;
-FILEOUT(FOARY,FONAM)    ; WRITE OUT A FILE
-        ;
-        W $$OUTPUT^C0CXPATH($NA(@FOARY@(1)),FONAM,^TMP("C0CCCR","ODIR"))
-        Q
-        ;
-FILEREF(FNUM)   ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM
-        ;
-        N C0CF
-        S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE
-        S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT
-        I C0CF["()" S C0CF=$P(C0CF,"()",1)
-        Q C0CF
-        ;
-SKIP    ;
-        N TXT,DIERR
-        S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT")
-        I $D(DIERR) D CLEAN^DILF Q
-        W "  report_text:",!  ;Progress Note Text
-        N LN S LN=0
-        F  S LN=$O(TXT(LN)) Q:'LN  D
-        . W "    text"_LN_": "_TXT(LN),!
-        . Q
-        Q
-        ;
-RNF2HNV(ZOUT,ZIN)       ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME
-        ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT
-        ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END
-        ; THE TABLE WILL BE IN NV FORMAT, ROWS ARE NAMES COLUMNS ARE VALUES 
-        D PUSH^C0CXPATH(ZOUT,"<table border=""1"">")
-        N ZI,ZJ,ZV,ZN S ZI="" S ZJ=0
-        D PUSH^C0CXPATH(ZOUT,"<tr><td></td>") ;begin row and leave a blank col
-        F  S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0  D  ; FOR EACH OCCURANCE
-        . S ZV="<td>"_ZJ_"</td>" ; OCCURANCE AS COLUMNS HEADER
-        . D PUSH^C0CXPATH(ZOUT,ZV)
-        D PUSH^C0CXPATH(ZOUT,"</tr>") ;end of first row
-        S ZI=""
-        F  S ZI=$O(@ZIN@("F",ZI)) Q:ZI=""  D  ; FOR EACH VARIABLE
-        . S ZN="<tr><td>"_ZI_"</td>" ; VARIABLE NAME IN FIRST COLUMN
-        . D PUSH^C0CXPATH(ZOUT,ZN)
-        . S ZJ=0 ;RESET TO DO IT AGAIN
-        . F  S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0  D  ; FOR EACH OCCURANCE
-        . . S ZV="<td>"_$G(@ZIN@("V",ZJ,ZI,1))_"</td>"
-        . . D PUSH^C0CXPATH(ZOUT,ZV)
-        . D PUSH^C0CXPATH(ZOUT,"</tr>") ;END OF ROW
-        D PUSH^C0CXPATH(ZOUT,"</table>") ; end of table
-        Q
-        ;
-RNF2HVN(ZOUT,ZIN)       ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME
-        ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT
-        ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END
-        ; THE TABLE WILL BE IN VN FORMAT, ROWS ARE VALUES COLUMNS ARE NAMES 
-        D PUSH^C0CXPATH(ZOUT,"<table border=""1"">")
-        N ZI,ZJ S ZI="" S ZJ=0
-        D PUSH^C0CXPATH(ZOUT,"<tr>") ;new row for column headers
-        F  S ZI=$O(@ZIN@("F",ZI)) Q:ZI=""  D  ; FOR EACH VARIABLE
-        . S ZV="<td>"_ZI_"</td>"
-        . D PUSH^C0CXPATH(ZOUT,ZV) ; name
-        D PUSH^C0CXPATH(ZOUT,"</tr>") ; end header row
-        S ZI="" ;RESET TO DO AGAIN
-        F  S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0  D  ; FOR EACH ROW OF VARIABLES
-        . D PUSH^C0CXPATH(ZOUT,"<tr>") ;begin row
-        . F  S ZI=$O(@ZIN@("F",ZI)) Q:ZI=""  D  ; FOR EACH VARIABLE
-        . . S ZV="<td>"_$G(@ZIN@("V",ZJ,ZI,1))_"</td>" ; value
-        . . D PUSH^C0CXPATH(ZOUT,ZV) ; value
-        . D PUSH^C0CXPATH(ZOUT,"</tr>") ; end header
-        D PUSH^C0CXPATH(ZOUT,"</table>") ;end of table
-        Q
-        ;
-ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        Q $P(@ZTAB@(ZFN),"^",1)
-ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        Q $P(@ZTAB@(ZFN),"^",2)
-ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        Q $P($G(@ZTAB@(ZFN)),"^",3)
-        ;
-ZVALUEI(ZFN,ZTAB)       ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        Q $P($G(@ZTAB@(ZFN,"I")),"^",3)
-        ;
+C0CRNF   ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "This is the Reference Name Format (RNF) Utility Library ",!
+ W !
+ Q
+ ;
+FIELDS(C0CFRTN,C0CF) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF,
+ ; C0CFRTN IS PASSED BY NAME, C0CF IS PASSED BY VALUE
+ ;
+ N C0CFI,C0CFJ ;INNER LOOP, OUTER LOOP
+ N C0CFN ; FIELD NAME
+ S C0CFI=0 S C0CFJ=C0CF
+ K @C0CFRTN ; CLEAR THE RETURN ARRAY
+ F  Q:C0CFJ'[C0CF  D ; FOR THE C0CF FILE AND ALL SUBFILES INCLUSIVE
+ . ;W "1: "_C0CFJ," ",C0CFI,!
+ . F  S C0CFI=$O(^DD(C0CFJ,C0CFI)) Q:+C0CFI=0  D  ; EVERY FIELD
+ . . ;W "2: "_C0CFJ," ",C0CFI,!
+ . . S C0CFN=$P($G(^DD(C0CFJ,C0CFI,0)),"^",1) ;PULL FIELD NAME FROM ^DD
+ . . ;W "N: ",C0CFN,!
+ . . ;I C0CFN="STR" W C0CFN," ",C0CFJ,!
+ . . I $D(@C0CFRTN@(C0CFN)) D  ; IS THIS A DUPLICATE?
+ . . . I $G(DEBUG) D  ;
+ . . . . W "DUPLICATE FOUND! ",C0CFJ," ",C0CFI," ",C0CFN,!,@C0CFRTN@(C0CFN),!
+ . . . S @C0CFRTN@(C0CFN_"_"_C0CFJ)=C0CFJ_"^"_C0CFI
+ . . E  S @C0CFRTN@(C0CFN)=C0CFJ_"^"_C0CFI
+ . S C0CFJ=$O(^DD(C0CFJ)) ; NEXT SUBFILE
+ Q
+ ;
+TESTRNF ; TEST THE RNF1TO2 ROUTINE
+ S G1("ONE")=1
+ S G1("TWO")=2
+ S G1("THREE")=3
+ D RNF1TO2("GPL","G1")
+ S G1("ONE")="NOT1"
+ S G1("TWO")="STILL2"
+ S G1("THREE")=3
+ D RNF1TO2("GPL","G1")
+ ZWR GPL
+ Q
+ ;
+RNF1TO2(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY 
+ ; (ZOUT) BOTH ARE PASSED BY NAME
+ ; RNF1 IS OF THE FORM:
+ ; @ZIN@("VAR1")=VAL1 
+ ; @ZIN@("VAR2")=VAL2 
+ ; RNF2 IS OF THE FORM:
+ ; @ZOUT@("F","VAR1")=""
+ ; @ZOUT@("F","VAR2")=""
+ ; @ZOUT@("V",n,"VAR1")=VAL1
+ ; @ZOUT@("V",n,"VAR2")=VAL2
+ ; WHERE n IS THE "ROW" OF THE ARRAY
+ N ZI S ZI=""
+ N ZN
+ I '$D(@ZOUT@("V",1)) S ZN=1
+ E  S ZN=$O(@ZOUT@("V",""),-1)+1
+ F  S ZI=$O(@ZIN@(ZI)) Q:ZI=""  D  ;
+ . S @ZOUT@("F",ZI)=""
+ . S @ZOUT@("V",ZN,ZI)=@ZIN@(ZI)
+ Q
+ ;
+RNF1TO2B(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY 
+ ; THE "B" ROUTINE SUPPORTS WP FIELDS IN THE ARRAY
+ ; EVERY "V" VARIABLE IS FOLLOWED BY A "1"
+ ; FOR EXAMPLE @G@("V",n,"VAR1",1)="VALUE1"
+ ; USE THIS ROUTINE IF YOU WANT TO CONVERT THE RESULT TO A CSV 
+ ; WITH RNF2CSV 
+ ; (ZOUT) BOTH ARE PASSED BY NAME
+ ; RNF1 IS OF THE FORM:
+ ; @ZIN@("VAR1")=VAL1 
+ ; @ZIN@("VAR2")=VAL2 
+ ; RNF2 IS OF THE FORM:
+ ; @ZOUT@("F","VAR1")=""
+ ; @ZOUT@("F","VAR2")=""
+ ; @ZOUT@("V",n,"VAR1",1)=VAL1
+ ; @ZOUT@("V",n,"VAR2",1)=VAL2
+ ; WHERE n IS THE "ROW" OF THE ARRAY
+ N ZI S ZI=""
+ N ZN
+ I '$D(@ZOUT@("V",1)) S ZN=1
+ E  S ZN=$O(@ZOUT@("V",""),-1)+1
+ F  S ZI=$O(@ZIN@(ZI)) Q:ZI=""  D  ;
+ . S @ZOUT@("F",ZI)=""
+ . S @ZOUT@("V",ZN,ZI,1)=@ZIN@(ZI)
+ Q
+ ;
+GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME
+ ; GRTN IS PASSED BY NAME
+ ;
+ N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
+ I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
+ E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
+ S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
+ D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
+ D GETS^DIQ(GFILE,C0CREF,"**","I","C0CTMP")
+ D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
+ S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J ; STRUCTURE SIGNATURE
+ S (C0CI,C0CJ)=""
+ F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
+ . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
+ . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
+ . . ;W C0CJ," ",C0CI,!
+ . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
+ . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI) ;
+ . . I C0CVALUE["C0CTMP" S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,1) ;1ST LINE OF WP
+ . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
+ I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
+ . S C0CI=""
+ . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
+ . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
+ Q
+ ;
+GETN(GRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP
+ ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1
+ ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
+ ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN
+ ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
+ ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
+ ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
+ ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
+ ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
+ ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
+ ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
+ ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
+ ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
+ ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
+ ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
+ ; GREF IS THE VALUE FOR THE INDEX
+ ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
+ ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
+ ;
+ ;
+ N GIEN,GF
+ S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE
+ I ('$D(GNDX))!($G(GNDX)="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN
+ E  D  ; WE ARE USING AN INDEX
+ . ;N ZG
+ . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX
+ . I ZG'="" D  ;
+ . . I $QS(ZG,3)=GREF D  ; IS GREF IN INDEX?
+ . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN
+ . . E  S GIEN="" ; NOT FOUND IN INDEX
+ . E  S GIEN="" ;
+ ;W "IEN: ",GIEN,!
+ ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
+ I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
+ E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
+ S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
+ D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
+ K C0CTMP
+ D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP")
+ D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
+ S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE
+ S (C0CI,C0CJ)=""
+ F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
+ . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
+ . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
+ . . ;W C0CJ," ",C0CI,!
+ . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
+ . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ;
+ . . I C0CVALUE["C0CTMP" D  ; WP FIELD
+ . . . N ZT,ZWP S ZWP=0 ;ITERATOR
+ . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE
+ . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE
+ . . . F  S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP  D  ;
+ . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP
+ . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT "
+ . . . . S C0CVALUE=C0CVALUE_ZT ;
+ . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
+ . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I"))
+ I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
+ . S C0CI=""
+ . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
+ . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
+ Q
+ ;
+GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP
+ ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1
+ ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
+ ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN
+ ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
+ ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")=""
+ ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
+ ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE
+ ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
+ ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
+ ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
+ ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
+ ; IF GREF IS "" THE FIRST RECORD IS OBTAINED
+ ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE
+ ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN
+ ; GREF IS THE VALUE FOR THE INDEX
+ ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
+ ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN
+ ;
+ ;
+ N GIEN,GF
+ S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE
+ I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN
+ E  D  ; WE ARE USING AN INDEX
+ . ;N ZG
+ . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX
+ . I ZG'="" D  ;
+ . . I $QS(ZG,3)=GREF D  ; IS GREF IN INDEX?
+ . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN
+ . . E  S GIEN="" ; NOT FOUND IN INDEX
+ . E  S GIEN="" ;
+ ;W "IEN: ",GIEN,!
+ ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME
+ I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED)
+ E  S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED)
+ S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE
+ D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
+ K C0CTMP
+ D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP")
+ D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE
+ S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE
+ S (C0CI,C0CJ)=""
+ F  S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ=""  D  ; FOR ALL SUBFILES
+ . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE
+ . F  S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI=""  D  ; ARRAY OF FIELDS
+ . . ;W C0CJ," ",C0CI,!
+ . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME
+ . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ;
+ . . I C0CVALUE["C0CTMP" D  ; WP FIELD
+ . . . N ZT,ZWP S ZWP=0 ;ITERATOR
+ . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE
+ . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE
+ . . . F  S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP  D  ;
+ . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP
+ . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT "
+ . . . . S C0CVALUE=C0CVALUE_ZT ;
+ . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3
+ . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I"))
+ I C0CNN D  ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED
+ . S C0CI=""
+ . F  S C0CI=$O(@GRTN@(C0CI)) Q:C0CI=""  D  ; GO THROUGH THE WHOLE ARRAY
+ . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES
+ Q
+ ;
+GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES
+ ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP
+ ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#"
+ ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP
+ ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE
+ ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES
+ ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE
+ ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP
+ ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP
+ ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE
+ ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE
+ ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN
+ ; .. OF THE FILE WILL BE USED
+ ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE
+ ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED
+ ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE
+ ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD
+ ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED
+ ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL
+ ;N GATMP,GAI,GAF
+ S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE
+ I '$D(GAIDX) S GAIDX="" ;DEFAULT
+ I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED
+ I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX
+ W GAF,!
+ W $O(@GAF@(0)) ;
+ S GAI=0 ;ITERATOR
+ F  S GAI=$O(@GAF@(GAI)) Q:GAI=""  D  ;
+ . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD
+ . N GAX S GAX=0
+ . F  S GAX=$O(GATMP(GAX)) Q:GAX=""  D  ;PULL OUT THE FIELDS
+ . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN
+ Q
+ ;
+ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX
+ ;
+ S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD#
+ S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE
+ Q
+ ;
+RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT
+ ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES
+ ; RNSTY IS STYLE OF THE OUTPUT -
+ ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES
+ ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES
+ ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES
+ N RNR,RNC ;ROW ROOT,COL ROOT
+ N RNI,RNJ,RNX
+ I '$D(RNSTY) S RNSTY="NV" ;DEFAULT
+ I RNSTY="NV" D NV(RNRTN,RNIN)  ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION
+ E  D VN(RNRTN,RNIN) ;
+ Q
+ ;
+NV(RNRTN,RNIN) ;
+ S RNR=$NA(@RNIN@("F"))
+ S RNC=$NA(@RNIN@("V"))
+ ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
+ S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD"
+ S RNI=""
+ F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
+ . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
+ S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
+ D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
+ S RNI=""
+ F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
+ . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
+ . S RNJ=""
+ . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
+ . . I $D(@RNC@(RNJ,RNI,1)) D  ; THIS ROW HAS THIS COLUMN
+ . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA
+ . . E  S RNX=RNX_"," ; NUL COLUMN
+ . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
+ . D PUSH^C0CXPATH(RNRTN,RNX)
+ Q
+ ;
+VN(RNRTN,RNIN) ;
+ S RNR=$NA(@RNIN@("V"))
+ S RNC=$NA(@RNIN@("F"))
+ ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER
+ S RNX="""ROW"""_"," ; FIRST COLUMN NAME IS "ROW"
+ S RNI=""
+ F  S RNI=$O(@RNC@(RNI)) Q:RNI=""  D  ; FOR EACH COLUMN
+ . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA
+ S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
+ D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS
+ S RNI=""
+ F  S RNI=$O(@RNR@(RNI)) Q:RNI=""  D  ; FOR EACH ROW
+ . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD
+ . S RNJ=""
+ . F  S RNJ=$O(@RNC@(RNJ)) Q:RNJ=""  D  ; FOR EACH COL
+ . . I $D(@RNR@(RNI,RNJ,1)) D  ; THIS ROW HAS THIS COLUMN
+ . . . S RNV=$TR(@RNR@(RNI,RNJ,1),"""","")
+ . . . S RNV=$TR(RNV,",","")
+ . . . S RNX=RNX_""""_RNV_""""_"," ; ADD THE ELEMENT PLUS A COMMA
+ . . E  S RNX=RNX_"," ; NUL COLUMN
+ . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA
+ . D PUSH^C0CXPATH(RNRTN,RNX)
+ Q
+ ;
+READCSV(PATH,NAME,GLB) ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME
+ ;
+ Q $$FTG^%ZISH(PATH,NAME,GLB,1)
+ ;
+FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV
+ ;
+ ;N G1,G2
+ I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE
+ S G1=$NA(^TMP($J,"C0CCSV",1))
+ S G2=$NA(^TMP($J,"C0CCSV",2))
+ D GETN2(G1,FNUM) ; GET THE MATRIX
+ D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE
+ K @G1
+ D FILEOUT(G2,"FILE_"_FNUM_".csv")
+ K @G2
+ Q
+ ;
+FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE
+ ;
+ W $$OUTPUT^C0CXPATH($NA(@FOARY@(1)),FONAM,^TMP("C0CCCR","ODIR"))
+ Q
+ ;
+FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM
+ ;
+ N C0CF
+ S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE
+ S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT
+ I C0CF["()" S C0CF=$P(C0CF,"()",1)
+ Q C0CF
+ ;
+SKIP ;
+ N TXT,DIERR
+ S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT")
+ I $D(DIERR) D CLEAN^DILF Q
+ W "  report_text:",!  ;Progress Note Text
+ N LN S LN=0
+ F  S LN=$O(TXT(LN)) Q:'LN  D
+ . W "    text"_LN_": "_TXT(LN),!
+ . Q
+ Q
+ ;
+RNF2HNV(ZOUT,ZIN) ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME
+ ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT
+ ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END
+ ; THE TABLE WILL BE IN NV FORMAT, ROWS ARE NAMES COLUMNS ARE VALUES 
+ D PUSH^C0CXPATH(ZOUT,"<table border=""1"">")
+ N ZI,ZJ,ZV,ZN S ZI="" S ZJ=0
+ D PUSH^C0CXPATH(ZOUT,"<tr><td></td>") ;begin row and leave a blank col
+ F  S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0  D  ; FOR EACH OCCURANCE
+ . S ZV="<td>"_ZJ_"</td>" ; OCCURANCE AS COLUMNS HEADER
+ . D PUSH^C0CXPATH(ZOUT,ZV)
+ D PUSH^C0CXPATH(ZOUT,"</tr>") ;end of first row
+ S ZI=""
+ F  S ZI=$O(@ZIN@("F",ZI)) Q:ZI=""  D  ; FOR EACH VARIABLE
+ . S ZN="<tr><td>"_ZI_"</td>" ; VARIABLE NAME IN FIRST COLUMN
+ . D PUSH^C0CXPATH(ZOUT,ZN)
+ . S ZJ=0 ;RESET TO DO IT AGAIN
+ . F  S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0  D  ; FOR EACH OCCURANCE
+ . . S ZV="<td>"_$G(@ZIN@("V",ZJ,ZI,1))_"</td>"
+ . . D PUSH^C0CXPATH(ZOUT,ZV)
+ . D PUSH^C0CXPATH(ZOUT,"</tr>") ;END OF ROW
+ D PUSH^C0CXPATH(ZOUT,"</table>") ; end of table
+ Q
+ ;
+RNF2HVN(ZOUT,ZIN) ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME
+ ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT
+ ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END
+ ; THE TABLE WILL BE IN VN FORMAT, ROWS ARE VALUES COLUMNS ARE NAMES 
+ D PUSH^C0CXPATH(ZOUT,"<table border=""1"">")
+ N ZI,ZJ S ZI="" S ZJ=0
+ D PUSH^C0CXPATH(ZOUT,"<tr>") ;new row for column headers
+ F  S ZI=$O(@ZIN@("F",ZI)) Q:ZI=""  D  ; FOR EACH VARIABLE
+ . S ZV="<td>"_ZI_"</td>"
+ . D PUSH^C0CXPATH(ZOUT,ZV) ; name
+ D PUSH^C0CXPATH(ZOUT,"</tr>") ; end header row
+ S ZI="" ;RESET TO DO AGAIN
+ F  S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0  D  ; FOR EACH ROW OF VARIABLES
+ . D PUSH^C0CXPATH(ZOUT,"<tr>") ;begin row
+ . F  S ZI=$O(@ZIN@("F",ZI)) Q:ZI=""  D  ; FOR EACH VARIABLE
+ . . S ZV="<td>"_$G(@ZIN@("V",ZJ,ZI,1))_"</td>" ; value
+ . . D PUSH^C0CXPATH(ZOUT,ZV) ; value
+ . D PUSH^C0CXPATH(ZOUT,"</tr>") ; end header
+ D PUSH^C0CXPATH(ZOUT,"</table>") ;end of table
+ Q
+ ;
+ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ Q $P(@ZTAB@(ZFN),"^",1)
+ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ Q $P(@ZTAB@(ZFN),"^",2)
+ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ Q $P($G(@ZTAB@(ZFN)),"^",3)
+ ;
+ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ Q $P($G(@ZTAB@(ZFN,"I")),"^",3)
+ ;

ccr/trunk/p/C0CRXN.m

@@ -1 @@
-C0CRXN    ; CCDCCR/GPL - CCR RXN utilities; 12/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "This is the CCR RXNORM Utility Library ",!
-        W !
-        Q
-        ;
-EXPAND  ; MAIN ROUTINE TO CREATE THE C0C RXNORM VUID EXPANSION FILE (176.112)
-        ; READ EACH RECORD FROM 176.111 AND USE THE VUID TO LOOK UP THE RXNORM
-        ; CODE FROM 176.001 (RXNORM CONCEPTS)
-        ; POPULATE ALL FIELDS IN 176.112 AND SET "NEW" TO "Y" IF 176.111 DOES NOT
-        ; ALREADY HAVE AN RXNORM CODE.
-        ; ADD THE RXNORM TEXT FIELD TO EVERY RECORD (NOT PRESENT IN 176.111)
-        ; AND COMPARE THE RXNORM TEXT FIELD WITH THE VUID TEXT FIELD, SETTING THE
-        ; "DIFFERENT TEXT" FIELD TO "Y" IF THERE ARE DIFFERENCES
-        ; USES SUPPORT ROUTINES FROM C0CRNF.m
-        N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR
-        N C0CFVA,C0CFRXN ; CLOSED ROOTS FOR SOURCE FILES
-        N C0CF ; CLOSED ROOT FOR DESTINATION FILE
-        S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE
-        S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE
-        S C0CF=$$FILEREF^C0CRNF(176.112) ; C0C RXNORM VUID MAPPING EXPANSION FILE
-        W C0CVA,C0CFRXN,C0CF,!
-        S C0CZX=0
-        S (HASRXN,NORXN,NOVUID,RXFOUND,RXMATCH,TXTMATCH)=0 ; INITIALIZE COUNTERS
-        F  S C0CZX=$O(^C0CCODES(176.111,C0CZX)) Q:+C0CZX=0  D  ; FOR EVERY RECORD
-        . K C0CA,C0CB,C0CC ; CLEAR ARRAYS
-        . D FIELDS^C0CRNF("C0CC",176.112) ;GET FIELD NAMES FOR OUTPUT FILE
-        . D GETN1^C0CRNF("C0CA",176.111,C0CZX,"","ALL") ;GET THE FIELDS
-        . I $$ZVALUE("MEDIATION CODE")="" D
-        . . S NORXN=NORXN+1 ;
-        . E  D  ; PROCESS MEDIATION CODE
-        . . S HASRXN=HASRXN+1
-        . . D SETFDA("MEDIATION CODE",$$ZVALUE("MEDIATION CODE")) ;
-        . I $$ZVALUE("VUID")="" D  ; BAD RECORD
-        . . S NOVUID=NOVUID+1
-        . . ;D SETFDA("VUID",$$ZVALUE("VUID"))
-        . E  D SETFDA("VUID TEXT",$$ZVALUE("VUID TEXT"))
-        . . ;ZWR C0CA
-        . D GETN1^C0CRNF("C0CB",176.001,$$ZVALUE("VUID"),"VUID","ALL")
-        . I $$ZVALUE("RXCUI","C0CB")'="" D  ; RXNORM FOUND
-        . . S RXFOUND=RXFOUND+1
-        . . I $$ZVALUE("MEDIATION CODE")="" D  ; THIS IS A NEW CODE
-        . . . D SETFDA("MEDIATION CODE",$$ZVALUE("RXCUI","C0CB"))
-        . . . D SETFDA("NEW","Y") ;FLAG RECORD HAS HAVING NEW RXNORM
-        . . W "RXNORM=",$$ZVALUE("RXCUI","C0CB")," ",$$ZVALUE("STR","C0CB"),!
-        . . W "VUID TEXT: ",$$ZVALUE("VUID TEXT"),!
-        . . I $$ZVALUE("VUID TEXT")=$$ZVALUE("STR","C0CB") S TXTMATCH=TXTMATCH+1
-        . . E  D  ;
-        . . . S ZZ=$$ZVALUE("VUID TEXT")_"^"_$$ZVALUE("STR","C0CB")
-        . . . D PUSH^GPLXPATH("NOMATCH",ZZ)
-        . . . D SETFDA("RXNORM TEXT",$$ZVALUE("STR","C0CB")) ;
-        . . . D SETFDA("DIFFERENT TEXT","Y") ;FLAG RECORD FOR DIFFERENT TEXT
-        . I $$ZVALUE("MEDIATION CODE")=$$ZVALUE("RXCUI","C0CB") D  ;
-        . . S RXMATCH=RXMATCH+1
-        . . W "VUID=",$$ZVALUE("VUID")," MATCH RXNORM=",$$ZVALUE("MEDIATION CODE"),!
-        . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
-        . S C0CFDA(176.112,"+"_C0CZX_",",.01)=$$ZVALUE("VUID") ; NEW VUID RECORD
-        . D UPDATE^DIE("","C0CFDA")
-        . I $D(^TMP("DIERR",$J)) U $P BREAK
-        W "HAS RXN=",HASRXN,!
-        W "NO RXN=",NORXN,!
-        W "NO VUID=",NOVUID,!
-        W "RXNORM FOUND=",RXFOUND,!
-        W "RXNORM MATCHES:",RXMATCH,!
-        W "TEXT MATCHES:",TXTMATCH,!
-        Q
-        ;
-EXP2    ; ROUTINE TO CREATE 176.113 C0C RXNORM VUID MAPPING DISCREPANCIES FILE
-        ; CROSS CHECKS THE NATIONAL DRUG FILE AND THE VA MAPPING FILE AGAINST
-        ; THE UMLS RXNORM DATABASE
-        ; THIS ROUTINE HAS BEEN ENHANCED TO ALSO CHECK THE 50.416 DRUG INGREDIENT
-        ; FILE AND TREAT VUIDS FOUND THERE LIKE THE ONES BEING FOUND IN THE NDF
-        ; IF THE VUID EXISISTS IN ALL THREE FILES, THE RXNORM CODE MATCHES IN
-        ; THE VA MAPPING FILE AND THE TEXT STRINGS ARE THE SAME, THE VUID IS INCLUDED
-        ; IN THE FILE BUT NO FLAGS ARE SET
-        ; IF THE VUID IS MISSING FROM THE NATIONAL DRUG FILE NDF=N
-        ; (IF THE VUID IS MISSING FROM THE NDF, IT IS CHECKED IN THE DRUG INGREDIENT
-        ; FILE, AND IF FOUND, THE FLAG IS NOT SET. IN THIS CASE THE TEXT FROM THE
-        ; DRUG INGREDIENT FILE IS USED FOR COMPARISONS)
-        ; IF THE VUID IS MISSING FROM THE VA MAPPING FILE VAMAP=N
-        ; IF THE VUID IS PRESENT IN THE VA MAPPING FILE, BUT THE RXNORM
-        ; CODE IS MISSING IN THAT FILE, VARXN=N
-        ; IF THE TEXT STRINGS DO NOT MATCH EXACTLY, TXTM=N AND ALL THREE STRINGS
-        ; ARE SHOWN; NDF TEXT=NDF TEXT STRING, VA MAP TEXT=VA MAPPING TEXT STRING
-        ; RXNORM TEXT=RXNORM TEXT STRING
-        ; THE FILE IS KEYED ON VUID AND WOULD USUALLY BE SORTED BY VUID
-        ; THE OBJECTIVE IS TO SEE IF NDF (50.68) AND VA MAPPING (176.111) HAVE
-        ; ALL THE VUID CODES THAT ARE IN THE UMLS RXNORM DATABASE
-        N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR
-        N C0CFVA,C0CFRXN ; CLOSED ROOTS FOR SOURCE FILES
-        N C0CF ; CLOSED ROOT FOR DESTINATION FILE
-        S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE
-        S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE
-        ;S C0CF=$$FILEREF^C0CRNF(176.113) ; C0C RXNORM VUID MAPPING ADDITIONAL FILE
-        W C0CVA,C0CFRXN,! ;C0CF,!
-        S C0CZX=0
-        S (NDFVCNT,NDFTCNT,NDFNO)=0 ; COUNTERS FOR NDF TESTS
-        S (VAVCNT,VATCNT,VARCNT,VANO)=0 ; COUNTERS FOR VA MAPPING FILE TESTS
-        F  S C0CZX=$O(^C0CRXN(176.001,"VUID",C0CZX)) Q:+C0CZX=0  D  ; FOR EVERY VUID
-        . K C0CA,C0CB,C0CC,C0CD ; CLEAR ARRAYS
-        . D FIELDS^C0CRNF("C0CC",176.113) ;GET FIELD NAMES FOR OUTPUT FILE
-        . D GETN1^C0CRNF("C0CA",176.001,C0CZX,"VUID","ALL") ;GET FROM RXNORM FILE
-        . D GETN1^C0CRNF("C0CB",176.111,C0CZX,"B","ALL") ;GET FROM VA MAPPING FILE
-        . D GETN1^C0CRNF("C0CD",50.68,C0CZX,"AVUID","ALL") ;GET FROM NDF
-        . D GETN1^C0CRNF("C0CE",50.416,C0CZX,"AVUID","ALL") ;GET FROM DRUG INGREDIENTS
-        . ;D SETFDA("VUID",$$ZVALUE("CODE")) ;SET THE VUID CODE
-        . D SETFDA("RXNORM",$$ZVALUE("RXCUI")) ;SET THE RXNORM CODE
-        . D SETFDA("RXNORM TEXT",$$ZVALUE("STR")) ;SET THE RXNORM TEXT
-        . ;VA MAPPING FILE TESTS
-        . I $$ZVALUE("VUID","C0CB")=C0CZX D  ; VUID FOUND
-        . . S VAVCNT=VAVCNT+1 ;INCREMENT COUNT
-        . . I $$ZVALUE("STR")'=$$ZVALUE("VUID TEXT","C0CB") D  ;TEXT MISMATCH
-        . . . S VATCNT=VATCNT+1 ; INCREMENT VA TEXT MISMATCH COUNT
-        . . . D SETFDA("TXTM","N") ;MARK THAT TEXT DOESN'T MATCH
-        . . . D SETFDA("VA MAP TEXT",$$ZVALUE("VUID TEXT","C0CB")) ; SET VA MAP TEXT
-        . E  D  ; VUID NOT FOUND
-        . . S VANO=VANO+1
-        . . D SETFDA("VAMAP","N") ;MARK AS MISSING FROM VA MAPPING FILE
-        . ; NATIONAL DRUG FILE TESTS
-        . I ($$ZVALUE("VUID","C0CD")=C0CZX)!($$ZVALUE("VUID","C0CE")=C0CZX) D  ;
-        . . ;FOUND IN NATIONAL DRUG FILE OR DRUG INGREDIENT FILE
-        . . S NDFVCNT=NDFVCNT+1 ;INCREMENT VUID FOUND COUNT
-        . . I $$ZVALUE("NAME","C0CD")'=$$ZVALUE("STR") D  ;NDF TEXT DOESN'T MATCH
-        . . . I $$ZVALUE("NAME","C0CE")'=$$ZVALUE("STR") D  ;DRUG ING FILE ALSO
-        . . . . S NDFTCNT=NDFTCNT+1 ; INCREMENT MISMATCHED NDF TEXT COUNT
-        . . . . D SETFDA("TXTM","N") ; SET TEXT MATCH FLAG TO N
-        . . . . D SETFDA("NDF TEXT",$$ZVALUE("NAME","C0CD")) ;POST THE TEXT
-        . . . . D SETFDA("NAT DRUG TEXT",$$ZVALUE("NAME","C0CE")) ;POST TEXT
-        . E  D  ;
-        . . D SETFDA("NDF","N") ;MARK AS MISSING
-        . . S NDFNO=NDFNO+1 ;INCREMENT MISSING COUNT
-        . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
-        . S C0CFDA(176.113,"+"_C0CZX_",",.01)=C0CZX ; NEW VUID RECORD
-        . D UPDATE^DIE("","C0CFDA")
-        . I $D(^TMP("DIERR",$J)) U $P BREAK
-        W "VA MAPPING VUID COUNT: ",VAVCNT,!
-        W "VA MAPPING MISSING: ",VANO,!
-        W "VA MAPPING TEXT MISMATCH: ",VATCNT,!
-        W "NDF VUID COUNT: ",NDFVCNT,!
-        W "NDF MISSING: ",NDFNO,!
-        W "NDF TEXT MISMATCH: ",NDFTCNT,!
-        Q
-CHKNDF  ; ROUTINE TO CHECK THE NATIONAL DRUG FILE WITH THE UMLS RXNORM DB
-        ; USING THE AVUID INDEX, READS ALL VUID CODES IN ^PSNDF(50.68),
-        ; CHECKS TO SEE IF THE CODE IS IN 176.001, AND CREATES A RECORD
-        ; IN 176.114
-        ; THE OBJECTIVE IS TO SEE IF ^PSNDF(50.68) HAS ALL THE VUID CODES IN THE
-        ; UMLS RXNORM DATABASE AND IF THE TEXT FIELDS MATCH
-        ; ALSO CAPTURES THE RXNORM CODE MAPPING
-        ; CHKNDF2 WILL CHECK THE OTHER DIRECTION, STARTING WITH THE 176.001 VUID INDEX
-        ; THIS ROUTINE ALSO CHECKS IF THE VUID CODE IS IN 176.111 AND IF NOT
-        ; SETS NOTMAPPED=Y
-        N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR
-        N C0CFVA,C0CFRXN,C0CPSNDF ; CLOSED ROOTS FOR SOURCE FILES
-        N C0CF ; CLOSED ROOT FOR DESTINATION FILE
-        S C0CPSNDF=$$FILEREF^C0CRNF(50.68) ; NDF CLOSED ROOT REFERENCE
-        S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE
-        S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE
-        ;S C0CF=$$FILEREF^C0CRNF(176.113) ; C0C RXNORM VUID MAPPING ADDITIONAL FILE
-        W C0CVA,C0CFRXN,! ;C0CF,!
-        S C0CZX=0
-        S (FOUND,MISSING)=0
-        S (NOVUID,VMATCH,NOMATCH,MISSING,FOUND,TXTMATCH,NOTM,NVAM)=0 ; COUNTERS
-        F  S C0CZX=$O(^PSNDF(50.68,"AVUID",C0CZX)) Q:+C0CZX=0  D  ; FOR EVERY VUID
-        . K C0CA,C0CB,C0CC,C0CD ; CLEAR ARRAYS
-        . ;D FIELDS^C0CRNF("C0CC",176.113) ;GET FIELD NAMES FOR OUTPUT FILE
-        . D GETN1^C0CRNF("C0CA",50.68,C0CZX,"AVUID","ALL") ;GET THE FIELDS
-        . I $$ZVALUE("VUID")="" D  ; ERROR, SHOULD NOT HAPPEN
-        . . S NOVUID=NOVUID+1 ; FLAG THE ERROR
-        . . D PUSH^GPLXPATH("NOVUID",C0CZX) ; RECORD THE VUID
-        . D GETN1^C0CRNF("C0CD",176.001,C0CZX,"VUID","ALL") ;TRY RXNORM DB
-        . I $$ZVALUE("CODE","C0CD")=C0CZX D  ; FOUND IN RXNORM
-        . . S VMATCH=VMATCH+1 ; COUNT OF PSNDF VUIDS FOUND IN RXNORM
-        . . I $$ZVALUE("NAME")=$$ZVALUE("STR","C0CD") D  ;TEXT MATCHES
-        . . . S TXTMATCH=TXTMATCH+1 ; COUNT IT
-        . . E  D  ; TEXT DOESN'T MATCH
-        . . . S NOTM=NOTM+1 ;NO TEXT MATCH COUNTER
-        . . . S ZV=$$ZVALUE("NAME")_"^"_$$ZVALUE("STR","C0CD")
-        . . . W ZV,!
-        . . . D PUSH^GPLXPATH("TXTNM",ZV) ; RECORD THE TXT MISMATCH
-        . E  S NOMATCH=NOMATCH+1 ; NOT FOUND IN RXNORM
-        . D GETN1^C0CRNF("C0CB",176.111,C0CZX,"B","ALL") ;TRY TO GET FROM 176.111
-        . I $$ZVALUE("VUID","C0CB")="" D  ; VUID NOT FOUND
-        . . ;W "NOT FOUND: ",C0CZX," ",$$ZVALUE("STR")," ",$$ZVALUE("RXCUI"),!
-        . . S MISSING=MISSING+1
-        . . D PUSH^GPLXPATH("MISSING",C0CZX) ;MISSING FROM MAPPING FILE
-        . E  D  ; FOUND IN VA MAPPING FILE
-        . . S FOUND=FOUND+1
-        . . I $$ZVALUE("VUID TEXT","C0CB")'=$$ZVALUE("NAME") D  ; TEXT DOESN'T MATCH
-        . . . S NVAM=NVAM+1 ; MAPPING FILE TEXT IS DIFFERENT THAN NDF
-        . . . S ZY=$$ZVALUE("VUID TEXT","C0CB")_"^"_$$ZVALUE("NAME") ;BOTH STRINGS
-        . . . W "VA: ",ZY,!
-        . . . D PUSH^GPLXPATH("NVAM",ZY) ;SAVE IT
-        W "MISSING IN MAPPING FILE: ",MISSING,!
-        W "FOUND IN MAPPING FILE: ",FOUND,!
-        W "FOUND IN RXNORM: ",VMATCH,!
-        W "NOT FOUND IN RXNORM: ",NOMATCH,!
-        W "ERRORS: ",NOVUID,!
-        Q
-        ;
-        . I $$ZVALUE("MEDIATION CODE")="" D
-        . . S NORXN=NORXN+1 ;
-        . E  D  ; PROCESS MEDIATION CODE
-        . . S HASRXN=HASRXN+1
-        . . D SETFDA("MEDIATION CODE",$$ZVALUE("MEDIATION CODE")) ;
-        . I $$ZVALUE("VUID")="" D  ; BAD RECORD
-        . . S NOVUID=NOVUID+1
-        . . ;D SETFDA("VUID",$$ZVALUE("VUID"))
-        . E  D SETFDA("VUID TEXT",$$ZVALUE("VUID TEXT"))
-        . . ;ZWR C0CA
-        . D GETN1^C0CRNF("C0CB",176.001,$$ZVALUE("VUID"),"VUID","ALL")
-        . I $$ZVALUE("RXCUI","C0CB")'="" D  ; RXNORM FOUND
-        . . S RXFOUND=RXFOUND+1
-        . . I $$ZVALUE("MEDIATION CODE")="" D  ; THIS IS A NEW CODE
-        . . . D SETFDA("MEDIATION CODE",$$ZVALUE("RXCUI","C0CB"))
-        . . . D SETFDA("NEW","Y") ;FLAG RECORD HAS HAVING NEW RXNORM
-        . . W "RXNORM=",$$ZVALUE("RXCUI","C0CB")," ",$$ZVALUE("STR","C0CB"),!
-        . . W "VUID TEXT: ",$$ZVALUE("VUID TEXT"),!
-        . . I $$ZVALUE("VUID TEXT")=$$ZVALUE("STR","C0CB") S TXTMATCH=TXTMATCH+1
-        . . E  D  ;
-        . . . D PUSH^GPLXPATH("NOMATCH",$$ZVALUE("VUID TEXT")_"^"_$$ZVALUE("STR","C0CB"))
-        . . . D SETFDA("RXNORM TEXT",$$ZVALUE("STR","C0CB")) ;
-        . . . D SETFDA("DIFFERENT TEXT","Y") ;FLAG RECORD FOR DIFFERENT TEXT
-        . I $$ZVALUE("MEDIATION CODE")=$$ZVALUE("RXCUI","C0CB") D  ;
-        . . S RXMATCH=RXMATCH+1
-        . . W "VUID=",$$ZVALUE("VUID")," MATCH RXNORM=",$$ZVALUE("MEDIATION CODE"),!
-        . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
-        . S C0CFDA(176.112,"+"_C0CZX_",",.01)=$$ZVALUE("VUID") ; NEW VUID RECORD
-        . D UPDATE^DIE("","C0CFDA")
-        . I $D(^TMP("DIERR",$J)) U $P BREAK
-        W "HAS RXN=",HASRXN,!
-        W "NO RXN=",NORXN,!
-        W "NO VUID=",NOVUID,!
-        W "RXNORM FOUND=",RXFOUND,!
-        W "RXNORM MATCHES:",RXMATCH,!
-        W "TEXT MATCHES:",TXTMATCH,!
-        Q
-SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
-        ; TO SET TO VALUE C0CSV.
-        ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
-        ; C0CSN,C0CSV ARE PASSED BY VALUE
-        ;
-        N C0CSI,C0CSJ
-        S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
-        S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
-        S C0CFDA(C0CSI,"+"_C0CZX_",",C0CSJ)=C0CSV
-        Q
-ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
-        E  S ZR=""
-        Q ZR
-ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
-        E  S ZR=""
-        Q ZR
-        ;
-ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
-        E  S ZR=""
-        Q ZR
-        ;
+C0CRXN   ; CCDCCR/GPL - CCR RXN utilities; 12/6/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "This is the CCR RXNORM Utility Library ",!
+ W !
+ Q
+ ;
+EXPAND ; MAIN ROUTINE TO CREATE THE C0C RXNORM VUID EXPANSION FILE (176.112)
+ ; READ EACH RECORD FROM 176.111 AND USE THE VUID TO LOOK UP THE RXNORM
+ ; CODE FROM 176.001 (RXNORM CONCEPTS)
+ ; POPULATE ALL FIELDS IN 176.112 AND SET "NEW" TO "Y" IF 176.111 DOES NOT
+ ; ALREADY HAVE AN RXNORM CODE.
+ ; ADD THE RXNORM TEXT FIELD TO EVERY RECORD (NOT PRESENT IN 176.111)
+ ; AND COMPARE THE RXNORM TEXT FIELD WITH THE VUID TEXT FIELD, SETTING THE
+ ; "DIFFERENT TEXT" FIELD TO "Y" IF THERE ARE DIFFERENCES
+ ; USES SUPPORT ROUTINES FROM C0CRNF.m
+ N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR
+ N C0CFVA,C0CFRXN ; CLOSED ROOTS FOR SOURCE FILES
+ N C0CF ; CLOSED ROOT FOR DESTINATION FILE
+ S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE
+ S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE
+ S C0CF=$$FILEREF^C0CRNF(176.112) ; C0C RXNORM VUID MAPPING EXPANSION FILE
+ W C0CVA,C0CFRXN,C0CF,!
+ S C0CZX=0
+ S (HASRXN,NORXN,NOVUID,RXFOUND,RXMATCH,TXTMATCH)=0 ; INITIALIZE COUNTERS
+ F  S C0CZX=$O(^C0CCODES(176.111,C0CZX)) Q:+C0CZX=0  D  ; FOR EVERY RECORD
+ . K C0CA,C0CB,C0CC ; CLEAR ARRAYS
+ . D FIELDS^C0CRNF("C0CC",176.112) ;GET FIELD NAMES FOR OUTPUT FILE
+ . D GETN1^C0CRNF("C0CA",176.111,C0CZX,"","ALL") ;GET THE FIELDS
+ . I $$ZVALUE("MEDIATION CODE")="" D
+ . . S NORXN=NORXN+1 ;
+ . E  D  ; PROCESS MEDIATION CODE
+ . . S HASRXN=HASRXN+1
+ . . D SETFDA("MEDIATION CODE",$$ZVALUE("MEDIATION CODE")) ;
+ . I $$ZVALUE("VUID")="" D  ; BAD RECORD
+ . . S NOVUID=NOVUID+1
+ . . ;D SETFDA("VUID",$$ZVALUE("VUID"))
+ . E  D SETFDA("VUID TEXT",$$ZVALUE("VUID TEXT"))
+ . . ;ZWR C0CA
+ . D GETN1^C0CRNF("C0CB",176.001,$$ZVALUE("VUID"),"VUID","ALL")
+ . I $$ZVALUE("RXCUI","C0CB")'="" D  ; RXNORM FOUND
+ . . S RXFOUND=RXFOUND+1
+ . . I $$ZVALUE("MEDIATION CODE")="" D  ; THIS IS A NEW CODE
+ . . . D SETFDA("MEDIATION CODE",$$ZVALUE("RXCUI","C0CB"))
+ . . . D SETFDA("NEW","Y") ;FLAG RECORD HAS HAVING NEW RXNORM
+ . . W "RXNORM=",$$ZVALUE("RXCUI","C0CB")," ",$$ZVALUE("STR","C0CB"),!
+ . . W "VUID TEXT: ",$$ZVALUE("VUID TEXT"),!
+ . . I $$ZVALUE("VUID TEXT")=$$ZVALUE("STR","C0CB") S TXTMATCH=TXTMATCH+1
+ . . E  D  ;
+ . . . S ZZ=$$ZVALUE("VUID TEXT")_"^"_$$ZVALUE("STR","C0CB")
+ . . . D PUSH^GPLXPATH("NOMATCH",ZZ)
+ . . . D SETFDA("RXNORM TEXT",$$ZVALUE("STR","C0CB")) ;
+ . . . D SETFDA("DIFFERENT TEXT","Y") ;FLAG RECORD FOR DIFFERENT TEXT
+ . I $$ZVALUE("MEDIATION CODE")=$$ZVALUE("RXCUI","C0CB") D  ;
+ . . S RXMATCH=RXMATCH+1
+ . . W "VUID=",$$ZVALUE("VUID")," MATCH RXNORM=",$$ZVALUE("MEDIATION CODE"),!
+ . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
+ . S C0CFDA(176.112,"+"_C0CZX_",",.01)=$$ZVALUE("VUID") ; NEW VUID RECORD
+ . D UPDATE^DIE("","C0CFDA")
+ . I $D(^TMP("DIERR",$J)) U $P BREAK
+ W "HAS RXN=",HASRXN,!
+ W "NO RXN=",NORXN,!
+ W "NO VUID=",NOVUID,!
+ W "RXNORM FOUND=",RXFOUND,!
+ W "RXNORM MATCHES:",RXMATCH,!
+ W "TEXT MATCHES:",TXTMATCH,!
+ Q
+ ;
+EXP2 ; ROUTINE TO CREATE 176.113 C0C RXNORM VUID MAPPING DISCREPANCIES FILE
+ ; CROSS CHECKS THE NATIONAL DRUG FILE AND THE VA MAPPING FILE AGAINST
+ ; THE UMLS RXNORM DATABASE
+ ; THIS ROUTINE HAS BEEN ENHANCED TO ALSO CHECK THE 50.416 DRUG INGREDIENT
+ ; FILE AND TREAT VUIDS FOUND THERE LIKE THE ONES BEING FOUND IN THE NDF
+ ; IF THE VUID EXISISTS IN ALL THREE FILES, THE RXNORM CODE MATCHES IN
+ ; THE VA MAPPING FILE AND THE TEXT STRINGS ARE THE SAME, THE VUID IS INCLUDED
+ ; IN THE FILE BUT NO FLAGS ARE SET
+ ; IF THE VUID IS MISSING FROM THE NATIONAL DRUG FILE NDF=N
+ ; (IF THE VUID IS MISSING FROM THE NDF, IT IS CHECKED IN THE DRUG INGREDIENT
+ ; FILE, AND IF FOUND, THE FLAG IS NOT SET. IN THIS CASE THE TEXT FROM THE
+ ; DRUG INGREDIENT FILE IS USED FOR COMPARISONS)
+ ; IF THE VUID IS MISSING FROM THE VA MAPPING FILE VAMAP=N
+ ; IF THE VUID IS PRESENT IN THE VA MAPPING FILE, BUT THE RXNORM
+ ; CODE IS MISSING IN THAT FILE, VARXN=N
+ ; IF THE TEXT STRINGS DO NOT MATCH EXACTLY, TXTM=N AND ALL THREE STRINGS
+ ; ARE SHOWN; NDF TEXT=NDF TEXT STRING, VA MAP TEXT=VA MAPPING TEXT STRING
+ ; RXNORM TEXT=RXNORM TEXT STRING
+ ; THE FILE IS KEYED ON VUID AND WOULD USUALLY BE SORTED BY VUID
+ ; THE OBJECTIVE IS TO SEE IF NDF (50.68) AND VA MAPPING (176.111) HAVE
+ ; ALL THE VUID CODES THAT ARE IN THE UMLS RXNORM DATABASE
+ N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR
+ N C0CFVA,C0CFRXN ; CLOSED ROOTS FOR SOURCE FILES
+ N C0CF ; CLOSED ROOT FOR DESTINATION FILE
+ S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE
+ S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE
+ ;S C0CF=$$FILEREF^C0CRNF(176.113) ; C0C RXNORM VUID MAPPING ADDITIONAL FILE
+ W C0CVA,C0CFRXN,! ;C0CF,!
+ S C0CZX=0
+ S (NDFVCNT,NDFTCNT,NDFNO)=0 ; COUNTERS FOR NDF TESTS
+ S (VAVCNT,VATCNT,VARCNT,VANO)=0 ; COUNTERS FOR VA MAPPING FILE TESTS
+ F  S C0CZX=$O(^C0CRXN(176.001,"VUID",C0CZX)) Q:+C0CZX=0  D  ; FOR EVERY VUID
+ . K C0CA,C0CB,C0CC,C0CD ; CLEAR ARRAYS
+ . D FIELDS^C0CRNF("C0CC",176.113) ;GET FIELD NAMES FOR OUTPUT FILE
+ . D GETN1^C0CRNF("C0CA",176.001,C0CZX,"VUID","ALL") ;GET FROM RXNORM FILE
+ . D GETN1^C0CRNF("C0CB",176.111,C0CZX,"B","ALL") ;GET FROM VA MAPPING FILE
+ . D GETN1^C0CRNF("C0CD",50.68,C0CZX,"AVUID","ALL") ;GET FROM NDF
+ . D GETN1^C0CRNF("C0CE",50.416,C0CZX,"AVUID","ALL") ;GET FROM DRUG INGREDIENTS
+ . ;D SETFDA("VUID",$$ZVALUE("CODE")) ;SET THE VUID CODE
+ . D SETFDA("RXNORM",$$ZVALUE("RXCUI")) ;SET THE RXNORM CODE
+ . D SETFDA("RXNORM TEXT",$$ZVALUE("STR")) ;SET THE RXNORM TEXT
+ . ;VA MAPPING FILE TESTS
+ . I $$ZVALUE("VUID","C0CB")=C0CZX D  ; VUID FOUND
+ . . S VAVCNT=VAVCNT+1 ;INCREMENT COUNT
+ . . I $$ZVALUE("STR")'=$$ZVALUE("VUID TEXT","C0CB") D  ;TEXT MISMATCH
+ . . . S VATCNT=VATCNT+1 ; INCREMENT VA TEXT MISMATCH COUNT
+ . . . D SETFDA("TXTM","N") ;MARK THAT TEXT DOESN'T MATCH
+ . . . D SETFDA("VA MAP TEXT",$$ZVALUE("VUID TEXT","C0CB")) ; SET VA MAP TEXT
+ . E  D  ; VUID NOT FOUND
+ . . S VANO=VANO+1
+ . . D SETFDA("VAMAP","N") ;MARK AS MISSING FROM VA MAPPING FILE
+ . ; NATIONAL DRUG FILE TESTS
+ . I ($$ZVALUE("VUID","C0CD")=C0CZX)!($$ZVALUE("VUID","C0CE")=C0CZX) D  ;
+ . . ;FOUND IN NATIONAL DRUG FILE OR DRUG INGREDIENT FILE
+ . . S NDFVCNT=NDFVCNT+1 ;INCREMENT VUID FOUND COUNT
+ . . I $$ZVALUE("NAME","C0CD")'=$$ZVALUE("STR") D  ;NDF TEXT DOESN'T MATCH
+ . . . I $$ZVALUE("NAME","C0CE")'=$$ZVALUE("STR") D  ;DRUG ING FILE ALSO
+ . . . . S NDFTCNT=NDFTCNT+1 ; INCREMENT MISMATCHED NDF TEXT COUNT
+ . . . . D SETFDA("TXTM","N") ; SET TEXT MATCH FLAG TO N
+ . . . . D SETFDA("NDF TEXT",$$ZVALUE("NAME","C0CD")) ;POST THE TEXT
+ . . . . D SETFDA("NAT DRUG TEXT",$$ZVALUE("NAME","C0CE")) ;POST TEXT
+ . E  D  ;
+ . . D SETFDA("NDF","N") ;MARK AS MISSING
+ . . S NDFNO=NDFNO+1 ;INCREMENT MISSING COUNT
+ . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
+ . S C0CFDA(176.113,"+"_C0CZX_",",.01)=C0CZX ; NEW VUID RECORD
+ . D UPDATE^DIE("","C0CFDA")
+ . I $D(^TMP("DIERR",$J)) U $P BREAK
+ W "VA MAPPING VUID COUNT: ",VAVCNT,!
+ W "VA MAPPING MISSING: ",VANO,!
+ W "VA MAPPING TEXT MISMATCH: ",VATCNT,!
+ W "NDF VUID COUNT: ",NDFVCNT,!
+ W "NDF MISSING: ",NDFNO,!
+ W "NDF TEXT MISMATCH: ",NDFTCNT,!
+ Q
+CHKNDF ; ROUTINE TO CHECK THE NATIONAL DRUG FILE WITH THE UMLS RXNORM DB
+ ; USING THE AVUID INDEX, READS ALL VUID CODES IN ^PSNDF(50.68),
+ ; CHECKS TO SEE IF THE CODE IS IN 176.001, AND CREATES A RECORD
+ ; IN 176.114
+ ; THE OBJECTIVE IS TO SEE IF ^PSNDF(50.68) HAS ALL THE VUID CODES IN THE
+ ; UMLS RXNORM DATABASE AND IF THE TEXT FIELDS MATCH
+ ; ALSO CAPTURES THE RXNORM CODE MAPPING
+ ; CHKNDF2 WILL CHECK THE OTHER DIRECTION, STARTING WITH THE 176.001 VUID INDEX
+ ; THIS ROUTINE ALSO CHECKS IF THE VUID CODE IS IN 176.111 AND IF NOT
+ ; SETS NOTMAPPED=Y
+ N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR
+ N C0CFVA,C0CFRXN,C0CPSNDF ; CLOSED ROOTS FOR SOURCE FILES
+ N C0CF ; CLOSED ROOT FOR DESTINATION FILE
+ S C0CPSNDF=$$FILEREF^C0CRNF(50.68) ; NDF CLOSED ROOT REFERENCE
+ S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE
+ S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE
+ ;S C0CF=$$FILEREF^C0CRNF(176.113) ; C0C RXNORM VUID MAPPING ADDITIONAL FILE
+ W C0CVA,C0CFRXN,! ;C0CF,!
+ S C0CZX=0
+ S (FOUND,MISSING)=0
+ S (NOVUID,VMATCH,NOMATCH,MISSING,FOUND,TXTMATCH,NOTM,NVAM)=0 ; COUNTERS
+ F  S C0CZX=$O(^PSNDF(50.68,"AVUID",C0CZX)) Q:+C0CZX=0  D  ; FOR EVERY VUID
+ . K C0CA,C0CB,C0CC,C0CD ; CLEAR ARRAYS
+ . ;D FIELDS^C0CRNF("C0CC",176.113) ;GET FIELD NAMES FOR OUTPUT FILE
+ . D GETN1^C0CRNF("C0CA",50.68,C0CZX,"AVUID","ALL") ;GET THE FIELDS
+ . I $$ZVALUE("VUID")="" D  ; ERROR, SHOULD NOT HAPPEN
+ . . S NOVUID=NOVUID+1 ; FLAG THE ERROR
+ . . D PUSH^GPLXPATH("NOVUID",C0CZX) ; RECORD THE VUID
+ . D GETN1^C0CRNF("C0CD",176.001,C0CZX,"VUID","ALL") ;TRY RXNORM DB
+ . I $$ZVALUE("CODE","C0CD")=C0CZX D  ; FOUND IN RXNORM
+ . . S VMATCH=VMATCH+1 ; COUNT OF PSNDF VUIDS FOUND IN RXNORM
+ . . I $$ZVALUE("NAME")=$$ZVALUE("STR","C0CD") D  ;TEXT MATCHES
+ . . . S TXTMATCH=TXTMATCH+1 ; COUNT IT
+ . . E  D  ; TEXT DOESN'T MATCH
+ . . . S NOTM=NOTM+1 ;NO TEXT MATCH COUNTER
+ . . . S ZV=$$ZVALUE("NAME")_"^"_$$ZVALUE("STR","C0CD")
+ . . . W ZV,!
+ . . . D PUSH^GPLXPATH("TXTNM",ZV) ; RECORD THE TXT MISMATCH
+ . E  S NOMATCH=NOMATCH+1 ; NOT FOUND IN RXNORM
+ . D GETN1^C0CRNF("C0CB",176.111,C0CZX,"B","ALL") ;TRY TO GET FROM 176.111
+ . I $$ZVALUE("VUID","C0CB")="" D  ; VUID NOT FOUND
+ . . ;W "NOT FOUND: ",C0CZX," ",$$ZVALUE("STR")," ",$$ZVALUE("RXCUI"),!
+ . . S MISSING=MISSING+1
+ . . D PUSH^GPLXPATH("MISSING",C0CZX) ;MISSING FROM MAPPING FILE
+ . E  D  ; FOUND IN VA MAPPING FILE
+ . . S FOUND=FOUND+1
+ . . I $$ZVALUE("VUID TEXT","C0CB")'=$$ZVALUE("NAME") D  ; TEXT DOESN'T MATCH
+ . . . S NVAM=NVAM+1 ; MAPPING FILE TEXT IS DIFFERENT THAN NDF
+ . . . S ZY=$$ZVALUE("VUID TEXT","C0CB")_"^"_$$ZVALUE("NAME") ;BOTH STRINGS
+ . . . W "VA: ",ZY,!
+ . . . D PUSH^GPLXPATH("NVAM",ZY) ;SAVE IT
+ W "MISSING IN MAPPING FILE: ",MISSING,!
+ W "FOUND IN MAPPING FILE: ",FOUND,!
+ W "FOUND IN RXNORM: ",VMATCH,!
+ W "NOT FOUND IN RXNORM: ",NOMATCH,!
+ W "ERRORS: ",NOVUID,!
+ Q
+ ;
+ . I $$ZVALUE("MEDIATION CODE")="" D
+ . . S NORXN=NORXN+1 ;
+ . E  D  ; PROCESS MEDIATION CODE
+ . . S HASRXN=HASRXN+1
+ . . D SETFDA("MEDIATION CODE",$$ZVALUE("MEDIATION CODE")) ;
+ . I $$ZVALUE("VUID")="" D  ; BAD RECORD
+ . . S NOVUID=NOVUID+1
+ . . ;D SETFDA("VUID",$$ZVALUE("VUID"))
+ . E  D SETFDA("VUID TEXT",$$ZVALUE("VUID TEXT"))
+ . . ;ZWR C0CA
+ . D GETN1^C0CRNF("C0CB",176.001,$$ZVALUE("VUID"),"VUID","ALL")
+ . I $$ZVALUE("RXCUI","C0CB")'="" D  ; RXNORM FOUND
+ . . S RXFOUND=RXFOUND+1
+ . . I $$ZVALUE("MEDIATION CODE")="" D  ; THIS IS A NEW CODE
+ . . . D SETFDA("MEDIATION CODE",$$ZVALUE("RXCUI","C0CB"))
+ . . . D SETFDA("NEW","Y") ;FLAG RECORD HAS HAVING NEW RXNORM
+ . . W "RXNORM=",$$ZVALUE("RXCUI","C0CB")," ",$$ZVALUE("STR","C0CB"),!
+ . . W "VUID TEXT: ",$$ZVALUE("VUID TEXT"),!
+ . . I $$ZVALUE("VUID TEXT")=$$ZVALUE("STR","C0CB") S TXTMATCH=TXTMATCH+1
+ . . E  D  ;
+ . . . D PUSH^GPLXPATH("NOMATCH",$$ZVALUE("VUID TEXT")_"^"_$$ZVALUE("STR","C0CB"))
+ . . . D SETFDA("RXNORM TEXT",$$ZVALUE("STR","C0CB")) ;
+ . . . D SETFDA("DIFFERENT TEXT","Y") ;FLAG RECORD FOR DIFFERENT TEXT
+ . I $$ZVALUE("MEDIATION CODE")=$$ZVALUE("RXCUI","C0CB") D  ;
+ . . S RXMATCH=RXMATCH+1
+ . . W "VUID=",$$ZVALUE("VUID")," MATCH RXNORM=",$$ZVALUE("MEDIATION CODE"),!
+ . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP
+ . S C0CFDA(176.112,"+"_C0CZX_",",.01)=$$ZVALUE("VUID") ; NEW VUID RECORD
+ . D UPDATE^DIE("","C0CFDA")
+ . I $D(^TMP("DIERR",$J)) U $P BREAK
+ W "HAS RXN=",HASRXN,!
+ W "NO RXN=",NORXN,!
+ W "NO VUID=",NOVUID,!
+ W "RXNORM FOUND=",RXFOUND,!
+ W "RXNORM MATCHES:",RXMATCH,!
+ W "TEXT MATCHES:",TXTMATCH,!
+ Q
+SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
+ ; TO SET TO VALUE C0CSV.
+ ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
+ ; C0CSN,C0CSV ARE PASSED BY VALUE
+ ;
+ N C0CSI,C0CSJ
+ S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
+ S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
+ S C0CFDA(C0CSI,"+"_C0CZX_",",C0CSJ)=C0CSV
+ Q
+ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
+ E  S ZR=""
+ Q ZR
+ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
+ E  S ZR=""
+ Q ZR
+ ;
+ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
+ E  S ZR=""
+ Q ZR
+ ;

ccr/trunk/p/C0CSOAP.m

@@ -1 @@
-C0CSOAP  ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "This is an SOAP utility library",!
-        W !
-        Q
-        ;
-TEST1   
-        S url="https://ec2-75-101-247-83.compute-1.amazonaws.com:8181/ccr/CCRService?wsdl"
-        D GET1URL^C0CEWD2(url)
-        Q
-        ;
-INITFARY(ARY)   ;initialize the Fileman Field array for SOAP processing
-        ; ARY is passed by name
-        S @ARY@("XML FILE NUMBER")="178.301"
-        S @ARY@("BINDING SUBFILE NUMBER")="178.3014"
-        S @ARY@("MIME TYPE")="2.3"
-        S @ARY@("PROXY SERVER")="2.4"
-        S @ARY@("REPLY TEMPLATE")=".03"
-        S @ARY@("TEMPLATE NAME")=".01"
-        S @ARY@("TEMPLATE XML")="3"
-        S @ARY@("URL")="1"
-        S @ARY@("WSDL URL")="2"
-        S @ARY@("XML")="2.1"
-        S @ARY@("XML HEADER")="2.2"
-        S @ARY@("XPATH REDUCTION STRING")="2.5"
-        S @ARY@("CCR VARIABLE")="4"
-        S @ARY@("FILEMAN FIELD NAME")="1"
-        S @ARY@("FILEMAN FIELD NUMBER")="1.2"
-        S @ARY@("FILEMAN FILE POINTER")="1.1"
-        S @ARY@("INDEXED BY")=".05"
-        S @ARY@("SQLI FIELD NAME")="3"
-        S @ARY@("VARIABLE NAME")="2"
-        Q
-        ;
-RESTID(INNAM,INFARY)    ;EXTRINSIC TO RESOLVE TEMPLATE PASSED BY NAME
-        ; FILE IS IDENTIFIED IN FARY, PASSED BY NAME
-        I '$D(INFARY) D  ; NO FILE ARRAY PASSED
-        . S INFARY="FARY"
-        . D INITFARY(INFARY)
-        N ZN,ZREF,ZR
-        S ZN=@INFARY@("XML FILE NUMBER")
-        S ZREF=$$FILEREF^C0CRNF(ZN)
-        S ZR=$O(@ZREF@("B",INNAM,""))
-        Q ZR
-        ;
-TESTSOAP        ;
-        ; USING ICD9 WEB SERVICE TO TEST SOAP
-        S G("CODE")="E*"
-        S G("CODELN")=3
-        D SOAP("GPL","ICD9","G")
-        Q
-        ;
-SOAP(C0CRTN,C0CTID,C0CVA,C0CVOR,ALTXML,IFARY)   ; MAKES A SOAP CALL FOR 
-        ; TEMPLATE ID C0CTID
-        ; RETURNS THE XML RESULT IN C0CRTN, PASSED BY NAME
-        ; C0CVA IS PASSED BY NAME AND IS THE VARIABLE ARRAY TO PASS TO BIND
-        ; C0CVOR IS THE NAME OF A VARIABLE OVERRIDE ARRAY, WHICH IS APPLIED 
-        ; BEFORE MAPPING
-        ; IF ALTXML IS PASSED, BIND AND MAP WILL BE SKIPPED AND 
-        ; ALTXML WILL BE USED INSTEAD
-        ;
-        ; ARTIFACTS SECTION
-        ; THE FOLLOWING WILL SET UP DEBUGGING ARTIFACTS FOR A POSSIBLE FUTURE
-        ; ONLINE DEBUGGER. IF DEBUG=1, VARIABLES CONTAINING INTERMEDIATE RESULTS
-        ; WILL NOT BE NEWED.
-        I $G(WSDEBUG)="" N C0CV ; CATALOG OF ARTIFACT VARIABLES AND ARRAYS
-        S C0CV(100,"C0CXF","XML TEMPLATE FILE NUMBER")=""
-        S C0CV(200,"C0CHEAD","SOAP HEADER VARIABLE NAME")=""
-        S C0CV(300,"HEADER","SOAP HEADER")=""
-        S C0CV(400,"C0CMIME","MIME TYPE")=""
-        S C0CV(500,"C0CURL","WS URL")=""
-        S C0CV(550,"C0CPURL","PROXY URL")=""
-        S C0CV(600,"C0CXML","XML VARIABLE NAME")=""
-        S C0CV(700,"XML","OUTBOUND XML")=""
-        S C0CV(800,"C0CRSLT","RAW XML RESULT RETURNED FROM WEB SERVICE")=""
-        S C0CV(900,"C0CRHDR","RETURNED HEADER")=""
-        S C0CV(1000,"C0CRXML","XML RESULT NORMALIZED")=""
-        S C0CV(1100,"C0CR","REPLY TEMPLATE")=""
-        S C0CV(1200,"C0CREDUX","REDUX STRING")=""
-        S C0CV(1300,"C0CIDX","RESULT XPATH INDEX")=""
-        S C0CV(1400,"C0CARY","RESULT XPATH ARRAY")=""
-        S C0CV(1500,"C0CNOM","RESULT DOM DOCUMENT NAME")=""
-        S C0CV(1600,"C0CID","RESULT DOM ID")=""
-        I $G(DEBUG)'="" G NOTNEW ; SKIP NEWING THE VARIABLES IF IN DEBUG
-        N ZI,ZJ S ZI=""
-NEW     
-        S ZI=$O(C0CV(ZI))
-        S ZJ=$O(C0CV(ZI,"")) ; SET UP NEW COMMAND
-        ;W ZJ,!
-        N @ZJ ; NEW THE VARIABLE
-        I $O(C0CV(ZI))'="" G NEW ;LOOP TO GET NEW IN CONTEXT
-NOTNEW  
-        ; END ARTIFACTS
-        ;
-        I '$D(IFARY) D INITFARY("C0CF") ; SET FILE NUMBER AND PARAMATERS 
-        E  D  ; 
-        . K C0CF
-        . M C0CF=@IFARY
-        S C0CXF=C0CF("XML FILE NUMBER") ; FILE NUMBER FOR THE XML TEMPLATE FILE
-        I +C0CTID=0 D  ; A STRING WAS PASSED FOR THE TEMPLATE NAME
-        . S C0CUTID=$$RESTID(C0CTID,"C0CF") ;RESOLVE TEMPLATE IEN FROM NAME
-        E  S C0CUTID=C0CTID ; AN IEN WAS PASSED
-        N XML,TEMPLATE,HEADER
-        N C0CFH S C0CFH=C0CF("XML HEADER")
-        S C0CHEAD=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFH,,"HEADER")
-        N C0CFM S C0CFM=C0CF("MIME TYPE")
-        S C0CMIME=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFM)
-        N C0CFP S C0CFP=C0CF("PROXY SERVER")
-        S C0CPURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFP)
-        N C0CFU S C0CFU=C0CF("URL")
-        S C0CURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFU)
-        N C0CFX S C0CFX=C0CF("XML")
-        S C0CXML=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFX,,"XML")
-        N C0CFT S C0CFT=C0CF("TEMPLATE XML")
-        S C0CTMPL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFT,,"TEMPLATE")
-        I C0CTMPL="TEMPLATE" D  ; there is a template to process
-        . K XML ; going to replace the xml array
-        . N VARS
-        . I $D(C0CVOR) M @C0CVA=@C0CVOR ; merge in varible overrides
-        . I '$D(ALTXML) D  ; if ALTXML is passed in, don't bind
-        . . D BIND("VARS",C0CVA,C0CUTID,"C0CF")
-        . . D MAP("XML","VARS",TPTR,"C0CF")
-        . . K XML(0)
-        . E  M XML=@ALTXML ; use ALTXML instead
-        I $G(C0CPROXY) S C0CURL=C0CPURL
-        K C0CRSLT,C0CRHDR
-        B
-        S ok=$$httpPOST^%zewdGTM(C0CURL,.XML,C0CMIME,.C0CRSLT,.HEADER,"",.gpl5,.C0CRHDR)
-        K C0CRXML
-        D NORMAL("C0CRXML","C0CRSLT(1)") ;RETURN XML IN AN ARRAY
-        N C0CFR S C0CFR=$G(C0CF("REPLY TEMPLATE"))
-        S C0CR=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFR,"I") ; REPLY TEMPLATE
-        ; reply templates are optional and are specified by populating a
-        ; template pointer in field 2.5 of the request template
-        ; if specified, the reply template is the source of the REDUX string
-        ; used for XPath on the reply, and for UNBIND processing
-        ; if no reply template is specified, REDUX is obtained from the request
-        ; template and no UNBIND processing is performed. The XPath array is
-        ; returned without variable bindings
-        I C0CR'="" D  ; REPLY TEMPLATE EXISTS
-        . I +$G(DEBUG)'=0 W "REPLY TEMPLATE:",C0CR,!
-        . S C0CTID=C0CR ;
-        N C0CFRDX S C0CFRDX=C0CF("XPATH REDUCTION STRING")
-        S C0CREDUX=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFRDX) ;XPATH REDUCTION STRING
-        K C0CIDX,C0CARY ; XPATH INDEX AND ARRAY VARS
-        S C0CNOM="C0CWS"_$J ; DOCUMENT NAME FOR THE DOM
-        S C0CID=$$PARSE^C0CXEWD("C0CRXML",C0CNOM) ;CALL THE PARSER
-        S C0CID=$$FIRST^C0CXEWD($$ID^C0CXEWD(C0CNOM)) ;ID OF FIRST NODE
-        D XPATH^C0CXEWD(C0CID,"/","C0CIDX","C0CARY","",C0CREDUX) ;XPATH GENERATOR
-        ; Next, call UNBIND to map the reply XPath array to variables
-        ; This is only done if a Reply Template is provided
-        D DEMUXARY(C0CRTN,"C0CARY")
-        ; M @C0CRTN=C0CARY
-        Q
-        ;
-DEMUXARY(OARY,IARY)     ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
-        ; FORMAT @OARY@(x,xpath) where x is the first multiple
-        N ZI,ZJ,ZK,ZL S ZI=""
-        F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ;
-        . D DEMUX^C0CMXP("ZJ",ZI)
-        . S ZK=$P(ZJ,"^",3)
-        . S ZK=$RE($P($RE(ZK),"/",1))
-        . S ZL=$P(ZJ,"^",1)
-        . I ZL="" S ZL=1
-        . S @OARY@(ZL,ZK)=@IARY@(ZI)
-        Q
-        ;
-NORMAL(OUTXML,INXML)    ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
-        ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
-        ;
-        N ZI,ZN,ZTMP
-        S ZN=1
-        S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">"
-        S ZN=ZN+1
-        F  S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)=""  D  ;
-        . S @OUTXML@(ZN)=@OUTXML@(ZN)_">"
-        . S ZN=ZN+1
-        Q
-        ;
-MAP(RARY,IVARS,TPTR,INFARY)     ;RETURNS MAPPED XML IN RARY PASSED BY NAME
-        ; IVARS IS AN XPATH ARRAY PASSED BY NAME
-        ; TPTR IS A POINT TO THE C0C XML TEMPLATE FILE USED TO RETRIEVE THE TEMPLATE
-        ;
-        N ZT ;THE TEMPLATE
-        K ZT,@RARY
-        I '$D(INFARY) D  ;
-        . S INFARY="FARY"
-        . D INITFARY(INFARY)
-        N ZF,ZFT
-        S ZF=@INFARY@("XML FILE NUMBER")
-        S ZFT=@INFARY@("TEMPLATE XML")
-        I $$GET1^DIQ(ZF,TPTR_",",ZFT,,"ZT")'="ZT" D  Q  ; ERROR GETTING TEMPLATE
-        . W "ERROR RETRIEVING TEMPLATE",!
-        D MAP^C0CXPATH("ZT",IVARS,RARY) ;DO THE MAPPING
-        Q
-        ;
-TESTBIND        ;
-        S G1("TESTONE")=1
-        S G1("TESTTWO")=2
-        D BIND("G","G1","TEST")
-        W !
-        ZWR G
-        Q
-        ;
-BIND(RARY,IVARS,INTPTR,INFARY)  ;RETURNS AN XPATH ARRAY IN RARY FOR USE WITH MAP
-        ; TO BUILD AN INSTANTIATED TEMPLATE
-        ; TPTR IS THE IEN OF THE XML TEMPATE IN THE C0C XML TEMPLATE FILE
-        ; LOOPS THROUGHT THE BINDING SUBFILE TO PULL OUT XPATHS AND 
-        ; EITHER ASSIGNS VARIABLES OR DOES A FILEMAN CALL TO GET VALUES
-        ; VARIABLES ARE IN IVARS WHICH IS PASSED BY NAME
-        I '$D(INFARY) D  ;
-        . S INFARY="FARY"
-        . D INITFARY(INFARY) ;INITIALIZE FILE ARRAY IF NOT PASSED
-        I +INTPTR>0 S TPTR=INTPTR
-        E  S TPTR=$$RESTID(INTPTR,INFARY)
-        N C0CFF,C0CBF,C0CXI,C0CFREF,C0CXREF
-        S C0CFF=@INFARY@("XML FILE NUMBER") ;fileman file number of XML file
-        S C0CFREF=$$FILEREF^C0CRNF(C0CFF) ; closed file reference to the file
-        S C0CBF=@INFARY@("BINDING SUBFILE NUMBER") ; BINDING SUBFILE NUMBER
-        S C0CXI=$G(@INFARY@("XPATH INDEX")) ; index to the XPath bindings
-        I C0CXI="" S C0CXI="XPATH" ; default is the XPATH index
-        ; this needs to be a whole file index on the XPath subfile with
-        ; the Template IEN perceding the XPath in the index
-        N ZI
-        S ZI=""
-        S C0CXREF=$NA(@C0CFREF@(C0CXI,TPTR)) ; where the xref is
-        ;F  S ZI=$O(^C0CX(TPTR,5,"B",ZI)) Q:ZI=""  D  ; FOR EACH XPATH
-        F  S ZI=$O(@C0CXREF@(ZI)) Q:ZI=""  D  ; for each XPath in this template
-        . ;W !,ZI," ",$O(@C0CXREF@(ZI,TPTR,""))
-        . N ZIEN,ZFILE,ZFIELD,ZVAR,ZIDX,ZINDEX ;
-        . S ZIEN=$O(@C0CXREF@(ZI,TPTR,"")) ; IEN OF THE BINDING RECORD
-        . N ZFF S ZFF=@INFARY@("FILEMAN FILE POINTER")
-        . S ZFILE=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFF,"I")
-        . N ZFFLD S ZFFLD=@INFARY@("FILEMAN FIELD NUMBER")
-        . S ZFIELD=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFFLD,"I")
-        . N ZFV S ZFV=@INFARY@("VARIABLE NAME")
-        . S ZVAR=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFV,"E")
-        . N ZFX S ZFX=("INDEXED BY")
-        . S ZIDX=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFX,"I")
-        . S ZINDEX=""
-        . I ZIDX="DUZ" S ZINDEX=$G(DUZ) ; FILE IS INDEXED BY DUZ
-        . I ZIDX="DFN" S ZINDEX=$G(DFN) ; BY DFN
-        . E  I ZIDX'="" S ZINDEX=$G(@ZIDX) ; index variable
-        . ;I ZIDX="ACCT" S ZINDEX=C0CACCT ; BY ACCOUNT RECORD POINT TO C0C WS ACCT
-        . ;I ZIDX="LOC" S ZINDEX=C0CLOC ; BY LOCATION
-        . I ZVAR'="" D  ; VARIABLES TAKE PRESCIDENCE OVER FILEMAN FIELDS
-        . . S @RARY@(ZI)=@IVARS@(ZVAR) ; 
-        . E  D  ; IF NO VARIABLE, TRY ACCESSING FROM FILEMAN
-        . . I (ZFILE="")!(ZFIELD="") Q  ;QUIT IF FILE OR FIELD NOT THERE
-        . . D CLEAN^DILF
-        . . S @RARY@(ZI)=$$GET1^DIQ(ZFILE,ZINDEX_",",ZFIELD) ;GET THE VALUE
-        . . I $D(^TMP("DIERR",$J,1)) D  B ;
-        . . . W "ERROR!",!
-        . . . ZWR ^TMP("DIERR",$J,*)
-        Q
-        ;
+C0CSOAP  ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "This is an SOAP utility library",!
+ W !
+ Q
+ ;
+TEST1 
+ S url="https://ec2-75-101-247-83.compute-1.amazonaws.com:8181/ccr/CCRService?wsdl"
+ D GET1URL^C0CEWD2(url)
+ Q
+ ;
+INITFARY(ARY) ;initialize the Fileman Field array for SOAP processing
+ ; ARY is passed by name
+ S @ARY@("XML FILE NUMBER")="178.301"
+ S @ARY@("BINDING SUBFILE NUMBER")="178.3014"
+ S @ARY@("MIME TYPE")="2.3"
+ S @ARY@("PROXY SERVER")="2.4"
+ S @ARY@("REPLY TEMPLATE")=".03"
+ S @ARY@("TEMPLATE NAME")=".01"
+ S @ARY@("TEMPLATE XML")="3"
+ S @ARY@("URL")="1"
+ S @ARY@("WSDL URL")="2"
+ S @ARY@("XML")="2.1"
+ S @ARY@("XML HEADER")="2.2"
+ S @ARY@("XPATH REDUCTION STRING")="2.5"
+ S @ARY@("CCR VARIABLE")="4"
+ S @ARY@("FILEMAN FIELD NAME")="1"
+ S @ARY@("FILEMAN FIELD NUMBER")="1.2"
+ S @ARY@("FILEMAN FILE POINTER")="1.1"
+ S @ARY@("INDEXED BY")=".05"
+ S @ARY@("SQLI FIELD NAME")="3"
+ S @ARY@("VARIABLE NAME")="2"
+ Q
+ ;
+RESTID(INNAM,INFARY) ;EXTRINSIC TO RESOLVE TEMPLATE PASSED BY NAME
+ ; FILE IS IDENTIFIED IN FARY, PASSED BY NAME
+ I '$D(INFARY) D  ; NO FILE ARRAY PASSED
+ . S INFARY="FARY"
+ . D INITFARY(INFARY)
+ N ZN,ZREF,ZR
+ S ZN=@INFARY@("XML FILE NUMBER")
+ S ZREF=$$FILEREF^C0CRNF(ZN)
+ S ZR=$O(@ZREF@("B",INNAM,""))
+ Q ZR
+ ;
+TESTSOAP ;
+ ; USING ICD9 WEB SERVICE TO TEST SOAP
+ S G("CODE")="E*"
+ S G("CODELN")=3
+ D SOAP("GPL","ICD9","G")
+ Q
+ ;
+SOAP(C0CRTN,C0CTID,C0CVA,C0CVOR,ALTXML,IFARY) ; MAKES A SOAP CALL FOR 
+ ; TEMPLATE ID C0CTID
+ ; RETURNS THE XML RESULT IN C0CRTN, PASSED BY NAME
+ ; C0CVA IS PASSED BY NAME AND IS THE VARIABLE ARRAY TO PASS TO BIND
+ ; C0CVOR IS THE NAME OF A VARIABLE OVERRIDE ARRAY, WHICH IS APPLIED 
+ ; BEFORE MAPPING
+ ; IF ALTXML IS PASSED, BIND AND MAP WILL BE SKIPPED AND 
+ ; ALTXML WILL BE USED INSTEAD
+ ;
+ ; ARTIFACTS SECTION
+ ; THE FOLLOWING WILL SET UP DEBUGGING ARTIFACTS FOR A POSSIBLE FUTURE
+ ; ONLINE DEBUGGER. IF DEBUG=1, VARIABLES CONTAINING INTERMEDIATE RESULTS
+ ; WILL NOT BE NEWED.
+ I $G(WSDEBUG)="" N C0CV ; CATALOG OF ARTIFACT VARIABLES AND ARRAYS
+ S C0CV(100,"C0CXF","XML TEMPLATE FILE NUMBER")=""
+ S C0CV(200,"C0CHEAD","SOAP HEADER VARIABLE NAME")=""
+ S C0CV(300,"HEADER","SOAP HEADER")=""
+ S C0CV(400,"C0CMIME","MIME TYPE")=""
+ S C0CV(500,"C0CURL","WS URL")=""
+ S C0CV(550,"C0CPURL","PROXY URL")=""
+ S C0CV(600,"C0CXML","XML VARIABLE NAME")=""
+ S C0CV(700,"XML","OUTBOUND XML")=""
+ S C0CV(800,"C0CRSLT","RAW XML RESULT RETURNED FROM WEB SERVICE")=""
+ S C0CV(900,"C0CRHDR","RETURNED HEADER")=""
+ S C0CV(1000,"C0CRXML","XML RESULT NORMALIZED")=""
+ S C0CV(1100,"C0CR","REPLY TEMPLATE")=""
+ S C0CV(1200,"C0CREDUX","REDUX STRING")=""
+ S C0CV(1300,"C0CIDX","RESULT XPATH INDEX")=""
+ S C0CV(1400,"C0CARY","RESULT XPATH ARRAY")=""
+ S C0CV(1500,"C0CNOM","RESULT DOM DOCUMENT NAME")=""
+ S C0CV(1600,"C0CID","RESULT DOM ID")=""
+ I $G(DEBUG)'="" G NOTNEW ; SKIP NEWING THE VARIABLES IF IN DEBUG
+ N ZI,ZJ S ZI=""
+NEW 
+ S ZI=$O(C0CV(ZI))
+ S ZJ=$O(C0CV(ZI,"")) ; SET UP NEW COMMAND
+ ;W ZJ,!
+ N @ZJ ; NEW THE VARIABLE
+ I $O(C0CV(ZI))'="" G NEW ;LOOP TO GET NEW IN CONTEXT
+NOTNEW 
+ ; END ARTIFACTS
+ ;
+ I '$D(IFARY) D INITFARY("C0CF") ; SET FILE NUMBER AND PARAMATERS 
+ E  D  ; 
+ . K C0CF
+ . M C0CF=@IFARY
+ S C0CXF=C0CF("XML FILE NUMBER") ; FILE NUMBER FOR THE XML TEMPLATE FILE
+ I +C0CTID=0 D  ; A STRING WAS PASSED FOR THE TEMPLATE NAME
+ . S C0CUTID=$$RESTID(C0CTID,"C0CF") ;RESOLVE TEMPLATE IEN FROM NAME
+ E  S C0CUTID=C0CTID ; AN IEN WAS PASSED
+ N XML,TEMPLATE,HEADER
+ N C0CFH S C0CFH=C0CF("XML HEADER")
+ S C0CHEAD=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFH,,"HEADER")
+ N C0CFM S C0CFM=C0CF("MIME TYPE")
+ S C0CMIME=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFM)
+ N C0CFP S C0CFP=C0CF("PROXY SERVER")
+ S C0CPURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFP)
+ N C0CFU S C0CFU=C0CF("URL")
+ S C0CURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFU)
+ N C0CFX S C0CFX=C0CF("XML")
+ S C0CXML=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFX,,"XML")
+ N C0CFT S C0CFT=C0CF("TEMPLATE XML")
+ S C0CTMPL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFT,,"TEMPLATE")
+ I C0CTMPL="TEMPLATE" D  ; there is a template to process
+ . K XML ; going to replace the xml array
+ . N VARS
+ . I $D(C0CVOR) M @C0CVA=@C0CVOR ; merge in varible overrides
+ . I '$D(ALTXML) D  ; if ALTXML is passed in, don't bind
+ . . D BIND("VARS",C0CVA,C0CUTID,"C0CF")
+ . . D MAP("XML","VARS",TPTR,"C0CF")
+ . . K XML(0)
+ . E  M XML=@ALTXML ; use ALTXML instead
+ I $G(C0CPROXY) S C0CURL=C0CPURL
+ K C0CRSLT,C0CRHDR
+ B
+ S ok=$$httpPOST^%zewdGTM(C0CURL,.XML,C0CMIME,.C0CRSLT,.HEADER,"",.gpl5,.C0CRHDR)
+ K C0CRXML
+ D NORMAL("C0CRXML","C0CRSLT(1)") ;RETURN XML IN AN ARRAY
+ N C0CFR S C0CFR=$G(C0CF("REPLY TEMPLATE"))
+ S C0CR=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFR,"I") ; REPLY TEMPLATE
+ ; reply templates are optional and are specified by populating a
+ ; template pointer in field 2.5 of the request template
+ ; if specified, the reply template is the source of the REDUX string
+ ; used for XPath on the reply, and for UNBIND processing
+ ; if no reply template is specified, REDUX is obtained from the request
+ ; template and no UNBIND processing is performed. The XPath array is
+ ; returned without variable bindings
+ I C0CR'="" D  ; REPLY TEMPLATE EXISTS
+ . I +$G(DEBUG)'=0 W "REPLY TEMPLATE:",C0CR,!
+ . S C0CTID=C0CR ;
+ N C0CFRDX S C0CFRDX=C0CF("XPATH REDUCTION STRING")
+ S C0CREDUX=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFRDX) ;XPATH REDUCTION STRING
+ K C0CIDX,C0CARY ; XPATH INDEX AND ARRAY VARS
+ S C0CNOM="C0CWS"_$J ; DOCUMENT NAME FOR THE DOM
+ S C0CID=$$PARSE^C0CXEWD("C0CRXML",C0CNOM) ;CALL THE PARSER
+ S C0CID=$$FIRST^C0CXEWD($$ID^C0CXEWD(C0CNOM)) ;ID OF FIRST NODE
+ D XPATH^C0CXEWD(C0CID,"/","C0CIDX","C0CARY","",C0CREDUX) ;XPATH GENERATOR
+ ; Next, call UNBIND to map the reply XPath array to variables
+ ; This is only done if a Reply Template is provided
+ D DEMUXARY(C0CRTN,"C0CARY")
+ ; M @C0CRTN=C0CARY
+ Q
+ ;
+DEMUXARY(OARY,IARY) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
+ ; FORMAT @OARY@(x,xpath) where x is the first multiple
+ N ZI,ZJ,ZK,ZL S ZI=""
+ F  S ZI=$O(@IARY@(ZI)) Q:ZI=""  D  ;
+ . D DEMUX^C0CMXP("ZJ",ZI)
+ . S ZK=$P(ZJ,"^",3)
+ . S ZK=$RE($P($RE(ZK),"/",1))
+ . S ZL=$P(ZJ,"^",1)
+ . I ZL="" S ZL=1
+ . S @OARY@(ZL,ZK)=@IARY@(ZI)
+ Q
+ ;
+NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
+ ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
+ ;
+ N ZI,ZN,ZTMP
+ S ZN=1
+ S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">"
+ S ZN=ZN+1
+ F  S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)=""  D  ;
+ . S @OUTXML@(ZN)=@OUTXML@(ZN)_">"
+ . S ZN=ZN+1
+ Q
+ ;
+MAP(RARY,IVARS,TPTR,INFARY) ;RETURNS MAPPED XML IN RARY PASSED BY NAME
+ ; IVARS IS AN XPATH ARRAY PASSED BY NAME
+ ; TPTR IS A POINT TO THE C0C XML TEMPLATE FILE USED TO RETRIEVE THE TEMPLATE
+ ;
+ N ZT ;THE TEMPLATE
+ K ZT,@RARY
+ I '$D(INFARY) D  ;
+ . S INFARY="FARY"
+ . D INITFARY(INFARY)
+ N ZF,ZFT
+ S ZF=@INFARY@("XML FILE NUMBER")
+ S ZFT=@INFARY@("TEMPLATE XML")
+ I $$GET1^DIQ(ZF,TPTR_",",ZFT,,"ZT")'="ZT" D  Q  ; ERROR GETTING TEMPLATE
+ . W "ERROR RETRIEVING TEMPLATE",!
+ D MAP^C0CXPATH("ZT",IVARS,RARY) ;DO THE MAPPING
+ Q
+ ;
+TESTBIND ;
+ S G1("TESTONE")=1
+ S G1("TESTTWO")=2
+ D BIND("G","G1","TEST")
+ W !
+ ZWR G
+ Q
+ ;
+BIND(RARY,IVARS,INTPTR,INFARY) ;RETURNS AN XPATH ARRAY IN RARY FOR USE WITH MAP
+ ; TO BUILD AN INSTANTIATED TEMPLATE
+ ; TPTR IS THE IEN OF THE XML TEMPATE IN THE C0C XML TEMPLATE FILE
+ ; LOOPS THROUGHT THE BINDING SUBFILE TO PULL OUT XPATHS AND 
+ ; EITHER ASSIGNS VARIABLES OR DOES A FILEMAN CALL TO GET VALUES
+ ; VARIABLES ARE IN IVARS WHICH IS PASSED BY NAME
+ I '$D(INFARY) D  ;
+ . S INFARY="FARY"
+ . D INITFARY(INFARY) ;INITIALIZE FILE ARRAY IF NOT PASSED
+ I +INTPTR>0 S TPTR=INTPTR
+ E  S TPTR=$$RESTID(INTPTR,INFARY)
+ N C0CFF,C0CBF,C0CXI,C0CFREF,C0CXREF
+ S C0CFF=@INFARY@("XML FILE NUMBER") ;fileman file number of XML file
+ S C0CFREF=$$FILEREF^C0CRNF(C0CFF) ; closed file reference to the file
+ S C0CBF=@INFARY@("BINDING SUBFILE NUMBER") ; BINDING SUBFILE NUMBER
+ S C0CXI=$G(@INFARY@("XPATH INDEX")) ; index to the XPath bindings
+ I C0CXI="" S C0CXI="XPATH" ; default is the XPATH index
+ ; this needs to be a whole file index on the XPath subfile with
+ ; the Template IEN perceding the XPath in the index
+ N ZI
+ S ZI=""
+ S C0CXREF=$NA(@C0CFREF@(C0CXI,TPTR)) ; where the xref is
+ ;F  S ZI=$O(^C0CX(TPTR,5,"B",ZI)) Q:ZI=""  D  ; FOR EACH XPATH
+ F  S ZI=$O(@C0CXREF@(ZI)) Q:ZI=""  D  ; for each XPath in this template
+ . ;W !,ZI," ",$O(@C0CXREF@(ZI,TPTR,""))
+ . N ZIEN,ZFILE,ZFIELD,ZVAR,ZIDX,ZINDEX ;
+ . S ZIEN=$O(@C0CXREF@(ZI,TPTR,"")) ; IEN OF THE BINDING RECORD
+ . N ZFF S ZFF=@INFARY@("FILEMAN FILE POINTER")
+ . S ZFILE=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFF,"I")
+ . N ZFFLD S ZFFLD=@INFARY@("FILEMAN FIELD NUMBER")
+ . S ZFIELD=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFFLD,"I")
+ . N ZFV S ZFV=@INFARY@("VARIABLE NAME")
+ . S ZVAR=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFV,"E")
+ . N ZFX S ZFX=("INDEXED BY")
+ . S ZIDX=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFX,"I")
+ . S ZINDEX=""
+ . I ZIDX="DUZ" S ZINDEX=$G(DUZ) ; FILE IS INDEXED BY DUZ
+ . I ZIDX="DFN" S ZINDEX=$G(DFN) ; BY DFN
+ . E  I ZIDX'="" S ZINDEX=$G(@ZIDX) ; index variable
+ . ;I ZIDX="ACCT" S ZINDEX=C0CACCT ; BY ACCOUNT RECORD POINT TO C0C WS ACCT
+ . ;I ZIDX="LOC" S ZINDEX=C0CLOC ; BY LOCATION
+ . I ZVAR'="" D  ; VARIABLES TAKE PRESCIDENCE OVER FILEMAN FIELDS
+ . . S @RARY@(ZI)=@IVARS@(ZVAR) ; 
+ . E  D  ; IF NO VARIABLE, TRY ACCESSING FROM FILEMAN
+ . . I (ZFILE="")!(ZFIELD="") Q  ;QUIT IF FILE OR FIELD NOT THERE
+ . . D CLEAN^DILF
+ . . S @RARY@(ZI)=$$GET1^DIQ(ZFILE,ZINDEX_",",ZFIELD) ;GET THE VALUE
+ . . I $D(^TMP("DIERR",$J,1)) D  B ;
+ . . . W "ERROR!",!
+ . . . ZWR ^TMP("DIERR",$J,*)
+ Q
+ ;

ccr/trunk/p/C0CSUB1.m

@@ -1 @@
-C0CSUB1   ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "This is the CCR SUBSCRIPTIONN Utility Library ",!
-        Q
-        ;
-CHK1(DFN)       ; ADD THE CHECKSUM FOR ONE PATIENT
-        ;
-        S C0CCHK=$NA(^TMP("C0CRIM","CHKSUM"))
-        S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE
-        S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE
-        S C0CSFC=177.1012 ; FILE NUMBER FOR CHECKSUM SUBFILE
-        S C0CSFDC=177.10121 ; FILE NUMBER FOR DOMAIN CHECKSUMS
-        S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT
-        K C0CFDA 
-        S C0CALL=$G(@C0CCHK@(DFN,"ALL"))
-        I C0CALL'="" S C0CFDA(C0CSFC,"?+1,"_C0CPAT_",",.01)=C0CALL
-        E  Q ; NO CHECKSUMS FOR THISPATIENT
-        D UPDIE
-        N C0CJ S C0CJ=""
-        F  S C0CJ=$O(@C0CCHK@(DFN,"DOMAIN",C0CJ)) Q:C0CJ=""  D  ; FOR EACH DOMAIN
-        . S C0CD=$O(^C0CDIC(170.101,"B",C0CJ,"")) 
-        . W C0CJ," ",C0CD,!
-        . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",.01)=C0CD
-        . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",1)=@C0CCHK@(DFN,"DOMAIN",C0CJ)
-        . D UPDIE
-        Q
-        ;
-SUBALL  ; SUBSCRIBE ALL PATIENTS IN CCR GLOBALS TO SUBCRIBER 1
-        ;
-        S C0CGLB=$NA(^TMP("C0CRIM","VARS"))
-        S C0CI=""
-        F  S C0CI=$O(@C0CGLB@(C0CI)) Q:C0CI=""  D  ; FOR EACH PATIENT
-        . D SUB1(C0CI,1) ;SUBSCIRBE THEM TO EPCRN
-        Q
-        ;
-SUB1(DFN,C0CSS) ; SUBSCRIBE ONE PATIENT TO SUBSCRIBER C0CSS
-        ;
-        S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE
-        S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE
-        S C0CSFC=177.10121 ; FILE NUMBER FOR CHECKSUMS
-        S C0CSSF=177.201 ; FILE NUMBER FOR SUBSCRIBER FILE
-        K C0CFDA
-        S C0CFDA(C0CSF,"+1,",.01)=DFN
-        D UPDIE ; ADD THE PATIENT
-        S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT
-        S C0CFDA(C0CSFS,"+1,"_C0CPAT_",",.01)=C0CSS ; C0CSS IS A POINTER
-        D UPDIE ; ADD THE SUBSCRIPTION
-        D CHK1(DFN) ; ADD THE CHECKSUMS
-        Q
-        ;
-UPDIE   ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
-        K ZERR
-        D CLEAN^DILF
-        D UPDATE^DIE("","C0CFDA","","ZERR")
-        I $D(ZERR) D  ;
-        . W "ERROR",!
-        . ZWR ZERR
-        . B
-        K C0CFDA
-        Q
-        ;
-VARPTR(ZVAR,ZTYP)       ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
-        ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
-        ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
-        ;
-        N ZCCRD,ZVARN,C0CFDA2
-        S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
-        S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
-        I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
-        . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
-        . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
-        . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
-        . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
-        . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
-        . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
-        . I $D(ZERR) D  ; LAYGO ERROR
-        . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
-        . E  D  ;
-        . . D CLEAN^DILF ; CLEAN UP
-        . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
-        . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
-        Q ZVARN
-        ;
-SETFDA(C0CSN,C0CSV)     ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
-        ; TO SET TO VALUE C0CSV.
-        ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
-        ; C0CSN,C0CSV ARE PASSED BY VALUE
-        ;
-        N C0CSI,C0CSJ
-        S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
-        S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
-        S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
-        Q
-ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
-        E  S ZR=""
-        Q ZR
-ZFIELD(ZFN,ZTAB)        ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
-        E  S ZR=""
-        Q ZR
-        ;
-ZVALUE(ZFN,ZTAB)        ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
-        ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        N ZR
-        I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
-        E  S ZR=""
-        Q ZR
-        ;
+C0CSUB1   ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2009 George Lilly.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "This is the CCR SUBSCRIPTIONN Utility Library ",!
+ Q
+ ;
+CHK1(DFN) ; ADD THE CHECKSUM FOR ONE PATIENT
+ ;
+ S C0CCHK=$NA(^TMP("C0CRIM","CHKSUM"))
+ S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE
+ S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE
+ S C0CSFC=177.1012 ; FILE NUMBER FOR CHECKSUM SUBFILE
+ S C0CSFDC=177.10121 ; FILE NUMBER FOR DOMAIN CHECKSUMS
+ S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT
+ K C0CFDA 
+ S C0CALL=$G(@C0CCHK@(DFN,"ALL"))
+ I C0CALL'="" S C0CFDA(C0CSFC,"?+1,"_C0CPAT_",",.01)=C0CALL
+ E  Q ; NO CHECKSUMS FOR THISPATIENT
+ D UPDIE
+ N C0CJ S C0CJ=""
+ F  S C0CJ=$O(@C0CCHK@(DFN,"DOMAIN",C0CJ)) Q:C0CJ=""  D  ; FOR EACH DOMAIN
+ . S C0CD=$O(^C0CDIC(170.101,"B",C0CJ,"")) 
+ . W C0CJ," ",C0CD,!
+ . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",.01)=C0CD
+ . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",1)=@C0CCHK@(DFN,"DOMAIN",C0CJ)
+ . D UPDIE
+ Q
+ ;
+SUBALL ; SUBSCRIBE ALL PATIENTS IN CCR GLOBALS TO SUBCRIBER 1
+ ;
+ S C0CGLB=$NA(^TMP("C0CRIM","VARS"))
+ S C0CI=""
+ F  S C0CI=$O(@C0CGLB@(C0CI)) Q:C0CI=""  D  ; FOR EACH PATIENT
+ . D SUB1(C0CI,1) ;SUBSCIRBE THEM TO EPCRN
+ Q
+ ;
+SUB1(DFN,C0CSS) ; SUBSCRIBE ONE PATIENT TO SUBSCRIBER C0CSS
+ ;
+ S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE
+ S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE
+ S C0CSFC=177.10121 ; FILE NUMBER FOR CHECKSUMS
+ S C0CSSF=177.201 ; FILE NUMBER FOR SUBSCRIBER FILE
+ K C0CFDA
+ S C0CFDA(C0CSF,"+1,",.01)=DFN
+ D UPDIE ; ADD THE PATIENT
+ S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT
+ S C0CFDA(C0CSFS,"+1,"_C0CPAT_",",.01)=C0CSS ; C0CSS IS A POINTER
+ D UPDIE ; ADD THE SUBSCRIPTION
+ D CHK1(DFN) ; ADD THE CHECKSUMS
+ Q
+ ;
+UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
+ K ZERR
+ D CLEAN^DILF
+ D UPDATE^DIE("","C0CFDA","","ZERR")
+ I $D(ZERR) D  ;
+ . W "ERROR",!
+ . ZWR ZERR
+ . B
+ K C0CFDA
+ Q
+ ;
+VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE
+ ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO
+ ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO
+ ;
+ N ZCCRD,ZVARN,C0CFDA2
+ S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY
+ S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
+ I ZVARN="" D  ; VARIABLE NOT IN CCR DICTIONARY - ADD IT
+ . I '$D(ZTYP) D  Q  ; WON'T ADD A VARIABLE WITHOUT A TYPE
+ . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,!
+ . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE
+ . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE
+ . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN
+ . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY
+ . I $D(ZERR) D  ; LAYGO ERROR
+ . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",!
+ . E  D  ;
+ . . D CLEAN^DILF ; CLEAN UP
+ . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE
+ . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,!
+ Q ZVARN
+ ;
+SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN
+ ; TO SET TO VALUE C0CSV.
+ ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE
+ ; C0CSN,C0CSV ARE PASSED BY VALUE
+ ;
+ N C0CSI,C0CSJ
+ S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER
+ S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER
+ S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV
+ Q
+ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1)
+ E  S ZR=""
+ Q ZR
+ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2)
+ E  S ZR=""
+ Q ZR
+ ;
+ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED
+ ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ N ZR
+ I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3)
+ E  S ZR=""
+ Q ZR
+ ;

ccr/trunk/p/C0CSYS.m

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

ccr/trunk/p/C0CUNIT.m

@@ -1 @@
-C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008 George Lilly. Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-                 W "This is a unit testing library",!
-                 W !
-                 Q
-                 ;
-ZT(ZARY,BAT,TST)        ; private routine to add a test case to the ZARY array
-                 ; ZARY IS PASSED BY REFERENCE
-                 ; BAT is a string identifying the test battery
-                 ; TST is a test which will evaluate to true or false
-                 ; I '$G(ZARY) D
-                 ; . S ZARY(0)=0 ; initially there are no elements
-                 ; W "GOT HERE LOADING "_TST,!
-                 N CNT ; count of array elements
-                 S CNT=ZARY(0) ; contains array count
-                 S CNT=CNT+1 ; increment count
-                 S ZARY(CNT)=TST ; put the test in the array
-                 I $D(ZARY(BAT))  D  ; NOT THE FIRST TEST IN BATTERY
-                 . N II,TN ; TEMP FOR ENDING TEST IN BATTERY
-                 . S II=$P(ZARY(BAT),"^",2)
-                 . S $P(ZARY(BAT),"^",2)=II+1
-                 I '$D(ZARY(BAT))  D  ; FIRST TEST IN THIS BATTERY
-                 . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY
-                 . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX
-                 . ; S TN=$NA(ZARY("TESTS"))
-                 . ; D PUSH^C0CXPATH(TN,BAT)
-                 S ZARY(0)=CNT ; update the array counter
-                 Q
-                 ;
-ZLOAD(ZARY,ROUTINE)      ; load tests into ZARY which is passed by reference
-                 ; ZARY IS PASSED BY NAME
-                 ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
-                 ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
-                 K @ZARY
-                 S @ZARY@(0)=0 ; initialize array count
-                 N LINE,LABEL,BODY
-                 N INTEST S INTEST=0 ; switch for in the test case section
-                 N SECTION S SECTION="[anonymous]" ; test case section
-                 ;
-                 N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
-                 . I LINE?." "1";;><TEST>".E S INTEST=1 ; entering test section
-                 . I LINE?." "1";;><TEMPLATE>".E S INTEST=1 ; entering TEMPLATE section
-                 . I LINE?." "1";;></TEST>".E S INTEST=0 ; leaving test section
-                 . I LINE?." "1";;></TEMPLATE>".E S INTEST=0 ; leaving TEMPLATE section
-                 . I INTEST  D  ; within the testing section
-                 . . I LINE?." "1";;><".E  D  ; section name found
-                 . . . S SECTION=$P($P(LINE,";;><",2),">",1) ; pull out name
-                 . . I LINE?." "1";;>>".E  D  ; test case found
-                 . . . D ZT(.@ZARY,SECTION,$P(LINE,";;>>",2)) ; put the test in the array
-                 S @ZARY@("ALL")="1"_"^"_@ZARY@(0) ; MAKE A BATTERY FOR ALL
-                 Q
-                 ;
-ZTEST(ZARY,WHICH)         ; try out the tests using a passed array ZTEST
-                 N ZI,ZX,ZR,ZP
-                 S DEBUG=0
-                 ; I WHICH="ALL" D  Q ; RUN ALL THE TESTS
-                 ; . W "DOING ALL",!
-                 ; . N J,NT
-                 ; . S NT=$NA(ZARY("TESTS"))
-                 ; . W NT,@NT@(0),!
-                 ; . F J=1:1:@NT@(0) D  ;
-                 ; . . W @NT@(J),!
-                 ; . . D ZTEST^C0CUNIT(@ZARY,@NT@(J))
-                 I '$D(ZARY(WHICH))  D  Q ; TEST SECTION DOESN'T EXIST
-                 . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,!
-                 N FIRST,LAST
-                 S FIRST=$P(ZARY(WHICH),"^",1)
-                 S LAST=$P(ZARY(WHICH),"^",2)
-                 F ZI=FIRST:1:LAST  D
-                 . I ZARY(ZI)?1">"1.E  D  ; NOT A TEST, JUST RUN THE STATEMENT
-                 . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI)))
-                 . . ;  W ZP,!
-                 . . S ZX=ZP
-                 . . W "RUNNING: "_ZP
-                 . . X ZX
-                 . . W "..SUCCESS: ",WHICH,!
-                 . I ZARY(ZI)?1"?"1.E  D  ; THIS IS A TEST
-                 . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI)))
-                 . . S ZX="S ZR="_ZP
-                 . . W "TRYING: "_ZP
-                 . . X ZX
-                 . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),!
-                 . . I '$D(TPASSED) D  ; NOT INITIALIZED YET
-                 . . . S TPASSED=0 S TFAILED=0
-                 . . I ZR S TPASSED=TPASSED+1
-                 . . I 'ZR S TFAILED=TFAILED+1
-                 Q
-                 ;
-TEST      ; RUN ALL THE TEST CASES
-                 N ZTMP
-                 D ZLOAD(.ZTMP)
-                 D ZTEST(.ZTMP,"ALL")
-                 W "PASSED: ",TPASSED,!
-                 W "FAILED: ",TFAILED,!
-                 W !
-                 W "THE TESTS!",!
-                 ; I DEBUG ZWR ZTMP
-                 Q
-                 ;
-GTSTS(GTZARY,RTN)       ; return an array of test names
-                 N I,J S I="" S I=$O(GTZARY("TESTS",I))
-                 F J=0:0  Q:I=""  D
-                 . D PUSH^C0CXPATH(RTN,I)
-                 . S I=$O(GTZARY("TESTS",I))
-                 Q
-                 ;
-TESTALL(RNM)    ; RUN ALL THE TESTS
-                 N ZI,J,TZTMP,TSTS,TOTP,TOTF
-                 S TOTP=0 S TOTF=0
-                 D ZLOAD^C0CUNIT("TZTMP",RNM)
-                 D GTSTS(.TZTMP,"TSTS")
-                 F ZI=1:1:TSTS(0) D  ;
-                 . S TPASSED=0 S TFAILED=0
-                 . D ZTEST^C0CUNIT(.TZTMP,TSTS(ZI))
-                 . S TOTP=TOTP+TPASSED
-                 . S TOTF=TOTF+TFAILED
-                 . S $P(TSTS(ZI),"^",2)=TPASSED
-                 . S $P(TSTS(ZI),"^",3)=TFAILED
-                 F ZI=1:1:TSTS(0) D  ;
-                 . W "TEST=> ",$P(TSTS(ZI),"^",1)
-                 . W " PASSED=>",$P(TSTS(ZI),"^",2)
-                 . W " FAILED=>",$P(TSTS(ZI),"^",3),!
-                 W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,!
-                 Q
-                 ;
-TLIST(ZARY)     ; LIST ALL THE TESTS
-                 ; THEY ARE MARKED AS ;;><TESTNAME> IN THE TEST CASES
-                 ; ZARY IS PASSED BY REFERENCE
-                 N I,J,K S I="" S I=$O(ZARY("TESTS",I))
-                 S K=1
-                 F J=0:0  Q:I=""  D
-                 . ; W "I IS NOW=",I,!
-                 . W I," "
-                 . S I=$O(ZARY("TESTS",I))
-                 . S K=K+1 I K=6  D
-                 . . W !
-                 . . S K=1
-                 Q
-                 ;
-MEDS    
-        N DEBUG S DEBUG=0
-        N DFN S DFN=5685
-        K ^TMP($J)
-        W "Loading CCR Template into T using LOAD^GPLCCR0($NA(^TMP($J,""CCR"")))",!!
-        N T S T=$NA(^TMP($J,"CCR"))     D LOAD^GPLCCR0(T)
-        N XPATH S XPATH="//ContinuityOfCareRecord/Body/Medications"
-        W "XPATH is: "_XPATH,!
-        W "Getting Med Template into INXML using",!
-        W "QUERY^GPLXPATH(T,XPATH,""INXML"")",!!
-        D QUERY^GPLXPATH(T,XPATH,"INXML")
-        W "Executing EXTRACT^C0CMED(INXML,DFN,OUTXML)",!
-        W "OUTXML will be ^TMP($J,""OUT"")",!
-        N OUTXML S OUTXML=$NA(^TMP($J,"OUT"))
-        D EXTRACT^C0CMED6("INXML",DFN,OUTXML)
-        D FILEOUT^C0CRNF(OUTXML,"TESTMEDS.xml")
-        Q
-PAT     
-        D ANALYZE^ARJTXRD("C0CDPT",.OUT) ; Analyze a routine in the directory
-        N X,Y
-        ; Select Patient
-        S DIC=2,DIC(0)="AEMQ" D ^DIC
-        ;
-        W "You have selected patient "_Y,!!
-        N I S I=89 F  S I=$O(OUT(I)) Q:I="ALINE"  D
-        . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" "
-        . W "valued at "
-        . W @("$$"_$P(OUT(I,0),"(DFN)")_"^"_"C0CDPT"_"("_$P(Y,"^")_")")
-        . W !
-        Q
+C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008 George Lilly. Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+          W "This is a unit testing library",!
+          W !
+          Q
+          ;
+ZT(ZARY,BAT,TST) ; private routine to add a test case to the ZARY array
+          ; ZARY IS PASSED BY REFERENCE
+          ; BAT is a string identifying the test battery
+          ; TST is a test which will evaluate to true or false
+          ; I '$G(ZARY) D
+          ; . S ZARY(0)=0 ; initially there are no elements
+          ; W "GOT HERE LOADING "_TST,!
+          N CNT ; count of array elements
+          S CNT=ZARY(0) ; contains array count
+          S CNT=CNT+1 ; increment count
+          S ZARY(CNT)=TST ; put the test in the array
+          I $D(ZARY(BAT))  D  ; NOT THE FIRST TEST IN BATTERY
+          . N II,TN ; TEMP FOR ENDING TEST IN BATTERY
+          . S II=$P(ZARY(BAT),"^",2)
+          . S $P(ZARY(BAT),"^",2)=II+1
+          I '$D(ZARY(BAT))  D  ; FIRST TEST IN THIS BATTERY
+          . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY
+          . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX
+          . ; S TN=$NA(ZARY("TESTS"))
+          . ; D PUSH^C0CXPATH(TN,BAT)
+          S ZARY(0)=CNT ; update the array counter
+          Q
+          ;
+ZLOAD(ZARY,ROUTINE)  ; load tests into ZARY which is passed by reference
+          ; ZARY IS PASSED BY NAME
+          ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
+          ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
+          K @ZARY
+          S @ZARY@(0)=0 ; initialize array count
+          N LINE,LABEL,BODY
+          N INTEST S INTEST=0 ; switch for in the test case section
+          N SECTION S SECTION="[anonymous]" ; test case section
+          ;
+          N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
+          . I LINE?." "1";;><TEST>".E S INTEST=1 ; entering test section
+          . I LINE?." "1";;><TEMPLATE>".E S INTEST=1 ; entering TEMPLATE section
+          . I LINE?." "1";;></TEST>".E S INTEST=0 ; leaving test section
+          . I LINE?." "1";;></TEMPLATE>".E S INTEST=0 ; leaving TEMPLATE section
+          . I INTEST  D  ; within the testing section
+          . . I LINE?." "1";;><".E  D  ; section name found
+          . . . S SECTION=$P($P(LINE,";;><",2),">",1) ; pull out name
+          . . I LINE?." "1";;>>".E  D  ; test case found
+          . . . D ZT(.@ZARY,SECTION,$P(LINE,";;>>",2)) ; put the test in the array
+          S @ZARY@("ALL")="1"_"^"_@ZARY@(0) ; MAKE A BATTERY FOR ALL
+          Q
+          ;
+ZTEST(ZARY,WHICH)   ; try out the tests using a passed array ZTEST
+          N ZI,ZX,ZR,ZP
+          S DEBUG=0
+          ; I WHICH="ALL" D  Q ; RUN ALL THE TESTS
+          ; . W "DOING ALL",!
+          ; . N J,NT
+          ; . S NT=$NA(ZARY("TESTS"))
+          ; . W NT,@NT@(0),!
+          ; . F J=1:1:@NT@(0) D  ;
+          ; . . W @NT@(J),!
+          ; . . D ZTEST^C0CUNIT(@ZARY,@NT@(J))
+          I '$D(ZARY(WHICH))  D  Q ; TEST SECTION DOESN'T EXIST
+          . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,!
+          N FIRST,LAST
+          S FIRST=$P(ZARY(WHICH),"^",1)
+          S LAST=$P(ZARY(WHICH),"^",2)
+          F ZI=FIRST:1:LAST  D
+          . I ZARY(ZI)?1">"1.E  D  ; NOT A TEST, JUST RUN THE STATEMENT
+          . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI)))
+          . . ;  W ZP,!
+          . . S ZX=ZP
+          . . W "RUNNING: "_ZP
+          . . X ZX
+          . . W "..SUCCESS: ",WHICH,!
+          . I ZARY(ZI)?1"?"1.E  D  ; THIS IS A TEST
+          . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI)))
+          . . S ZX="S ZR="_ZP
+          . . W "TRYING: "_ZP
+          . . X ZX
+          . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),!
+          . . I '$D(TPASSED) D  ; NOT INITIALIZED YET
+          . . . S TPASSED=0 S TFAILED=0
+          . . I ZR S TPASSED=TPASSED+1
+          . . I 'ZR S TFAILED=TFAILED+1
+          Q
+          ;
+TEST   ; RUN ALL THE TEST CASES
+          N ZTMP
+          D ZLOAD(.ZTMP)
+          D ZTEST(.ZTMP,"ALL")
+          W "PASSED: ",TPASSED,!
+          W "FAILED: ",TFAILED,!
+          W !
+          W "THE TESTS!",!
+          ; I DEBUG ZWR ZTMP
+          Q
+          ;
+GTSTS(GTZARY,RTN) ; return an array of test names
+          N I,J S I="" S I=$O(GTZARY("TESTS",I))
+          F J=0:0  Q:I=""  D
+          . D PUSH^C0CXPATH(RTN,I)
+          . S I=$O(GTZARY("TESTS",I))
+          Q
+          ;
+TESTALL(RNM) ; RUN ALL THE TESTS
+          N ZI,J,TZTMP,TSTS,TOTP,TOTF
+          S TOTP=0 S TOTF=0
+          D ZLOAD^C0CUNIT("TZTMP",RNM)
+          D GTSTS(.TZTMP,"TSTS")
+          F ZI=1:1:TSTS(0) D  ;
+          . S TPASSED=0 S TFAILED=0
+          . D ZTEST^C0CUNIT(.TZTMP,TSTS(ZI))
+          . S TOTP=TOTP+TPASSED
+          . S TOTF=TOTF+TFAILED
+          . S $P(TSTS(ZI),"^",2)=TPASSED
+          . S $P(TSTS(ZI),"^",3)=TFAILED
+          F ZI=1:1:TSTS(0) D  ;
+          . W "TEST=> ",$P(TSTS(ZI),"^",1)
+          . W " PASSED=>",$P(TSTS(ZI),"^",2)
+          . W " FAILED=>",$P(TSTS(ZI),"^",3),!
+          W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,!
+          Q
+          ;
+TLIST(ZARY) ; LIST ALL THE TESTS
+          ; THEY ARE MARKED AS ;;><TESTNAME> IN THE TEST CASES
+          ; ZARY IS PASSED BY REFERENCE
+          N I,J,K S I="" S I=$O(ZARY("TESTS",I))
+          S K=1
+          F J=0:0  Q:I=""  D
+          . ; W "I IS NOW=",I,!
+          . W I," "
+          . S I=$O(ZARY("TESTS",I))
+          . S K=K+1 I K=6  D
+          . . W !
+          . . S K=1
+          Q
+          ;
+MEDS 
+ N DEBUG S DEBUG=0
+ N DFN S DFN=5685
+ K ^TMP($J)
+ W "Loading CCR Template into T using LOAD^GPLCCR0($NA(^TMP($J,""CCR"")))",!!
+ N T S T=$NA(^TMP($J,"CCR"))     D LOAD^GPLCCR0(T)
+ N XPATH S XPATH="//ContinuityOfCareRecord/Body/Medications"
+ W "XPATH is: "_XPATH,!
+ W "Getting Med Template into INXML using",!
+ W "QUERY^GPLXPATH(T,XPATH,""INXML"")",!!
+ D QUERY^GPLXPATH(T,XPATH,"INXML")
+ W "Executing EXTRACT^C0CMED(INXML,DFN,OUTXML)",!
+ W "OUTXML will be ^TMP($J,""OUT"")",!
+ N OUTXML S OUTXML=$NA(^TMP($J,"OUT"))
+ D EXTRACT^C0CMED6("INXML",DFN,OUTXML)
+ D FILEOUT^C0CRNF(OUTXML,"TESTMEDS.xml")
+ Q
+PAT 
+ D ANALYZE^ARJTXRD("C0CDPT",.OUT) ; Analyze a routine in the directory
+ N X,Y
+ ; Select Patient
+ S DIC=2,DIC(0)="AEMQ" D ^DIC
+ ;
+ W "You have selected patient "_Y,!!
+ N I S I=89 F  S I=$O(OUT(I)) Q:I="ALINE"  D
+ . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" "
+ . W "valued at "
+ . W @("$$"_$P(OUT(I,0),"(DFN)")_"^"_"C0CDPT"_"("_$P(Y,"^")_")")
+ . W !
+ Q

ccr/trunk/p/C0CUTIL.m

@@ -1 @@
-C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08
-        ;;0.1;C0C;;Jun 15, 2008;Build 38
-        ;Copyright 2008-2009 Sam Habiel & George Lilly.  
-        ;Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "No Entry at Top!"
-        Q
-        ;
-UUID()   ; thanks to Wally for this.
-               N R,I,J,N 
-               S N="",R="" F  S N=N_$R(100000) Q:$L(N)>64 
-               F I=1:2:64 S R=R_$E("0123456789abcdef",($E(N,I,I+1)#16+1)) 
-               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)
-        ;
-OLDUUID()       ; GENERATE A RANDOM UUID (Version 4)
-        N I,J,ZS
-        S ZS="0123456789abcdef" S J=""
-        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))
-        Q J
-        ;
-FMDTOUTC(DATE,FORMAT)   ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic
-        ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time)
-        ; If not passed, or passed incorrectly, it's assumed that it is D.
-        ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied.
-        ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC
-        ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters)
-        N UTC,Y,M,D,H,MM,S,OFF
-        S Y=1700+$E(DATE,1,3)
-        S M=$E(DATE,4,5)
-        S D=$E(DATE,6,7)
-        S H=$E(DATE,9,10)
-        I $L(H)=1 S H="0"_H
-        S MM=$E(DATE,11,12)
-        I $L(MM)=1 S MM="0"_MM
-        S S=$E(DATE,13,14)
-        I $L(S)=1 S S="0"_S
-        S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation.
-        S OFFS=$E(OFF,1,1)
-        S OFF0=$TR(OFF,"+-")
-        S OFF1=$E(OFF0+10000,2,3)
-        S OFF2=$E(OFF0+10000,4,5)
-        S OFF=OFFS_OFF1_":"_OFF2
-        ;S OFF2=$E(OFF,1,2) ;
-        ;S OFF2=$E(100+OFF2,2,3) ; GPL 11/08 CHANGED TO -05:00 FORMAT
-        ;S OFF3=$E(OFF,3,4) ;MINUTES
-        ;S OFF=$S(OFF2="":"00",0:"00",1:OFF2)_"."_$S(OFF3="":"00",1:OFF3)
-        ; If H, MM and S are empty, it means that the FM date didn't supply the time.
-        ; In this case, set H, MM and S to "00"
-        ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING?
-        S:'$L(H) H="00"
-        S:'$L(MM) MM="00"
-        S:'$L(S) S="00"
-        S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds
-        I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time.
-        E  Q $P(UTC,"T")
-        ;
-SORTDT(V1,V2,ORDR)      ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT
-        ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE
-        ; DATE AND TIME ORDER. DEFAULT IS FORWARD
-        ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT
-        ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER
-        ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER
-        ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC
-        ; BOTH V1 AND V2 ARE PASSED BY REFERENCE
-        N VSRT ; TEMP FOR HASHING DATES
-        N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2
-        S ZCNT=V2(0) ; COUNTING NUMBER OF DATES
-        F ZI=1:1:ZCNT D  ; FOR EACH DATE IN THE ARRAY
-        . I $D(V2(ZI)) D  ; IF THE DATE EXISTS
-        . . S ZP1=$P(V2(ZI),".",1) ; THE DATE PIECE
-        . . S ZP2=$P(V2(ZI),".",2) ; THE TIME PIECE
-        . . ; W "DATE: ",ZP1," TIME: ",ZP2,!
-        . . S VSRT(ZP1,ZP2,ZI)=ZI ; INDEX OF DATE, TIME AND COUNT
-        N ZG
-        S ZG=$Q(VSRT(""))
-        F  D  Q:ZG=""  ;
-        . ; W ZG,!
-        . D PUSH^C0CXPATH("V1",@ZG)
-        . S ZG=$Q(@ZG)
-        I ORDR=-1 D  ; HAVE TO REVERSE ORDER
-        . N ZG2
-        . F ZI=1:1:V1(0) D  ; FOR EACH ELELMENT
-        . . S ZG2(V1(0)-ZI+1)=V1(ZI) ; SET IN REVERSE ORDER
-        . S ZG2(0)=V1(0)
-        . D CP^C0CXPATH("ZG2","V1") ; COPY OVER THE NEW ARRAY
-        Q ZCNT
-        ;
-DA2SNO(RTN,DNAME)       ; LOOK UP DRUG ALLERGY CODE IN ^LEX
-        ; RETURNS AN ARRAY RTN PASSED BY REFERENCE
-        ; THIS ROUTINE CAN BE USED AS AN RPC
-        ; RTN(0) IS THE NUMBER OF ELEMENTS IN THE ARRAY
-        ; RTN(1) IS THE SNOMED CODE FOR THE DRUG ALLERGY
-        ;
-        N LEXIEN
-        I $O(^LEX(757.21,"ADIS",DNAME,""))'="" D  ; IEN FOUND FOR THIS DRUG
-        . S LEXIEN=$O(^LEX(757.21,"ADIS",DNAME,"")) ; GET THE IEN IN THE LEXICON
-        . W LEXIEN,!
-        . S RTN(1)=$P(^LEX(757.02,LEXIEN,0),"^",2) ; SNOMED CODE IN P2
-        . S RTN(0)=1 ; ONE THING RETURNED
-        E  S RTN(0)=0 ; NOT FOUND
-        Q
-        ;
-DASNO(DANAME)   ; PRINTS THE SNOMED CODE FOR ALLERGY TO DRUG DANAME
-        ;
-        N DARTN
-        D DA2SNO(.DARTN,DANAME) ; CALL THE LOOKUP ROUTINE
-        I DARTN(0)>0 D  ; GOT RESULTS
-        . W !,DARTN(1) ;PRINT THE SNOMED CODE
-        E  W !,"NOT FOUND",!
-        Q
-        ;
-DASNALL(WHICH)  ; ROUTINE TO EXAMINE THE ADIS INDEX IN LEX AND RETRIEVE ALL
-        ; ASSOCIATED SNOMED CODES
-        N DASTMP,DASIEN,DASNO
-        S DASTMP=""
-        F  S DASTMP=$O(^LEX(757.21,WHICH,DASTMP)) Q:DASTMP=""  D  ; NAME OF MED
-        . S DASIEN=$O(^LEX(757.21,WHICH,DASTMP,"")) ; IEN OF MED
-        . S DASNO=$P(^LEX(757.02,DASIEN,0),"^",2) ; SNOMED CODE FOR ENTRY
-        . W DASTMP,"=",DASNO,! ; PRINT IT OUT
-        Q
-        ;
-RXNFN() Q 1130590011.001 ; RxNorm Concepts file number
+C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08
+ ;;0.1;C0C;;Jun 15, 2008;Build 38
+ ;Copyright 2008-2009 Sam Habiel & George Lilly.  
+ ;Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "No Entry at Top!"
+ Q
+ ;
+UUID()  ; thanks to Wally for this.
+        N R,I,J,N 
+        S N="",R="" F  S N=N_$R(100000) Q:$L(N)>64 
+        F I=1:2:64 S R=R_$E("0123456789abcdef",($E(N,I,I+1)#16+1)) 
+        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)
+ ;
+OLDUUID() ; GENERATE A RANDOM UUID (Version 4)
+ N I,J,ZS
+ S ZS="0123456789abcdef" S J=""
+ 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))
+ Q J
+ ;
+FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic
+ ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time)
+ ; If not passed, or passed incorrectly, it's assumed that it is D.
+ ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied.
+ ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC
+ ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters)
+ N UTC,Y,M,D,H,MM,S,OFF
+ S Y=1700+$E(DATE,1,3)
+ S M=$E(DATE,4,5)
+ S D=$E(DATE,6,7)
+ S H=$E(DATE,9,10)
+ I $L(H)=1 S H="0"_H
+ S MM=$E(DATE,11,12)
+ I $L(MM)=1 S MM="0"_MM
+ S S=$E(DATE,13,14)
+ I $L(S)=1 S S="0"_S
+ S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation.
+ S OFFS=$E(OFF,1,1)
+ S OFF0=$TR(OFF,"+-")
+ S OFF1=$E(OFF0+10000,2,3)
+ S OFF2=$E(OFF0+10000,4,5)
+ S OFF=OFFS_OFF1_":"_OFF2
+ ;S OFF2=$E(OFF,1,2) ;
+ ;S OFF2=$E(100+OFF2,2,3) ; GPL 11/08 CHANGED TO -05:00 FORMAT
+ ;S OFF3=$E(OFF,3,4) ;MINUTES
+ ;S OFF=$S(OFF2="":"00",0:"00",1:OFF2)_"."_$S(OFF3="":"00",1:OFF3)
+ ; If H, MM and S are empty, it means that the FM date didn't supply the time.
+ ; In this case, set H, MM and S to "00"
+ ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING?
+ S:'$L(H) H="00"
+ S:'$L(MM) MM="00"
+ S:'$L(S) S="00"
+ S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds
+ I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time.
+ E  Q $P(UTC,"T")
+ ;
+SORTDT(V1,V2,ORDR) ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT
+ ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE
+ ; DATE AND TIME ORDER. DEFAULT IS FORWARD
+ ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT
+ ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER
+ ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER
+ ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC
+ ; BOTH V1 AND V2 ARE PASSED BY REFERENCE
+ N VSRT ; TEMP FOR HASHING DATES
+ N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2
+ S ZCNT=V2(0) ; COUNTING NUMBER OF DATES
+ F ZI=1:1:ZCNT D  ; FOR EACH DATE IN THE ARRAY
+ . I $D(V2(ZI)) D  ; IF THE DATE EXISTS
+ . . S ZP1=$P(V2(ZI),".",1) ; THE DATE PIECE
+ . . S ZP2=$P(V2(ZI),".",2) ; THE TIME PIECE
+ . . ; W "DATE: ",ZP1," TIME: ",ZP2,!
+ . . S VSRT(ZP1,ZP2,ZI)=ZI ; INDEX OF DATE, TIME AND COUNT
+ N ZG
+ S ZG=$Q(VSRT(""))
+ F  D  Q:ZG=""  ;
+ . ; W ZG,!
+ . D PUSH^C0CXPATH("V1",@ZG)
+ . S ZG=$Q(@ZG)
+ I ORDR=-1 D  ; HAVE TO REVERSE ORDER
+ . N ZG2
+ . F ZI=1:1:V1(0) D  ; FOR EACH ELELMENT
+ . . S ZG2(V1(0)-ZI+1)=V1(ZI) ; SET IN REVERSE ORDER
+ . S ZG2(0)=V1(0)
+ . D CP^C0CXPATH("ZG2","V1") ; COPY OVER THE NEW ARRAY
+ Q ZCNT
+ ;
+DA2SNO(RTN,DNAME) ; LOOK UP DRUG ALLERGY CODE IN ^LEX
+ ; RETURNS AN ARRAY RTN PASSED BY REFERENCE
+ ; THIS ROUTINE CAN BE USED AS AN RPC
+ ; RTN(0) IS THE NUMBER OF ELEMENTS IN THE ARRAY
+ ; RTN(1) IS THE SNOMED CODE FOR THE DRUG ALLERGY
+ ;
+ N LEXIEN
+ I $O(^LEX(757.21,"ADIS",DNAME,""))'="" D  ; IEN FOUND FOR THIS DRUG
+ . S LEXIEN=$O(^LEX(757.21,"ADIS",DNAME,"")) ; GET THE IEN IN THE LEXICON
+ . W LEXIEN,!
+ . S RTN(1)=$P(^LEX(757.02,LEXIEN,0),"^",2) ; SNOMED CODE IN P2
+ . S RTN(0)=1 ; ONE THING RETURNED
+ E  S RTN(0)=0 ; NOT FOUND
+ Q
+ ;
+DASNO(DANAME) ; PRINTS THE SNOMED CODE FOR ALLERGY TO DRUG DANAME
+ ;
+ N DARTN
+ D DA2SNO(.DARTN,DANAME) ; CALL THE LOOKUP ROUTINE
+ I DARTN(0)>0 D  ; GOT RESULTS
+ . W !,DARTN(1) ;PRINT THE SNOMED CODE
+ E  W !,"NOT FOUND",!
+ Q
+ ;
+DASNALL(WHICH) ; ROUTINE TO EXAMINE THE ADIS INDEX IN LEX AND RETRIEVE ALL
+ ; ASSOCIATED SNOMED CODES
+ N DASTMP,DASIEN,DASNO
+ S DASTMP=""
+ F  S DASTMP=$O(^LEX(757.21,WHICH,DASTMP)) Q:DASTMP=""  D  ; NAME OF MED
+ . S DASIEN=$O(^LEX(757.21,WHICH,DASTMP,"")) ; IEN OF MED
+ . S DASNO=$P(^LEX(757.02,DASIEN,0),"^",2) ; SNOMED CODE FOR ENTRY
+ . W DASTMP,"=",DASNO,! ; PRINT IT OUT
+ Q
+ ;
+RXNFN() Q 1130590011.001 ; RxNorm Concepts file number
  ;
 CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF 
@@ -165 +165 @@
  Q ZRXN
  ;
-RPMS()  ; Are we running on an RPMS system rather than Vista?
-        Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service
-VISTA() ; Are we running on Vanilla Vista?
-        Q $G(DUZ("AG"))="V" ; If User Agency is VA
-WV()    ; Are we running on WorldVista? 
-        Q $G(DUZ("AG"))="E" ; Code for WV.
-OV()    ; Are we running on OpenVista?
-        Q $G(DUZ("AG"))="O" ; Code for OpenVista
-        
+RPMS() ; Are we running on an RPMS system rather than Vista?
+ Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service
+VISTA() ; Are we running on Vanilla Vista?
+ Q $G(DUZ("AG"))="V" ; If User Agency is VA
+WV() ; Are we running on WorldVista? 
+ Q $G(DUZ("AG"))="E" ; Code for WV.
+OV() ; Are we running on OpenVista?
+ Q $G(DUZ("AG"))="O" ; Code for OpenVista
+ 

ccr/trunk/p/C0CVA200.m

@@ -1 @@
-C0CVA200        ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008 Sam Habiel.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        Q
-        ; This routine uses Kernel APIs and Direct Global Access to get
-        ; Proivder Data from File 200.
-        ;
-         ; The Global is VA(200,*)
-         ;
-FAMILY(DUZ)     ; Get Family Name; PUBLIC; EXTRINSIC
-         ; INPUT: DUZ (i.e. File 200 IEN) ByVal
-         ; OUTPUT: String
-         N NAME S NAME=$P(^VA(200,DUZ,0),U)
-         D NAMECOMP^XLFNAME(.NAME)
-         Q NAME("FAMILY")
-         ;
-GIVEN(DUZ)      ; Get Given Name; PUBLIC; EXTRINSIC
-         ; INPUT: DUZ ByVal
-         ; OUTPUT: String
-         N NAME S NAME=$P(^VA(200,DUZ,0),U)
-         D NAMECOMP^XLFNAME(.NAME)
-         Q NAME("GIVEN")
-         ;
-MIDDLE(DUZ)     ; Get Middle Name, PUBLIC; EXTRINSIC
-         ; INPUT: DUZ ByVal
-         ; OUTPUT: String
-         N NAME S NAME=$P(^VA(200,DUZ,0),U)
-         D NAMECOMP^XLFNAME(.NAME)
-         Q NAME("MIDDLE")
-         ;
-SUFFIX(DUZ)     ; Get Suffix Name, PUBLIC; EXTRINSIC
-         ; INPUT: DUZ ByVal
-         ; OUTPUT: String
-         N NAME S NAME=$P(^VA(200,DUZ,0),U)
-         D NAMECOMP^XLFNAME(.NAME)
-         Q NAME("SUFFIX")
-         ;
-TITLE(DUZ)      ; Get Title for Proivder, PUBLIC; EXTRINSIC
-         ; INPUT: DUZ ByVal
-         ; OUTPUT: String
-         ; Gets External Value of Title field in New Person File.
-         ; It's actually a pointer to file 3.1
-         ; 200=New Person File; 8 is Title Field
-         Q $$GET1^DIQ(200,DUZ_",",8)
-         ;
-NPI(DUZ)        ; Get NPI Number, PUBLIC; EXTRINSIC
-         ; INPUT: DUZ ByVal
-         ; OUTPUT: Delimited String in format:
-         ; IDType^ID^IDDescription
-         ; If the NPI doesn't exist, "" is returned.
-         ; This routine uses a call documented in the Kernel dev guide
-         ; This call returns as "NPI^TimeEntered^ActiveInactive"
-         ; It returns -1 for NPI if NPI doesn't exist.
-         N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U)
-         Q:NPI=-1 ""
-         Q "NPI^"_NPI_"^HHS"
-         ;
-SPEC(DUZ)       ; Get Provider Specialty, PUBLIC; EXTRINSIC
-         ; INPUT: DUZ ByVal
-         ; OUTPUT: String: ProviderType/Specialty/Subspecialty OR ""
-         ; Uses a Kernel API. Returns -1 if a specialty is not specified
-         ; in file 200.
-         ; Otherwise, returns IEN^Profession^Specialty^Sub­specialty^Effect date^Expired date^VA code
-         N STR S STR=$$GET^XUA4A72(DUZ)
-         Q:+STR<0 ""
-         ; Sometimes we have 3 pieces, or 2. Deal with that.
-         Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4)
-         Q $P(STR,U,2)_"-"_$P(STR,U,3)
-         ;
-ADDTYPE(DUZ)    ; Get Address Type, PUBLIC; EXTRINSIC
-         ; INPUT: DUZ, but not needed really... here for future expansion
-         ; OUTPUT: At this point "Work"
-         Q "Work"
-         ;
-ADDLINE1(ADUZ)  ; Get Address associated with this instituation; PUBLIC; EXTRINSIC ; CHANGED PARAMETER TO ADUZ TO KEEP FROM CRASHING GPL 1/09
-         ; INPUT: DUZ ByVal
-         ; Output: String.
-         ;
-         ; First, get site number from the institution file.
-         ; 1st piece returned by $$SITE^VASITE, which gets the system institution
-         N INST S INST=$P($$SITE^VASITE(),U)
-         ;
-         ; Second, get mailing address
-         ; There are two APIs to get the address, one for physical and one for
-         ; mailing. We will check if mailing exists first, since that's the
-         ; one we want to use; then check for physical. If neither exists,
-         ; then we return nothing. We check for the existence of an address
-         ; by the length of the returned string.
-         ; NOTE: API doesn't support Address 2, so I won't even include it
-         ; in the template.
-         N ADD
-         S ADD=$$MADD^XUAF4(INST) ; mailing address
-         Q:$L(ADD) $P(ADD,U)
-         S ADD=$$PADD^XUAF4(INST) ; physical address
-         Q:$L(ADD) $P(ADD,U)
-         Q ""
-         ;
-CITY(ADUZ)      ; Get City for Institution. PUBLIC; EXTRINSIC
-           ;GPL CHANGED PARAMETER TO ADUZ TO KEEP $$SITE^VASITE FROM CRASHING 
-         ; INPUT: DUZ ByVal
-         ; Output: String.
-         ; See ADD1 for comments
-         N INST S INST=$P($$SITE^VASITE(),U)
-         N ADD
-         S ADD=$$MADD^XUAF4(INST) ; mailing address
-         Q:$L(ADD) $P(ADD,U,2)
-         S ADD=$$PADD^XUAF4(INST) ; physical address
-         Q:$L(ADD) $P(ADD,U,2)
-         Q ""
-         ;
-STATE(ADUZ)     ; Get State for Institution. PUBLIC; EXTRINSIC
-         ; INPUT: DUZ ByVal
-         ; Output: String.
-         ; See ADD1 for comments
-         N INST S INST=$P($$SITE^VASITE(),U)
-         N ADD
-         S ADD=$$MADD^XUAF4(INST) ; mailing address
-         Q:$L(ADD) $P(ADD,U,3)
-         S ADD=$$PADD^XUAF4(INST) ; physical address
-         Q:$L(ADD) $P(ADD,U,3)
-         Q ""
-         ;
-POSTCODE(ADUZ)  ; Get Postal Code for Institution. PUBLIC; EXTRINSIC
-         ; INPUT: DUZ ByVal
-         ; OUTPUT: String.
-         ; See ADD1 for comments
-         N INST S INST=$P($$SITE^VASITE(),U)
-         N ADD
-         S ADD=$$MADD^XUAF4(INST) ; mailing address
-         Q:$L(ADD) $P(ADD,U,4)
-         S ADD=$$PADD^XUAF4(INST) ; physical address
-         Q:$L(ADD) $P(ADD,U,4)
-         Q ""
-         ;
-TEL(DUZ)        ; Get Office Phone number. PUBLIC; EXTRINSIC
-         ; INPUT: DUZ ByVal
-         ; OUTPUT: String.
-         ; Direct global access
-         N TEL S TEL=$G(^VA(200,DUZ,.13))
-         Q $P(TEL,U,2)
-         ;
-TELTYPE(DUZ)    ; Get Telephone Type. PUBLIC; EXTRINSIC
-         ; INPUT: DUZ ByVal
-         ; OUTPUT: String.
-         Q "Office"
-         ;
-EMAIL(DUZ)      ; Get Provider's Email. PUBLIC; EXTRINSIC
-         ; INPUT: DUZ ByVal
-         ; OUTPUT: String
-         ; Direct global access
-         N EMAIL S EMAIL=$G(^VA(200,DUZ,.15))
-         Q $P(EMAIL,U)
-         ;
+C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008 Sam Habiel.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ Q
+ ; This routine uses Kernel APIs and Direct Global Access to get
+ ; Proivder Data from File 200.
+ ;
+  ; The Global is VA(200,*)
+  ;
+FAMILY(DUZ) ; Get Family Name; PUBLIC; EXTRINSIC
+  ; INPUT: DUZ (i.e. File 200 IEN) ByVal
+  ; OUTPUT: String
+  N NAME S NAME=$P(^VA(200,DUZ,0),U)
+  D NAMECOMP^XLFNAME(.NAME)
+  Q NAME("FAMILY")
+  ;
+GIVEN(DUZ) ; Get Given Name; PUBLIC; EXTRINSIC
+  ; INPUT: DUZ ByVal
+  ; OUTPUT: String
+  N NAME S NAME=$P(^VA(200,DUZ,0),U)
+  D NAMECOMP^XLFNAME(.NAME)
+  Q NAME("GIVEN")
+  ;
+MIDDLE(DUZ) ; Get Middle Name, PUBLIC; EXTRINSIC
+  ; INPUT: DUZ ByVal
+  ; OUTPUT: String
+  N NAME S NAME=$P(^VA(200,DUZ,0),U)
+  D NAMECOMP^XLFNAME(.NAME)
+  Q NAME("MIDDLE")
+  ;
+SUFFIX(DUZ) ; Get Suffix Name, PUBLIC; EXTRINSIC
+  ; INPUT: DUZ ByVal
+  ; OUTPUT: String
+  N NAME S NAME=$P(^VA(200,DUZ,0),U)
+  D NAMECOMP^XLFNAME(.NAME)
+  Q NAME("SUFFIX")
+  ;
+TITLE(DUZ) ; Get Title for Proivder, PUBLIC; EXTRINSIC
+  ; INPUT: DUZ ByVal
+  ; OUTPUT: String
+  ; Gets External Value of Title field in New Person File.
+  ; It's actually a pointer to file 3.1
+  ; 200=New Person File; 8 is Title Field
+  Q $$GET1^DIQ(200,DUZ_",",8)
+  ;
+NPI(DUZ) ; Get NPI Number, PUBLIC; EXTRINSIC
+  ; INPUT: DUZ ByVal
+  ; OUTPUT: Delimited String in format:
+  ; IDType^ID^IDDescription
+  ; If the NPI doesn't exist, "" is returned.
+  ; This routine uses a call documented in the Kernel dev guide
+  ; This call returns as "NPI^TimeEntered^ActiveInactive"
+  ; It returns -1 for NPI if NPI doesn't exist.
+  N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U)
+  Q:NPI=-1 ""
+  Q "NPI^"_NPI_"^HHS"
+  ;
+SPEC(DUZ) ; Get Provider Specialty, PUBLIC; EXTRINSIC
+  ; INPUT: DUZ ByVal
+  ; OUTPUT: String: ProviderType/Specialty/Subspecialty OR ""
+  ; Uses a Kernel API. Returns -1 if a specialty is not specified
+  ; in file 200.
+  ; Otherwise, returns IEN^Profession^Specialty^Sub­specialty^Effect date^Expired date^VA code
+  N STR S STR=$$GET^XUA4A72(DUZ)
+  Q:+STR<0 ""
+  ; Sometimes we have 3 pieces, or 2. Deal with that.
+  Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4)
+  Q $P(STR,U,2)_"-"_$P(STR,U,3)
+  ;
+ADDTYPE(DUZ) ; Get Address Type, PUBLIC; EXTRINSIC
+  ; INPUT: DUZ, but not needed really... here for future expansion
+  ; OUTPUT: At this point "Work"
+  Q "Work"
+  ;
+ADDLINE1(ADUZ) ; Get Address associated with this instituation; PUBLIC; EXTRINSIC ; CHANGED PARAMETER TO ADUZ TO KEEP FROM CRASHING GPL 1/09
+  ; INPUT: DUZ ByVal
+  ; Output: String.
+  ;
+  ; First, get site number from the institution file.
+  ; 1st piece returned by $$SITE^VASITE, which gets the system institution
+  N INST S INST=$P($$SITE^VASITE(),U)
+  ;
+  ; Second, get mailing address
+  ; There are two APIs to get the address, one for physical and one for
+  ; mailing. We will check if mailing exists first, since that's the
+  ; one we want to use; then check for physical. If neither exists,
+  ; then we return nothing. We check for the existence of an address
+  ; by the length of the returned string.
+  ; NOTE: API doesn't support Address 2, so I won't even include it
+  ; in the template.
+  N ADD
+  S ADD=$$MADD^XUAF4(INST) ; mailing address
+  Q:$L(ADD) $P(ADD,U)
+  S ADD=$$PADD^XUAF4(INST) ; physical address
+  Q:$L(ADD) $P(ADD,U)
+  Q ""
+  ;
+CITY(ADUZ) ; Get City for Institution. PUBLIC; EXTRINSIC
+    ;GPL CHANGED PARAMETER TO ADUZ TO KEEP $$SITE^VASITE FROM CRASHING 
+  ; INPUT: DUZ ByVal
+  ; Output: String.
+  ; See ADD1 for comments
+  N INST S INST=$P($$SITE^VASITE(),U)
+  N ADD
+  S ADD=$$MADD^XUAF4(INST) ; mailing address
+  Q:$L(ADD) $P(ADD,U,2)
+  S ADD=$$PADD^XUAF4(INST) ; physical address
+  Q:$L(ADD) $P(ADD,U,2)
+  Q ""
+  ;
+STATE(ADUZ) ; Get State for Institution. PUBLIC; EXTRINSIC
+  ; INPUT: DUZ ByVal
+  ; Output: String.
+  ; See ADD1 for comments
+  N INST S INST=$P($$SITE^VASITE(),U)
+  N ADD
+  S ADD=$$MADD^XUAF4(INST) ; mailing address
+  Q:$L(ADD) $P(ADD,U,3)
+  S ADD=$$PADD^XUAF4(INST) ; physical address
+  Q:$L(ADD) $P(ADD,U,3)
+  Q ""
+  ;
+POSTCODE(ADUZ) ; Get Postal Code for Institution. PUBLIC; EXTRINSIC
+  ; INPUT: DUZ ByVal
+  ; OUTPUT: String.
+  ; See ADD1 for comments
+  N INST S INST=$P($$SITE^VASITE(),U)
+  N ADD
+  S ADD=$$MADD^XUAF4(INST) ; mailing address
+  Q:$L(ADD) $P(ADD,U,4)
+  S ADD=$$PADD^XUAF4(INST) ; physical address
+  Q:$L(ADD) $P(ADD,U,4)
+  Q ""
+  ;
+TEL(DUZ) ; Get Office Phone number. PUBLIC; EXTRINSIC
+  ; INPUT: DUZ ByVal
+  ; OUTPUT: String.
+  ; Direct global access
+  N TEL S TEL=$G(^VA(200,DUZ,.13))
+  Q $P(TEL,U,2)
+  ;
+TELTYPE(DUZ) ; Get Telephone Type. PUBLIC; EXTRINSIC
+  ; INPUT: DUZ ByVal
+  ; OUTPUT: String.
+  Q "Office"
+  ;
+EMAIL(DUZ) ; Get Provider's Email. PUBLIC; EXTRINSIC
+  ; INPUT: DUZ ByVal
+  ; OUTPUT: String
+  ; Direct global access
+  N EMAIL S EMAIL=$G(^VA(200,DUZ,.15))
+  Q $P(EMAIL,U)
+  ;

ccr/trunk/p/C0CVIT2.m

@@ -1 @@
-C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
-        ;;1.0;C0C;;Feb 16, 2010;Build 38
-        ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "NO ENTRY FROM TOP",!
-        Q
-        ;
-EXTRACT(VITXML,DFN,VITOUT)      ; EXTRACT VITAL SIGNS INTO XML TEMPLATE
-        ; VITXML AND VITOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
-        ;
-        ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS
-        ; THAT GET PASSED TO *GET ROUTINES
-        ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME))
-        N C0CVIT
-        S C0CVIT=$NA(^TMP("C0CCCR",$J,DFN,"C0CVIT"))
-        ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS
-        ; THAT GET INSERTED INTO THE XML TEMPLATE
-        ; D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS
-        I $$RPMS^C0CUTIL() D GETRPMS(DFN,C0CVIT) ; GET VARS
-        I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D GETVISTA(DFN,C0CVIT)
-        ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE
-        ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES
-        D MAP(VITXML,C0CVIT,VITOUT) ;MAP RESULTS FOR PROCEDURES
-        Q
-        ;
-GETVISTA(DFN,C0CVIT)    ; CALLS VITALS^ORQQVI TO GET VITAL SIGNS. 
-        ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
-        ; C0CVIT: VITAL SIGNS
-        ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2
-        ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 
-        ; EXIST.
-        ;
-        ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J))
-        ;
-        ; SETUP RPC/API CALL HERE
-        ; USE START AND END DATES FROM PARAMETERS IF REQUIRED
-        ;
-        N VIT,DATA,START,END
-        ; RPC REQUIRES FM DATES NOT T-* DATES
-        D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM
-        D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM
-        ; RPC CALL (ORY,DFN,ORSDT,OREDT):
-        ;ORY: return variable
-        ;DFN: patient identifier from Patient File [#2]
-        ;ORSDT: start date/time in Fileman format
-        ;OREDT: end date/time in Fileman format
-        ; OUTPUT FORMAT:
-        ;vital measurement ien^vital type^rate^date/time taken
-        D VITALS^ORQQVI(.VIT,DFN,START,END) ; RUN QUERY VITALS CALL
-        I '$D(VIT) S @VITOUT@(0)=0 K VIT Q  ; RETURN NOT FOUND, KILL ARRAY AND QUIT
-        I $P(VIT(1),U,2)="No vitals found." D  Q  ; signal no vitals and quit
-        . I $D(VITOUT) S @VITOUT@(0)=0 
-        . K VIT
-        ;
-        ; PREFORM SORT HERE IF NEEDED
-        ;
-        ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST
-        ; COPIED SORT LOGIC:
-        N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
-        D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
-        S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
-        ; VSORT IS VITALS IN REVERSE ORDER
-        ;
-        ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY
-        ; RNF1 ARRAY FORMAT:
-        ; VAR("NAME_OF_RIM_VARIABLE")=VALUE
-        ;
-        ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS
-        ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD
-        ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS
-        N C0CVI,C0CC,ZRNF
-        ;S C0CVI="" ; INITIALIZE FOR $O
-        F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D  ; FOR EACH VITAL SIGN IN THE LIST
-        . I DEBUG W VIT(C0CVI),!
-        . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER)
-        . 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")
-        . 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")
-        . 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),"")
-        . 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")
-        . 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),"")
-        . 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),"")
-        . 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),"")
-        . 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
-        . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY
-        . K ZRNF
-        ; SAVE RIM VARIABLES SEE C0CRIMA
-        N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS"))
-        M @ZRIM=@C0CVIT@("V")
-        Q
-        ;
-GETRPMS(DFN,C0CVIT)     ; CALLS QUERY^BEHOVM TO GET VITAL SIGNS. 
-        ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
-        ; C0CVIT: VITAL SIGNS
-        ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2
-        ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 
-        ; EXIST.
-        ;
-        ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J))
-        ;
-        ; SETUP RPC/API CALL HERE
-        ; USE START AND END DATES FROM PARAMETERS IF REQUIRED
-        ;
-        ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE
-        ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE
-        N C0CEDT,C0CSDT,VIT,DATA,START,END
-        ; RPC REQUIRES FM DATES NOT T-* DATES
-        D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM
-        D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM
-        ; RPC OUTPUT FORMAT:
-        ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric)
-        D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL
-        I '$D(^TMP("CIAVMRPC",$J)) S @VITOUT@(0)=0 K ^TMP("CIAVMRPC",$J) Q  ; RETURN NOT FOUND, KILL ARRAY AND QUIT
-        ; MOVE THE ARRAY TO LOCAL VARIABLE
-        M VIT=^TMP("CIAVMRPC",$J,0)
-        ; RPC CLEANUP
-        K ^TMP("CIAVMRPC",$J),VITS,RMAX,START,END,DATA,METRIC,VSTR,VUNT
-        ;
-        ; PREFORM SORT HERE IF NEEDED
-        ;
-        ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST
-        ; COPIED SORT LOGIC:
-        N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
-        D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
-        S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
-        ; VSORT IS VITALS IN REVERSE ORDER
-        ;
-        ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY
-        ; RNF1 ARRAY FORMAT:
-        ; VAR("NAME_OF_RIM_VARIABLE")=VALUE
-        ;
-        ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS
-        ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD
-        ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS
-        N C0CVI,C0CC,ZRNF
-        ;S C0CVI="" ; INITIALIZE FOR $O
-        F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D  ; FOR EACH VITAL SIGN IN THE LIST
-        . I DEBUG W VIT(C0CVI),!
-        . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER)
-        . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT
-        . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT
-        . D:$P(VIT(C0CVI),U,3)="BP" BP
-        . D:$P(VIT(C0CVI),U,3)="TMP" TMP
-        . D:$P(VIT(C0CVI),U,3)="RS" RESP
-        . D:$P(VIT(C0CVI),U,3)="PU" PULSE
-        . D:$P(VIT(C0CVI),U,3)="PA" PAIN
-        . D:'$D(ZRNF) OTHER ;IF THE VITAL ISN'T DEFINED IT IS OTHER
-        . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY
-        . K ZRNF
-        ; SAVE RIM VARIABLES SEE C0CRIMA
-        N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS"))
-        M @ZRIM=@C0CVIT@("V")
-        Q
-        ;
-HEIGHT  
-        I DEBUG W "IN VITAL:  HEIGHT",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
-        Q
-        ;
-WEIGHT  
-        I DEBUG W "IN VITAL:  WEIGHT",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
-        Q
-        ;
-BP      
-        I DEBUG W "IN VITAL:  BLOOD PRESSURE",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
-        Q
-        ;
-TMP     
-        I DEBUG W "IN VITAL:  TEMPERATURE",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
-        Q
-        ;
-RESP    
-        I DEBUG W "IN VITAL:  RESPIRATION",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
-        Q
-        ;
-PULSE   
-        I DEBUG W "IN VITAL:  PULSE",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
-        Q
-        ;
-PAIN    
-        I DEBUG W "IN VITAL:  PAIN",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
-        Q
-        ;
-OTHER   
-        I DEBUG W "IN VITAL:  OTHER",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=$P(VIT(C0CVI),U,2)
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")=""
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")=""
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
-        Q
-        ;
-        ;TEMPORARY, THINKING ON HOW TO REFACTOR (CJE)
-HEIGHT1(DT,ACTOR,VALUE,UNIT)    
-        I DEBUG W "IN VITAL:  HEIGHT",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
-        Q
-        ;
-WEIGHT1(DT,ACTOR,VALUE,UNIT)    
-        I DEBUG W "IN VITAL:  WEIGHT",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
-        Q
-        ;
-BP1(DT,ACTOR,VALUE,UNIT)        
-        I DEBUG W "IN VITAL:  BLOOD PRESSURE",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
-        Q
-        ;
-TMP1(DT,ACTOR,VALUE,UNIT)       
-        I DEBUG W "IN VITAL:  TEMPERATURE",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
-        Q
-        ;
-RESP1(DT,ACTOR,VALUE,UNIT)      
-        I DEBUG W "IN VITAL:  RESPIRATION",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
-        Q
-        ;
-PULSE1(DT,ACTOR,VALUE,UNIT)     
-        I DEBUG W "IN VITAL:  PULSE",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
-        Q
-        ;
-PAIN1(DT,ACTOR,VALUE,UNIT)      
-        I DEBUG W "IN VITAL:  PAIN",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000"
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
-        Q
-        ;
-OTHER1(DT,TEXT,ACTOR,VALUE,UNIT)        
-        I DEBUG W "IN VITAL:  OTHER",!
-        S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
-        S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSEXACTDATETIME")=DT
-        S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=TEXT
-        S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
-        S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        S ZRNF("VITALSIGNSDESCCODEVALUE")=""
-        S ZRNF("VITALSIGNSDESCCODINGSYSTEM")=""
-        S ZRNF("VITALSIGNSCODEVERSION")=""
-        S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
-        S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
-        S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
-        Q
-        ;
-VITSORT(VDT)    ; RUN DATE SORTING ALGORITHM
-        ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY
-        ; OF DATES IN THE VITALS RESULTS
-        N VDTI,VDTJ,VTDCNT
-        S VTDCNT=0 ; COUNT TO BUILD ARRAY
-        S VDTJ="" ; USED TO VISIT THE RESULTS
-        F VDTI=0:0 D  Q:$O(VIT(VDTJ))=""  ; VISIT ALL RESULTS
-        . S VDTJ=$O(VIT(VDTJ)) ; NEXT RESULT
-        . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER
-        . S VDT(VTDCNT)=$P(VIT(VDTJ),U,4) ; PULL OUT THE DATE
-        S VDT(0)=VTDCNT
-        Q
-        ;
-MAP(VITXML,C0CVIT,VITOUT)       ; MAP VITAL SIGNS XML 
-        ;
-        N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"VITTEMP")) ;WORK AREA FOR TEMPLATE
-        K @ZTEMP
-        N ZBLD
-        S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"VITBLD")) ; BUILD LIST AREA
-        D QUEUE^C0CXPATH(ZBLD,VITXML,1,1) ; FIRST LINE
-        N ZINNER
-        ; XPATH NEEDS TO MATCH YOUR SECTION
-        D QUERY^C0CXPATH(VITXML,"//VitalSigns/Result","ZINNER") ;ONE VITAL SIGN
-        N ZTMP,ZVAR,ZI
-        S ZI=""
-        F  S ZI=$O(@C0CVIT@("V",ZI)) Q:ZI=""  D  ;FOR EACH VITAL SIGN
-        . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS VITAL SIGN XML
-        . S ZVAR=$NA(@C0CVIT@("V",ZI)) ;THIS VITAL SIGN VARIABLES
-        . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE VITAL SIGN
-        . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD
-        D QUEUE^C0CXPATH(ZBLD,VITXML,@VITXML@(0),@VITXML@(0))
-        N ZZTMP ; IS THIS NEEDED?
-        D BUILD^C0CXPATH(ZBLD,VITOUT) ;BUILD FINAL XML
-        K @ZTEMP,@ZBLD
-        Q
-        ;  
+C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
+ ;;1.0;C0C;;Feb 16, 2010;Build 38
+ ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "NO ENTRY FROM TOP",!
+ Q
+ ;
+EXTRACT(VITXML,DFN,VITOUT) ; EXTRACT VITAL SIGNS INTO XML TEMPLATE
+ ; VITXML AND VITOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED
+ ;
+ ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS
+ ; THAT GET PASSED TO *GET ROUTINES
+ ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME))
+ N C0CVIT
+ S C0CVIT=$NA(^TMP("C0CCCR",$J,DFN,"C0CVIT"))
+ ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS
+ ; THAT GET INSERTED INTO THE XML TEMPLATE
+ ; D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS
+ I $$RPMS^C0CUTIL() D GETRPMS(DFN,C0CVIT) ; GET VARS
+ I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D GETVISTA(DFN,C0CVIT)
+ ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE
+ ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES
+ D MAP(VITXML,C0CVIT,VITOUT) ;MAP RESULTS FOR PROCEDURES
+ Q
+ ;
+GETVISTA(DFN,C0CVIT) ; CALLS VITALS^ORQQVI TO GET VITAL SIGNS. 
+ ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
+ ; C0CVIT: VITAL SIGNS
+ ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2
+ ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 
+ ; EXIST.
+ ;
+ ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J))
+ ;
+ ; SETUP RPC/API CALL HERE
+ ; USE START AND END DATES FROM PARAMETERS IF REQUIRED
+ ;
+ N VIT,DATA,START,END
+ ; RPC REQUIRES FM DATES NOT T-* DATES
+ D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM
+ D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM
+ ; RPC CALL (ORY,DFN,ORSDT,OREDT):
+ ;ORY: return variable
+ ;DFN: patient identifier from Patient File [#2]
+ ;ORSDT: start date/time in Fileman format
+ ;OREDT: end date/time in Fileman format
+ ; OUTPUT FORMAT:
+ ;vital measurement ien^vital type^rate^date/time taken
+ D VITALS^ORQQVI(.VIT,DFN,START,END) ; RUN QUERY VITALS CALL
+ I '$D(VIT) S @VITOUT@(0)=0 K VIT Q  ; RETURN NOT FOUND, KILL ARRAY AND QUIT
+ I $P(VIT(1),U,2)="No vitals found." D  Q  ; signal no vitals and quit
+ . I $D(VITOUT) S @VITOUT@(0)=0 
+ . K VIT
+ ;
+ ; PREFORM SORT HERE IF NEEDED
+ ;
+ ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST
+ ; COPIED SORT LOGIC:
+ N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
+ D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
+ S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
+ ; VSORT IS VITALS IN REVERSE ORDER
+ ;
+ ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY
+ ; RNF1 ARRAY FORMAT:
+ ; VAR("NAME_OF_RIM_VARIABLE")=VALUE
+ ;
+ ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS
+ ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD
+ ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS
+ N C0CVI,C0CC,ZRNF
+ ;S C0CVI="" ; INITIALIZE FOR $O
+ F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D  ; FOR EACH VITAL SIGN IN THE LIST
+ . I DEBUG W VIT(C0CVI),!
+ . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER)
+ . 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")
+ . 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")
+ . 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),"")
+ . 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")
+ . 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),"")
+ . 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),"")
+ . 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),"")
+ . 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
+ . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY
+ . K ZRNF
+ ; SAVE RIM VARIABLES SEE C0CRIMA
+ N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS"))
+ M @ZRIM=@C0CVIT@("V")
+ Q
+ ;
+GETRPMS(DFN,C0CVIT) ; CALLS QUERY^BEHOVM TO GET VITAL SIGNS. 
+ ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME
+ ; C0CVIT: VITAL SIGNS
+ ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2
+ ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 
+ ; EXIST.
+ ;
+ ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J))
+ ;
+ ; SETUP RPC/API CALL HERE
+ ; USE START AND END DATES FROM PARAMETERS IF REQUIRED
+ ;
+ ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE
+ ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE
+ N C0CEDT,C0CSDT,VIT,DATA,START,END
+ ; RPC REQUIRES FM DATES NOT T-* DATES
+ D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM
+ D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM
+ ; RPC OUTPUT FORMAT:
+ ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric)
+ D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL
+ I '$D(^TMP("CIAVMRPC",$J)) S @VITOUT@(0)=0 K ^TMP("CIAVMRPC",$J) Q  ; RETURN NOT FOUND, KILL ARRAY AND QUIT
+ ; MOVE THE ARRAY TO LOCAL VARIABLE
+ M VIT=^TMP("CIAVMRPC",$J,0)
+ ; RPC CLEANUP
+ K ^TMP("CIAVMRPC",$J),VITS,RMAX,START,END,DATA,METRIC,VSTR,VUNT
+ ;
+ ; PREFORM SORT HERE IF NEEDED
+ ;
+ ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST
+ ; COPIED SORT LOGIC:
+ N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
+ D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
+ S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
+ ; VSORT IS VITALS IN REVERSE ORDER
+ ;
+ ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY
+ ; RNF1 ARRAY FORMAT:
+ ; VAR("NAME_OF_RIM_VARIABLE")=VALUE
+ ;
+ ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS
+ ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD
+ ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS
+ N C0CVI,C0CC,ZRNF
+ ;S C0CVI="" ; INITIALIZE FOR $O
+ F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D  ; FOR EACH VITAL SIGN IN THE LIST
+ . I DEBUG W VIT(C0CVI),!
+ . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER)
+ . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT
+ . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT
+ . D:$P(VIT(C0CVI),U,3)="BP" BP
+ . D:$P(VIT(C0CVI),U,3)="TMP" TMP
+ . D:$P(VIT(C0CVI),U,3)="RS" RESP
+ . D:$P(VIT(C0CVI),U,3)="PU" PULSE
+ . D:$P(VIT(C0CVI),U,3)="PA" PAIN
+ . D:'$D(ZRNF) OTHER ;IF THE VITAL ISN'T DEFINED IT IS OTHER
+ . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY
+ . K ZRNF
+ ; SAVE RIM VARIABLES SEE C0CRIMA
+ N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS"))
+ M @ZRIM=@C0CVIT@("V")
+ Q
+ ;
+HEIGHT 
+ I DEBUG W "IN VITAL:  HEIGHT",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
+ Q
+ ;
+WEIGHT 
+ I DEBUG W "IN VITAL:  WEIGHT",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
+ Q
+ ;
+BP 
+ I DEBUG W "IN VITAL:  BLOOD PRESSURE",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
+ Q
+ ;
+TMP 
+ I DEBUG W "IN VITAL:  TEMPERATURE",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
+ Q
+ ;
+RESP 
+ I DEBUG W "IN VITAL:  RESPIRATION",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
+ Q
+ ;
+PULSE 
+ I DEBUG W "IN VITAL:  PULSE",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
+ Q
+ ;
+PAIN 
+ I DEBUG W "IN VITAL:  PAIN",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
+ Q
+ ;
+OTHER 
+ I DEBUG W "IN VITAL:  OTHER",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT")
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=$P(VIT(C0CVI),U,2)
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")=""
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")=""
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4)
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1)
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2)
+ Q
+ ;
+ ;TEMPORARY, THINKING ON HOW TO REFACTOR (CJE)
+HEIGHT1(DT,ACTOR,VALUE,UNIT) 
+ I DEBUG W "IN VITAL:  HEIGHT",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=DT
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
+ Q
+ ;
+WEIGHT1(DT,ACTOR,VALUE,UNIT) 
+ I DEBUG W "IN VITAL:  WEIGHT",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=DT
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
+ Q
+ ;
+BP1(DT,ACTOR,VALUE,UNIT) 
+ I DEBUG W "IN VITAL:  BLOOD PRESSURE",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=DT
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
+ Q
+ ;
+TMP1(DT,ACTOR,VALUE,UNIT) 
+ I DEBUG W "IN VITAL:  TEMPERATURE",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=DT
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
+ Q
+ ;
+RESP1(DT,ACTOR,VALUE,UNIT) 
+ I DEBUG W "IN VITAL:  RESPIRATION",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=DT
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
+ Q
+ ;
+PULSE1(DT,ACTOR,VALUE,UNIT) 
+ I DEBUG W "IN VITAL:  PULSE",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=DT
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
+ Q
+ ;
+PAIN1(DT,ACTOR,VALUE,UNIT) 
+ I DEBUG W "IN VITAL:  PAIN",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=DT
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000"
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
+ Q
+ ;
+OTHER1(DT,TEXT,ACTOR,VALUE,UNIT) 
+ I DEBUG W "IN VITAL:  OTHER",!
+ S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC
+ S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSEXACTDATETIME")=DT
+ S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=TEXT
+ S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC
+ S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ S ZRNF("VITALSIGNSDESCCODEVALUE")=""
+ S ZRNF("VITALSIGNSDESCCODINGSYSTEM")=""
+ S ZRNF("VITALSIGNSCODEVERSION")=""
+ S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR
+ S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE
+ S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT
+ Q
+ ;
+VITSORT(VDT) ; RUN DATE SORTING ALGORITHM
+ ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY
+ ; OF DATES IN THE VITALS RESULTS
+ N VDTI,VDTJ,VTDCNT
+ S VTDCNT=0 ; COUNT TO BUILD ARRAY
+ S VDTJ="" ; USED TO VISIT THE RESULTS
+ F VDTI=0:0 D  Q:$O(VIT(VDTJ))=""  ; VISIT ALL RESULTS
+ . S VDTJ=$O(VIT(VDTJ)) ; NEXT RESULT
+ . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER
+ . S VDT(VTDCNT)=$P(VIT(VDTJ),U,4) ; PULL OUT THE DATE
+ S VDT(0)=VTDCNT
+ Q
+ ;
+MAP(VITXML,C0CVIT,VITOUT) ; MAP VITAL SIGNS XML 
+ ;
+ N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"VITTEMP")) ;WORK AREA FOR TEMPLATE
+ K @ZTEMP
+ N ZBLD
+ S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"VITBLD")) ; BUILD LIST AREA
+ D QUEUE^C0CXPATH(ZBLD,VITXML,1,1) ; FIRST LINE
+ N ZINNER
+ ; XPATH NEEDS TO MATCH YOUR SECTION
+ D QUERY^C0CXPATH(VITXML,"//VitalSigns/Result","ZINNER") ;ONE VITAL SIGN
+ N ZTMP,ZVAR,ZI
+ S ZI=""
+ F  S ZI=$O(@C0CVIT@("V",ZI)) Q:ZI=""  D  ;FOR EACH VITAL SIGN
+ . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS VITAL SIGN XML
+ . S ZVAR=$NA(@C0CVIT@("V",ZI)) ;THIS VITAL SIGN VARIABLES
+ . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE VITAL SIGN
+ . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD
+ D QUEUE^C0CXPATH(ZBLD,VITXML,@VITXML@(0),@VITXML@(0))
+ N ZZTMP ; IS THIS NEEDED?
+ D BUILD^C0CXPATH(ZBLD,VITOUT) ;BUILD FINAL XML
+ K @ZTEMP,@ZBLD
+ Q
+ ;  

ccr/trunk/p/C0CVITAL.m

@@ -1 @@
-C0CVITAL        ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
-        ;Licensed under the terms of the GNU General Public License.
-        ;See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "NO ENTRY FROM TOP",!
-        Q
-        ;
-EXTRACT(VITXML,DFN,VITOUTXML)   ; EXTRACT VITALS INTO PROVIDED XML TEMPLATE
-        ;
-        ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
-        ; IVITXML CONTAINS ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE
-        ;
-        N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF,VORDR
-        S C0CVLMT=$$GET^C0CPARMS("VITLIMIT") ; GET THE LIMIT PARM
-        S C0CVSTRT=$$GET^C0CPARMS("VITSTART") ; GET START PARM
-        D DT^DILF(,C0CVLMT,.C0CEDT) ;
-        D DT^DILF(,C0CVSTRT,.C0CSDT) ; 
-        ;D DT^DILF(,C0CVLMT,.C0CSDT) ; GPL TESTING
-        ;D DT^DILF(,C0CVSTRT,.C0CEDT) ; 
-        W "VITALS START: ",C0CVSTRT," LIMIT: ",C0CVLMT,!
-        I $$RPMS^C0CUTIL() D VITRPMS QUIT
-        I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VITVISTA QUIT
-        ;I $$SYSNAME^C0CSYS()="RPMS" D VITRPMS
-        ;E  D VITVISTA
-        Q
-        ;
-VITVISTA        ; EXTRACT VITALS FROM VISTA INTO PROVIDED XML TEMPLATE
-        D FASTVIT^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) ; GPL THIS ONE WORKS FOR AT
-        ; LEAST ONE SET OF VITALS - TO DO, CALL IT REPETIVELY TO GET EARLIER VITALS
-        ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT)
-        ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CSDT,C0CEDT)
-        ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CVSTRT,C0CVLMT) ; GPL LET GMR HANDLE THE DATES
-        I '$D(VITRSLT(1)) S @VITOUTXML@(0)=0 Q  ; RETURN NOT FOUND AND QUIT
-        I $P(VITRSLT(1),U,2)="No vitals found." D  Q  ; NULL RESULT FROM RPC
-        . I DEBUG W "NO VITALS FOUND FROM VITALS RPC",!
-        . S @VITOUTXML@(0)=0
-        I $P(VITRSLT(1),U,2)="No vitals found." Q  ; QUIT
-        ; ZWR RPCRSLT
-        S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS"))
-        S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP"))
-        K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES
-        N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
-        D VITDVISTA(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
-        I DEBUG ZWR VDATES ;DEBUG
-        S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
-        ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY
-        S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS
-        F J=1:1:VCNT  D  ; FOR EACH VITAL IN THE LIST
-        . I $D(VITRSLT(VSORT(J))) D
-        . . S VITVMAP=$NA(@VITTVMAP@(J))
-        . . K @VITVMAP
-        . . I DEBUG W "VMAP= ",VITVMAP,!
-        . . S VITPTMP=VITRSLT(VSORT(J)) ; DATE SORTED VITAL FROM RETURN ARRAY
-        . . I DEBUG W "VITAL ",VSORT(J),!
-        . . I DEBUG W VITRSLT(VSORT(J))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),!
-        . . I DEBUG W $P(VITPTMP,U,4),!
-        . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID
+C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
+ ;Licensed under the terms of the GNU General Public License.
+ ;See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "NO ENTRY FROM TOP",!
+ Q
+ ;
+EXTRACT(VITXML,DFN,VITOUTXML) ; EXTRACT VITALS INTO PROVIDED XML TEMPLATE
+ ;
+ ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
+ ; IVITXML CONTAINS ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE
+ ;
+ N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF,VORDR
+ S C0CVLMT=$$GET^C0CPARMS("VITLIMIT") ; GET THE LIMIT PARM
+ S C0CVSTRT=$$GET^C0CPARMS("VITSTART") ; GET START PARM
+ D DT^DILF(,C0CVLMT,.C0CEDT) ;
+ D DT^DILF(,C0CVSTRT,.C0CSDT) ; 
+ ;D DT^DILF(,C0CVLMT,.C0CSDT) ; GPL TESTING
+ ;D DT^DILF(,C0CVSTRT,.C0CEDT) ; 
+ W "VITALS START: ",C0CVSTRT," LIMIT: ",C0CVLMT,!
+ I $$RPMS^C0CUTIL() D VITRPMS QUIT
+ I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VITVISTA QUIT
+ ;I $$SYSNAME^C0CSYS()="RPMS" D VITRPMS
+ ;E  D VITVISTA
+ Q
+ ;
+VITVISTA ; EXTRACT VITALS FROM VISTA INTO PROVIDED XML TEMPLATE
+ D FASTVIT^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) ; GPL THIS ONE WORKS FOR AT
+ ; LEAST ONE SET OF VITALS - TO DO, CALL IT REPETIVELY TO GET EARLIER VITALS
+ ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT)
+ ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CSDT,C0CEDT)
+ ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CVSTRT,C0CVLMT) ; GPL LET GMR HANDLE THE DATES
+ I '$D(VITRSLT(1)) S @VITOUTXML@(0)=0 Q  ; RETURN NOT FOUND AND QUIT
+ I $P(VITRSLT(1),U,2)="No vitals found." D  Q  ; NULL RESULT FROM RPC
+ . I DEBUG W "NO VITALS FOUND FROM VITALS RPC",!
+ . S @VITOUTXML@(0)=0
+ I $P(VITRSLT(1),U,2)="No vitals found." Q  ; QUIT
+ ; ZWR RPCRSLT
+ S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS"))
+ S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP"))
+ K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES
+ N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
+ D VITDVISTA(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
+ I DEBUG ZWR VDATES ;DEBUG
+ S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
+ ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY
+ S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS
+ F J=1:1:VCNT  D  ; FOR EACH VITAL IN THE LIST
+ . I $D(VITRSLT(VSORT(J))) D
+ . . S VITVMAP=$NA(@VITTVMAP@(J))
+ . . K @VITVMAP
+ . . I DEBUG W "VMAP= ",VITVMAP,!
+ . . S VITPTMP=VITRSLT(VSORT(J)) ; DATE SORTED VITAL FROM RETURN ARRAY
+ . . I DEBUG W "VITAL ",VSORT(J),!
+ . . I DEBUG W VITRSLT(VSORT(J))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),!
+ . . I DEBUG W $P(VITPTMP,U,4),!
+ . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID
         . . ;B  ;gpl
         . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6)
         . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D  ;
         . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1"
-        . . I $P(VITPTMP,U,2)="HT" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in"
-        . . E  I $P(VITPTMP,U,2)="WT" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs"
-        . . E  I $P(VITPTMP,U,2)="BP" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . ;S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
-        . . E  I $P(VITPTMP,U,2)="T" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F"
-        . . E  I $P(VITPTMP,U,2)="R" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
-        . . E  I $P(VITPTMP,U,2)="P" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
-        . . E  I $P(VITPTMP,U,2)="PN" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
-        . . E  I $P(VITPTMP,U,2)="BMI" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="60621009"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
-        . . E  D
-        . . . ;W "IN VITAL:  OTHER",!
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER VITAL"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="UNKNOWN"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER"
-        . . . ;S @VITVMAP@("VITALSIGNSDESCCODEVALUE")=""
-        . . . ;S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")=""
-        . . . ;S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN"
+ . . I $P(VITPTMP,U,2)="HT" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in"
+ . . E  I $P(VITPTMP,U,2)="WT" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs"
+ . . E  I $P(VITPTMP,U,2)="BP" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . ;S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
+ . . E  I $P(VITPTMP,U,2)="T" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F"
+ . . E  I $P(VITPTMP,U,2)="R" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
+ . . E  I $P(VITPTMP,U,2)="P" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
+ . . E  I $P(VITPTMP,U,2)="PN" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
+ . . E  I $P(VITPTMP,U,2)="BMI" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="60621009"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=""
+ . . E  D
+ . . . ;W "IN VITAL:  OTHER",!
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER VITAL"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="UNKNOWN"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER"
+ . . . ;S @VITVMAP@("VITALSIGNSDESCCODEVALUE")=""
+ . . . ;S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")=""
+ . . . ;S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN"
         . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D  ;
         . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ;
-        . . S VITARYTMP=$NA(@VITTARYTMP@(J))
-        . . K @VITARYTMP
-        . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP)
-        . . I J=1 D  ; FIRST ONE IS JUST A COPY
-        . . . ; W "FIRST ONE",!
-        . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML)
-        . . . I DEBUG W "VITOUTXML ",VITOUTXML,!
-        . . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
-        . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP)
-        ; ZWR ^TMP($J,"VITALS",*)
-        ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS
-        I DEBUG D PARY^C0CXPATH(VITOUTXML)
-        N VITTMP,I
-        D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS
-        I VITTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
-        . W "VITALS MISSING ",!
-        . F I=1:1:VITTMP(0) W VITTMP(I),!
-        Q
-        ;
-VITRPMS ; EXTRACT VITALS FROM RPMS INTO PROVIDED XML TEMPLATE
-        ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE
-        ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE
-        N END,START,DATA
-        D DT^DILF("",C0CVLMT,.END)
-        D DT^DILF("",C0CVSTRT,.START)
-        ; RPC OUTPUT FORMAT:
-        ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric)
-        D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL
-        I '$D(^TMP("CIAVMRPC",$J)) S @VITOUTXML@(0)=0 Q  ; RETURN NOT FOUND AND QUIT
-        ;ZW ^TMP("CIAVMRPC",$J)
-        S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS"))
-        S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP"))
-        K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES
-        N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
-        D VITDRPMS(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
-        S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
-        ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY
-        S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS
-        F J=1:1:VCNT  D  ; FOR EACH VITAL IN THE LIST
-        . I $D(^TMP("CIAVMRPC",$J,0,(VSORT(J)))) D
-        . . S VITVMAP=$NA(@VITTVMAP@(J))
-        . . K @VITVMAP
-        . . I DEBUG W "VMAP= ",VITVMAP,!
-        . . S VITPTMP=^TMP("CIAVMRPC",$J,0,(VSORT(J))) ; DATE SORTED VITAL FROM RETURN ARRAY
-        . . I DEBUG W "VITAL ",VSORT(J),!
-        . . I DEBUG W ^TMP("CIAVMRPC",$J,0,(VSORT(J)))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),!
-        . . I DEBUG W $P(VITPTMP,U,4),!
-        . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID
-        . . I $P(VITPTMP,U,3)="HT" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
-        . . E  I $P(VITPTMP,U,3)="WT" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
-        . . E  I $P(VITPTMP,U,3)="BP" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
-        . . E  I $P(VITPTMP,U,3)="TMP" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
-        . . E  I $P(VITPTMP,U,3)="RS" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
-        . . E  I $P(VITPTMP,U,3)="PU" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
-        . . E  I $P(VITPTMP,U,3)="PA" D
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000"
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
-        . . E  D
-        . . . ;W "IN VITAL:  OTHER",!
-        . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2)
-        . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
-        . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
-        . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
-        . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2)
-        . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")=""
-        . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")=""
-        . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
-        . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
-        . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
-        . . S VITARYTMP=$NA(@VITTARYTMP@(J))
-        . . K @VITARYTMP
-        . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP)
-        . . I J=1 D  ; FIRST ONE IS JUST A COPY
-        . . . ; W "FIRST ONE",!
-        . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML)
-        . . . I DEBUG W "VITOUTXML ",VITOUTXML,!
-        . . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
-        . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP)
-        ; ZWR ^TMP($J,"VITALS",*)
-        ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS
-        I DEBUG D PARY^C0CXPATH(VITOUTXML)
-        N VITTMP,I
-        D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS
-        I VITTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
-        . W "VITALS MISSING ",!
-        . F I=1:1:VITTMP(0) W VITTMP(I),!
-        K ^TMP("CIAVMRPC",$J)
-        Q
-        ;
-VITDRPMS(VDT)   ; RUN DATE SORTING ALGORITHM FOR RPMS
-        ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY
-        ; OF DATES IN THE VITALS RESULTS
-        N VDTI,VDTJ,VTDCNT
-        S VTDCNT=0 ; COUNT TO BUILD ARRAY
-        S VDTJ="" ; USED TO VISIT THE RESULTS
-        F VDTI=0:0 D  Q:$O(^TMP("CIAVMRPC",$J,0,VDTJ))=""  ; VISIT ALL RESULTS
-        . S VDTJ=$O(^TMP("CIAVMRPC",$J,0,VDTJ)) ; NEXT RESULT
-        . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER
-        . S VDT(VTDCNT)=$P(^TMP("CIAVMRPC",$J,0,VDTJ),U,4) ; PULL OUT THE DATE
-        S VDT(0)=VTDCNT
-        Q
-        ;
-VITDVISTA(VDT)  ; RUN DATE SORTING ALGORITHM FOR VISTA
-        ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY
-        ; OF DATES IN THE VITALS RESULTS
-        N VDTI,VDTJ,VTDCNT
-        S VTDCNT=0 ; COUNT TO BUILD ARRAY
-        S VDTJ="" ; USED TO VISIT THE RESULTS
-        F VDTI=0:0 D  Q:$O(VITRSLT(VDTJ))=""  ; VISIT ALL RESULTS
-        . S VDTJ=$O(VITRSLT(VDTJ)) ; NEXT RESULT
-        . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER
-        . S VDT(VTDCNT)=$P(VITRSLT(VDTJ),U,4) ; PULL OUT THE DATE
-        S VDT(0)=VTDCNT
-        Q
-        ;
+ . . S VITARYTMP=$NA(@VITTARYTMP@(J))
+ . . K @VITARYTMP
+ . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP)
+ . . I J=1 D  ; FIRST ONE IS JUST A COPY
+ . . . ; W "FIRST ONE",!
+ . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML)
+ . . . I DEBUG W "VITOUTXML ",VITOUTXML,!
+ . . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
+ . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP)
+ ; ZWR ^TMP($J,"VITALS",*)
+ ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS
+ I DEBUG D PARY^C0CXPATH(VITOUTXML)
+ N VITTMP,I
+ D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS
+ I VITTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
+ . W "VITALS MISSING ",!
+ . F I=1:1:VITTMP(0) W VITTMP(I),!
+ Q
+ ;
+VITRPMS ; EXTRACT VITALS FROM RPMS INTO PROVIDED XML TEMPLATE
+ ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE
+ ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE
+ N END,START,DATA
+ D DT^DILF("",C0CVLMT,.END)
+ D DT^DILF("",C0CVSTRT,.START)
+ ; RPC OUTPUT FORMAT:
+ ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric)
+ D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL
+ I '$D(^TMP("CIAVMRPC",$J)) S @VITOUTXML@(0)=0 Q  ; RETURN NOT FOUND AND QUIT
+ ;ZW ^TMP("CIAVMRPC",$J)
+ S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS"))
+ S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP"))
+ K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES
+ N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
+ D VITDRPMS(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
+ S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
+ ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY
+ S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS
+ F J=1:1:VCNT  D  ; FOR EACH VITAL IN THE LIST
+ . I $D(^TMP("CIAVMRPC",$J,0,(VSORT(J)))) D
+ . . S VITVMAP=$NA(@VITTVMAP@(J))
+ . . K @VITVMAP
+ . . I DEBUG W "VMAP= ",VITVMAP,!
+ . . S VITPTMP=^TMP("CIAVMRPC",$J,0,(VSORT(J))) ; DATE SORTED VITAL FROM RETURN ARRAY
+ . . I DEBUG W "VITAL ",VSORT(J),!
+ . . I DEBUG W ^TMP("CIAVMRPC",$J,0,(VSORT(J)))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),!
+ . . I DEBUG W $P(VITPTMP,U,4),!
+ . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID
+ . . I $P(VITPTMP,U,3)="HT" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
+ . . E  I $P(VITPTMP,U,3)="WT" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
+ . . E  I $P(VITPTMP,U,3)="BP" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
+ . . E  I $P(VITPTMP,U,3)="TMP" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
+ . . E  I $P(VITPTMP,U,3)="RS" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
+ . . E  I $P(VITPTMP,U,3)="PU" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
+ . . E  I $P(VITPTMP,U,3)="PA" D
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000"
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED"
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
+ . . E  D
+ . . . ;W "IN VITAL:  OTHER",!
+ . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT")
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2)
+ . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1"
+ . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
+ . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
+ . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2)
+ . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")=""
+ . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")=""
+ . . . S @VITVMAP@("VITALSIGNSCODEVERSION")=""
+ . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1)
+ . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2)
+ . . S VITARYTMP=$NA(@VITTARYTMP@(J))
+ . . K @VITARYTMP
+ . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP)
+ . . I J=1 D  ; FIRST ONE IS JUST A COPY
+ . . . ; W "FIRST ONE",!
+ . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML)
+ . . . I DEBUG W "VITOUTXML ",VITOUTXML,!
+ . . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
+ . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP)
+ ; ZWR ^TMP($J,"VITALS",*)
+ ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS
+ I DEBUG D PARY^C0CXPATH(VITOUTXML)
+ N VITTMP,I
+ D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS
+ I VITTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
+ . W "VITALS MISSING ",!
+ . F I=1:1:VITTMP(0) W VITTMP(I),!
+ K ^TMP("CIAVMRPC",$J)
+ Q
+ ;
+VITDRPMS(VDT) ; RUN DATE SORTING ALGORITHM FOR RPMS
+ ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY
+ ; OF DATES IN THE VITALS RESULTS
+ N VDTI,VDTJ,VTDCNT
+ S VTDCNT=0 ; COUNT TO BUILD ARRAY
+ S VDTJ="" ; USED TO VISIT THE RESULTS
+ F VDTI=0:0 D  Q:$O(^TMP("CIAVMRPC",$J,0,VDTJ))=""  ; VISIT ALL RESULTS
+ . S VDTJ=$O(^TMP("CIAVMRPC",$J,0,VDTJ)) ; NEXT RESULT
+ . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER
+ . S VDT(VTDCNT)=$P(^TMP("CIAVMRPC",$J,0,VDTJ),U,4) ; PULL OUT THE DATE
+ S VDT(0)=VTDCNT
+ Q
+ ;
+VITDVISTA(VDT) ; RUN DATE SORTING ALGORITHM FOR VISTA
+ ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY
+ ; OF DATES IN THE VITALS RESULTS
+ N VDTI,VDTJ,VTDCNT
+ S VTDCNT=0 ; COUNT TO BUILD ARRAY
+ S VDTJ="" ; USED TO VISIT THE RESULTS
+ F VDTI=0:0 D  Q:$O(VITRSLT(VDTJ))=""  ; VISIT ALL RESULTS
+ . S VDTJ=$O(VITRSLT(VDTJ)) ; NEXT RESULT
+ . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER
+ . S VDT(VTDCNT)=$P(VITRSLT(VDTJ),U,4) ; PULL OUT THE DATE
+ S VDT(0)=VTDCNT
+ Q
+ ;

ccr/trunk/p/C0CXPAT0.m

@@ -1 @@
-C0CXPAT0          ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-               W "NO ENTRY",!
-               Q
-               ;
-        ;;><TEST>
-        ;;><INIT>
-        ;;>>>K C0C S C0C=""
-        ;;>>>D PUSH^C0CXPATH("C0C","FIRST")
-        ;;>>>D PUSH^C0CXPATH("C0C","SECOND")
-        ;;>>>D PUSH^C0CXPATH("C0C","THIRD")
-        ;;>>>D PUSH^C0CXPATH("C0C","FOURTH")
-        ;;>>?C0C(0)=4
-        ;;><INITXML>
-        ;;>>>K GXML S GXML=""
-        ;;>>>D PUSH^C0CXPATH("GXML","<FIRST>")
-        ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>")
-        ;;>>>D PUSH^C0CXPATH("GXML","<THIRD>")
-        ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>@@DATA1@@</FOURTH>")
-        ;;>>>D PUSH^C0CXPATH("GXML","<FIFTH>")
-        ;;>>>D PUSH^C0CXPATH("GXML","@@DATA2@@")
-        ;;>>>D PUSH^C0CXPATH("GXML","</FIFTH>")
-        ;;>>>D PUSH^C0CXPATH("GXML","<SIXTH ID=""SELF"" />")
-        ;;>>>D PUSH^C0CXPATH("GXML","</THIRD>")
-        ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>")
-        ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>")
-        ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>")
-        ;;>>>D PUSH^C0CXPATH("GXML","</FIRST>")
-        ;;><INITXML2>
-        ;;>>>K GXML S GXML=""
-        ;;>>>D PUSH^C0CXPATH("GXML","<FIRST>")
-        ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>")
-        ;;>>>D PUSH^C0CXPATH("GXML","<THIRD>")
-        ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>DATA1</FOURTH>")
-        ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>")
-        ;;>>>D PUSH^C0CXPATH("GXML","DATA2")
-        ;;>>>D PUSH^C0CXPATH("GXML","</FOURTH>")
-        ;;>>>D PUSH^C0CXPATH("GXML","</THIRD>")
-        ;;>>>D PUSH^C0CXPATH("GXML","<_SECOND>")
-        ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>DATA3</FOURTH>")
-        ;;>>>D PUSH^C0CXPATH("GXML","</_SECOND>")
-        ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>")
-        ;;>>>D PUSH^C0CXPATH("GXML","</FIRST>")
-        ;;><PUSHPOP>
-        ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
-        ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT")
-        ;;>>?C0C(C0C(0))="FOURTH"
-        ;;>>>D POP^C0CXPATH("C0C",.GX)
-        ;;>>?GX="FOURTH"
-        ;;>>?C0C(C0C(0))="THIRD"
-        ;;>>>D POP^C0CXPATH("C0C",.GX)
-        ;;>>?GX="THIRD"
-        ;;>>?C0C(C0C(0))="SECOND"
-        ;;><MKMDX>
-        ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
-        ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT")
-        ;;>>>S GX=""
-        ;;>>>D MKMDX^C0CXPATH("C0C",.GX)
-        ;;>>?GX="//FIRST/SECOND/THIRD/FOURTH"
-        ;;><XNAME>
-        ;;>>?$$XNAME^C0CXPATH("<FOURTH>DATA1</FOURTH>")="FOURTH"
-        ;;>>?$$XNAME^C0CXPATH("<SIXTH  ID=""SELF"" />")="SIXTH"
-        ;;>>?$$XNAME^C0CXPATH("</THIRD>")="THIRD"
-        ;;><INDEX>
-        ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
-        ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INITXML")
-        ;;>>>D INDEX^C0CXPATH("GXML")
-        ;;>>?GXML("//FIRST/SECOND")="2^12"
-        ;;>>?GXML("//FIRST/SECOND/THIRD")="3^9"
-        ;;>>?GXML("//FIRST/SECOND/THIRD/FIFTH")="5^7"
-        ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^4^@@DATA1@@"
-        ;;>>?GXML("//FIRST/SECOND/THIRD/SIXTH")="8^8^"
-        ;;>>?GXML("//FIRST/SECOND")="2^12"
-        ;;>>?GXML("//FIRST")="1^13"
-        ;;><INDEX2>
-        ;;>>>D ZTEST^C0CXPATH("INITXML2")
-        ;;>>>D INDEX^C0CXPATH("GXML")
-        ;;>>?GXML("//FIRST/SECOND")="2^12"
-        ;;>>?GXML("//FIRST/SECOND/_SECOND")="9^11"
-        ;;>>?GXML("//FIRST/SECOND/_SECOND/FOURTH")="10^10^DATA3"
-        ;;>>?GXML("//FIRST/SECOND/THIRD")="3^8"
-        ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH[1]")="4^4^DATA1"
-        ;;>>?GXML("//FIRST")="1^13"
-        ;;><MISSING>
-        ;;>>>D ZTEST^C0CXPATH("INITXML")
-        ;;>>>S OUTARY="^TMP($J,""MISSINGTEST"")"
-        ;;>>>D MISSING^C0CXPATH("GXML",OUTARY)
-        ;;>>?@OUTARY@(1)="DATA1"
-        ;;>>?@OUTARY@(2)="DATA2"
-        ;;><MAP>
-        ;;>>>D ZTEST^C0CXPATH("INITXML")
-        ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")"
-        ;;>>>S OUTARY="^TMP($J,""MAPTEST"")"
-        ;;>>>S @MAPARY@("DATA2")="VALUE2"
-        ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY)
-        ;;>>?@OUTARY@(6)="VALUE2"
-        ;;><MAP2>
-        ;;>>>D ZTEST^C0CXPATH("INITXML")
-        ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")"
-        ;;>>>S OUTARY="^TMP($J,""MAPTEST"")"
-        ;;>>>S @MAPARY@("DATA1")="VALUE1"
-        ;;>>>S @MAPARY@("DATA2")="VALUE2"
-        ;;>>>S @MAPARY@("DATA3")="VALUE3"
-        ;;>>>S GXML(4)="<FOURTH>@@DATA1@@ AND @@DATA3@@</FOURTH>"
-        ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY)
-        ;;>>>D PARY^C0CXPATH(OUTARY)
-        ;;>>?@OUTARY@(4)="<FOURTH>VALUE1 AND VALUE3</FOURTH>"
-        ;;><QUEUE>
-        ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",2,3)
-        ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",4,5)
-        ;;>>?$P(BTLIST(2),";",2)=4
-        ;;><BUILD>
-        ;;>>>D ZTEST^C0CXPATH("INITXML")
-        ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FOURTH","G2")
-        ;;>>>D ZTEST^C0CXPATH("QUEUE")
-        ;;>>>D BUILD^C0CXPATH("BTLIST","G3")
-        ;;><CP>
-        ;;>>>D ZTEST^C0CXPATH("INITXML")
-        ;;>>>D CP^C0CXPATH("GXML","G2")
-        ;;>>?G2(0)=13
-        ;;><QOPEN>
-        ;;>>>K G2,GBL
-        ;;>>>D ZTEST^C0CXPATH("INITXML")
-        ;;>>>D QOPEN^C0CXPATH("GBL","GXML")
-        ;;>>?$P(GBL(1),";",3)=12
-        ;;>>>D BUILD^C0CXPATH("GBL","G2")
-        ;;>>?G2(G2(0))="</SECOND>"
-        ;;><QOPEN2>
-        ;;>>>K G2,GBL
-        ;;>>>D ZTEST^C0CXPATH("INITXML")
-        ;;>>>D QOPEN^C0CXPATH("GBL","GXML","//FIRST/SECOND")
-        ;;>>?$P(GBL(1),";",3)=11
-        ;;>>>D BUILD^C0CXPATH("GBL","G2")
-        ;;>>?G2(G2(0))="</SECOND>"
-        ;;><QCLOSE>
-        ;;>>>K G2,GBL
-        ;;>>>D ZTEST^C0CXPATH("INITXML")
-        ;;>>>D QCLOSE^C0CXPATH("GBL","GXML")
-        ;;>>?$P(GBL(1),";",3)=13
-        ;;>>>D BUILD^C0CXPATH("GBL","G2")
-        ;;>>?G2(G2(0))="</FIRST>"
-        ;;><QCLOSE2>
-        ;;>>>K G2,GBL
-        ;;>>>D ZTEST^C0CXPATH("INITXML")
-        ;;>>>D QCLOSE^C0CXPATH("GBL","GXML","//FIRST/SECOND/THIRD")
-        ;;>>?$P(GBL(1),";",3)=13
-        ;;>>>D BUILD^C0CXPATH("GBL","G2")
-        ;;>>?G2(G2(0))="</FIRST>"
-        ;;>>?G2(1)="</THIRD>"
-        ;;><INSERT>
-        ;;>>>K G2,GBL,G3,G4
-        ;;>>>D ZTEST^C0CXPATH("INITXML")
-        ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2")
-        ;;>>>D INSERT^C0CXPATH("GXML","G2","//FIRST/SECOND/THIRD")
-        ;;>>>D INSERT^C0CXPATH("G3","G2","//")
-        ;;>>?G2(1)=GXML(9)
-        ;;><REPLACE>
-        ;;>>>K G2,GBL,G3
-        ;;>>>D ZTEST^C0CXPATH("INITXML")
-        ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2")
-        ;;>>>D REPLACE^C0CXPATH("GXML","G2","//FIRST/SECOND")
-        ;;>>?GXML(2)="<FIFTH>"
-        ;;><INSINNER>
-        ;;>>>K GXML,G2,GBL,G3
-        ;;>>>D ZTEST^C0CXPATH("INITXML")
-        ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2")
-        ;;>>>D INSINNER^C0CXPATH("GXML","G2","//FIRST/SECOND/THIRD")
-        ;;>>?GXML(10)="<FIFTH>"
-        ;;><INSINNER2>
-        ;;>>>K GXML,G2,GBL,G3
-        ;;>>>D ZTEST^C0CXPATH("INITXML")
-        ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2")
-        ;;>>>D INSINNER^C0CXPATH("G2","G2")
-        ;;>>?G2(8)="<FIFTH>"
-        ;;><PUSHA>
-        ;;>>>K GTMP,GTMP2
-        ;;>>>N GTMP,GTMP2
-        ;;>>>D PUSH^C0CXPATH("GTMP","A")
-        ;;>>>D PUSH^C0CXPATH("GTMP2","B")
-        ;;>>>D PUSH^C0CXPATH("GTMP2","C")
-        ;;>>>D PUSHA^C0CXPATH("GTMP","GTMP2")
-        ;;>>?GTMP(3)="C"
-        ;;>>?GTMP(0)=3
-        ;;><H2ARY>
-        ;;>>>K GTMP,GTMP2
-        ;;>>>S GTMP("TEST1")=1
-        ;;>>>D H2ARY^C0CXPATH("GTMP2","GTMP")
-        ;;>>?GTMP2(0)=1
-        ;;>>?GTMP2(1)="^TEST1^1"
-        ;;><XVARS>
-        ;;>>>K GTMP,GTMP2
-        ;;>>>D PUSH^C0CXPATH("GTMP","<VALUE>@@VAR1@@</VALUE>")
-        ;;>>>D XVARS^C0CXPATH("GTMP2","GTMP")
-        ;;>>?GTMP2(1)="^VAR1^1"
-        ;;></TEST>
+C0CXPAT0   ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+        W "NO ENTRY",!
+        Q
+        ;
+ ;;><TEST>
+ ;;><INIT>
+ ;;>>>K C0C S C0C=""
+ ;;>>>D PUSH^C0CXPATH("C0C","FIRST")
+ ;;>>>D PUSH^C0CXPATH("C0C","SECOND")
+ ;;>>>D PUSH^C0CXPATH("C0C","THIRD")
+ ;;>>>D PUSH^C0CXPATH("C0C","FOURTH")
+ ;;>>?C0C(0)=4
+ ;;><INITXML>
+ ;;>>>K GXML S GXML=""
+ ;;>>>D PUSH^C0CXPATH("GXML","<FIRST>")
+ ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>")
+ ;;>>>D PUSH^C0CXPATH("GXML","<THIRD>")
+ ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>@@DATA1@@</FOURTH>")
+ ;;>>>D PUSH^C0CXPATH("GXML","<FIFTH>")
+ ;;>>>D PUSH^C0CXPATH("GXML","@@DATA2@@")
+ ;;>>>D PUSH^C0CXPATH("GXML","</FIFTH>")
+ ;;>>>D PUSH^C0CXPATH("GXML","<SIXTH ID=""SELF"" />")
+ ;;>>>D PUSH^C0CXPATH("GXML","</THIRD>")
+ ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>")
+ ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>")
+ ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>")
+ ;;>>>D PUSH^C0CXPATH("GXML","</FIRST>")
+ ;;><INITXML2>
+ ;;>>>K GXML S GXML=""
+ ;;>>>D PUSH^C0CXPATH("GXML","<FIRST>")
+ ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>")
+ ;;>>>D PUSH^C0CXPATH("GXML","<THIRD>")
+ ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>DATA1</FOURTH>")
+ ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>")
+ ;;>>>D PUSH^C0CXPATH("GXML","DATA2")
+ ;;>>>D PUSH^C0CXPATH("GXML","</FOURTH>")
+ ;;>>>D PUSH^C0CXPATH("GXML","</THIRD>")
+ ;;>>>D PUSH^C0CXPATH("GXML","<_SECOND>")
+ ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>DATA3</FOURTH>")
+ ;;>>>D PUSH^C0CXPATH("GXML","</_SECOND>")
+ ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>")
+ ;;>>>D PUSH^C0CXPATH("GXML","</FIRST>")
+ ;;><PUSHPOP>
+ ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
+ ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT")
+ ;;>>?C0C(C0C(0))="FOURTH"
+ ;;>>>D POP^C0CXPATH("C0C",.GX)
+ ;;>>?GX="FOURTH"
+ ;;>>?C0C(C0C(0))="THIRD"
+ ;;>>>D POP^C0CXPATH("C0C",.GX)
+ ;;>>?GX="THIRD"
+ ;;>>?C0C(C0C(0))="SECOND"
+ ;;><MKMDX>
+ ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
+ ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT")
+ ;;>>>S GX=""
+ ;;>>>D MKMDX^C0CXPATH("C0C",.GX)
+ ;;>>?GX="//FIRST/SECOND/THIRD/FOURTH"
+ ;;><XNAME>
+ ;;>>?$$XNAME^C0CXPATH("<FOURTH>DATA1</FOURTH>")="FOURTH"
+ ;;>>?$$XNAME^C0CXPATH("<SIXTH  ID=""SELF"" />")="SIXTH"
+ ;;>>?$$XNAME^C0CXPATH("</THIRD>")="THIRD"
+ ;;><INDEX>
+ ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
+ ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INITXML")
+ ;;>>>D INDEX^C0CXPATH("GXML")
+ ;;>>?GXML("//FIRST/SECOND")="2^12"
+ ;;>>?GXML("//FIRST/SECOND/THIRD")="3^9"
+ ;;>>?GXML("//FIRST/SECOND/THIRD/FIFTH")="5^7"
+ ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^4^@@DATA1@@"
+ ;;>>?GXML("//FIRST/SECOND/THIRD/SIXTH")="8^8^"
+ ;;>>?GXML("//FIRST/SECOND")="2^12"
+ ;;>>?GXML("//FIRST")="1^13"
+ ;;><INDEX2>
+ ;;>>>D ZTEST^C0CXPATH("INITXML2")
+ ;;>>>D INDEX^C0CXPATH("GXML")
+ ;;>>?GXML("//FIRST/SECOND")="2^12"
+ ;;>>?GXML("//FIRST/SECOND/_SECOND")="9^11"
+ ;;>>?GXML("//FIRST/SECOND/_SECOND/FOURTH")="10^10^DATA3"
+ ;;>>?GXML("//FIRST/SECOND/THIRD")="3^8"
+ ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH[1]")="4^4^DATA1"
+ ;;>>?GXML("//FIRST")="1^13"
+ ;;><MISSING>
+ ;;>>>D ZTEST^C0CXPATH("INITXML")
+ ;;>>>S OUTARY="^TMP($J,""MISSINGTEST"")"
+ ;;>>>D MISSING^C0CXPATH("GXML",OUTARY)
+ ;;>>?@OUTARY@(1)="DATA1"
+ ;;>>?@OUTARY@(2)="DATA2"
+ ;;><MAP>
+ ;;>>>D ZTEST^C0CXPATH("INITXML")
+ ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")"
+ ;;>>>S OUTARY="^TMP($J,""MAPTEST"")"
+ ;;>>>S @MAPARY@("DATA2")="VALUE2"
+ ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY)
+ ;;>>?@OUTARY@(6)="VALUE2"
+ ;;><MAP2>
+ ;;>>>D ZTEST^C0CXPATH("INITXML")
+ ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")"
+ ;;>>>S OUTARY="^TMP($J,""MAPTEST"")"
+ ;;>>>S @MAPARY@("DATA1")="VALUE1"
+ ;;>>>S @MAPARY@("DATA2")="VALUE2"
+ ;;>>>S @MAPARY@("DATA3")="VALUE3"
+ ;;>>>S GXML(4)="<FOURTH>@@DATA1@@ AND @@DATA3@@</FOURTH>"
+ ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY)
+ ;;>>>D PARY^C0CXPATH(OUTARY)
+ ;;>>?@OUTARY@(4)="<FOURTH>VALUE1 AND VALUE3</FOURTH>"
+ ;;><QUEUE>
+ ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",2,3)
+ ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",4,5)
+ ;;>>?$P(BTLIST(2),";",2)=4
+ ;;><BUILD>
+ ;;>>>D ZTEST^C0CXPATH("INITXML")
+ ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FOURTH","G2")
+ ;;>>>D ZTEST^C0CXPATH("QUEUE")
+ ;;>>>D BUILD^C0CXPATH("BTLIST","G3")
+ ;;><CP>
+ ;;>>>D ZTEST^C0CXPATH("INITXML")
+ ;;>>>D CP^C0CXPATH("GXML","G2")
+ ;;>>?G2(0)=13
+ ;;><QOPEN>
+ ;;>>>K G2,GBL
+ ;;>>>D ZTEST^C0CXPATH("INITXML")
+ ;;>>>D QOPEN^C0CXPATH("GBL","GXML")
+ ;;>>?$P(GBL(1),";",3)=12
+ ;;>>>D BUILD^C0CXPATH("GBL","G2")
+ ;;>>?G2(G2(0))="</SECOND>"
+ ;;><QOPEN2>
+ ;;>>>K G2,GBL
+ ;;>>>D ZTEST^C0CXPATH("INITXML")
+ ;;>>>D QOPEN^C0CXPATH("GBL","GXML","//FIRST/SECOND")
+ ;;>>?$P(GBL(1),";",3)=11
+ ;;>>>D BUILD^C0CXPATH("GBL","G2")
+ ;;>>?G2(G2(0))="</SECOND>"
+ ;;><QCLOSE>
+ ;;>>>K G2,GBL
+ ;;>>>D ZTEST^C0CXPATH("INITXML")
+ ;;>>>D QCLOSE^C0CXPATH("GBL","GXML")
+ ;;>>?$P(GBL(1),";",3)=13
+ ;;>>>D BUILD^C0CXPATH("GBL","G2")
+ ;;>>?G2(G2(0))="</FIRST>"
+ ;;><QCLOSE2>
+ ;;>>>K G2,GBL
+ ;;>>>D ZTEST^C0CXPATH("INITXML")
+ ;;>>>D QCLOSE^C0CXPATH("GBL","GXML","//FIRST/SECOND/THIRD")
+ ;;>>?$P(GBL(1),";",3)=13
+ ;;>>>D BUILD^C0CXPATH("GBL","G2")
+ ;;>>?G2(G2(0))="</FIRST>"
+ ;;>>?G2(1)="</THIRD>"
+ ;;><INSERT>
+ ;;>>>K G2,GBL,G3,G4
+ ;;>>>D ZTEST^C0CXPATH("INITXML")
+ ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2")
+ ;;>>>D INSERT^C0CXPATH("GXML","G2","//FIRST/SECOND/THIRD")
+ ;;>>>D INSERT^C0CXPATH("G3","G2","//")
+ ;;>>?G2(1)=GXML(9)
+ ;;><REPLACE>
+ ;;>>>K G2,GBL,G3
+ ;;>>>D ZTEST^C0CXPATH("INITXML")
+ ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2")
+ ;;>>>D REPLACE^C0CXPATH("GXML","G2","//FIRST/SECOND")
+ ;;>>?GXML(2)="<FIFTH>"
+ ;;><INSINNER>
+ ;;>>>K GXML,G2,GBL,G3
+ ;;>>>D ZTEST^C0CXPATH("INITXML")
+ ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2")
+ ;;>>>D INSINNER^C0CXPATH("GXML","G2","//FIRST/SECOND/THIRD")
+ ;;>>?GXML(10)="<FIFTH>"
+ ;;><INSINNER2>
+ ;;>>>K GXML,G2,GBL,G3
+ ;;>>>D ZTEST^C0CXPATH("INITXML")
+ ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2")
+ ;;>>>D INSINNER^C0CXPATH("G2","G2")
+ ;;>>?G2(8)="<FIFTH>"
+ ;;><PUSHA>
+ ;;>>>K GTMP,GTMP2
+ ;;>>>N GTMP,GTMP2
+ ;;>>>D PUSH^C0CXPATH("GTMP","A")
+ ;;>>>D PUSH^C0CXPATH("GTMP2","B")
+ ;;>>>D PUSH^C0CXPATH("GTMP2","C")
+ ;;>>>D PUSHA^C0CXPATH("GTMP","GTMP2")
+ ;;>>?GTMP(3)="C"
+ ;;>>?GTMP(0)=3
+ ;;><H2ARY>
+ ;;>>>K GTMP,GTMP2
+ ;;>>>S GTMP("TEST1")=1
+ ;;>>>D H2ARY^C0CXPATH("GTMP2","GTMP")
+ ;;>>?GTMP2(0)=1
+ ;;>>?GTMP2(1)="^TEST1^1"
+ ;;><XVARS>
+ ;;>>>K GTMP,GTMP2
+ ;;>>>D PUSH^C0CXPATH("GTMP","<VALUE>@@VAR1@@</VALUE>")
+ ;;>>>D XVARS^C0CXPATH("GTMP2","GTMP")
+ ;;>>?GTMP2(1)="^VAR1^1"
+ ;;></TEST>

ccr/trunk/p/C0CXPATH.m

@@ -1 @@
-C0CXPATH          ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
-        ;;1.0;C0C;;May 19, 2009;Build 38
-        ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
-        ;General Public License See attached copy of the License.
-        ;
-        ;This program is free software; you can redistribute it and/or modify
-        ;it under the terms of the GNU General Public License as published by
-        ;the Free Software Foundation; either version 2 of the License, or
-        ;(at your option) any later version.
-        ;
-        ;This program is distributed in the hope that it will be useful,
-        ;but WITHOUT ANY WARRANTY; without even the implied warranty of
-        ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-        ;GNU General Public License for more details.
-        ;
-        ;You should have received a copy of the GNU General Public License along
-        ;with this program; if not, write to the Free Software Foundation, Inc.,
-        ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-        ;
-        W "This is an XML XPATH utility library",!
-        W !
-        Q
-        ;
-OUTPUT(OUTARY,OUTNAME,OUTDIR)     ; WRITE AN ARRAY TO A FILE
-        ;
-        N Y
-        S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME)
-        I Y Q 1_U_"WROTE FILE: "_OUTNAME_" TO "_OUTDIR
-        I 'Y Q 0_U_"ERROR WRITING FILE"_OUTNAME_" TO "_OUTDIR
-        Q
-        ;
-PUSH(STK,VAL)     ; pushs VAL onto STK and updates STK(0)
-        ;  VAL IS A STRING AND STK IS PASSED BY NAME
-        ;
-        I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE
-        S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH
-        S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY
-        Q
-        ;
-POP(STK,VAL)       ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL
-        ; VAL AND STK ARE PASSED BY REFERENCE
-        ;
-        I @STK@(0)<1 D  ; IF ARRAY IS EMPTY
-        . S VAL=""
-        . S @STK@(0)=0
-        I @STK@(0)>0  D  ;
-        . S VAL=@STK@(@STK@(0))
-        . K @STK@(@STK@(0))
-        . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY
-        Q
-        ;
-PUSHA(ADEST,ASRC)       ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME
-        ;
-        N ZGI
-        F ZGI=1:1:@ASRC@(0) D  ; FOR ALL OF THE SOURCE ARRAY
-        . D PUSH(ADEST,@ASRC@(ZGI)) ; PUSH ONE ELEMENT
-        Q
-        ;
-MKMDX(STK,RTN,INREDUX)   ; MAKES A MUMPS INDEX FROM THE ARRAY STK
-        ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS
-        ; REDUX IS A STRING TO REMOVE FROM THE RESULT
-        S RTN=""
-        N I
-        ; W "STK= ",STK,!
-        I @STK@(0)>0  D  ; IF THE ARRAY IS NOT EMPTY
-        . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON
-        . I @STK@(0)>1  D  ; SUBSEQUENT ELEMENTS NEED A SEMICOLON
-        . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I)
-        I $G(INREDUX)'="" S RTN=$P(RTN,INREDUX,1)_$P(RTN,INREDUX,2)
-        Q
-        ;
-XNAME(ISTR)         ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG
-        ;  </NAME> AND <NAME ID=XNAME> WILL RETURN NAME
-        ; ISTR IS PASSED BY VALUE
-        N CUR,TMP
-        I ISTR?.E1"<".E  D  ; STRIP OFF LEFT BRACKET
-        . S TMP=$P(ISTR,"<",2)
-        I TMP?1"/".E  D  ; ALSO STRIP OFF SLASH IF PRESENT IE </NAME>
-        . S TMP=$P(TMP,"/",2)
-        S CUR=$P(TMP,">",1) ; EXTRACT THE NAME
-        ; W "CUR= ",CUR,!
-        I CUR?.1"_"1.A1" ".E  D  ; CONTAINS A BLANK IE NAME ID=TEST>
-        . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER
-        ; W "CUR2= ",CUR,!
-        Q CUR
-        ;
-XVAL(ISTR)      ; EXTRACTS THE VALUE FROM A FRAGMENT OF XML
-        ; <NAME>VALUE</NAME> WILL RETURN VALUE
-        N G
-        S G=$P(ISTR,">",2) ;STRIP OFF <NAME>
-        Q $P(G,"<",1) ; STRIP OFF </NAME> LEAVING VALUE
-        ;
-VDX2VDV(OUTVDV,INVDX)   ; CONVERT AN VDX ARRAY TO VDV
-        ; VDX: @INVDX@(XPATH)=VALUE
-        ; VDV: @OUTVDV@(X1X2X3X4)=VALUE
-        ; THE VDV DATANAMES MIGHT BE MORE CONVENIENT FOR USE IN CODE
-        ; AN INDEX IS PROVIDED TO GO BACK TO VDX FOR CONVERSIONS
-        ; @VDV@("XPATH",X1X2X3X4)="XPATH"
-        N ZA,ZI,ZW
-        S ZI=""
-        F  S ZI=$O(@INVDX@(ZI)) Q:ZI=""  D  ;
-        . S ZW=$TR(ZI,"/","") ; ELIMINATE ALL SLASHES - CAMEL CASE VARIABLE NAME
-        . W ZW,!
-        . S @OUTVDV@(ZW)=@INVDX@(ZI)
-        . S @OUTVDV@("XPATH",ZW)=ZI
-        Q
-        ;
-VDX2XPG(OUTXPG,INVDX)   ; CONVERT AN VDX ARRAY TO XPG
-        ; VDX: @VDX@(XPATH)=VALUE
-        ; XPG: @(VDX(X1,X2,X3,X4))@=VALUE
-        ; THIS IS A STEP TOWARD GENERATING XML FROM A VDX
-        N ZA,ZI,ZW
-        S ZI=""
-        F  S ZI=$O(@INVDX@(ZI)) Q:ZI=""  D  ;
-        . S ZW=$E(ZI,3,$L(ZI)) ; STRIP OFF INITIAL //
-        . S ZW2=$P(ZW,"/",1)
-        . F ZK=1:1:$L(ZW,"/") D PUSH("ZA",$P(ZW,"/",ZK))
-        . ;ZWR ZA
-        . S ZW2=ZA(1)
-        . F ZK=2:1:ZA(0) D  ;
-        . . S ZW2=ZW2_""","""_ZA(ZK)
-        . K ZA
-        . S ZW2=""""_ZW2_""""
-        . W ZW2,!
-        . S ZN=OUTXPG_"("_ZW2_")"
-        . S @ZN=@INVDX@(ZI)
-        Q
-        ;
-XML2XPG(OUTXPG,INXML)   ; CONVERT AN XML ARRAY, PASSED BY NAME TO AN XPG ARRAY
-        ; XPG MEANS XPATH GLOBAL AND HAS THE FORM @OUTXPG@("X1","X2","X3")=VALUE
-        ;
-        ;N G1
-        D INDEX(INXML,"G1",1) ; PRODUCES A VDX ARRAY IN G1, NO INDEX IS PRODUCED
-        D VDX2XPG(OUTXPG,"G1") ; CONVERTS THE VDX ARRAY TO XPG FORM
-        Q
-        ;
-DO      
-        D XPG2XML("^GPL2B","^GPL2A")
-        Q
-        ;
-T1      ; TEST OUT THESE ROUTINES 
-        D XML2XPG("G2","^GPL")
-        D XPG2XML("G3","G2")
-        K ^GPLOUT
-        M ^GPLOUT=G3
-        W $$OUTPUT^C0CXPATH("^GPLOUT(1)","GPLTEST.xml","/home/vademo2/EHR/p")
-        Q
-        ;
-XPG2XML(OUTXML,INXPG)   ;
-        N C0CN,FWD,ZA,G,GA,ZQ
-        S ZQ=0 ; QUIT FLAG
-        F  Q:ZQ=1  D  ; LOOP THROUGH EVERYTHING
-        . I '$D(C0CN) D  ; FIRST TIME THROUGH
-        . . K @OUTXML ; MAKE SURE OUTPUT ARRAY IS CLEAR
-        . . S FWD=1 ; START OUT GOING FORWARD THROUGH SUBSCRIPTS
-        . . S G=$Q(@INXPG) ; THIS ONE
-        . . S GN=$Q(@G) ; NEXT ONE
-        . . S C0CN=1 ; SUBSCRIPT COUNT
-        . . S ZQ=0 ; QUIT FLAG
-        . . D ZXO("?xml version=""1.0"" encoding=""UTF-8""?") ;MAKE IT REAL XML
-        . . I $QS(G,1)="ContinuityOfCareRecord" D  ;
-        . . . D ZXO("?xml-stylesheet type=""text/xsl"" href=""ccr.xsl""?") ; HACK TO MAKE THE CCR STYLESHEET WORK
-        . I FWD D  ; GOING FORWARDS 
-        . . I C0CN<$QL(G) D  ; NOT A DATA NODE
-        . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT
-        . . . D ZXO(ZA) ; AND OPEN AN XML ELEMENT
-        . . . I @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord>" D  ;
-        . . . . S @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord xmlns=""urn:astm-org:CCR"">"
-        . . . S C0CN=C0CN+1 ; MOVE TO THE NEXT ONE
-        . . E  D  ; AT THE DATA NODE
-        . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT
-        . . . D ZXVAL(ZA,@G) ; OUTPUT <X>VAL</X> FOR DATA NODE
-        . . . S FWD=0 ; GO BACKWARDS
-        . I 'FWD D  ;GOING BACKWARDS
-        . . S GN=$Q(@G) ;NEXT XPATH
-        . . ;W "NEXT!",GN,!
-        . . S C0CN=C0CN-1 ; PREVIOUS SUBSCRIPT
-        . . I GN'="" D  ;
-        . . . I $QS(G,C0CN)'=$QS(GN,C0CN) D  ; NEED TO CLOSE OFF ELEMENT
-        . . . . D ZXC($QS(G,C0CN)) ;
-        . . . E  I GN'="" D  ; MORE ELEMENTS AT THIS LEVEL
-        . . . . S G=$Q(@G) ; ADVANCE TO NEW XPATH
-        . . . . S C0CN=C0CN+1 ; GET READY TO PROCESS NEXT SUBSCRIPT
-        . . . . S FWD=1 ; GOING FORWARD NOW
-        . I (GN="")&(C0CN=1) D  Q  ; WHEN WE ARE ALL DONE
-        . . D ZXC($QS(G,C0CN)) ; LAST ONE
-        . . S ZQ=1 ; QUIT NOW
-        Q
-        ;
-ZXO(WHAT)       
-        D PUSH("GA",WHAT)
-        D PUSH(OUTXML,"<"_WHAT_">")
-        Q
-        ;
-ZXC(WHAT)       
-        D POP("GA",.TMP)
-        D PUSH(OUTXML,"</"_WHAT_">")
-        Q
-        ;
-ZXVAL(WHAT,VAL) 
-        D PUSH(OUTXML,"<"_WHAT_">"_VAL_"</"_WHAT_">")
-        Q
-        ;
-INDEX(IZXML,VDX,NOINX,TEMPLATE,REDUX)   ; parse XML in IZXML and produce 
-        ; an XPATH index; REDUX is a string to be removed from each xpath
-        ; GPL 7/14/09 OPTIONALLY GENERATE AN XML TEMPLATE IF PASSED BY NAME
-        ; TEMPLATE IS IDENTICAL TO THE PARSED XML LINE BY LINE
-        ; EXCEPT THAT DATA VALUES ARE REPLACED WITH @@XPATH@@ FOR THE XPATH OF THE TAG
-        ; GPL 5/24/09 AND OPTIONALLY PRODUCE THE VDX ARRAY PASSED BY NAME
-        ; @VDX@("XPATH")=VALUE
-        ; ex. @IZXML@("XPATH")=FIRSTLINE^LASTLINE
-        ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE
-        ; XML SECTION
-        ; IZXML IS PASSED BY NAME
-        ; IF NOINX IS SET TO 1, NO INDEX WILL BE GENERATED, BUT THE VDX WILL BE
-        N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND,CURVAL,DVDX,LCNT
-        N C0CSTK ; LEAVE OUT FOR DEBUGGING
-        I '$D(REDUX) S REDUX=""
-        I '$D(NOINX) S NOINX=0 ; IF NOT PASSED, GENERATE AN INDEX
-        N ZXML
-        I NOINX S ZXML=$NA(^TMP("C0CINDEX",$J)) ; TEMP PLACE FOR INDEX TO DISCARD
-        E  S ZXML=IZXML ; PLACE FOR INDEX TO KEEP
-        I '$D(@IZXML@(0)) D  ; IF COUNT NOT IN NODE 0 COUNT THEM
-        . S I="",LCNT=0
-        . F  S I=$O(@IZXML@(I)) Q:I=""  S LCNT=LCNT+1
-        E  S LCNT=@IZXML@(0) ; LINE COUNT PASSED IN ARRAY
-        I LCNT=0  D  Q  ; NO XML PASSED
-        . W "ERROR IN XML FILE",!
-        S DVDX=0 ; DEFAULT DO NOT PRODUCE VDX INDEX
-        I $D(VDX) S DVDX=1 ; IF NAME PASSED, DO VDX
-        S C0CSTK(0)=0 ; INITIALIZE STACK
-        K LKASD ; KILL LOOKASIDE ARRAY
-        D MKLASD(.LKASD,IZXML) ;MAKE LOOK ASIDE BUFFER FOR MULTIPLES
-        F I=1:1:LCNT  D  ; PROCESS THE ENTIRE ARRAY
-        . S LINE=@IZXML@(I)
-        . I $D(TEMPLATE) D  ;IF TEMPLATE IS REQUESTED
-        . . S @TEMPLATE@(I)=$$CLEAN(LINE) 
-        . ;W LINE,!
-        . S FOUND=0  ; INTIALIZED FOUND FLAG
-        . I LINE?.E1"<!".E S FOUND=1 ; SKIP OVER COMMENTS
-        . I FOUND'=1  D
-        . . I (LINE?.E1"<"1.E1"</".E)!(LINE?.E1"<"1.E1"/>".E)  D
-        . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS
-        . . . ; ON THE SAME LINE
-        . . . ; W "FOUND ",LINE,!
-        . . . S FOUND=1  ; SET FOUND FLAG
-        . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
-        . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES
-        . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK
-        . . . D MKMDX("C0CSTK",.MDX,REDUX) ; GENERATE THE M INDEX
-        . . . ; W "MDX=",MDX,!
-        . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
-        . . . . ;I '$D(ZDUP(MDX)) S ZDUP(MDX)=2
-        . . . . ;E  S ZDUP(MDX)=ZDUP(MDX)+1
-        . . . . ;W "DUP:",MDX,!
-        . . . . ;I '$D(CURVAL) S CURVAL=""
-        . . . . ;I DVDX S @VDX@(MDX_"["_ZDUP(MDX)_"]")=CURVAL
-        . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
-        . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
-        . . . . S @ZXML@(MDX)=I_"^"_I  ; ADD INDEX ENTRY-FIRST AND LAST
-        . . . . S CURVAL=$$XVAL(LINE) ; VALUE
-        . . . . S $P(@ZXML@(MDX),"^",3)=CURVAL ; THIRD PIECE
-        . . . . I DVDX S @VDX@(MDX)=CURVAL ; FILL IN VDX ARRAY IF REQUESTED
-        . . . . I $D(TEMPLATE) D  ; IF TEMPLATE IS REQUESTED
-        . . . . . S LINE=$$CLEAN(LINE) ; CLEAN OUT CONTROL CHARACTERS
-        . . . . . S @TEMPLATE@(I)=$P(LINE,">",1)_">@@"_MDX_"@@</"_$P(LINE,"</",2)
-        . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK
-        . I FOUND'=1  D  ; THE LINE DOESN'T CONTAIN THE START AND END
-        . . I LINE?.E1"</"1.E  D  ; LINE CONTAINS END OF A SECTION
-        . . . ; W "FOUND ",LINE,!
-        . . . S FOUND=1  ; SET FOUND FLAG
-        . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
-        . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX
-        . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
-        . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK
-        . . . S TMP=$P(TMP,"[",1) ; REMOVE [X] FROM MULTIPLE
-        . . . I TMP'=CUR  D  ; MALFORMED XML, END MUST MATCH START
-        . . . . W "MALFORMED XML ",CUR,"LINE "_I_LINE,!
-        . . . . D PARY("C0CSTK") ; PRINT OUT THE STACK FOR DEBUGING
-        . . . . Q
-        . I FOUND'=1  D  ; THE LINE MIGHT CONTAIN A SECTION BEGINNING
-        . . I (LINE?.E1"<"1.E)&(LINE'["?>")  D  ; BEGINNING OF A SECTION
-        . . . ; W "FOUND ",LINE,!
-        . . . S FOUND=1  ; SET FOUND FLAG
-        . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
-        . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES
-        . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK
-        . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX
-        . . . ; W "MDX=",MDX,!
-        . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
-        . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
-        . . . . ;B
-        . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
-        . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX
-        S @ZXML@("INDEXED")=""
-        S @ZXML@("//")="1^"_LCNT ; ROOT XPATH
-        I NOINX K @ZXML ; DELETE UNWANTED INDEX
-        Q
-        ;
-MKLASD(OUTBUF,INARY)    ; CREATE A LOOKASIDE BUFFER FOR MULTILPLES
-        ;
-        N ZI,ZN,ZA,ZLINE,ZLINE2,CUR,CUR2
-        F ZI=1:1:LCNT-1  D  ; PROCESS THE ENTIRE ARRAY 
-        . S ZLINE=@IZXML@(ZI)
-        . I ZI<LCNT S ZLINE2=@IZXML@(ZI+1)
-        . I ZLINE?.E1"</"1.E  D  ; NEXT LINE CONTAINS END OF A SECTION
-        . . S CUR=$$XNAME(ZLINE) ; EXTRACT THE NAME
-        . . I (ZLINE2?.E1"<"1.E)&(ZLINE'["?>")  D  ; BEGINNING OF A SECTION
-        . . . S CUR2=$$XNAME(ZLINE2) ; EXTRACT THE NAME 
-        . . . I CUR=CUR2 D  ; IF THIS IS A MULTIPLE
-        . . . . S OUTBUF(CUR,ZI+1)=""
-        ;ZWR OUTBUF
-        S ZI=""
-        F  S ZI=$O(OUTBUF(ZI)) Q:ZI=""  D  ; FOR EACH KIND OF MULTIPLE
-        . S ZN=$O(OUTBUF(ZI,"")) ; LINE NUMBER OF SECOND MULTIPLE
-        . F  S ZN=$O(@IZXML@(ZN),-1) Q:ZN=""  I $E($P(@IZXML@(ZN),"<"_ZI,2),1,1)=">" Q  ;
-        . S OUTBUF(ZI,ZN)=""
-        S ZA=1,ZI="",ZN=""
-        F  S ZI=$O(OUTBUF(ZI)) Q:ZI=""  D  ; ADDING THE COUNT FOR THE MULIPLES [x]
-        . S ZN="",ZA=1
-        . F  S ZN=$O(OUTBUF(ZI,ZN)) Q:ZN=""  D  ;
-        . . S OUTBUF(ZI,ZN)="["_ZA_"]"
-        . . S ZA=ZA+1
-        Q
-        ;
-CLEAN(STR,TR)   ; extrinsic function; returns string
-        ;; Removes all non printable characters from a string.
-        ;; STR by Value
-        ;; TR IS OPTIONAL TO IMPROVE PERFORMANCE
-        N TR,I
-        I '$D(TR) D  ;
-        . F I=0:1:31 S TR=$G(TR)_$C(I)
-        . S TR=TR_$C(127)
-        QUIT $TR(STR,TR)
-        ;
-QUERY(IARY,XPATH,OARY)   ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION
-        ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD"
-        ; IARY AND OARY ARE PASSED BY NAME
-        I '$D(@IARY@("INDEXED"))  D  ; INDEX IS NOT PRESENT IN IARY
-        . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML
-        N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN
-        N TMP,I,J,QXPATH
-        S FIRST=1
-        I '$D(@IARY@(0)) D  ; LINE COUNT NOT IN ZERO NODE
-        . S @IARY@(0)=$O(@IARY@("//"),-1) ; THIS SHOULD USUALLY WORK
-        S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT
-        I XPATH'="//" D  ; NOT A ROOT QUERY
-        . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES
-        . S FIRST=$P(TMP,"^",1)
-        . S LAST=$P(TMP,"^",2)
-        K @OARY
-        S @OARY@(0)=+LAST-FIRST+1
-        S J=1
-        FOR I=FIRST:1:LAST  D
-        . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY
-        . S J=J+1
-        ; ZWR OARY
-        Q
-        ;
-XF(IDX,XPATH)     ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH
-        ; INDEX WITH TWO PIECES START^FINISH
-        ; IDX IS PASSED BY NAME
-        Q $P(@IDX@(XPATH),"^",1)
-        ;
-XL(IDX,XPATH)     ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH
-        ; INDEX WITH TWO PIECES START^FINISH
-        ; IDX IS PASSED BY NAME
-        Q $P(@IDX@(XPATH),"^",2)
-        ;
-START(ISTR)         ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX
-        ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
-        ; COMPANION TO FINISH ; IDX IS PASSED BY NAME
-        Q $P(ISTR,";",2)
-        ;
-FINISH(ISTR)       ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX
-        ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
-        Q $P(ISTR,";",3)
-        ;
-ARRAY(ISTR)         ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX
-        ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
-        Q $P(ISTR,";",1)
-        ;
-BUILD(BLIST,BDEST)           ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST
-        ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST
-        ; DEST IS CLEARED TO START
-        ; USES PUSH TO DO THE COPY
-        N I
-        K @BDEST
-        F I=1:1:@BLIST@(0) D  ; FOR EACH INSTRUCTION IN BLIST
-        . N J,ATMP
-        . S ATMP=$$ARRAY(@BLIST@(I))
-        . I $G(DEBUG) W "ATMP=",ATMP,!
-        . I $G(DEBUG) W @BLIST@(I),!
-        . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D  ;
-        . . ; FOR EACH LINE IN THIS INSTR
-        . . I $G(DEBUG) W "BDEST= ",BDEST,!
-        . . I $G(DEBUG) W "ATMP= ",@ATMP@(J),!
-        . . D PUSH(BDEST,@ATMP@(J))
-        Q
-        ;
-QUEUE(BLST,ARRAY,FIRST,LAST)       ; ADD AN ENTRY TO A BLIST
-        ;
-        I $G(DEBUG) W "QUEUEING ",BLST,!
-        D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST)
-        Q
-        ;
-CP(CPSRC,CPDEST)               ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME
-        ; KILLS CPDEST FIRST
-        N CPINSTR
-        I $G(DEBUG) W "MADE IT TO COPY",CPSRC,CPDEST,!
-        I @CPSRC@(0)<1 D  ; BAD LENGTH
-        . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,!
-        . Q
-        ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT
-        D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY
-        D BUILD("CPINSTR",CPDEST)
-        Q
-        ;
-QOPEN(QOBLIST,QOXML,QOXPATH)       ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST
-        ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD
-        ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT
-        ; USED TO INSERT CHILDREN NODES
-        I @QOXML@(0)<1 D  ; MALFORMED XML
-        . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,!
-        . Q
-        I $G(DEBUG) W "DOING QOPEN",!
-        N S1,E1,QOT,QOTMP
-        S S1=1 ; OPEN FROM THE BEGINNING OF THE XML
-        I $D(QOXPATH) D  ; XPATH PROVIDED
-        . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX
-        . S E1=$P(@QOXML@(QOXPATH),"^",2)-1
-        I '$D(QOXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
-        . S E1=@QOXML@(0)-1
-        D QUEUE(QOBLIST,QOXML,S1,E1)
-        ; S QOTMP=QOXML_"^"_S1_"^"_E1
-        ; D PUSH(QOBLIST,QOTMP)
-        Q
-        ;
-QCLOSE(QCBLIST,QCXML,QCXPATH)     ; CLOSE XML AFTER A QOPEN
-        ; ADDS THE LIST LINE OF QCXML TO QCBLIST
-        ; USED TO FINISH INSERTING CHILDERN NODES
-        ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END
-        ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO
-        I @QCXML@(0)<1 D  ; MALFORMED XML
-        . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,!
-        I $G(DEBUG) W "GOING TO CLOSE",!
-        N S1,E1,QCT,QCTMP
-        S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML
-        I $D(QCXPATH) D  ; XPATH PROVIDED
-        . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX
-        . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML
-        I '$D(QCXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
-        . S S1=@QCXML@(0)
-        D QUEUE(QCBLIST,QCXML,S1,E1)
-        ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1)
-        Q
-        ;
-INSERT(INSXML,INSNEW,INSXPATH)   ; INSERT INSNEW INTO INSXML AT THE
-        ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS
-        ; OMITTED, INSERTION WILL BE AT THE ROOT
-        ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW
-        ; XML AT THE END OF THE XPATH POINT
-        ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE
-        N INSBLD,INSTMP
-        I $G(DEBUG) W "DOING INSERT ",INSXML,INSNEW,INSXPATH,!
-        I $G(DEBUG) F G1=1:1:@INSXML@(0) W @INSXML@(G1),!
-        I '$D(@INSXML@(1)) D  ; INSERT INTO AN EMPTY ARRAY
-        . D CP^C0CXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT
-        I $D(@INSXML@(1)) D  ; IF ORIGINAL ARRAY IS NOT EMPTY
-        . I '$D(@INSXML@(0)) S @INSXML@(0)=$O(@INSXML@(""),-1) ;SET LENGTH
-        . I $D(INSXPATH) D  ; XPATH PROVIDED
-        . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE
-        . . I $G(DEBUG) D PARY^C0CXPATH("INSBLD")
-        . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
-        . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH
-        . I '$D(@INSNEW@(0)) S @INSNEW@(0)=$O(@INSNEW@(""),-1) ;SIZE OF XML
-        . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML
-        . I $D(INSXPATH) D  ; XPATH PROVIDED
-        . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH
-        . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
-        . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH
-        . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST
-        . D CP^C0CXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE
-        Q
-        ;
-INSINNER(INNXML,INNNEW,INNXPATH)               ; INSERT THE INNER XML OF INNNEW
-        ; INTO INNXML AT THE INNXPATH XPATH POINT
-        ;
-        N INNBLD,UXPATH
-        N INNTBUF
-        S INNTBUF=$NA(^TMP($J,"INNTBUF"))
-        I '$D(INNXPATH) D  ; XPATH NOT PASSED
-        . S UXPATH="//" ; USE ROOT XPATH
-        I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED
-        I '$D(@INNXML@(0)) D  ; INNXML IS EMPTY
-        . D QUEUE^C0CXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER
-        . D BUILD("INNBLD",INNXML)
-        I @INNXML@(0)>0  D  ; NOT EMPTY
-        . D QOPEN("INNBLD",INNXML,UXPATH) ;
-        . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML
-        . D QCLOSE("INNBLD",INNXML,UXPATH)
-        . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER
-        . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST
-        Q
-        ;
-INSB4(XDEST,XNEW)       ; INSERT XNEW AT THE BEGINNING OF XDEST
-        ; BUT XDEST AN XNEW ARE PASSED BY NAME
-        N XBLD,XTMP
-        D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT
-        D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST
-        D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION
-        D BUILD("XBLD","XTMP") ; BUILD THE RESULT
-        D CP("XTMP",XDEST) ; COPY TO THE DESTINATION
-        I $G(DEBUG) D PARY("XDEST")
-        Q
-        ;
-REPLACE(REXML,RENEW,REXPATH)       ; REPLACE THE XML AT THE XPATH POINT
-        ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE
-        ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE
-        ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD")
-        N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
-        S OLD=$NA(^TMP($J,"REPLACE_OLD"))
-        D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
-        S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
-        S XFIRST=$P(XNODE,"^",1)
-        S XLAST=$P(XNODE,"^",2)
-        I RENEW="" D  ; WE ARE DELETING A SECTION, MUST SAVE THE TAG
-        . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE
-        . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST
-        I RENEW'="" D  ; NEW XML IS NOT NULL
-        . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE
-        . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW
-        . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST
-        I $G(DEBUG) W "REPLACE PREBUILD",!
-        I $G(DEBUG) D PARY("REBLD")
-        D BUILD("REBLD","RTMP")
-        K @REXML ; KILL WHAT WAS THERE
-        D CP("RTMP",REXML) ; COPY IN THE RESULT
-        Q
-        ;
-DELETE(REXML,REXPATH)      ; DELETE THE XML AT THE XPATH POINT
-        ; REXML IS PASSED BY NAME XPATH IS A VALUE
-        N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
-        S OLD=$NA(^TMP($J,"REPLACE_OLD"))
-        D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
-        S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
-        S XFIRST=$P(XNODE,"^",1)
-        S XLAST=$P(XNODE,"^",2)
-        D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE
-        D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST
-        I $G(DEBUG) D PARY("REBLD")
-        D BUILD("REBLD","RTMP")
-        K @REXML ; KILL WHAT WAS THERE
-        D CP("RTMP",REXML) ; COPY IN THE RESULT
-        Q
-        ;
-MISSING(IXML,OARY)           ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY
-        ; W "Reporting on the missing",!
-        ; W OARY
-        I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q
-        N I
-        S @OARY@(0)=0 ; INITIALIZED MISSING COUNT
-        F I=1:1:@IXML@(0)  D   ; LOOP THROUGH WHOLE ARRAY
-        . I @IXML@(I)?.E1"@@".E D  ; MISSING VARIABLE HERE
-        . . D PUSH^C0CXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY
-        . . Q
-        Q
-        ;
-MAP(IXML,INARY,OXML)    ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY
-        ; AND PUT THE RESULTS IN OXML
-        N XCNT
-        I '$D(DEBUG) S DEBUG=0
-        I '$D(IXML) W "MALFORMED XML PASSED TO MAP",! Q
-        I '$D(@IXML@(0)) D  ; INITIALIZE COUNT
-        . S XCNT=$O(@IXML@(""),-1)
-        E  S XCNT=@IXML@(0) ;COUNT
-        I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q
-        N I,J,TNAM,TVAL,TSTR
-        S @OXML@(0)=XCNT ; TOTAL LINES IN OUTPUT
-        F I=1:1:XCNT  D   ; LOOP THROUGH WHOLE ARRAY
-        . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT
-        . I @OXML@(I)?.E1"@@".E D  ; IS THERE A VARIABLE HERE?
-        . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS
-        . . F J=2:2:10  D  Q:$P(@IXML@(I),"@@",J+2)=""  ; QUIT IF NO MORE VARS
-        . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,!
-        . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME
-        . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED
-        . . . I $D(@INARY@(TNAM))  D  ; IS THE VARIABLE IN THE MAP?
-        . . . . I '$D(@INARY@(TNAM,"F")) D  ; NOT A SPECIAL FIELD
-        . . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE
-        . . . . E  D DOFLD ; PROCESS A FIELD
-        . . . S TVAL=$$SYMENC^MXMLUTL(TVAL) ;MAKE SURE THE VALUE IS XML SAFE
-        . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER
-        . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES
-        . . I DEBUG W TSTR
-        I DEBUG W "MAPPED",!
-        Q
-        ;
-DOFLD   ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE
-        ;
-        Q
-        ;
-TRIM(THEXML)    ; TAKES OUT ALL NULL ELEMENTS
-        ; THEXML IS PASSED BY NAME
-        N I,J,TMPXML,DEL,FOUND,INTXT
-        S FOUND=0
-        S INTXT=0
-        I $G(DEBUG) W "DELETING EMPTY ELEMENTS",!
-        F I=1:1:(@THEXML@(0)-1) D  ; LOOP THROUGH ENTIRE ARRAY
-        . S J=@THEXML@(I)
-        . I J["<text>" D
-        . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM
-        . . I $G(DEBUG) W "IN HTML SECTION",!
-        . N JM,JP,JPX ; JMINUS AND JPLUS
-        . S JM=@THEXML@(I-1) ; LINE BEFORE
-        . I JM["</text>" S INTXT=0 ; LEFT HTML SECTION,START TRIM
-        . S JP=@THEXML@(I+1) ; LINE AFTER
-        . I INTXT=0 D  ; IF NOT IN AN HTML SECTION
-        . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH
-        . . I J=JPX D  ; AN EMPTY ELEMENT ON TWO LINES
-        . . . I $G(DEBUG) W I,J,JP,!
-        . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
-        . . . S DEL(I)="" ; SET LINE TO DELETE
-        . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE
-        . . I J["><" D  ; AN EMPTY ELEMENT ON ONE LINE
-        . . . I $G(DEBUG) W I,J,!
-        . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
-        . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED
-        . . . I JM=JPX D  ;
-        . . . . I $G(DEBUG) W I,JM_J_JPX,!
-        . . . . S DEL(I-1)=""
-        . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL
-        ; . I J'["><" D PUSH("TMPXML",J)
-        I FOUND D  ; NEED TO DELETE THINGS
-        . F I=1:1:@THEXML@(0) D  ; COPY ARRAY LEAVING OUT DELELTED LINES
-        . . I '$D(DEL(I)) D  ; IF THE LINE IS NOT DELETED
-        . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY
-        . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY
-        Q FOUND
-        ;
-UNMARK(XSEC)    ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML
-        ; XSEC IS A SECTION PASSED BY NAME
-        N XBLD,XTMP
-        D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML
-        D BUILD("XBLD","XTMP") ; BUILD THE RESULT
-        D CP("XTMP",XSEC) ; REPLACE PASSED XML
-        Q
-        ;
-PARY(GLO,ZN)          ;PRINT AN ARRAY
-        ; IF ZN=-1 NO LINE NUMBERS
-        N I
-        F I=1:1:@GLO@(0) D  ;
-        . I $G(ZN)=-1 W @GLO@(I),!
-        . E  W I_" "_@GLO@(I),!
-        Q
-        ;
-H2ARY(IARYRTN,IHASH,IPRE)       ; CONVERT IHASH TO RETURN ARRAY
-        ; IPRE IS OPTIONAL PREFIX FOR THE ELEMENTS. USED FOR MUPTIPLES 1^"VAR"^VALUE
-        I '$D(IPRE) S IPRE=""
-        N H2I S H2I=""
-        ; W $O(@IHASH@(H2I)),!
-        F  S H2I=$O(@IHASH@(H2I)) Q:H2I=""  D  ; FOR EACH ELEMENT OF THE HASH
-        . I $QS(H2I,$QL(H2I))="M" D  Q  ; SPECIAL CASE FOR MULTIPLES
-        . . ;W H2I_"^"_@IHASH@(H2I),!
-        . . N IH,IHI
-        . . S IH=$NA(@IHASH@(H2I)) ;
-        . . S IH2A=$O(@IH@("")) ; SKIP OVER MULTIPLE DISCRIPTOR
-        . . S IH2=$NA(@IH@(IH2A)) ; PAST THE "M","DIRETIONS" FOR EXAMPLE
-        . . S IHI="" ; INDEX INTO "M" MULTIPLES
-        . . F  S IHI=$O(@IH2@(IHI)) Q:IHI=""  D  ; FOR EACH SUB-MULTIPLE
-        . . . ; W @IH@(IHI)
-        . . . S IH3=$NA(@IH2@(IHI))
-        . . . ; W "HEY",IH3,!
-        . . . D H2ARY(.IARYRTN,IH3,IPRE_";"_IHI) ; RECURSIVE CALL - INDENTED ELEMENTS
-        . . ; W IH,!
-        . . ; W "C0CZZ",!
-        . . ; W $NA(@IHASH@(H2I)),!
-        . . Q  ;
-        . D PUSH(IARYRTN,IPRE_"^"_H2I_"^"_@IHASH@(H2I))
-        . ; W @IARYRTN@(0),!
-        Q
-        ;
-XVARS(XVRTN,XVIXML)     ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES
-        ; DEFINED IN INPUT XML XVIXML BY @@VAR@@
-        ; XVRTN AND XVIXML ARE PASSED BY NAME
-        ;
-        N XVI,XVTMP,XVT
-        F XVI=1:1:@XVIXML@(0) D  ; FOR ALL LINES OF THE XML
-        . S XVT=@XVIXML@(XVI)
-        . I XVT["@@" S XVTMP($P(XVT,"@@",2))=XVI
-        D H2ARY(XVRTN,"XVTMP")
-        Q
-        ;
-DXVARS(DXIN)    ;DISPLAY ALL VARIABLES IN A TEMPLATE
-        ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE
-        ;
-        N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED
-        I DXIN="CCR" D  ; NEED TO GO GET CCR TEMPLATE
-        . D LOAD^C0CCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP
-        . S DXUSE="DTMP" ; DXUSE IS NAME
-        E  I DXIN="CCD" D  ; NEED TO GO GET CCD TEMPLATE
-        . D LOAD^C0CCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP
-        . S DXUSE="DTMP" ; DXUSE IS NAME
-        E  S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE
-        N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE
-        D XVARS("DVARS",DXUSE) ; PULL OUT VARS
-        D PARY^C0CXPATH("DVARS") ;AND DISPLAY THEM
-        Q
-        ;
-TEST        ; Run all the test cases
-        D TESTALL^C0CUNIT("C0CXPAT0")
-        Q
-        ;
-ZTEST(WHICH)       ; RUN ONE SET OF TESTS
-        N ZTMP
-        S DEBUG=1
-        D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
-        D ZTEST^C0CUNIT(.ZTMP,WHICH)
-        Q
-        ;
-TLIST     ; LIST THE TESTS
-        N ZTMP
-        D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
-        D TLIST^C0CUNIT(.ZTMP)
-        Q
-        ;
+C0CXPATH   ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;Copyright 2008 George Lilly.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ W "This is an XML XPATH utility library",!
+ W !
+ Q
+ ;
+OUTPUT(OUTARY,OUTNAME,OUTDIR)   ; WRITE AN ARRAY TO A FILE
+ ;
+ N Y
+ S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME)
+ I Y Q 1_U_"WROTE FILE: "_OUTNAME_" TO "_OUTDIR
+ I 'Y Q 0_U_"ERROR WRITING FILE"_OUTNAME_" TO "_OUTDIR
+ Q
+ ;
+PUSH(STK,VAL)   ; pushs VAL onto STK and updates STK(0)
+ ;  VAL IS A STRING AND STK IS PASSED BY NAME
+ ;
+ I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE
+ S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH
+ S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY
+ Q
+ ;
+POP(STK,VAL)    ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL
+ ; VAL AND STK ARE PASSED BY REFERENCE
+ ;
+ I @STK@(0)<1 D  ; IF ARRAY IS EMPTY
+ . S VAL=""
+ . S @STK@(0)=0
+ I @STK@(0)>0  D  ;
+ . S VAL=@STK@(@STK@(0))
+ . K @STK@(@STK@(0))
+ . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY
+ Q
+ ;
+PUSHA(ADEST,ASRC) ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME
+ ;
+ N ZGI
+ F ZGI=1:1:@ASRC@(0) D  ; FOR ALL OF THE SOURCE ARRAY
+ . D PUSH(ADEST,@ASRC@(ZGI)) ; PUSH ONE ELEMENT
+ Q
+ ;
+MKMDX(STK,RTN,INREDUX)  ; MAKES A MUMPS INDEX FROM THE ARRAY STK
+ ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS
+ ; REDUX IS A STRING TO REMOVE FROM THE RESULT
+ S RTN=""
+ N I
+ ; W "STK= ",STK,!
+ I @STK@(0)>0  D  ; IF THE ARRAY IS NOT EMPTY
+ . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON
+ . I @STK@(0)>1  D  ; SUBSEQUENT ELEMENTS NEED A SEMICOLON
+ . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I)
+ I $G(INREDUX)'="" S RTN=$P(RTN,INREDUX,1)_$P(RTN,INREDUX,2)
+ Q
+ ;
+XNAME(ISTR)     ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG
+ ;  </NAME> AND <NAME ID=XNAME> WILL RETURN NAME
+ ; ISTR IS PASSED BY VALUE
+ N CUR,TMP
+ I ISTR?.E1"<".E  D  ; STRIP OFF LEFT BRACKET
+ . S TMP=$P(ISTR,"<",2)
+ I TMP?1"/".E  D  ; ALSO STRIP OFF SLASH IF PRESENT IE </NAME>
+ . S TMP=$P(TMP,"/",2)
+ S CUR=$P(TMP,">",1) ; EXTRACT THE NAME
+ ; W "CUR= ",CUR,!
+ I CUR?.1"_"1.A1" ".E  D  ; CONTAINS A BLANK IE NAME ID=TEST>
+ . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER
+ ; W "CUR2= ",CUR,!
+ Q CUR
+ ;
+XVAL(ISTR) ; EXTRACTS THE VALUE FROM A FRAGMENT OF XML
+ ; <NAME>VALUE</NAME> WILL RETURN VALUE
+ N G
+ S G=$P(ISTR,">",2) ;STRIP OFF <NAME>
+ Q $P(G,"<",1) ; STRIP OFF </NAME> LEAVING VALUE
+ ;
+VDX2VDV(OUTVDV,INVDX) ; CONVERT AN VDX ARRAY TO VDV
+ ; VDX: @INVDX@(XPATH)=VALUE
+ ; VDV: @OUTVDV@(X1X2X3X4)=VALUE
+ ; THE VDV DATANAMES MIGHT BE MORE CONVENIENT FOR USE IN CODE
+ ; AN INDEX IS PROVIDED TO GO BACK TO VDX FOR CONVERSIONS
+ ; @VDV@("XPATH",X1X2X3X4)="XPATH"
+ N ZA,ZI,ZW
+ S ZI=""
+ F  S ZI=$O(@INVDX@(ZI)) Q:ZI=""  D  ;
+ . S ZW=$TR(ZI,"/","") ; ELIMINATE ALL SLASHES - CAMEL CASE VARIABLE NAME
+ . W ZW,!
+ . S @OUTVDV@(ZW)=@INVDX@(ZI)
+ . S @OUTVDV@("XPATH",ZW)=ZI
+ Q
+ ;
+VDX2XPG(OUTXPG,INVDX) ; CONVERT AN VDX ARRAY TO XPG
+ ; VDX: @VDX@(XPATH)=VALUE
+ ; XPG: @(VDX(X1,X2,X3,X4))@=VALUE
+ ; THIS IS A STEP TOWARD GENERATING XML FROM A VDX
+ N ZA,ZI,ZW
+ S ZI=""
+ F  S ZI=$O(@INVDX@(ZI)) Q:ZI=""  D  ;
+ . S ZW=$E(ZI,3,$L(ZI)) ; STRIP OFF INITIAL //
+ . S ZW2=$P(ZW,"/",1)
+ . F ZK=1:1:$L(ZW,"/") D PUSH("ZA",$P(ZW,"/",ZK))
+ . ;ZWR ZA
+ . S ZW2=ZA(1)
+ . F ZK=2:1:ZA(0) D  ;
+ . . S ZW2=ZW2_""","""_ZA(ZK)
+ . K ZA
+ . S ZW2=""""_ZW2_""""
+ . W ZW2,!
+ . S ZN=OUTXPG_"("_ZW2_")"
+ . S @ZN=@INVDX@(ZI)
+ Q
+ ;
+XML2XPG(OUTXPG,INXML) ; CONVERT AN XML ARRAY, PASSED BY NAME TO AN XPG ARRAY
+ ; XPG MEANS XPATH GLOBAL AND HAS THE FORM @OUTXPG@("X1","X2","X3")=VALUE
+ ;
+ ;N G1
+ D INDEX(INXML,"G1",1) ; PRODUCES A VDX ARRAY IN G1, NO INDEX IS PRODUCED
+ D VDX2XPG(OUTXPG,"G1") ; CONVERTS THE VDX ARRAY TO XPG FORM
+ Q
+ ;
+DO 
+ D XPG2XML("^GPL2B","^GPL2A")
+ Q
+ ;
+T1 ; TEST OUT THESE ROUTINES 
+ D XML2XPG("G2","^GPL")
+ D XPG2XML("G3","G2")
+ K ^GPLOUT
+ M ^GPLOUT=G3
+ W $$OUTPUT^C0CXPATH("^GPLOUT(1)","GPLTEST.xml","/home/vademo2/EHR/p")
+ Q
+ ;
+XPG2XML(OUTXML,INXPG) ;
+ N C0CN,FWD,ZA,G,GA,ZQ
+ S ZQ=0 ; QUIT FLAG
+ F  Q:ZQ=1  D  ; LOOP THROUGH EVERYTHING
+ . I '$D(C0CN) D  ; FIRST TIME THROUGH
+ . . K @OUTXML ; MAKE SURE OUTPUT ARRAY IS CLEAR
+ . . S FWD=1 ; START OUT GOING FORWARD THROUGH SUBSCRIPTS
+ . . S G=$Q(@INXPG) ; THIS ONE
+ . . S GN=$Q(@G) ; NEXT ONE
+ . . S C0CN=1 ; SUBSCRIPT COUNT
+ . . S ZQ=0 ; QUIT FLAG
+ . . D ZXO("?xml version=""1.0"" encoding=""UTF-8""?") ;MAKE IT REAL XML
+ . . I $QS(G,1)="ContinuityOfCareRecord" D  ;
+ . . . D ZXO("?xml-stylesheet type=""text/xsl"" href=""ccr.xsl""?") ; HACK TO MAKE THE CCR STYLESHEET WORK
+ . I FWD D  ; GOING FORWARDS 
+ . . I C0CN<$QL(G) D  ; NOT A DATA NODE
+ . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT
+ . . . D ZXO(ZA) ; AND OPEN AN XML ELEMENT
+ . . . I @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord>" D  ;
+ . . . . S @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord xmlns=""urn:astm-org:CCR"">"
+ . . . S C0CN=C0CN+1 ; MOVE TO THE NEXT ONE
+ . . E  D  ; AT THE DATA NODE
+ . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT
+ . . . D ZXVAL(ZA,@G) ; OUTPUT <X>VAL</X> FOR DATA NODE
+ . . . S FWD=0 ; GO BACKWARDS
+ . I 'FWD D  ;GOING BACKWARDS
+ . . S GN=$Q(@G) ;NEXT XPATH
+ . . ;W "NEXT!",GN,!
+ . . S C0CN=C0CN-1 ; PREVIOUS SUBSCRIPT
+ . . I GN'="" D  ;
+ . . . I $QS(G,C0CN)'=$QS(GN,C0CN) D  ; NEED TO CLOSE OFF ELEMENT
+ . . . . D ZXC($QS(G,C0CN)) ;
+ . . . E  I GN'="" D  ; MORE ELEMENTS AT THIS LEVEL
+ . . . . S G=$Q(@G) ; ADVANCE TO NEW XPATH
+ . . . . S C0CN=C0CN+1 ; GET READY TO PROCESS NEXT SUBSCRIPT
+ . . . . S FWD=1 ; GOING FORWARD NOW
+ . I (GN="")&(C0CN=1) D  Q  ; WHEN WE ARE ALL DONE
+ . . D ZXC($QS(G,C0CN)) ; LAST ONE
+ . . S ZQ=1 ; QUIT NOW
+ Q
+ ;
+ZXO(WHAT) 
+ D PUSH("GA",WHAT)
+ D PUSH(OUTXML,"<"_WHAT_">")
+ Q
+ ;
+ZXC(WHAT) 
+ D POP("GA",.TMP)
+ D PUSH(OUTXML,"</"_WHAT_">")
+ Q
+ ;
+ZXVAL(WHAT,VAL) 
+ D PUSH(OUTXML,"<"_WHAT_">"_VAL_"</"_WHAT_">")
+ Q
+ ;
+INDEX(IZXML,VDX,NOINX,TEMPLATE,REDUX) ; parse XML in IZXML and produce 
+ ; an XPATH index; REDUX is a string to be removed from each xpath
+ ; GPL 7/14/09 OPTIONALLY GENERATE AN XML TEMPLATE IF PASSED BY NAME
+ ; TEMPLATE IS IDENTICAL TO THE PARSED XML LINE BY LINE
+ ; EXCEPT THAT DATA VALUES ARE REPLACED WITH @@XPATH@@ FOR THE XPATH OF THE TAG
+ ; GPL 5/24/09 AND OPTIONALLY PRODUCE THE VDX ARRAY PASSED BY NAME
+ ; @VDX@("XPATH")=VALUE
+ ; ex. @IZXML@("XPATH")=FIRSTLINE^LASTLINE
+ ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE
+ ; XML SECTION
+ ; IZXML IS PASSED BY NAME
+ ; IF NOINX IS SET TO 1, NO INDEX WILL BE GENERATED, BUT THE VDX WILL BE
+ N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND,CURVAL,DVDX,LCNT
+ N C0CSTK ; LEAVE OUT FOR DEBUGGING
+ I '$D(REDUX) S REDUX=""
+ I '$D(NOINX) S NOINX=0 ; IF NOT PASSED, GENERATE AN INDEX
+ N ZXML
+ I NOINX S ZXML=$NA(^TMP("C0CINDEX",$J)) ; TEMP PLACE FOR INDEX TO DISCARD
+ E  S ZXML=IZXML ; PLACE FOR INDEX TO KEEP
+ I '$D(@IZXML@(0)) D  ; IF COUNT NOT IN NODE 0 COUNT THEM
+ . S I="",LCNT=0
+ . F  S I=$O(@IZXML@(I)) Q:I=""  S LCNT=LCNT+1
+ E  S LCNT=@IZXML@(0) ; LINE COUNT PASSED IN ARRAY
+ I LCNT=0  D  Q  ; NO XML PASSED
+ . W "ERROR IN XML FILE",!
+ S DVDX=0 ; DEFAULT DO NOT PRODUCE VDX INDEX
+ I $D(VDX) S DVDX=1 ; IF NAME PASSED, DO VDX
+ S C0CSTK(0)=0 ; INITIALIZE STACK
+ K LKASD ; KILL LOOKASIDE ARRAY
+ D MKLASD(.LKASD,IZXML) ;MAKE LOOK ASIDE BUFFER FOR MULTIPLES
+ F I=1:1:LCNT  D  ; PROCESS THE ENTIRE ARRAY
+ . S LINE=@IZXML@(I)
+ . I $D(TEMPLATE) D  ;IF TEMPLATE IS REQUESTED
+ . . S @TEMPLATE@(I)=$$CLEAN(LINE) 
+ . ;W LINE,!
+ . S FOUND=0  ; INTIALIZED FOUND FLAG
+ . I LINE?.E1"<!".E S FOUND=1 ; SKIP OVER COMMENTS
+ . I FOUND'=1  D
+ . . I (LINE?.E1"<"1.E1"</".E)!(LINE?.E1"<"1.E1"/>".E)  D
+ . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS
+ . . . ; ON THE SAME LINE
+ . . . ; W "FOUND ",LINE,!
+ . . . S FOUND=1  ; SET FOUND FLAG
+ . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
+ . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES
+ . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK
+ . . . D MKMDX("C0CSTK",.MDX,REDUX) ; GENERATE THE M INDEX
+ . . . ; W "MDX=",MDX,!
+ . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
+ . . . . ;I '$D(ZDUP(MDX)) S ZDUP(MDX)=2
+ . . . . ;E  S ZDUP(MDX)=ZDUP(MDX)+1
+ . . . . ;W "DUP:",MDX,!
+ . . . . ;I '$D(CURVAL) S CURVAL=""
+ . . . . ;I DVDX S @VDX@(MDX_"["_ZDUP(MDX)_"]")=CURVAL
+ . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
+ . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
+ . . . . S @ZXML@(MDX)=I_"^"_I  ; ADD INDEX ENTRY-FIRST AND LAST
+ . . . . S CURVAL=$$XVAL(LINE) ; VALUE
+ . . . . S $P(@ZXML@(MDX),"^",3)=CURVAL ; THIRD PIECE
+ . . . . I DVDX S @VDX@(MDX)=CURVAL ; FILL IN VDX ARRAY IF REQUESTED
+ . . . . I $D(TEMPLATE) D  ; IF TEMPLATE IS REQUESTED
+ . . . . . S LINE=$$CLEAN(LINE) ; CLEAN OUT CONTROL CHARACTERS
+ . . . . . S @TEMPLATE@(I)=$P(LINE,">",1)_">@@"_MDX_"@@</"_$P(LINE,"</",2)
+ . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK
+ . I FOUND'=1  D  ; THE LINE DOESN'T CONTAIN THE START AND END
+ . . I LINE?.E1"</"1.E  D  ; LINE CONTAINS END OF A SECTION
+ . . . ; W "FOUND ",LINE,!
+ . . . S FOUND=1  ; SET FOUND FLAG
+ . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
+ . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX
+ . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
+ . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK
+ . . . S TMP=$P(TMP,"[",1) ; REMOVE [X] FROM MULTIPLE
+ . . . I TMP'=CUR  D  ; MALFORMED XML, END MUST MATCH START
+ . . . . W "MALFORMED XML ",CUR,"LINE "_I_LINE,!
+ . . . . D PARY("C0CSTK") ; PRINT OUT THE STACK FOR DEBUGING
+ . . . . Q
+ . I FOUND'=1  D  ; THE LINE MIGHT CONTAIN A SECTION BEGINNING
+ . . I (LINE?.E1"<"1.E)&(LINE'["?>")  D  ; BEGINNING OF A SECTION
+ . . . ; W "FOUND ",LINE,!
+ . . . S FOUND=1  ; SET FOUND FLAG
+ . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
+ . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES
+ . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK
+ . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX
+ . . . ; W "MDX=",MDX,!
+ . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
+ . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
+ . . . . ;B
+ . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
+ . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX
+ S @ZXML@("INDEXED")=""
+ S @ZXML@("//")="1^"_LCNT ; ROOT XPATH
+ I NOINX K @ZXML ; DELETE UNWANTED INDEX
+ Q
+ ;
+MKLASD(OUTBUF,INARY) ; CREATE A LOOKASIDE BUFFER FOR MULTILPLES
+ ;
+ N ZI,ZN,ZA,ZLINE,ZLINE2,CUR,CUR2
+ F ZI=1:1:LCNT-1  D  ; PROCESS THE ENTIRE ARRAY 
+ . S ZLINE=@IZXML@(ZI)
+ . I ZI<LCNT S ZLINE2=@IZXML@(ZI+1)
+ . I ZLINE?.E1"</"1.E  D  ; NEXT LINE CONTAINS END OF A SECTION
+ . . S CUR=$$XNAME(ZLINE) ; EXTRACT THE NAME
+ . . I (ZLINE2?.E1"<"1.E)&(ZLINE'["?>")  D  ; BEGINNING OF A SECTION
+ . . . S CUR2=$$XNAME(ZLINE2) ; EXTRACT THE NAME 
+ . . . I CUR=CUR2 D  ; IF THIS IS A MULTIPLE
+ . . . . S OUTBUF(CUR,ZI+1)=""
+ ;ZWR OUTBUF
+ S ZI=""
+ F  S ZI=$O(OUTBUF(ZI)) Q:ZI=""  D  ; FOR EACH KIND OF MULTIPLE
+ . S ZN=$O(OUTBUF(ZI,"")) ; LINE NUMBER OF SECOND MULTIPLE
+ . F  S ZN=$O(@IZXML@(ZN),-1) Q:ZN=""  I $E($P(@IZXML@(ZN),"<"_ZI,2),1,1)=">" Q  ;
+ . S OUTBUF(ZI,ZN)=""
+ S ZA=1,ZI="",ZN=""
+ F  S ZI=$O(OUTBUF(ZI)) Q:ZI=""  D  ; ADDING THE COUNT FOR THE MULIPLES [x]
+ . S ZN="",ZA=1
+ . F  S ZN=$O(OUTBUF(ZI,ZN)) Q:ZN=""  D  ;
+ . . S OUTBUF(ZI,ZN)="["_ZA_"]"
+ . . S ZA=ZA+1
+ Q
+ ;
+CLEAN(STR,TR) ; extrinsic function; returns string
+ ;; Removes all non printable characters from a string.
+ ;; STR by Value
+ ;; TR IS OPTIONAL TO IMPROVE PERFORMANCE
+ N TR,I
+ I '$D(TR) D  ;
+ . F I=0:1:31 S TR=$G(TR)_$C(I)
+ . S TR=TR_$C(127)
+ QUIT $TR(STR,TR)
+ ;
+QUERY(IARY,XPATH,OARY)  ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION
+ ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD"
+ ; IARY AND OARY ARE PASSED BY NAME
+ I '$D(@IARY@("INDEXED"))  D  ; INDEX IS NOT PRESENT IN IARY
+ . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML
+ N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN
+ N TMP,I,J,QXPATH
+ S FIRST=1
+ I '$D(@IARY@(0)) D  ; LINE COUNT NOT IN ZERO NODE
+ . S @IARY@(0)=$O(@IARY@("//"),-1) ; THIS SHOULD USUALLY WORK
+ S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT
+ I XPATH'="//" D  ; NOT A ROOT QUERY
+ . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES
+ . S FIRST=$P(TMP,"^",1)
+ . S LAST=$P(TMP,"^",2)
+ K @OARY
+ S @OARY@(0)=+LAST-FIRST+1
+ S J=1
+ FOR I=FIRST:1:LAST  D
+ . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY
+ . S J=J+1
+ ; ZWR OARY
+ Q
+ ;
+XF(IDX,XPATH)   ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH
+ ; INDEX WITH TWO PIECES START^FINISH
+ ; IDX IS PASSED BY NAME
+ Q $P(@IDX@(XPATH),"^",1)
+ ;
+XL(IDX,XPATH)   ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH
+ ; INDEX WITH TWO PIECES START^FINISH
+ ; IDX IS PASSED BY NAME
+ Q $P(@IDX@(XPATH),"^",2)
+ ;
+START(ISTR)     ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX
+ ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
+ ; COMPANION TO FINISH ; IDX IS PASSED BY NAME
+ Q $P(ISTR,";",2)
+ ;
+FINISH(ISTR)    ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX
+ ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
+ Q $P(ISTR,";",3)
+ ;
+ARRAY(ISTR)     ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX
+ ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
+ Q $P(ISTR,";",1)
+ ;
+BUILD(BLIST,BDEST)      ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST
+ ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST
+ ; DEST IS CLEARED TO START
+ ; USES PUSH TO DO THE COPY
+ N I
+ K @BDEST
+ F I=1:1:@BLIST@(0) D  ; FOR EACH INSTRUCTION IN BLIST
+ . N J,ATMP
+ . S ATMP=$$ARRAY(@BLIST@(I))
+ . I $G(DEBUG) W "ATMP=",ATMP,!
+ . I $G(DEBUG) W @BLIST@(I),!
+ . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D  ;
+ . . ; FOR EACH LINE IN THIS INSTR
+ . . I $G(DEBUG) W "BDEST= ",BDEST,!
+ . . I $G(DEBUG) W "ATMP= ",@ATMP@(J),!
+ . . D PUSH(BDEST,@ATMP@(J))
+ Q
+ ;
+QUEUE(BLST,ARRAY,FIRST,LAST)    ; ADD AN ENTRY TO A BLIST
+ ;
+ I $G(DEBUG) W "QUEUEING ",BLST,!
+ D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST)
+ Q
+ ;
+CP(CPSRC,CPDEST)        ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME
+ ; KILLS CPDEST FIRST
+ N CPINSTR
+ I $G(DEBUG) W "MADE IT TO COPY",CPSRC,CPDEST,!
+ I @CPSRC@(0)<1 D  ; BAD LENGTH
+ . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,!
+ . Q
+ ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT
+ D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY
+ D BUILD("CPINSTR",CPDEST)
+ Q
+ ;
+QOPEN(QOBLIST,QOXML,QOXPATH)    ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST
+ ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD
+ ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT
+ ; USED TO INSERT CHILDREN NODES
+ I @QOXML@(0)<1 D  ; MALFORMED XML
+ . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,!
+ . Q
+ I $G(DEBUG) W "DOING QOPEN",!
+ N S1,E1,QOT,QOTMP
+ S S1=1 ; OPEN FROM THE BEGINNING OF THE XML
+ I $D(QOXPATH) D  ; XPATH PROVIDED
+ . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX
+ . S E1=$P(@QOXML@(QOXPATH),"^",2)-1
+ I '$D(QOXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
+ . S E1=@QOXML@(0)-1
+ D QUEUE(QOBLIST,QOXML,S1,E1)
+ ; S QOTMP=QOXML_"^"_S1_"^"_E1
+ ; D PUSH(QOBLIST,QOTMP)
+ Q
+ ;
+QCLOSE(QCBLIST,QCXML,QCXPATH)   ; CLOSE XML AFTER A QOPEN
+ ; ADDS THE LIST LINE OF QCXML TO QCBLIST
+ ; USED TO FINISH INSERTING CHILDERN NODES
+ ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END
+ ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO
+ I @QCXML@(0)<1 D  ; MALFORMED XML
+ . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,!
+ I $G(DEBUG) W "GOING TO CLOSE",!
+ N S1,E1,QCT,QCTMP
+ S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML
+ I $D(QCXPATH) D  ; XPATH PROVIDED
+ . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX
+ . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML
+ I '$D(QCXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
+ . S S1=@QCXML@(0)
+ D QUEUE(QCBLIST,QCXML,S1,E1)
+ ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1)
+ Q
+ ;
+INSERT(INSXML,INSNEW,INSXPATH)  ; INSERT INSNEW INTO INSXML AT THE
+ ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS
+ ; OMITTED, INSERTION WILL BE AT THE ROOT
+ ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW
+ ; XML AT THE END OF THE XPATH POINT
+ ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE
+ N INSBLD,INSTMP
+ I $G(DEBUG) W "DOING INSERT ",INSXML,INSNEW,INSXPATH,!
+ I $G(DEBUG) F G1=1:1:@INSXML@(0) W @INSXML@(G1),!
+ I '$D(@INSXML@(1)) D  ; INSERT INTO AN EMPTY ARRAY
+ . D CP^C0CXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT
+ I $D(@INSXML@(1)) D  ; IF ORIGINAL ARRAY IS NOT EMPTY
+ . I '$D(@INSXML@(0)) S @INSXML@(0)=$O(@INSXML@(""),-1) ;SET LENGTH
+ . I $D(INSXPATH) D  ; XPATH PROVIDED
+ . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE
+ . . I $G(DEBUG) D PARY^C0CXPATH("INSBLD")
+ . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
+ . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH
+ . I '$D(@INSNEW@(0)) S @INSNEW@(0)=$O(@INSNEW@(""),-1) ;SIZE OF XML
+ . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML
+ . I $D(INSXPATH) D  ; XPATH PROVIDED
+ . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH
+ . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
+ . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH
+ . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST
+ . D CP^C0CXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE
+ Q
+ ;
+INSINNER(INNXML,INNNEW,INNXPATH)        ; INSERT THE INNER XML OF INNNEW
+ ; INTO INNXML AT THE INNXPATH XPATH POINT
+ ;
+ N INNBLD,UXPATH
+ N INNTBUF
+ S INNTBUF=$NA(^TMP($J,"INNTBUF"))
+ I '$D(INNXPATH) D  ; XPATH NOT PASSED
+ . S UXPATH="//" ; USE ROOT XPATH
+ I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED
+ I '$D(@INNXML@(0)) D  ; INNXML IS EMPTY
+ . D QUEUE^C0CXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER
+ . D BUILD("INNBLD",INNXML)
+ I @INNXML@(0)>0  D  ; NOT EMPTY
+ . D QOPEN("INNBLD",INNXML,UXPATH) ;
+ . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML
+ . D QCLOSE("INNBLD",INNXML,UXPATH)
+ . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER
+ . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST
+ Q
+ ;
+INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST
+ ; BUT XDEST AN XNEW ARE PASSED BY NAME
+ N XBLD,XTMP
+ D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT
+ D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST
+ D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION
+ D BUILD("XBLD","XTMP") ; BUILD THE RESULT
+ D CP("XTMP",XDEST) ; COPY TO THE DESTINATION
+ I $G(DEBUG) D PARY("XDEST")
+ Q
+ ;
+REPLACE(REXML,RENEW,REXPATH)    ; REPLACE THE XML AT THE XPATH POINT
+ ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE
+ ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE
+ ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD")
+ N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
+ S OLD=$NA(^TMP($J,"REPLACE_OLD"))
+ D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
+ S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
+ S XFIRST=$P(XNODE,"^",1)
+ S XLAST=$P(XNODE,"^",2)
+ I RENEW="" D  ; WE ARE DELETING A SECTION, MUST SAVE THE TAG
+ . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE
+ . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST
+ I RENEW'="" D  ; NEW XML IS NOT NULL
+ . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE
+ . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW
+ . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST
+ I $G(DEBUG) W "REPLACE PREBUILD",!
+ I $G(DEBUG) D PARY("REBLD")
+ D BUILD("REBLD","RTMP")
+ K @REXML ; KILL WHAT WAS THERE
+ D CP("RTMP",REXML) ; COPY IN THE RESULT
+ Q
+ ;
+DELETE(REXML,REXPATH)    ; DELETE THE XML AT THE XPATH POINT
+ ; REXML IS PASSED BY NAME XPATH IS A VALUE
+ N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
+ S OLD=$NA(^TMP($J,"REPLACE_OLD"))
+ D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
+ S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
+ S XFIRST=$P(XNODE,"^",1)
+ S XLAST=$P(XNODE,"^",2)
+ D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE
+ D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST
+ I $G(DEBUG) D PARY("REBLD")
+ D BUILD("REBLD","RTMP")
+ K @REXML ; KILL WHAT WAS THERE
+ D CP("RTMP",REXML) ; COPY IN THE RESULT
+ Q
+ ;
+MISSING(IXML,OARY)      ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY
+ ; W "Reporting on the missing",!
+ ; W OARY
+ I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q
+ N I
+ S @OARY@(0)=0 ; INITIALIZED MISSING COUNT
+ F I=1:1:@IXML@(0)  D   ; LOOP THROUGH WHOLE ARRAY
+ . I @IXML@(I)?.E1"@@".E D  ; MISSING VARIABLE HERE
+ . . D PUSH^C0CXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY
+ . . Q
+ Q
+ ;
+MAP(IXML,INARY,OXML) ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY
+ ; AND PUT THE RESULTS IN OXML
+ N XCNT
+ I '$D(DEBUG) S DEBUG=0
+ I '$D(IXML) W "MALFORMED XML PASSED TO MAP",! Q
+ I '$D(@IXML@(0)) D  ; INITIALIZE COUNT
+ . S XCNT=$O(@IXML@(""),-1)
+ E  S XCNT=@IXML@(0) ;COUNT
+ I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q
+ N I,J,TNAM,TVAL,TSTR
+ S @OXML@(0)=XCNT ; TOTAL LINES IN OUTPUT
+ F I=1:1:XCNT  D   ; LOOP THROUGH WHOLE ARRAY
+ . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT
+ . I @OXML@(I)?.E1"@@".E D  ; IS THERE A VARIABLE HERE?
+ . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS
+ . . F J=2:2:10  D  Q:$P(@IXML@(I),"@@",J+2)=""  ; QUIT IF NO MORE VARS
+ . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,!
+ . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME
+ . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED
+ . . . I $D(@INARY@(TNAM))  D  ; IS THE VARIABLE IN THE MAP?
+ . . . . I '$D(@INARY@(TNAM,"F")) D  ; NOT A SPECIAL FIELD
+ . . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE
+ . . . . E  D DOFLD ; PROCESS A FIELD
+ . . . S TVAL=$$SYMENC^MXMLUTL(TVAL) ;MAKE SURE THE VALUE IS XML SAFE
+ . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER
+ . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES
+ . . I DEBUG W TSTR
+ I DEBUG W "MAPPED",!
+ Q
+ ;
+DOFLD ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE
+ ;
+ Q
+ ;
+TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS
+ ; THEXML IS PASSED BY NAME
+ N I,J,TMPXML,DEL,FOUND,INTXT
+ S FOUND=0
+ S INTXT=0
+ I $G(DEBUG) W "DELETING EMPTY ELEMENTS",!
+ F I=1:1:(@THEXML@(0)-1) D  ; LOOP THROUGH ENTIRE ARRAY
+ . S J=@THEXML@(I)
+ . I J["<text>" D
+ . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM
+ . . I $G(DEBUG) W "IN HTML SECTION",!
+ . N JM,JP,JPX ; JMINUS AND JPLUS
+ . S JM=@THEXML@(I-1) ; LINE BEFORE
+ . I JM["</text>" S INTXT=0 ; LEFT HTML SECTION,START TRIM
+ . S JP=@THEXML@(I+1) ; LINE AFTER
+ . I INTXT=0 D  ; IF NOT IN AN HTML SECTION
+ . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH
+ . . I J=JPX D  ; AN EMPTY ELEMENT ON TWO LINES
+ . . . I $G(DEBUG) W I,J,JP,!
+ . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
+ . . . S DEL(I)="" ; SET LINE TO DELETE
+ . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE
+ . . I J["><" D  ; AN EMPTY ELEMENT ON ONE LINE
+ . . . I $G(DEBUG) W I,J,!
+ . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
+ . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED
+ . . . I JM=JPX D  ;
+ . . . . I $G(DEBUG) W I,JM_J_JPX,!
+ . . . . S DEL(I-1)=""
+ . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL
+ ; . I J'["><" D PUSH("TMPXML",J)
+ I FOUND D  ; NEED TO DELETE THINGS
+ . F I=1:1:@THEXML@(0) D  ; COPY ARRAY LEAVING OUT DELELTED LINES
+ . . I '$D(DEL(I)) D  ; IF THE LINE IS NOT DELETED
+ . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY
+ . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY
+ Q FOUND
+ ;
+UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML
+ ; XSEC IS A SECTION PASSED BY NAME
+ N XBLD,XTMP
+ D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML
+ D BUILD("XBLD","XTMP") ; BUILD THE RESULT
+ D CP("XTMP",XSEC) ; REPLACE PASSED XML
+ Q
+ ;
+PARY(GLO,ZN)       ;PRINT AN ARRAY
+ ; IF ZN=-1 NO LINE NUMBERS
+ N I
+ F I=1:1:@GLO@(0) D  ;
+ . I $G(ZN)=-1 W @GLO@(I),!
+ . E  W I_" "_@GLO@(I),!
+ Q
+ ;
+H2ARY(IARYRTN,IHASH,IPRE) ; CONVERT IHASH TO RETURN ARRAY
+ ; IPRE IS OPTIONAL PREFIX FOR THE ELEMENTS. USED FOR MUPTIPLES 1^"VAR"^VALUE
+ I '$D(IPRE) S IPRE=""
+ N H2I S H2I=""
+ ; W $O(@IHASH@(H2I)),!
+ F  S H2I=$O(@IHASH@(H2I)) Q:H2I=""  D  ; FOR EACH ELEMENT OF THE HASH
+ . I $QS(H2I,$QL(H2I))="M" D  Q  ; SPECIAL CASE FOR MULTIPLES
+ . . ;W H2I_"^"_@IHASH@(H2I),!
+ . . N IH,IHI
+ . . S IH=$NA(@IHASH@(H2I)) ;
+ . . S IH2A=$O(@IH@("")) ; SKIP OVER MULTIPLE DISCRIPTOR
+ . . S IH2=$NA(@IH@(IH2A)) ; PAST THE "M","DIRETIONS" FOR EXAMPLE
+ . . S IHI="" ; INDEX INTO "M" MULTIPLES
+ . . F  S IHI=$O(@IH2@(IHI)) Q:IHI=""  D  ; FOR EACH SUB-MULTIPLE
+ . . . ; W @IH@(IHI)
+ . . . S IH3=$NA(@IH2@(IHI))
+ . . . ; W "HEY",IH3,!
+ . . . D H2ARY(.IARYRTN,IH3,IPRE_";"_IHI) ; RECURSIVE CALL - INDENTED ELEMENTS
+ . . ; W IH,!
+ . . ; W "C0CZZ",!
+ . . ; W $NA(@IHASH@(H2I)),!
+ . . Q  ;
+ . D PUSH(IARYRTN,IPRE_"^"_H2I_"^"_@IHASH@(H2I))
+ . ; W @IARYRTN@(0),!
+ Q
+ ;
+XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES
+ ; DEFINED IN INPUT XML XVIXML BY @@VAR@@
+ ; XVRTN AND XVIXML ARE PASSED BY NAME
+ ;
+ N XVI,XVTMP,XVT
+ F XVI=1:1:@XVIXML@(0) D  ; FOR ALL LINES OF THE XML
+ . S XVT=@XVIXML@(XVI)
+ . I XVT["@@" S XVTMP($P(XVT,"@@",2))=XVI
+ D H2ARY(XVRTN,"XVTMP")
+ Q
+ ;
+DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE
+ ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE
+ ;
+ N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED
+ I DXIN="CCR" D  ; NEED TO GO GET CCR TEMPLATE
+ . D LOAD^C0CCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP
+ . S DXUSE="DTMP" ; DXUSE IS NAME
+ E  I DXIN="CCD" D  ; NEED TO GO GET CCD TEMPLATE
+ . D LOAD^C0CCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP
+ . S DXUSE="DTMP" ; DXUSE IS NAME
+ E  S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE
+ N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE
+ D XVARS("DVARS",DXUSE) ; PULL OUT VARS
+ D PARY^C0CXPATH("DVARS") ;AND DISPLAY THEM
+ Q
+ ;
+TEST     ; Run all the test cases
+ D TESTALL^C0CUNIT("C0CXPAT0")
+ Q
+ ;
+ZTEST(WHICH)    ; RUN ONE SET OF TESTS
+ N ZTMP
+ S DEBUG=1
+ D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
+ D ZTEST^C0CUNIT(.ZTMP,WHICH)
+ Q
+ ;
+TLIST   ; LIST THE TESTS
+ N ZTMP
+ D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
+ D TLIST^C0CUNIT(.ZTMP)
+ Q
+ ;