Changeset 1337

Timestamp:

Jan 4, 2012, 9:40:24 PM (13 years ago)

Author:

George Lilly

Message:

certification version without tabs

Location:

ccr/branches/ohum/p

Files:

• 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)
• C0CDIC.m (modified) (1 diff)
• C0CDOM.m (modified) (1 diff)
• C0CDPT.m (modified) (1 diff)
• C0CENC.m (modified) (1 diff)
• C0CENV.m (modified) (1 diff)
• C0CEVC.m (modified) (1 diff)
• C0CEWD.m (modified) (1 diff)
• C0CEWD1.m (modified) (1 diff)
• C0CFM1.m (modified) (1 diff)
• C0CFM2.m (modified) (1 diff)
• C0CFM3.m (modified) (1 diff)
• C0CIM2.m (modified) (1 diff)
• C0CIMMU.m (modified) (1 diff)
• C0CIN.m (modified) (1 diff)
• C0CLA7DD.m (modified) (1 diff)
• C0CLA7Q.m (modified) (1 diff)
• C0CLABS.m (modified) (1 diff)
• C0CMAIL.m (modified) (1 diff)
• C0CMAIL2.m (modified) (1 diff)
• C0CMAIL3.m (modified) (1 diff)
• C0CMCCD.m (modified) (1 diff)
• C0CMED.m (modified) (1 diff)
• C0CMED1.m (modified) (1 diff)
• C0CMED2.m (modified) (1 diff)
• C0CMED3.m (modified) (1 diff)
• C0CMED4.m (modified) (1 diff)
• C0CMED6.m (modified) (1 diff)
• C0CMIME.m (modified) (1 diff)
• C0CMXML.m (modified) (1 diff)
• C0CMXMLB.m (modified) (1 diff)
• C0CMXP.m (modified) (1 diff)
• C0CNHIN.m (modified) (1 diff)
• C0CNMED2.m (modified) (1 diff)
• C0CNMED4.m (modified) (1 diff)
• C0CORSLT.m (modified) (1 diff)
• C0CPARMS.m (modified) (1 diff)
• C0CPROBS.m (modified) (1 diff)
• C0CPROC.m (modified) (1 diff)
• C0CPXRM.m (modified) (1 diff)
• C0CQRY1.m (modified) (1 diff)
• C0CQRY2.m (modified) (1 diff)
• C0CRIMA.m (modified) (1 diff)
• C0CRNF.m (modified) (1 diff)
• C0CRNFRP.m (modified) (1 diff)
• C0CRPMS.m (modified) (1 diff)
• C0CRXN.m (modified) (1 diff)
• C0CRXNRD.m (modified) (1 diff)
• C0CSNOA.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) (1 diff)
• C0CVA200.m (modified) (1 diff)
• C0CVIT2.m (modified) (1 diff)
• C0CVITAL.m (modified) (1 diff)
• C0CVOBX1.m (modified) (1 diff)
• C0CVORU.m (modified) (1 diff)
• C0CXEWD.m (modified) (1 diff)
• C0CXPAT0.m (modified) (1 diff)
• C0CXPATH.m (modified) (1 diff)

ccr/branches/ohum/p/C0CACTOR.m

@@ -1 @@
-C0CACTOR         ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CALERT.m

@@ -1 @@
-C0CALERT         ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CBAT.m

@@ -1 @@
-C0CBAT    ; CCDCCR/GPL - CCR Batch utilities; 4/21/09
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CCCD.m

@@ -1 @@
-C0CCCD    ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CCCD1.m

@@ -1 @@
-C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CCCR.m

@@ -1 @@
-C0CCCR    ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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
-        ;OHUM/RUT 3120102 To take inputs from user for date limits and notes
-        D ^C0CVALID
-        ;OHUM/RUT
-        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
-        ;OHUM/RUT 3111228 Condition for Notes ; It should be included or not
-        I ^TMP("C0CCCR","TIULIMIT")'="" D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")")
-        ;OHUM/RUT
-        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/branches/ohum/p/C0CCCR0.m

@@ -1 @@
-C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CCMT.m

@@ -1 @@
-C0CCMT   ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10
-        ;;1.0;C0C;;May 21, 2010;Build 1
-        ;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/branches/ohum/p/C0CCPT.m

@@ -1 @@
-C0CCPT  ;;BSL;RETURN CPT DATA;
-        ;Sequence Managers Software GPL;;;;;Build 1
-        ;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
-        ;OHUM/RUT 3111228 Date Range for Notes
-               S STDT=^TMP("C0CCCR","TIULIMIT") D NOW^%DTC S ENDDT=X
-               ;OHUM/RUT
-               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/branches/ohum/p/C0CDIC.m

@@ -1 @@
-C0CDIC    ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08
-        ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
-        ;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 "This is the CCR Dictionary Utility Library ",!
-        W !
-        Q
-        ;
-DIC2CSV ;OUTPUT THE CCR DICTIONARY TO A CSV FILE
-        ;
-        N ZI
-        S ZI=""
-        S G1=$NA(^TMP($J,"C0CCSV",1))
-        S G1A=$NA(@G1@("V"))
-        S G2=$NA(^TMP($J,"C0CCSV",2))
-        D GETN2^C0CRNF(G1,170) ; GET THE MATRIX
-        F  S ZI=$O(@G1A@(ZI)) Q:ZI=""  D  ;FOR EACH ROW IN THE MATRIX
-        . I $G(@G1A@(ZI,"MAPPING METHOD",1))'="" D  ;
-        . . W @G1A@(ZI,"MAPPING METHOD",1),!
-        . . ;K @G1A@(ZI,"MAPPING METHOD")
-        . ;W !,ZI,$G(@G1A@(ZI,"MAPPING METHOD",1))
-        D RNF2CSV^C0CRNF(G2,G1,"VN") ; PREPARE THE CVS FILE
-        K @G1
-        D FILEOUT^C0CRNF(G2,"FILE_"_170_".csv")
-        K @G2
-        Q
-        ;
-GVARS(C0CVARS,C0CT)     ; Get the CCR variables from the CCR template
-        ; and return them in C0CVARS, which is passed by name
-        ; FIRST PIECE OF C0CVARS(x) IS THE VARIABLE NAME, SECOND PIECE
-        ; IS THE LINE NUMBER OF THE VARIABLE IN THE TEMPLATE
-        ; C0CT IS RETURNED AS THE CCR TEMPLATE
-        N C0CTVARS ; ARRAY FOR THE TEMPLATE AND ARRAY FOR THE VARS
-        D LOAD^GPLCCR0(C0CT) ; LOAD THE CCR TEMPLATE
-        D XVARS^GPLXPATH("C0CTVARS",C0CT) ; PULL OUT THE VARS
-        N C0CI,C0CX
-        S @C0CVARS@(0)=C0CTVARS(0) ; SAME COUNT
-        F C0CI=1:1:C0CTVARS(0) D  ; FOR EVERY LINE IN THE ARRAY
-        . S C0CX=C0CTVARS(C0CI) ; THE VARIABLE - 3 PIECES, FIRST ONE NULL
-        . S @C0CVARS@(C0CI)=$P(C0CX,"^",2)_"^"_$P(C0CX,"^",3) ; VAR NAME^LINE NUMBER
-        ;D PARY^GPLXPATH("C0CVARS")
-        Q
-        ;
-GXPATH(C0CPVARS,C0CPT)  ; LOAD THE CCR TEMPLATE INTO C0CPT, PULL OUT VARIABLES
-        ; AND THE XPATH TO THE VARIABLES INTO C0CPVARS
-        ; BY INDEXING THE TEMPLATE C0CT AND MATCHING THE XPATH TO THE VARIABLE
-        ; BOTH ARE PASSED BY NAME
-        ; C0CPVARS(x) IS VAR^LINENUM^XPATH SORTED BY LINENUM
-        ; C0CPVARS(0) IS NUMBER OF VARIABLES
-        ; C0CPT(0) IS NUMBER OF LINES IN THE TEMPLATE
-        D GVARS(C0CPVARS,C0CPT) ; GET THE VARIABLES AND LINE NUMBERS
-        ;N C0CTVARS ; HASH TABLE FOR VARIABLE BY LINE NUMBER
-        D HASHV ; PUT THE VARIABLES IN A LINE NUMBER HASH FOR MATCHING TO XPATHS
-        ; NOW GO GET THE XPATH INDEXES
-        D INDEX^GPLXPATH(C0CPT) ; ADD THE XPATH INDEXES TO THE TEMPLATE ARRAY
-        S C0CI="" ; GOING TO LOOP THROUGH THE WHOLE ARRAY LOOKING AT XPATHS
-        F  S C0CI=$O(@C0CPT@(C0CI)) Q:C0CI=""  D  ; VISIT EVERY LINE
-        . I +C0CI'=0 Q  ; SKIP EVERYTHING BUT THE XPATH INDEX
-        . I C0CI=0 Q  ; SKIP THE ZERO NODE
-        . S C0CX=@C0CPT@(C0CI) ; PULL OUT THE LINE NUMBERS X^Y
-        . S C0CY=$P(C0CX,"^",1) ; STARTING LINE NUMBER
-        . S C0CZ=$P(C0CX,"^",2) ; ENDING LINE NUMBER
-        . I C0CY=C0CZ D  ; THIS IS AN XPATH END NODE, HAS A VARIABLE (WE HOPE)
-        . . ; W "FOUND ",C0CI,!
-        . . I $D(C0CTVARS(C0CY)) D  ; IF THERE IS A VARIABLE THERE
-        . . . S $P(C0CTVARS(C0CY),"^",3)=C0CI ; INSERT THE XPATH FOR THE VAR
-        D SORTV ; SORT THE ARRAY BY LINE NUMBER
-        Q
-        ;
-HASHV   ; INTERNAL ROUTINE TO PUT VARIABLE NAMES IN A LINE NUMBER HASH
-        ;N C0CI,C0CTVARS,C0CX,C0CY
-        F C0CI=1:1:@C0CPVARS@(0) D  ; FOR THE ENTIRE ARRAY
-        . S C0CX=$P(@C0CPVARS@(C0CI),"^",2) ; LINE NUMBER
-        . S C0CY=$P(@C0CPVARS@(C0CI),"^",1) ; VARIABLE NAME
-        . S C0CTVARS(C0CX)=C0CY ; BUILD HASH OF VARIABLES BY LINE NUMBER
-        Q
-        ;
-SORTV   ; INTERNAL ROUTINE TO OUTPUT VARIABLES (AND XPATHS) IN LINE NUMBER ORDER
-        ;N C0CV2 ; SCRACTH SPACE FOR BUILDING SORTED ARRAY
-        S C0CI="" ;
-        F  S C0CI=$O(C0CTVARS(C0CI)) Q:C0CI=""  D  ; BY LINE NUMBER
-        . S C0CX=C0CTVARS(C0CI) ;VARIABLE NAME
-        . S $P(C0CX,"^",2)=C0CI ; LINE NUMBER IS SECOND PIECE
-        . D PUSH^GPLXPATH("C0C2",C0CX) ; PUT ONTO ARRAY
-        K @C0CPVARS
-        M @C0CPVARS=C0C2
-        Q
-        ;
-LOAD    ; LOAD VARIABLE NAMES AND XPATH IN ^C0CDIC(170
-        ; INITIAL LOAD OF THE CCR DICTIONARY
-        ;
-        N C0CDIC,C0CARY,C0CXML,C0CFDA,C0CI
-        S C0CDIC="^C0CDIC(170," ; ROOT OF THE CCR DICTIONARY
-        D GXPATH("C0CARY","C0CXML") ; FETCH THE VARIABLES AND XPATH INTO C0CARY
-        ; C0CXML WILL CONTAIN THE TEMPLATE - NOT NEEDED FOR LOAD
-        D PARY^GPLXPATH("C0CARY") ;TEST
-        F C0CI=1:1:C0CARY(0) D  ; LOAD EACH VARIABLE
-        . S C0CFDA(170,"+"_C0CI_",",.01)=$P(C0CARY(C0CI),"^",1) ; VAR NAME
-        . S C0CFDA(170,"+"_C0CI_",",2)=$P(C0CARY(C0CI),"^",3) ; XPATH
-        . D UPDATE^DIE("","C0CFDA")
-        . I $D(^TMP("DIERR",$J)) U $P BREAK
-        . W "LOADING:",C0CI," ",C0CARY(C0CI),!
-        Q
-        ;
-INIT    ; INITIALIZE CCR DICTIONARY BASED ON VARIABLE NAMES
-        ;
-        ; CHEAT SHEET FOR VARIABLE NAMES IN ^C0CDIC(170.xx,
-        ; THIS IS WHAT WILL BE IN C0CA FOR EACH DICTIONARY ENTRY
-        ;G1("CODING")="170^8"
-        ;G1("DATA ELEMENT")="170^7"
-        ;G1("DESCRIPTION")="170^3"
-        ;G1("ID")="170^1"
-        ;G1("M","170^8","CODING")="170.08^.01"
-        ;G1("MAPPING METHOD")="170.08^1"
-        ;G1("SECTION")="170^10"
-        ;G1("SOURCE")="170^4"
-        ;G1("STATUS")="170^9"
-        ;G1("TYPE")="170^6"
-        ;G1("VARIABLE")="170^.01"
-        ;G1("XPATH")="170^2"
-        ;
-        N C0CZA,C0CZX,C0CN,C0CSTAT
-        S C0CZX=0
-        S C0CSTAT=0 ; INIT STATUS SET FLAG
-        F  S C0CZX=$O(^C0CDIC(170,C0CZX)) Q:+C0CZX=0  D  ; FOR EACH DICT ENTRY
-        . ;W C0CZX,!
-        . K C0CA,C0CN ; CLEAR OUT THE LAST ONE
-        . D GETN1^C0CRNF("C0CA",170,C0CZX,"","ALL") ; GET VARIABLE HASH
-        . ;ZWR C0CA B ;
-        . S C0CN=$$ZVALUE("VARIABLE") ;NAME OF THE VARIABLE
-        . W "VARIABLE: ",C0CN,!
-        . I $E(C0CN,1,5)="ACTOR" D SETFDA("SECTION","ACTORS") ;
-        . I $E(C0CN,1,6)="SOCIAL" D  ;
-        . . D SETFDA("SECTION","SOC") ;
-        . . D SETFDA("STATUS","X") ;SOCIAL HISTORY NOT IMPLEMENTED
-        . . S C0CSTAT=1
-        . I $E(C0CN,1,6)="FAMILY" D  ;
-        . . D SETFDA("SECTION","FAM") ;
-        . . D SETFDA("STATUS","X") ;FAMILY HISTORY NOT IMPLEMENTED
-        . . S C0CSTAT=1
-        . ;D SETFDA("TYPE","") ;CORRECT FOR TYPE ERRORS
-        . I $E(C0CN,1,5)="ALERT" D SETFDA("SECTION","ALERTS")
-        . I $E(C0CN,1,5)="VITAL" D SETFDA("SECTION","VITALS")
-        . I $E(C0CN,1,7)="PROBLEM" D SETFDA("SECTION","PROBLEMS")
-        . I $E(C0CN,1,10)="RESULTTEST" D SETFDA("SECTION","TEST")
-        . E  I $E(C0CN,1,6)="RESULT" D SETFDA("SECTION","LABS")
-        . I C0CN["CODEVALUE" D SETFDA("TYPE","CD") ;CODES
-        . I C0CN["CODEVERSION" D SETFDA("TYPE","CV") ; CODE VERSION
-        . I C0CN["CODINGSYSTEM" D SETFDA("TYPE","CS") ;CODING SYSTEM
-        . I $$ZVALUE("STATUS")=""!'C0CSTAT D SETFDA("STATUS","N") ;BLANK STATUS TO N
-        . I $$ZVALUE("XPATH")["/Medication/Directions/" D  ; MEDS DIRECTIONS VAR
-        . . D SETFDA("SECTION","DIR") ; SPECIAL SECTION FOR DIRECTIONS
-        . E  I $$ZVALUE("XPATH")["/Medications/Medication/" D  ; ALL OTHER MEDS
-        . . D SETFDA("SECTION","MEDS") ; A MEDS VAR
-        . I $E(C0CN,($L(C0CN)-1),$L(C0CN))="ID" D SETFDA("TYPE","ID") ;CATCH THE IDS
-        . I C0CN["DATETIME" D SETFDA("TYPE","DT") ; DATE/TIME VARIABLE
-        . W "VARIABLE: ",C0CZX," ",C0CA("VARIABLE"),!
-        . ;ZWR C0CFDA
-        . I $D(C0CFDA) D  ; WE HAVE CHANGES ON THIS VARIABLE
-        . . ;ZWR C0CFDA
-        . . D UPDATE^DIE("","C0CFDA(C0CZX)")
-        . . I $D(^TMP("DIERR",$J)) U $P BREAK
-        . . D CLEAN^DILF ; CLEAN UP
-        . ;ZWR C0CFDA
-        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,"C0CA") ; FILE NUMBER
-        S C0CSJ=$$ZFIELD(C0CSN,"C0CA") ; FIELD NUMBER
-        S C0CFDA(C0CZX,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"
-        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 C0CA(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 C0CA(ZFN)
-        ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
-        I '$D(ZTAB) S ZTAB="C0CA"
-        Q $P(@ZTAB@(ZFN),"^",3)
-        ;
+C0CDIC   ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08
+ ;;0.1;CCDCCR;nopatch;noreleasedate
+ ;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 "This is the CCR Dictionary Utility Library ",!
+ W !
+ Q
+ ;
+DIC2CSV ;OUTPUT THE CCR DICTIONARY TO A CSV FILE
+ ;
+ N ZI
+ S ZI=""
+ S G1=$NA(^TMP($J,"C0CCSV",1))
+ S G1A=$NA(@G1@("V"))
+ S G2=$NA(^TMP($J,"C0CCSV",2))
+ D GETN2^C0CRNF(G1,170) ; GET THE MATRIX
+ F  S ZI=$O(@G1A@(ZI)) Q:ZI=""  D  ;FOR EACH ROW IN THE MATRIX
+ . I $G(@G1A@(ZI,"MAPPING METHOD",1))'="" D  ;
+ . . W @G1A@(ZI,"MAPPING METHOD",1),!
+ . . ;K @G1A@(ZI,"MAPPING METHOD")
+ . ;W !,ZI,$G(@G1A@(ZI,"MAPPING METHOD",1))
+ D RNF2CSV^C0CRNF(G2,G1,"VN") ; PREPARE THE CVS FILE
+ K @G1
+ D FILEOUT^C0CRNF(G2,"FILE_"_170_".csv")
+ K @G2
+ Q
+ ;
+GVARS(C0CVARS,C0CT) ; Get the CCR variables from the CCR template
+ ; and return them in C0CVARS, which is passed by name
+ ; FIRST PIECE OF C0CVARS(x) IS THE VARIABLE NAME, SECOND PIECE
+ ; IS THE LINE NUMBER OF THE VARIABLE IN THE TEMPLATE
+ ; C0CT IS RETURNED AS THE CCR TEMPLATE
+ N C0CTVARS ; ARRAY FOR THE TEMPLATE AND ARRAY FOR THE VARS
+ D LOAD^GPLCCR0(C0CT) ; LOAD THE CCR TEMPLATE
+ D XVARS^GPLXPATH("C0CTVARS",C0CT) ; PULL OUT THE VARS
+ N C0CI,C0CX
+ S @C0CVARS@(0)=C0CTVARS(0) ; SAME COUNT
+ F C0CI=1:1:C0CTVARS(0) D  ; FOR EVERY LINE IN THE ARRAY
+ . S C0CX=C0CTVARS(C0CI) ; THE VARIABLE - 3 PIECES, FIRST ONE NULL
+ . S @C0CVARS@(C0CI)=$P(C0CX,"^",2)_"^"_$P(C0CX,"^",3) ; VAR NAME^LINE NUMBER
+ ;D PARY^GPLXPATH("C0CVARS")
+ Q
+ ;
+GXPATH(C0CPVARS,C0CPT) ; LOAD THE CCR TEMPLATE INTO C0CPT, PULL OUT VARIABLES
+ ; AND THE XPATH TO THE VARIABLES INTO C0CPVARS
+ ; BY INDEXING THE TEMPLATE C0CT AND MATCHING THE XPATH TO THE VARIABLE
+ ; BOTH ARE PASSED BY NAME
+ ; C0CPVARS(x) IS VAR^LINENUM^XPATH SORTED BY LINENUM
+ ; C0CPVARS(0) IS NUMBER OF VARIABLES
+ ; C0CPT(0) IS NUMBER OF LINES IN THE TEMPLATE
+ D GVARS(C0CPVARS,C0CPT) ; GET THE VARIABLES AND LINE NUMBERS
+ ;N C0CTVARS ; HASH TABLE FOR VARIABLE BY LINE NUMBER
+ D HASHV ; PUT THE VARIABLES IN A LINE NUMBER HASH FOR MATCHING TO XPATHS
+ ; NOW GO GET THE XPATH INDEXES
+ D INDEX^GPLXPATH(C0CPT) ; ADD THE XPATH INDEXES TO THE TEMPLATE ARRAY
+ S C0CI="" ; GOING TO LOOP THROUGH THE WHOLE ARRAY LOOKING AT XPATHS
+ F  S C0CI=$O(@C0CPT@(C0CI)) Q:C0CI=""  D  ; VISIT EVERY LINE
+ . I +C0CI'=0 Q  ; SKIP EVERYTHING BUT THE XPATH INDEX
+ . I C0CI=0 Q  ; SKIP THE ZERO NODE
+ . S C0CX=@C0CPT@(C0CI) ; PULL OUT THE LINE NUMBERS X^Y
+ . S C0CY=$P(C0CX,"^",1) ; STARTING LINE NUMBER
+ . S C0CZ=$P(C0CX,"^",2) ; ENDING LINE NUMBER
+ . I C0CY=C0CZ D  ; THIS IS AN XPATH END NODE, HAS A VARIABLE (WE HOPE)
+ . . ; W "FOUND ",C0CI,!
+ . . I $D(C0CTVARS(C0CY)) D  ; IF THERE IS A VARIABLE THERE
+ . . . S $P(C0CTVARS(C0CY),"^",3)=C0CI ; INSERT THE XPATH FOR THE VAR
+ D SORTV ; SORT THE ARRAY BY LINE NUMBER
+ Q
+ ;
+HASHV ; INTERNAL ROUTINE TO PUT VARIABLE NAMES IN A LINE NUMBER HASH
+ ;N C0CI,C0CTVARS,C0CX,C0CY
+ F C0CI=1:1:@C0CPVARS@(0) D  ; FOR THE ENTIRE ARRAY
+ . S C0CX=$P(@C0CPVARS@(C0CI),"^",2) ; LINE NUMBER
+ . S C0CY=$P(@C0CPVARS@(C0CI),"^",1) ; VARIABLE NAME
+ . S C0CTVARS(C0CX)=C0CY ; BUILD HASH OF VARIABLES BY LINE NUMBER
+ Q
+ ;
+SORTV ; INTERNAL ROUTINE TO OUTPUT VARIABLES (AND XPATHS) IN LINE NUMBER ORDER
+ ;N C0CV2 ; SCRACTH SPACE FOR BUILDING SORTED ARRAY
+ S C0CI="" ;
+ F  S C0CI=$O(C0CTVARS(C0CI)) Q:C0CI=""  D  ; BY LINE NUMBER
+ . S C0CX=C0CTVARS(C0CI) ;VARIABLE NAME
+ . S $P(C0CX,"^",2)=C0CI ; LINE NUMBER IS SECOND PIECE
+ . D PUSH^GPLXPATH("C0C2",C0CX) ; PUT ONTO ARRAY
+ K @C0CPVARS
+ M @C0CPVARS=C0C2
+ Q
+ ;
+LOAD ; LOAD VARIABLE NAMES AND XPATH IN ^C0CDIC(170
+ ; INITIAL LOAD OF THE CCR DICTIONARY
+ ;
+ N C0CDIC,C0CARY,C0CXML,C0CFDA,C0CI
+ S C0CDIC="^C0CDIC(170," ; ROOT OF THE CCR DICTIONARY
+ D GXPATH("C0CARY","C0CXML") ; FETCH THE VARIABLES AND XPATH INTO C0CARY
+ ; C0CXML WILL CONTAIN THE TEMPLATE - NOT NEEDED FOR LOAD
+ D PARY^GPLXPATH("C0CARY") ;TEST
+ F C0CI=1:1:C0CARY(0) D  ; LOAD EACH VARIABLE
+ . S C0CFDA(170,"+"_C0CI_",",.01)=$P(C0CARY(C0CI),"^",1) ; VAR NAME
+ . S C0CFDA(170,"+"_C0CI_",",2)=$P(C0CARY(C0CI),"^",3) ; XPATH
+ . D UPDATE^DIE("","C0CFDA")
+ . I $D(^TMP("DIERR",$J)) U $P BREAK
+ . W "LOADING:",C0CI," ",C0CARY(C0CI),!
+ Q
+ ;
+INIT ; INITIALIZE CCR DICTIONARY BASED ON VARIABLE NAMES
+ ;
+ ; CHEAT SHEET FOR VARIABLE NAMES IN ^C0CDIC(170.xx,
+ ; THIS IS WHAT WILL BE IN C0CA FOR EACH DICTIONARY ENTRY
+ ;G1("CODING")="170^8"
+ ;G1("DATA ELEMENT")="170^7"
+ ;G1("DESCRIPTION")="170^3"
+ ;G1("ID")="170^1"
+ ;G1("M","170^8","CODING")="170.08^.01"
+ ;G1("MAPPING METHOD")="170.08^1"
+ ;G1("SECTION")="170^10"
+ ;G1("SOURCE")="170^4"
+ ;G1("STATUS")="170^9"
+ ;G1("TYPE")="170^6"
+ ;G1("VARIABLE")="170^.01"
+ ;G1("XPATH")="170^2"
+ ;
+ N C0CZA,C0CZX,C0CN,C0CSTAT
+ S C0CZX=0
+ S C0CSTAT=0 ; INIT STATUS SET FLAG
+ F  S C0CZX=$O(^C0CDIC(170,C0CZX)) Q:+C0CZX=0  D  ; FOR EACH DICT ENTRY
+ . ;W C0CZX,!
+ . K C0CA,C0CN ; CLEAR OUT THE LAST ONE
+ . D GETN1^C0CRNF("C0CA",170,C0CZX,"","ALL") ; GET VARIABLE HASH
+ . ;ZWR C0CA B ;
+ . S C0CN=$$ZVALUE("VARIABLE") ;NAME OF THE VARIABLE
+ . W "VARIABLE: ",C0CN,!
+ . I $E(C0CN,1,5)="ACTOR" D SETFDA("SECTION","ACTORS") ;
+ . I $E(C0CN,1,6)="SOCIAL" D  ;
+ . . D SETFDA("SECTION","SOC") ;
+ . . D SETFDA("STATUS","X") ;SOCIAL HISTORY NOT IMPLEMENTED
+ . . S C0CSTAT=1
+ . I $E(C0CN,1,6)="FAMILY" D  ;
+ . . D SETFDA("SECTION","FAM") ;
+ . . D SETFDA("STATUS","X") ;FAMILY HISTORY NOT IMPLEMENTED
+ . . S C0CSTAT=1
+ . ;D SETFDA("TYPE","") ;CORRECT FOR TYPE ERRORS
+ . I $E(C0CN,1,5)="ALERT" D SETFDA("SECTION","ALERTS")
+ . I $E(C0CN,1,5)="VITAL" D SETFDA("SECTION","VITALS")
+ . I $E(C0CN,1,7)="PROBLEM" D SETFDA("SECTION","PROBLEMS")
+ . I $E(C0CN,1,10)="RESULTTEST" D SETFDA("SECTION","TEST")
+ . E  I $E(C0CN,1,6)="RESULT" D SETFDA("SECTION","LABS")
+ . I C0CN["CODEVALUE" D SETFDA("TYPE","CD") ;CODES
+ . I C0CN["CODEVERSION" D SETFDA("TYPE","CV") ; CODE VERSION
+ . I C0CN["CODINGSYSTEM" D SETFDA("TYPE","CS") ;CODING SYSTEM
+ . I $$ZVALUE("STATUS")=""!'C0CSTAT D SETFDA("STATUS","N") ;BLANK STATUS TO N
+ . I $$ZVALUE("XPATH")["/Medication/Directions/" D  ; MEDS DIRECTIONS VAR
+ . . D SETFDA("SECTION","DIR") ; SPECIAL SECTION FOR DIRECTIONS
+ . E  I $$ZVALUE("XPATH")["/Medications/Medication/" D  ; ALL OTHER MEDS
+ . . D SETFDA("SECTION","MEDS") ; A MEDS VAR
+ . I $E(C0CN,($L(C0CN)-1),$L(C0CN))="ID" D SETFDA("TYPE","ID") ;CATCH THE IDS
+ . I C0CN["DATETIME" D SETFDA("TYPE","DT") ; DATE/TIME VARIABLE
+ . W "VARIABLE: ",C0CZX," ",C0CA("VARIABLE"),!
+ . ;ZWR C0CFDA
+ . I $D(C0CFDA) D  ; WE HAVE CHANGES ON THIS VARIABLE
+ . . ;ZWR C0CFDA
+ . . D UPDATE^DIE("","C0CFDA(C0CZX)")
+ . . I $D(^TMP("DIERR",$J)) U $P BREAK
+ . . D CLEAN^DILF ; CLEAN UP
+ . ;ZWR C0CFDA
+ 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,"C0CA") ; FILE NUMBER
+ S C0CSJ=$$ZFIELD(C0CSN,"C0CA") ; FIELD NUMBER
+ S C0CFDA(C0CZX,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"
+ 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 C0CA(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 C0CA(ZFN)
+ ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA
+ I '$D(ZTAB) S ZTAB="C0CA"
+ Q $P(@ZTAB@(ZFN),"^",3)
+ ;

ccr/branches/ohum/p/C0CDOM.m

@@ -1 @@
-C0CDOM    ; GPL - DOM PROCESSING ROUTINES ;6/6/11  17:05
-        ;;0.1;C0C;nopatch;noreleasedate;Build 1
-        ;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
-        ;
-DOMO(ZOID,ZPATH,ZNARY,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,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY
-        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 GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE
-        I $D(GA) D  ; PROCESS THE ATTRIBUTES
-        . N ZI S ZI=""
-        . F  S ZI=$O(GA(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
-        . . N ZP S ZP=NEWPATH_"@"_ZI ; PATH FOR ATTRIBUTE
-        . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY
-        . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE
-        N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
-        I $D(GD(2)) D  ;
-        . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
-        E  I $D(GD(1)) D  ;
-        . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
-        . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN 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 DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; 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 DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
-        . E  D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB
-        Q
-        ;
-ADDNARY(ZXP,ZVALUE)     ; ADD AN NHIN ARRAY VALUE TO ZNARY
-        ;
-        ; IF ZATT=1 THE ARRAY IS ADDED AS ATTRIBUTES
-        ;
-        N ZZI,ZZJ,ZZN
-        S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY
-        I ZZI="" Q  ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE
-        S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY
-        S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH .
-        I ZZI'["]" D  ; A SINGLETON
-        . S ZZN=1
-        E  D  ; THERE IS AN [x] OCCURANCE
-        . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE
-        . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X]
-        I ZZJ'="" D  ; TIME TO ADD THE VALUE
-        . S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE
-        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,NO1ST) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM
-        ;
-        S C0CDOCID=INID
-        I '$D(NO1ST) S NO1ST=0 ; DO NOT SURPRESS THE <?xml tag generation
-        D START^C0CMXMLB($$TAG(1),,"G",NO1ST)
-        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
-        ;
-WNHIN(ZDFN)     ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE
-        ;
-        N GN,GN2
-        D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML
-        S GN2=$NA(@GN@(1))
-        W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/")
-        Q
-        ;
-NARY2XML(ZGOUT,ZGIN)    ; CREATE XML FROM AN NHIN ARRAY
-        ; ZGOUT AND ZGIN ARE PASSED BY NAME
-        N C0CDOCID
-        W !,ZGOUT," ",ZGIN
-        S C0CDOCID=$$DOMI(ZGIN) ; PUT IT INTO THE DOM
-        D OUTXML(ZGOUT,C0CDOCID)
-        Q
-        ;
-        ; EXAMPLE OF NHIN ARRAY FORMAT - THIS IS AN OUTPUT OF DOMO ABOVE WHEN RUN
-        ; AGAINST THE OUTPUT OF THE GET^NHINV ROUTINE. (THIS IS NOT REAL PATIENT DATA)
-        ;
-        ;GNARY("med",1,"doses.dose@dose")=10
-        ;GNARY("med",1,"doses.dose@noun")="TABLET"
-        ;GNARY("med",1,"doses.dose@route")="PO"
-        ;GNARY("med",1,"doses.dose@schedule")="QD"
-        ;GNARY("med",1,"doses.dose@units")="MG"
-        ;GNARY("med",1,"doses.dose@unitsPerDose")=1
-        ;GNARY("med",1,"facility@code")=100
-        ;GNARY("med",1,"facility@name")="VOE OFFICE INSTITUTION"
-        ;GNARY("med",1,"form@value")="TAB"
-        ;GNARY("med",1,"id@value")="1N;O"
-        ;GNARY("med",1,"location@code")=5
-        ;GNARY("med",1,"location@name")="3 WEST"
-        ;GNARY("med",1,"name@value")="LISINOPRIL TAB"
-        ;GNARY("med",1,"orderID@value")=294
-        ;GNARY("med",1,"ordered@value")=3110531.001233
-        ;GNARY("med",1,"orderingProvider@code")=63
-        ;GNARY("med",1,"orderingProvider@name")="KING,MATTHEW MICHAEL"
-        ;GNARY("med",1,"products.product.class@code")="ACE INHIBITORS"
-        ;GNARY("med",1,"products.product.vaGeneric@code")=1990
-        ;GNARY("med",1,"products.product.vaGeneric@name")="LISINOPRIL"
-        ;GNARY("med",1,"products.product.vaGeneric@vuid")=4019380
-        ;GNARY("med",1,"products.product.vaProduct@code")=8118
-        ;GNARY("med",1,"products.product.vaProduct@name")="LISINOPRIL 10MG TAB"
-        ;GNARY("med",1,"products.product.vaProduct@vuid")=4008593
-        ;GNARY("med",1,"products.product@code")=6174
-        ;GNARY("med",1,"products.product@name")="LISINOPRIL 10MG U/D"
-        ;GNARY("med",1,"products.product@role")="D"
-        ;GNARY("med",1,"sig")="10MG BY MOUTH EVERY DAY"
-        ;GNARY("med",1,"sig@xml:space")="preserve"
-        ;GNARY("med",1,"status@value")="active"
-        ;GNARY("med",1,"type@value")="OTC"
-        ;GNARY("med",1,"vaType@value")="N"
-        ;
-        ; DOMI is an extrinsic to insert NHIN ARRAY FORMAT arrays into the DOM
-        ; it returns 0 or 1 based on success.
-        ;
-        ; INARY is passed by name and has the format shown above
-        ; HANDLE is the document number in the DOM (both MXML and EWD DOMs will
-        ; be supported eventually - initial implementation is for MXML
-        ;
-        ; PARENT is the node id or tag of the parent under which the DOM will
-        ; be populated. If it is numeric, it is a node. If it is a string, the DOM
-        ; will be searched to find the tag. If not found and there is no root,
-        ; it will be inserted as the root. If not found and there is a root, it
-        ; will be inserted under the root.
-        ;
-        ; For the above example the call would be OK=$$DOMI("GNARY",0,"results")
-        ; because "results" is the root tag. Use OUTXML to render the xml from
-        ; the DOM.
-        ;
-DOMI(INARY,HANDLE,PARENT)       ; EXTRINSIC TO INSERT NHIN ARRAYS TO A DOM
-        ;
-        N ZPARNODE
-        S (SUCCESS,LEVEL,LEVEL(0),NODE)=0
-        I '$D(INARY) Q 0 ; NO ARRAY PASSED
-        I '$D(HANDLE) S HANDLE=$$NEWDOM() ; MAKE A NEW DOM
-        ;I PARENT="" S PARENT="root"
-        I +$G(PARENT)>0 S ZPARNODE=PARENT ; WE HAVE BEEN PASSED A PARENT NODE ID
-        E  I $L($G(PARENT))>0 D  ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL
-        . D STARTELE^MXMLDOM(PARENT) ; INSERT THE PARENT NODE
-        . S ZPARNODE=1 ;
-        ; WE NOW HAVE A HANDLE AND A PARENT NODE AND LEVEL HAS BEEN SET
-        N ZEXARY
-        D EXPAND("ZEXARY",INARY) ; EXPAND THE NHIN ARRAY
-        D MAJOR("ZEXARY") ; PROCESS ALL THE NODES TO BE ADDED
-        I $L($G(PARENT))>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE
-        Q HANDLE ; SUCCESS
-        ; 
-MAJOR(ZARY)     ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES
-        N ZI S ZI=""
-        N ZTAG
-        F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH SECTION
-        . N ZELEADD S ZELEADD=0
-        . I ZI["@" D  ; END NODE HAS NO VALUE, ONLY ATTRIBUTES
-        . . S ZTAG=$P(ZI,"@",1) ; PULL OUT THE TAG
-        . . K ZATT ; CLEAR OUT LAST ONE
-        . . M ZATT=@ZARY@(ZI,1) ; GET ATTRIBUTE ARRAY
-        . . D STARTELE^MXMLDOM(ZTAG,.ZATT) ; ADD THE NODE
-        . . S ZELEADD=1 ; FLAG TO NOT ADD THE ELEMENT TWICE
-        . I $O(@ZARY@(ZI,""))="" D  ;END NODE
-        . . S ZTAG=ZI ; USE ZI FOR THE TAG
-        . . I 'ZELEADD D STARTELE^MXMLDOM(ZTAG) ; ADD ELEMENT IF NOT THERE
-        . . S ZELEADD=1 ; ADDED AN ELEMENT
-        . . D CHAR^MXMLDOM($G(@ZARY@(ZI))) ; INSERT THE VALUE
-        . I ZELEADD D  Q  ; NO MORE TO DO ON THIS LEVEL
-        . . D ENDELE^MXMLDOM(ZTAG) ; CLOSE THE ELEMENT BEFORE LEAVING
-        . N NEWARY ; INDENTED ARRAY
-        . N ZN S ZN=0
-        . F  S ZN=$O(@ZARY@(ZI,ZN)) Q:ZN=""  D  ; FOR EACH MULTIPLE
-        . . D STARTELE^MXMLDOM(ZI) ; ADD THE INTERMEDIATE TAG
-        . . S NEWARY=$NA(@ZARY@(ZI,ZN)) ; INDENT THE ARRAY
-        . . D MAJOR(NEWARY) ; RECURSE FOR INDENTED ARRAY
-        . . D ENDELE^MXMLDOM(ZI) ; END THE INTERMEDIATE TAG
-        Q
-        ;
-EXPAND(ZZOUT,ZZIN)      ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED 
-        ; CONSISTENT FORMAT
-        ; GNARY("patient",1,"facilities[2].facility@code")="050"
-        ; becomes G2ARY("patient",1,"facilities",2,"facility@",1,"code")="050"
-        ; for easier processing (this is fileman format genius)
-        ; basically removes the dot notation from the strings
-        ;
-        N ZZI
-        S ZZI=""
-        F  S ZZI=$O(@ZZIN@(ZZI)) Q:ZZI=""  D  ;
-        . N ZZN S ZZN=0
-        . F  S ZZN=$O(@ZZIN@(ZZI,ZZN)) Q:ZZN=""  D  ;
-        . . N ZZS S ZZS=""
-        . . N GA ;PUSH STACK
-        . . F  S ZZS=$O(@ZZIN@(ZZI,ZZN,ZZS)) Q:ZZS=""  D  ;
-        . . . K GA ; NEW STACK
-        . . . D PUSH^C0CXPATH("GA",ZZI_"^"_ZZN) ; PUSH PARENT
-        . . . N ZZV ; PLACE TO STASH THE VALUE
-        . . . S ZZV=@ZZIN@(ZZI,ZZN,ZZS) ; VALUE
-        . . . W !,"VALUE:",ZZV
-        . . . N GK ; COUNTER
-        . . . F GK=1:1:$L(ZZS,".") D  ; FOR EACH INTERMEDIATE NODE
-        . . . . N ZZN2 S ZZN2=1 ; DEFAULT IF NO [X]
-        . . . . N GM S GM=$P(ZZS,".",GK) ; TAG
-        . . . . I GM["[" D  ; IT'S A MULTIPLE
-        . . . . . S ZZN2=$P($P(GM,"[",2),"]",1) ; PULL OUT THE NUMBER
-        . . . . . S GM=$P(GM,"[",1) ; PULL OUT THE TAG
-        . . . . I GM["@" D  ; IT'S GOT ATTRIBUTES
-        . . . . . N GM2 S GM2=$P(GM,"@",2) ; PULLOUT THE ATTRIBUTE NAME
-        . . . . . D PUSH^C0CXPATH("GA",$P(GM,"@",1)_"@"_"^"_ZZN2) ; PUSH THE TAG
-        . . . . . D PUSH^C0CXPATH("GA",GM2_"^"_ZZN2)
-        . . . . E  D PUSH^C0CXPATH("GA",GM_"^"_ZZN2) ;
-        . . . S GA(GA(0))=$P(GA(GA(0)),"^",1)_"^" ; GET RID OF THE LAST "1" 
-        . . . N GZI S GZI="" ; STRING FOR THE INDEX
-        . . . F GK=1:1:GA(0) D  ; TIME TO REVERSE POP THE TAGS
-        . . . . S GM=$P(GA(GK),"^",1) ; THE TAG
-        . . . . S ZZN2=$P(GA(GK),"^",2) ; THE NUMBER IF ANY
-        . . . . I ZZN2="" S GZI=GZI_""""_GM_"""" ; FOR THE LAST ONE
-        . . . . E  S GZI=GZI_""""_GM_""""_","_ZZN2_"," ; FOR THE REST
-        . . . S GZI2=ZZOUT_"("_GZI_")" ; INCLUDE THE ARRAY NAME
-        . . . W !,GZI
-        . . . S @GZI2=ZZV ; REMEMBER THE VALUE?
-        Q
-        ;
-NEWDOM()        ; extrinsic which creates a new DOM and returns the HANDLE
-        N CBK,SUCCESS,LEVEL,NODE,HANDLE
-        K ^TMP("MXMLERR",$J)
-        L +^TMP("MXMLDOM",$J):5
-        E  Q 0
-        S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)=""
-        L -^TMP("MXMLDOM",$J)
-        Q HANDLE
-        ;
+C0CDOM   ; GPL - DOM PROCESSING ROUTINES ;6/6/11  17:05
+ ;;0.1;C0C;nopatch;noreleasedate;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.
+ ;
+ Q
+ ;
+DOMO(ZOID,ZPATH,ZNARY,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,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY
+ 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 GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE
+ I $D(GA) D  ; PROCESS THE ATTRIBUTES
+ . N ZI S ZI=""
+ . F  S ZI=$O(GA(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
+ . . N ZP S ZP=NEWPATH_"@"_ZI ; PATH FOR ATTRIBUTE
+ . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY
+ . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE
+ N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
+ I $D(GD(2)) D  ;
+ . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
+ E  I $D(GD(1)) D  ;
+ . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
+ . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN 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 DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; 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 DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
+ . E  D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB
+ Q
+ ;
+ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY
+ ;
+ ; IF ZATT=1 THE ARRAY IS ADDED AS ATTRIBUTES
+ ;
+ N ZZI,ZZJ,ZZN
+ S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY
+ I ZZI="" Q  ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE
+ S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY
+ S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH .
+ I ZZI'["]" D  ; A SINGLETON
+ . S ZZN=1
+ E  D  ; THERE IS AN [x] OCCURANCE
+ . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE
+ . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X]
+ I ZZJ'="" D  ; TIME TO ADD THE VALUE
+ . S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE
+ 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,NO1ST) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM
+ ;
+ S C0CDOCID=INID
+ I '$D(NO1ST) S NO1ST=0 ; DO NOT SURPRESS THE <?xml tag generation
+ D START^C0CMXMLB($$TAG(1),,"G",NO1ST)
+ 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
+ ;
+WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE
+ ;
+ N GN,GN2
+ D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML
+ S GN2=$NA(@GN@(1))
+ W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/")
+ Q
+ ;
+NARY2XML(ZGOUT,ZGIN) ; CREATE XML FROM AN NHIN ARRAY
+ ; ZGOUT AND ZGIN ARE PASSED BY NAME
+ N C0CDOCID
+ W !,ZGOUT," ",ZGIN
+ S C0CDOCID=$$DOMI(ZGIN) ; PUT IT INTO THE DOM
+ D OUTXML(ZGOUT,C0CDOCID)
+ Q
+ ;
+ ; EXAMPLE OF NHIN ARRAY FORMAT - THIS IS AN OUTPUT OF DOMO ABOVE WHEN RUN
+ ; AGAINST THE OUTPUT OF THE GET^NHINV ROUTINE. (THIS IS NOT REAL PATIENT DATA)
+ ;
+ ;GNARY("med",1,"doses.dose@dose")=10
+ ;GNARY("med",1,"doses.dose@noun")="TABLET"
+ ;GNARY("med",1,"doses.dose@route")="PO"
+ ;GNARY("med",1,"doses.dose@schedule")="QD"
+ ;GNARY("med",1,"doses.dose@units")="MG"
+ ;GNARY("med",1,"doses.dose@unitsPerDose")=1
+ ;GNARY("med",1,"facility@code")=100
+ ;GNARY("med",1,"facility@name")="VOE OFFICE INSTITUTION"
+ ;GNARY("med",1,"form@value")="TAB"
+ ;GNARY("med",1,"id@value")="1N;O"
+ ;GNARY("med",1,"location@code")=5
+ ;GNARY("med",1,"location@name")="3 WEST"
+ ;GNARY("med",1,"name@value")="LISINOPRIL TAB"
+ ;GNARY("med",1,"orderID@value")=294
+ ;GNARY("med",1,"ordered@value")=3110531.001233
+ ;GNARY("med",1,"orderingProvider@code")=63
+ ;GNARY("med",1,"orderingProvider@name")="KING,MATTHEW MICHAEL"
+ ;GNARY("med",1,"products.product.class@code")="ACE INHIBITORS"
+ ;GNARY("med",1,"products.product.vaGeneric@code")=1990
+ ;GNARY("med",1,"products.product.vaGeneric@name")="LISINOPRIL"
+ ;GNARY("med",1,"products.product.vaGeneric@vuid")=4019380
+ ;GNARY("med",1,"products.product.vaProduct@code")=8118
+ ;GNARY("med",1,"products.product.vaProduct@name")="LISINOPRIL 10MG TAB"
+ ;GNARY("med",1,"products.product.vaProduct@vuid")=4008593
+ ;GNARY("med",1,"products.product@code")=6174
+ ;GNARY("med",1,"products.product@name")="LISINOPRIL 10MG U/D"
+ ;GNARY("med",1,"products.product@role")="D"
+ ;GNARY("med",1,"sig")="10MG BY MOUTH EVERY DAY"
+ ;GNARY("med",1,"sig@xml:space")="preserve"
+ ;GNARY("med",1,"status@value")="active"
+ ;GNARY("med",1,"type@value")="OTC"
+ ;GNARY("med",1,"vaType@value")="N"
+ ;
+ ; DOMI is an extrinsic to insert NHIN ARRAY FORMAT arrays into the DOM
+ ; it returns 0 or 1 based on success.
+ ;
+ ; INARY is passed by name and has the format shown above
+ ; HANDLE is the document number in the DOM (both MXML and EWD DOMs will
+ ; be supported eventually - initial implementation is for MXML
+ ;
+ ; PARENT is the node id or tag of the parent under which the DOM will
+ ; be populated. If it is numeric, it is a node. If it is a string, the DOM
+ ; will be searched to find the tag. If not found and there is no root,
+ ; it will be inserted as the root. If not found and there is a root, it
+ ; will be inserted under the root.
+ ;
+ ; For the above example the call would be OK=$$DOMI("GNARY",0,"results")
+ ; because "results" is the root tag. Use OUTXML to render the xml from
+ ; the DOM.
+ ;
+DOMI(INARY,HANDLE,PARENT) ; EXTRINSIC TO INSERT NHIN ARRAYS TO A DOM
+ ;
+ N ZPARNODE
+ S (SUCCESS,LEVEL,LEVEL(0),NODE)=0
+ I '$D(INARY) Q 0 ; NO ARRAY PASSED
+ I '$D(HANDLE) S HANDLE=$$NEWDOM() ; MAKE A NEW DOM
+ ;I PARENT="" S PARENT="root"
+ I +$G(PARENT)>0 S ZPARNODE=PARENT ; WE HAVE BEEN PASSED A PARENT NODE ID
+ E  I $L($G(PARENT))>0 D  ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL
+ . D STARTELE^MXMLDOM(PARENT) ; INSERT THE PARENT NODE
+ . S ZPARNODE=1 ;
+ ; WE NOW HAVE A HANDLE AND A PARENT NODE AND LEVEL HAS BEEN SET
+ N ZEXARY
+ D EXPAND("ZEXARY",INARY) ; EXPAND THE NHIN ARRAY
+ D MAJOR("ZEXARY") ; PROCESS ALL THE NODES TO BE ADDED
+ I $L($G(PARENT))>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE
+ Q HANDLE ; SUCCESS
+ ; 
+MAJOR(ZARY) ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES
+ N ZI S ZI=""
+ N ZTAG
+ F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH SECTION
+ . N ZELEADD S ZELEADD=0
+ . I ZI["@" D  ; END NODE HAS NO VALUE, ONLY ATTRIBUTES
+ . . S ZTAG=$P(ZI,"@",1) ; PULL OUT THE TAG
+ . . K ZATT ; CLEAR OUT LAST ONE
+ . . M ZATT=@ZARY@(ZI,1) ; GET ATTRIBUTE ARRAY
+ . . D STARTELE^MXMLDOM(ZTAG,.ZATT) ; ADD THE NODE
+ . . S ZELEADD=1 ; FLAG TO NOT ADD THE ELEMENT TWICE
+ . I $O(@ZARY@(ZI,""))="" D  ;END NODE
+ . . S ZTAG=ZI ; USE ZI FOR THE TAG
+ . . I 'ZELEADD D STARTELE^MXMLDOM(ZTAG) ; ADD ELEMENT IF NOT THERE
+ . . S ZELEADD=1 ; ADDED AN ELEMENT
+ . . D CHAR^MXMLDOM($G(@ZARY@(ZI))) ; INSERT THE VALUE
+ . I ZELEADD D  Q  ; NO MORE TO DO ON THIS LEVEL
+ . . D ENDELE^MXMLDOM(ZTAG) ; CLOSE THE ELEMENT BEFORE LEAVING
+ . N NEWARY ; INDENTED ARRAY
+ . N ZN S ZN=0
+ . F  S ZN=$O(@ZARY@(ZI,ZN)) Q:ZN=""  D  ; FOR EACH MULTIPLE
+ . . D STARTELE^MXMLDOM(ZI) ; ADD THE INTERMEDIATE TAG
+ . . S NEWARY=$NA(@ZARY@(ZI,ZN)) ; INDENT THE ARRAY
+ . . D MAJOR(NEWARY) ; RECURSE FOR INDENTED ARRAY
+ . . D ENDELE^MXMLDOM(ZI) ; END THE INTERMEDIATE TAG
+ Q
+ ;
+EXPAND(ZZOUT,ZZIN) ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED 
+ ; CONSISTENT FORMAT
+ ; GNARY("patient",1,"facilities[2].facility@code")="050"
+ ; becomes G2ARY("patient",1,"facilities",2,"facility@",1,"code")="050"
+ ; for easier processing (this is fileman format genius)
+ ; basically removes the dot notation from the strings
+ ;
+ N ZZI
+ S ZZI=""
+ F  S ZZI=$O(@ZZIN@(ZZI)) Q:ZZI=""  D  ;
+ . N ZZN S ZZN=0
+ . F  S ZZN=$O(@ZZIN@(ZZI,ZZN)) Q:ZZN=""  D  ;
+ . . N ZZS S ZZS=""
+ . . N GA ;PUSH STACK
+ . . F  S ZZS=$O(@ZZIN@(ZZI,ZZN,ZZS)) Q:ZZS=""  D  ;
+ . . . K GA ; NEW STACK
+ . . . D PUSH^C0CXPATH("GA",ZZI_"^"_ZZN) ; PUSH PARENT
+ . . . N ZZV ; PLACE TO STASH THE VALUE
+ . . . S ZZV=@ZZIN@(ZZI,ZZN,ZZS) ; VALUE
+ . . . W !,"VALUE:",ZZV
+ . . . N GK ; COUNTER
+ . . . F GK=1:1:$L(ZZS,".") D  ; FOR EACH INTERMEDIATE NODE
+ . . . . N ZZN2 S ZZN2=1 ; DEFAULT IF NO [X]
+ . . . . N GM S GM=$P(ZZS,".",GK) ; TAG
+ . . . . I GM["[" D  ; IT'S A MULTIPLE
+ . . . . . S ZZN2=$P($P(GM,"[",2),"]",1) ; PULL OUT THE NUMBER
+ . . . . . S GM=$P(GM,"[",1) ; PULL OUT THE TAG
+ . . . . I GM["@" D  ; IT'S GOT ATTRIBUTES
+ . . . . . N GM2 S GM2=$P(GM,"@",2) ; PULLOUT THE ATTRIBUTE NAME
+ . . . . . D PUSH^C0CXPATH("GA",$P(GM,"@",1)_"@"_"^"_ZZN2) ; PUSH THE TAG
+ . . . . . D PUSH^C0CXPATH("GA",GM2_"^"_ZZN2)
+ . . . . E  D PUSH^C0CXPATH("GA",GM_"^"_ZZN2) ;
+ . . . S GA(GA(0))=$P(GA(GA(0)),"^",1)_"^" ; GET RID OF THE LAST "1" 
+ . . . N GZI S GZI="" ; STRING FOR THE INDEX
+ . . . F GK=1:1:GA(0) D  ; TIME TO REVERSE POP THE TAGS
+ . . . . S GM=$P(GA(GK),"^",1) ; THE TAG
+ . . . . S ZZN2=$P(GA(GK),"^",2) ; THE NUMBER IF ANY
+ . . . . I ZZN2="" S GZI=GZI_""""_GM_"""" ; FOR THE LAST ONE
+ . . . . E  S GZI=GZI_""""_GM_""""_","_ZZN2_"," ; FOR THE REST
+ . . . S GZI2=ZZOUT_"("_GZI_")" ; INCLUDE THE ARRAY NAME
+ . . . W !,GZI
+ . . . S @GZI2=ZZV ; REMEMBER THE VALUE?
+ Q
+ ;
+NEWDOM() ; extrinsic which creates a new DOM and returns the HANDLE
+ N CBK,SUCCESS,LEVEL,NODE,HANDLE
+ K ^TMP("MXMLERR",$J)
+ L +^TMP("MXMLDOM",$J):5
+ E  Q 0
+ S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)=""
+ L -^TMP("MXMLDOM",$J)
+ Q HANDLE
+ ;

ccr/branches/ohum/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 1
-        ;
-        ; 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/branches/ohum/p/C0CENC.m

@@ -1 @@
-C0CENC   ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10
-        ;;1.0;C0C;;May 21, 2010;Build 1
-        ;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/branches/ohum/p/C0CENV.m

@@ -1 @@
-C0CENV  ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;
-        ;
-ENV     ; Does not prevent loading of the transport global.
-        ; Environment check is done only during the install.
-        ;
-        N XQA,XQAMSG
-        ;
-        ;
-        ; Make sure the patch name exist
-        ;
-        I '$D(XPDNM) D  Q
-        . D BMES("No valid patch name exist")
-        . S XPDQUIT=2
-        . D EXIT
-        ;
-        D CHECK
-        D EXIT
-        Q
-        ;
-        ;
-CHECK   ; Perform environment check
-        ;
-        I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D
-        . D BMES("Terminal Device is not defined")
-        . S XPDQUIT=2
-        ;
-        I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D
-        . D BMES("Please log in to set local DUZ... variables")
-        . S XPDQUIT=2
-        ;
-        I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D
-        . D BMES("You are not a valid user on this system")
-        . S XPDQUIT=2
-        Q
-        ;
-        ;
-EXIT    ;
-        ;
-        ;
-        I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q
-        D BMES("--- Environment Check is Ok ---")
-        ;
-        Q
-        ;
-        ;
-PRE     ;Pre-install entry point
-        ;
-        ; No action needed in pre-install
-        D BMES("No action need for pre-install")
-        ;
-        Q
-        ;
-        ;
-POST    ;Post install
-        ;
-        ; Check for RPMS system with V LAB file.
-        ;
-        I $$VFILE^DILFD(9000010.09)'=1 Q
-        ;
-        S %=$$NEWCP^XPDUTL("RPMS1","POST1^C0CENV")
-        S %=$$NEWCP^XPDUTL("RPMS2","POST2^C0CENV")
-        S %=$$NEWCP^XPDUTL("RPMS3","POST3^C0CENV")
-        S %=$$NEWCP^XPDUTL("RPMS4","POST4^C0CENV")
-        S %=$$NEWCP^XPDUTL("RPMS5","POST5^C0CENV")
-        S %=$$NEWCP^XPDUTL("RPMS6","POST6^C0CENV")
-        S %=$$NEWCP^XPDUTL("RPMS7","POST7^C0CENV")
-        ;
-        Q
-        ;
-        ;
-POST1   ; Checkpoint call back entry point.
-        ; Add new style ALR1 cross-reference to V LAB file.
-        ;
-        N MSG
-        S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        D ALR1^C0CLA7DD
-        S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        Q
-        ;
-        ;
-POST2   ; Checkpoint call back entry point.
-        ; Add new style ALR2 cross-reference to V LAB file.
-        ;
-        N MSG
-        S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        D ALR2^C0CLA7DD
-        S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        Q
-        ;
-        ;
-POST3   ; Checkpoint call back entry point.
-        ; Add new style ALR3 cross-reference to V LAB file.
-        ;
-        N MSG
-        S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        D ALR3^C0CLA7DD
-        S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        Q
-        ;
-        ;
-POST4   ; Checkpoint call back entry point.
-        ; Add new style ALR4 cross-reference to V LAB file.
-        ;
-        N MSG
-        S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        D ALR4^C0CLA7DD
-        S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        Q
-        ;
-        ;
-POST5   ; Checkpoint call back entry point.
-        ; Add new style ALR5 cross-reference to V LAB file.
-        ;
-        N MSG
-        S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        D ALR5^C0CLA7DD
-        S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        Q
-        ;
-        ;
-POST6   ; Checkpoint call back entry point.
-        ; Check for RPMS system and determine LAB patch level
-        ;  and need to load in C0C version of LA7 routines.
-        ;
-        N MSG
-        ;
-        ; Load and rename C0CQRY2 to LA7QRY2 if LA*5.2*69 not installed
-        I '$$PATCH^XPDUTL("LA*5.2*69") D
-        . S MSG="This system missing LAB patch LA*5.2*69"
-        . D BMES(MSG)
-        . S MSG="Renaming routine C0CQRY2 to LA7QRY2"
-        . D BMES(MSG)
-        . D LOAD("C0CQRY2")
-        . D SAVE("C0CQRY2","LA7QRY2")
-        ;
-        ; Load and rename C0CVOBX1 to LA7VOBX1 if LA*5.2*64 not installed.
-        I '$$PATCH^XPDUTL("LA*5.2*64") D
-        . S MSG="This system missing LAB patch LA*5.2*64"
-        . D BMES(MSG)
-        . S MSG="Renaming routine C0CVOBX1 to LA7VOBX1"
-        . D BMES(MSG)
-        . D LOAD("C0CVOBX1")
-        . D SAVE("C0CVOBX1","LA7VOBX1")
-        ;
-        ; Load and rename C0CQRY1 to LA7QRY1 if LA*5.2*68 not installed.
-        I '$$PATCH^XPDUTL("LA*5.2*68") D
-        . S MSG="This system missing LAB patch LA*5.2*68"
-        . D BMES(MSG)
-        . S MSG="Renaming routine C0CQRY1 to LA7QRY1"
-        . D BMES(MSG)
-        . D LOAD("C0CQRY1")
-        . D SAVE("C0CQRY1","LA7QRY1")
-        ;
-        Q
-        ;
-        ;
-POST7   ; Checkpoint call back entry point.
-        ;
-        D REINDEX^C0CLA7DD
-        ;
-        Q
-        ;
-        ;
-BMES(STR)       ; Write BMES^XPDUTL statements
-        ;
-        D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
-        ;
-        Q
-        ;
-        ;
-LOAD(X) ; load routine X
-        N %N,DIF,XCNP
-        K ^TMP($J,X)
-        S DIF="^TMP($J,X,",XCNP=0
-        X ^%ZOSF("LOAD")
-        Q
-        ;
-        ;
-SAVE(OLD,NEW)   ; restore routine X
-        N %,DIE,X,XCM,XCN,XCS
-        S DIE="^TMP($J,"""_OLD_""",",XCN=0,X=NEW
-        X ^%ZOSF("SAVE")
-        Q
+C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009
+ ;;1.0;C0C;;May 19, 2009;
+ ;
+ ;
+ENV ; Does not prevent loading of the transport global.
+ ; Environment check is done only during the install.
+ ;
+ N XQA,XQAMSG
+ ;
+ ;
+ ; Make sure the patch name exist
+ ;
+ I '$D(XPDNM) D  Q
+ . D BMES("No valid patch name exist")
+ . S XPDQUIT=2
+ . D EXIT
+ ;
+ D CHECK
+ D EXIT
+ Q
+ ;
+ ;
+CHECK ; Perform environment check
+ ;
+ I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D
+ . D BMES("Terminal Device is not defined")
+ . S XPDQUIT=2
+ ;
+ I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D
+ . D BMES("Please log in to set local DUZ... variables")
+ . S XPDQUIT=2
+ ;
+ I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D
+ . D BMES("You are not a valid user on this system")
+ . S XPDQUIT=2
+ Q
+ ;
+ ;
+EXIT ;
+ ;
+ ;
+ I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q
+ D BMES("--- Environment Check is Ok ---")
+ ;
+ Q
+ ;
+ ;
+PRE ;Pre-install entry point
+ ;
+ ; No action needed in pre-install
+ D BMES("No action need for pre-install")
+ ;
+ Q
+ ;
+ ;
+POST ;Post install
+ ;
+ ; Check for RPMS system with V LAB file.
+ ;
+ I $$VFILE^DILFD(9000010.09)'=1 Q
+ ;
+ S %=$$NEWCP^XPDUTL("RPMS1","POST1^C0CENV")
+ S %=$$NEWCP^XPDUTL("RPMS2","POST2^C0CENV")
+ S %=$$NEWCP^XPDUTL("RPMS3","POST3^C0CENV")
+ S %=$$NEWCP^XPDUTL("RPMS4","POST4^C0CENV")
+ S %=$$NEWCP^XPDUTL("RPMS5","POST5^C0CENV")
+ S %=$$NEWCP^XPDUTL("RPMS6","POST6^C0CENV")
+ S %=$$NEWCP^XPDUTL("RPMS7","POST7^C0CENV")
+ ;
+ Q
+ ;
+ ;
+POST1 ; Checkpoint call back entry point.
+ ; Add new style ALR1 cross-reference to V LAB file.
+ ;
+ N MSG
+ S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR1^C0CLA7DD
+ S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ Q
+ ;
+ ;
+POST2 ; Checkpoint call back entry point.
+ ; Add new style ALR2 cross-reference to V LAB file.
+ ;
+ N MSG
+ S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR2^C0CLA7DD
+ S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ Q
+ ;
+ ;
+POST3 ; Checkpoint call back entry point.
+ ; Add new style ALR3 cross-reference to V LAB file.
+ ;
+ N MSG
+ S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR3^C0CLA7DD
+ S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ Q
+ ;
+ ;
+POST4 ; Checkpoint call back entry point.
+ ; Add new style ALR4 cross-reference to V LAB file.
+ ;
+ N MSG
+ S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR4^C0CLA7DD
+ S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ Q
+ ;
+ ;
+POST5 ; Checkpoint call back entry point.
+ ; Add new style ALR5 cross-reference to V LAB file.
+ ;
+ N MSG
+ S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR5^C0CLA7DD
+ S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ Q
+ ;
+ ;
+POST6 ; Checkpoint call back entry point.
+ ; Check for RPMS system and determine LAB patch level
+ ;  and need to load in C0C version of LA7 routines.
+ ;
+ N MSG
+ ;
+ ; Load and rename C0CQRY2 to LA7QRY2 if LA*5.2*69 not installed
+ I '$$PATCH^XPDUTL("LA*5.2*69") D
+ . S MSG="This system missing LAB patch LA*5.2*69"
+ . D BMES(MSG)
+ . S MSG="Renaming routine C0CQRY2 to LA7QRY2"
+ . D BMES(MSG)
+ . D LOAD("C0CQRY2")
+ . D SAVE("C0CQRY2","LA7QRY2")
+ ;
+ ; Load and rename C0CVOBX1 to LA7VOBX1 if LA*5.2*64 not installed.
+ I '$$PATCH^XPDUTL("LA*5.2*64") D
+ . S MSG="This system missing LAB patch LA*5.2*64"
+ . D BMES(MSG)
+ . S MSG="Renaming routine C0CVOBX1 to LA7VOBX1"
+ . D BMES(MSG)
+ . D LOAD("C0CVOBX1")
+ . D SAVE("C0CVOBX1","LA7VOBX1")
+ ;
+ ; Load and rename C0CQRY1 to LA7QRY1 if LA*5.2*68 not installed.
+ I '$$PATCH^XPDUTL("LA*5.2*68") D
+ . S MSG="This system missing LAB patch LA*5.2*68"
+ . D BMES(MSG)
+ . S MSG="Renaming routine C0CQRY1 to LA7QRY1"
+ . D BMES(MSG)
+ . D LOAD("C0CQRY1")
+ . D SAVE("C0CQRY1","LA7QRY1")
+ ;
+ Q
+ ;
+ ;
+POST7 ; Checkpoint call back entry point.
+ ;
+ D REINDEX^C0CLA7DD
+ ;
+ Q
+ ;
+ ;
+BMES(STR) ; Write BMES^XPDUTL statements
+ ;
+ D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
+ ;
+ Q
+ ;
+ ;
+LOAD(X) ; load routine X
+ N %N,DIF,XCNP
+ K ^TMP($J,X)
+ S DIF="^TMP($J,X,",XCNP=0
+ X ^%ZOSF("LOAD")
+ Q
+ ;
+ ;
+SAVE(OLD,NEW) ; restore routine X
+ N %,DIE,X,XCM,XCN,XCS
+ S DIE="^TMP($J,"""_OLD_""",",XCN=0,X=NEW
+ X ^%ZOSF("SAVE")
+ Q

ccr/branches/ohum/p/C0CEVC.m

@@ -1 @@
-C0CEVC    ; CCDCCR/GPL - SUPPORT FOR EWD VISTCOM PAGES ; 3/1/2010
-        ;;1.0;C0C;;Mar 1, 2010;Build 1
-gpltest2        ; experiment with sending a CCR to an ewd page
-        N ZI
-        S ZI=""
-        D PSEUDO
-        N ZIO
-        S ZIO=IO
-        S IO="/dev/null"
-        OPEN IO
-        U IO
-        N G
-        S G=$$URLTOKEN^C0CEWD
-        D CCRRPC^C0CCCR(.GPL,2)
-        S IO=ZIO
-        OPEN IO
-        U IO
-        K GPL(0)
-        F  S ZI=$O(GPL(ZI)) Q:ZI=""  W GPL(ZI),!
-        Q
-        ;
-gpltest ; experiment with sending a CCR to an ewd page
-        N ZI
-        S ZI=""
-        K ^GPL(0)
-        S ^GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>"
-        F  S ZI=$O(^GPL(ZI)) Q:ZI=""  W ^GPL(ZI),!
-        Q
-        ;
-TEST(sessid);   
-        d setSessionValue^%zewdAPI("person.Name","Rob",sessid)
-        d setSessionValue^%zewdAPI("person.DateOfBirth","13/06/55",sessid)
-        d setSessionValue^%zewdAPI("person.Address.PostCode","SW1 3QA",sessid)
-        d setSessionValue^%zewdAPI("person.Address.Line1","1 The Street",sessid)
-        d setSessionValue^%zewdAPI("person.Address.2.hello","world",sessid)
-        d setJSONValue^%zewdAPI("json","person",sessid)
-        Q ""
-        
-PARSE(INXML,INDOC)      ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
-        ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
-        ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
-        N ZR
-        M ^CacheTempEWD($j)=@INXML ;
-        S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
-        Q ZR
-        ;
-TEST2(sessid)   ; try to put a ccr in the session
-        S U="^"
-        D PSEUDO ; FAKE LOGIN
-        S ZIO=$IO
-        S DEV="/dev/null"
-        O DEV U DEV
-        N G
-        N ZDFN
-        S ZDFN=$$getSessionValue^%zewdAPI("vista.dfn",sessid)
-        I ZDFN="" S ZDFN=2
-        ;K ^TMP("GPL")
-        ;M ^TMP("GPL")=^%zewdSession("session",sessid)
-        D CCRRPC^C0CCCR(.GPL,ZDFN)
-        K GPL(0)   
-        S GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>"
-        C DEV U ZIO
-        ;M ^CacheTempEWD($j)=GPL
-        S DOCNAME="CCR"
-        ;ZWR GPL 
-        ;S ZR=$$parseDocument^%zewdHTMLParser(DOCNAME)
-        ;d setSessionValues^%zewdAPI(DOCNAME,GPL,sessid)
-        d mergeArrayToSession^%zewdAPI(.GPL,DOCNAME,sessid)
-        Q ""
-        ;
-INITSES(sessid) ;initialize an EWD/CPRS session
-        K ^TMP("GPL")
-        ;M ^TMP("GPL")=^%zewdSession("session",sessid)
-        N ZT,ZDFN
-        S ZT=$$URLTOKEN^C0CEWD(sessid)
-        ;S ^TMP("GPL")=ZT
-        d trace^%zewdAPI("*********************ZT="_ZT)
-        S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN
-        S ^TMP("GPL","DFN")=ZDFN
-        I ZDFN=0 S DFN=2 ; DEFAULT TEST PATIENT
-        D setSessionValue^%zewdAPI("vista.dfn",ZDFN,sessid)
-        ;M ^TMP("GPL","request")=requestArray
-        ;D PSEUDO
-        ;D ^%ZTER
-        q ""
-        ;
-PRSEORTK(ZTOKEN)        ;PARSES THE TOKEN SENT BY CPRS AND RETURNS THE DFN 
-        ; OF THE PATIENT ; HERE'S WHAT THE TOKEN LOOKS LIKE: 
-        ; ^TMP('ORWCHART',6547,'192.168.169.8',002E0FE6)
-        N ZX,ZN1,ZIP,ZN2,ZDFN,ZG
-        S ZDFN=0 ; DEFAULT RETURN
-        S ZN1=$P(ZTOKEN,",",2) ; FIRST NUMBER
-        S ZIP=$P(ZTOKEN,",",3) ; IP NUMBER
-        S ZIP=$P(ZIP,"'",2) ; GET RID OF '
-        S ZN2=$P(ZTOKEN,",",4) ; SECOND NUMBER
-        S ZN2=$P(ZN2,")",1) ; GET RID OF )
-        S ZG=$NA(^TMP("ORWCHART",ZN1,ZIP,ZN2)) ; BUILD THE GLOBAL NAME
-        I $G(@ZG)'="" S ZDFN=@ZG ; ACCESS THE GLOBAL
-        S ^TMP("GPL","FIRSTDFN")=ZDFN
-        S ^TMP("GPL","FIRSTGLB")=ZG
-        Q ZDFN
-        ;
-GETPATIENTLIST(sessid)  ;
-        D PSEUDO
-        D LISTALL^ORWPT(.RTN,"NAME","1")
-        N ZI
-        S ZI=""
-        F  S ZI=$O(RTN(ZI)) Q:ZI=""  D  ;
-        . S data(ZI,"DFN")=$P(RTN(ZI),"^",1)
-        . S data(ZI,"Name")=$P(RTN(ZI),"^",2)
-        ; ZWR data
-        ;S data(1,"DFN")=$P(RTN(1),"^",1)
-        ;S data(1,"Name")=$P(RTN(1),"^",2)
-        d deleteFromSession^%zewdAPI("patients",sessid)
-        d createDataTableStore^%zewdYUIRuntime(.data,"patients",sessid)
-        ;d mergeArrayToSession^%zewdAPI(.data,"patients",sessid)
-        Q ""
-        ;
-PSEUDO  
-        S U="^"
-        S DILOCKTM=3
-        S DISYS=19
-        S DT=3100219
-        S DTIME=999
-        S DUZ=10
-        S DUZ(0)="@"
-        S DUZ(1)=""
-        S DUZ(2)=1
-        S DUZ("AG")="V"
-        S DUZ("BUF")=1
-        S DUZ("LANG")=""
-        ;S IO="/dev/pts/2"
-        ;S IO(0)="/dev/pts/2"
-        ;S IO(1,"/dev/pts/2")=""
-        ;S IO("ERROR")=""
-        ;S IO("HOME")="41^/dev/pts/2"
-        ;S IO("ZIO")="/dev/pts/2"
-        ;S IOBS="$C(8)"
-        ;S IOF="#,$C(27,91,50,74,27,91,72)"
-        ;S SIOM=80
-        Q
-        ;
-PSEUDO2 ; FAKE LOGIN SETS SOME LOCAL VARIABLE TO FOOL FILEMAN
-        S DILOCKTM=3
-        S DISYS=19
-        S DT=3100112
-        S DTIME=9999
-        S DUZ=10000000020
-        S DUZ(0)="@"
-        S DUZ(1)=""
-        S DUZ(2)=67
-        S DUZ("AG")="E"
-        S DUZ("BUF")=1
-        S DUZ("LANG")=1
-        S IO="/dev/pts/0"
-        ;S IO(0)="/dev/pts/0"
-        ;S IO(1,"/dev/pts/0")=""
-        ;S IO("ERROR")=""
-        ;S IO("HOME")="50^/dev/pts/0"
-        ;S IO("ZIO")="/dev/pts/0"
-        ;S IOBS="$C(8)"
-        ;S IOF="!!!!!!!!!!!!!!!!!!!!!!!!,#,$C(27,91,50,74,27,91,72)"
-        ;S IOM=80
-        ;S ION="GTM/UNIX TELNET"
-        ;S IOS=50
-        ;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="1;DIC(4.2,"
-        S XPARSYS="1;DIC(4.2,"
-        S XQXFLG="^^XUP"
-        S Y="DEV^VISTA^hollywood^VISTA:hollywood"
-        Q
-        ;
+C0CEVC   ; CCDCCR/GPL - SUPPORT FOR EWD VISTCOM PAGES ; 3/1/2010
+ ;;1.0;C0C;;Mar 1, 2010;
+gpltest2 ; experiment with sending a CCR to an ewd page
+ N ZI
+ S ZI=""
+ D PSEUDO
+ N ZIO
+ S ZIO=IO
+ S IO="/dev/null"
+ OPEN IO
+ U IO
+ N G
+ S G=$$URLTOKEN^C0CEWD
+ D CCRRPC^C0CCCR(.GPL,2)
+ S IO=ZIO
+ OPEN IO
+ U IO
+ K GPL(0)
+ F  S ZI=$O(GPL(ZI)) Q:ZI=""  W GPL(ZI),!
+ Q
+ ;
+gpltest ; experiment with sending a CCR to an ewd page
+ N ZI
+ S ZI=""
+ K ^GPL(0)
+ S ^GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>"
+ F  S ZI=$O(^GPL(ZI)) Q:ZI=""  W ^GPL(ZI),!
+ Q
+ ;
+TEST(sessid); 
+ d setSessionValue^%zewdAPI("person.Name","Rob",sessid)
+ d setSessionValue^%zewdAPI("person.DateOfBirth","13/06/55",sessid)
+ d setSessionValue^%zewdAPI("person.Address.PostCode","SW1 3QA",sessid)
+ d setSessionValue^%zewdAPI("person.Address.Line1","1 The Street",sessid)
+ d setSessionValue^%zewdAPI("person.Address.2.hello","world",sessid)
+ d setJSONValue^%zewdAPI("json","person",sessid)
+ Q ""
+
+PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
+ ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
+ ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
+ N ZR
+ M ^CacheTempEWD($j)=@INXML ;
+ S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
+ Q ZR
+ ;
+TEST2(sessid) ; try to put a ccr in the session
+ S U="^"
+ D PSEUDO ; FAKE LOGIN
+ S ZIO=$IO
+ S DEV="/dev/null"
+ O DEV U DEV
+ N G
+ N ZDFN
+ S ZDFN=$$getSessionValue^%zewdAPI("vista.dfn",sessid)
+ I ZDFN="" S ZDFN=2
+ ;K ^TMP("GPL")
+ ;M ^TMP("GPL")=^%zewdSession("session",sessid)
+ D CCRRPC^C0CCCR(.GPL,ZDFN)
+ K GPL(0)   
+ S GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>"
+ C DEV U ZIO
+ ;M ^CacheTempEWD($j)=GPL
+ S DOCNAME="CCR"
+ ;ZWR GPL 
+ ;S ZR=$$parseDocument^%zewdHTMLParser(DOCNAME)
+ ;d setSessionValues^%zewdAPI(DOCNAME,GPL,sessid)
+ d mergeArrayToSession^%zewdAPI(.GPL,DOCNAME,sessid)
+ Q ""
+ ;
+INITSES(sessid) ;initialize an EWD/CPRS session
+ K ^TMP("GPL")
+ ;M ^TMP("GPL")=^%zewdSession("session",sessid)
+ N ZT,ZDFN
+ S ZT=$$URLTOKEN^C0CEWD(sessid)
+ ;S ^TMP("GPL")=ZT
+ d trace^%zewdAPI("*********************ZT="_ZT)
+ S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN
+ S ^TMP("GPL","DFN")=ZDFN
+ I ZDFN=0 S DFN=2 ; DEFAULT TEST PATIENT
+ D setSessionValue^%zewdAPI("vista.dfn",ZDFN,sessid)
+ ;M ^TMP("GPL","request")=requestArray
+ ;D PSEUDO
+ ;D ^%ZTER
+ q ""
+ ;
+PRSEORTK(ZTOKEN) ;PARSES THE TOKEN SENT BY CPRS AND RETURNS THE DFN 
+ ; OF THE PATIENT ; HERE'S WHAT THE TOKEN LOOKS LIKE: 
+ ; ^TMP('ORWCHART',6547,'192.168.169.8',002E0FE6)
+ N ZX,ZN1,ZIP,ZN2,ZDFN,ZG
+ S ZDFN=0 ; DEFAULT RETURN
+ S ZN1=$P(ZTOKEN,",",2) ; FIRST NUMBER
+ S ZIP=$P(ZTOKEN,",",3) ; IP NUMBER
+ S ZIP=$P(ZIP,"'",2) ; GET RID OF '
+ S ZN2=$P(ZTOKEN,",",4) ; SECOND NUMBER
+ S ZN2=$P(ZN2,")",1) ; GET RID OF )
+ S ZG=$NA(^TMP("ORWCHART",ZN1,ZIP,ZN2)) ; BUILD THE GLOBAL NAME
+ I $G(@ZG)'="" S ZDFN=@ZG ; ACCESS THE GLOBAL
+ S ^TMP("GPL","FIRSTDFN")=ZDFN
+ S ^TMP("GPL","FIRSTGLB")=ZG
+ Q ZDFN
+ ;
+GETPATIENTLIST(sessid) ;
+ D PSEUDO
+ D LISTALL^ORWPT(.RTN,"NAME","1")
+ N ZI
+ S ZI=""
+ F  S ZI=$O(RTN(ZI)) Q:ZI=""  D  ;
+ . S data(ZI,"DFN")=$P(RTN(ZI),"^",1)
+ . S data(ZI,"Name")=$P(RTN(ZI),"^",2)
+ ; ZWR data
+ ;S data(1,"DFN")=$P(RTN(1),"^",1)
+ ;S data(1,"Name")=$P(RTN(1),"^",2)
+ d deleteFromSession^%zewdAPI("patients",sessid)
+ d createDataTableStore^%zewdYUIRuntime(.data,"patients",sessid)
+ ;d mergeArrayToSession^%zewdAPI(.data,"patients",sessid)
+ Q ""
+ ;
+PSEUDO
+ S U="^"
+ S DILOCKTM=3
+ S DISYS=19
+ S DT=3100219
+ S DTIME=999
+ S DUZ=10
+ S DUZ(0)="@"
+ S DUZ(1)=""
+ S DUZ(2)=1
+ S DUZ("AG")="V"
+ S DUZ("BUF")=1
+ S DUZ("LANG")=""
+ ;S IO="/dev/pts/2"
+ ;S IO(0)="/dev/pts/2"
+ ;S IO(1,"/dev/pts/2")=""
+ ;S IO("ERROR")=""
+ ;S IO("HOME")="41^/dev/pts/2"
+ ;S IO("ZIO")="/dev/pts/2"
+ ;S IOBS="$C(8)"
+ ;S IOF="#,$C(27,91,50,74,27,91,72)"
+ ;S SIOM=80
+ Q
+ ;
+PSEUDO2 ; FAKE LOGIN SETS SOME LOCAL VARIABLE TO FOOL FILEMAN
+ S DILOCKTM=3
+ S DISYS=19
+ S DT=3100112
+ S DTIME=9999
+ S DUZ=10000000020
+ S DUZ(0)="@"
+ S DUZ(1)=""
+ S DUZ(2)=67
+ S DUZ("AG")="E"
+ S DUZ("BUF")=1
+ S DUZ("LANG")=1
+ S IO="/dev/pts/0"
+ ;S IO(0)="/dev/pts/0"
+ ;S IO(1,"/dev/pts/0")=""
+ ;S IO("ERROR")=""
+ ;S IO("HOME")="50^/dev/pts/0"
+ ;S IO("ZIO")="/dev/pts/0"
+ ;S IOBS="$C(8)"
+ ;S IOF="!!!!!!!!!!!!!!!!!!!!!!!!,#,$C(27,91,50,74,27,91,72)"
+ ;S IOM=80
+ ;S ION="GTM/UNIX TELNET"
+ ;S IOS=50
+ ;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="1;DIC(4.2,"
+ S XPARSYS="1;DIC(4.2,"
+ S XQXFLG="^^XUP"
+ S Y="DEV^VISTA^hollywood^VISTA:hollywood"
+ Q
+ ;

ccr/branches/ohum/p/C0CEWD.m

@@ -1 @@
-C0CEWD    ; CCDCCR/GPL - CCR EWD utilities; 1/6/11
-        ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
-        ;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/branches/ohum/p/C0CEWD1.m

@@ -1 @@
-C0CEWD1   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
-        ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
-        ;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
-        ;
-TEST(filepath)  ; filepath IS THE PATH/FILE TO BE READ IN
-        i $g(^%ZISH)["" d  ; if the VistA Kernal routine %ZISH exists
-        . n zfile,zpath,ztmp s (zfile,zpath,ztmp)=""
-        . s zfile=$re($p($re(filepath),"/",1)) ;file name
-        . s zpath=$p(filepath,zfile,1) ; file path
-        . s ztmp=$na(^CacheTempEWD($j,0))
-        . s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2
-        q
-        ;
-TEST2   ;
-        s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml"
-        ;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath)
-        s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global
-        s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0)
-        ;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM")
-        w ok,!
-        q
-        ;
-LOAD(filepath)  ; load an xml file into the EWD global for DOM processing
-        ; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML)
-        ; after to process it to the DOM - isHTML=0 for XML files
-        n i
-        i $g(^%ZISH)["" d  QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09
-        . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)=""
-        . s zfile=$re($p($re(filepath),"/",1)) ;file name
-        . s zpath=$p(filepath,zfile,1) ; file path
-        . s ztmp=$na(^CacheTempEWD($j,0))
-        . s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2
-        . s i=$o(^CacheTempEWD($j,""),-1) ; highest line number
-        q i
-        ;
-Q(ZQ,ZD)        ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED
-        I '$D(ZD) S ZD="DerekDOM"
-        s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ;
-        d displayNodes^%zewdXPath(.nodes)
-        q
-        ;
-GET1URL0(URL)   ;
-        s ok=$$httpGET^%zewdGTM(URL,.gpl)
-        D INDEX^C0CXPATH("gpl","gpl2")
-        W !,"S URL=""",URL,"""",!
-        S G=""
-        F  S G=$O(gpl2(G)) Q:G=""  D  ;
-        . W " S VDX(""",G,""")=""",gpl2(G),"""",!
-        W !
-        Q
+C0CEWD1   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
+ ;;0.1;CCDCCR;nopatch;noreleasedate
+ ;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
+ ;
+TEST(filepath) ; filepath IS THE PATH/FILE TO BE READ IN
+ i $g(^%ZISH)["" d  ; if the VistA Kernal routine %ZISH exists
+ . n zfile,zpath,ztmp s (zfile,zpath,ztmp)=""
+ . s zfile=$re($p($re(filepath),"/",1)) ;file name
+ . s zpath=$p(filepath,zfile,1) ; file path
+ . s ztmp=$na(^CacheTempEWD($j,0))
+ . s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2
+ q
+ ;
+TEST2 ;
+ s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml"
+ ;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath)
+ s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global
+ s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0)
+ ;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM")
+ w ok,!
+ q
+ ;
+LOAD(filepath) ; load an xml file into the EWD global for DOM processing
+ ; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML)
+ ; after to process it to the DOM - isHTML=0 for XML files
+ n i
+ i $g(^%ZISH)["" d  QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09
+ . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)=""
+ . s zfile=$re($p($re(filepath),"/",1)) ;file name
+ . s zpath=$p(filepath,zfile,1) ; file path
+ . s ztmp=$na(^CacheTempEWD($j,0))
+ . s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2
+ . s i=$o(^CacheTempEWD($j,""),-1) ; highest line number
+ q i
+ ;
+Q(ZQ,ZD) ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED
+ I '$D(ZD) S ZD="DerekDOM"
+ s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ;
+ d displayNodes^%zewdXPath(.nodes)
+ q
+ ;
+GET1URL0(URL) ;
+ s ok=$$httpGET^%zewdGTM(URL,.gpl)
+ D INDEX^C0CXPATH("gpl","gpl2")
+ W !,"S URL=""",URL,"""",!
+ S G=""
+ F  S G=$O(gpl2(G)) Q:G=""  D  ;
+ . W " S VDX(""",G,""")=""",gpl2(G),"""",!
+ W !
+ Q

ccr/branches/ohum/p/C0CFM1.m

@@ -1 @@
-C0CFM1    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CFM2.m

@@ -1 @@
-C0CFM2    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CFM3.m

@@ -1 @@
-C0CFM3    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
-        ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
-        ;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^GPLRIMA ; 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.601, ^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 ZSRC,PATN,ZTYPN,XD0,ZTYP
-        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 C0CF S C0CF=171.601 ; FILE AT ELEMENT LEVEL
-        N C0CFV S C0CFV=171.6011 ; FILE AT VARIABLE LVL
-        N C0CFDA
-        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(C0CF,"+1,",.01)=ZTYPN
-        S C0CFDA(C0CF,"+1,",.02)=DFN
-        S C0CFDA(C0CF,"+1,",.03)=ZSRC
-        S C0CFDA(C0CF,"+1,",.04)=" "_ZOCC ;CREATE OCCURANCE with leading space
-        D UPDIE ; CREATE THE RECORD
-        S C0CIEN=$O(^C0CE4("C",DFN,ZSRC,ZTYPN," "_ZOCC,""))
-        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 C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",.01)=ZVARN
-        . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",1)=@ZVALS@(ZC0CI)
-        . 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
-        ;
-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
-        ;
-SHOWE4(DFN)     ;
-        ;
-        N ZG
-        S ZG=""
-        F  S ZG=$O(^C0CE4("P",DFN,ZG)) Q:ZG=""  D  ZWR ^C0CE4(ZG,*)
-        Q
-        ;
+C0CFM3   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
+ ;;0.1;CCDCCR;nopatch;noreleasedate
+ ;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^GPLRIMA ; 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.601, ^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 ZSRC,PATN,ZTYPN,XD0,ZTYP
+ 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 C0CF S C0CF=171.601 ; FILE AT ELEMENT LEVEL
+ N C0CFV S C0CFV=171.6011 ; FILE AT VARIABLE LVL
+ N C0CFDA
+ 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(C0CF,"+1,",.01)=ZTYPN
+ S C0CFDA(C0CF,"+1,",.02)=DFN
+ S C0CFDA(C0CF,"+1,",.03)=ZSRC
+ S C0CFDA(C0CF,"+1,",.04)=" "_ZOCC ;CREATE OCCURANCE with leading space
+ D UPDIE ; CREATE THE RECORD
+ S C0CIEN=$O(^C0CE4("C",DFN,ZSRC,ZTYPN," "_ZOCC,""))
+ 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 C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",.01)=ZVARN
+ . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",1)=@ZVALS@(ZC0CI)
+ . 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
+ ;
+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
+ ;
+SHOWE4(DFN) ;
+ ;
+ N ZG
+ S ZG=""
+ F  S ZG=$O(^C0CE4("P",DFN,ZG)) Q:ZG=""  D  ZWR ^C0CE4(ZG,*)
+ Q
+ ;

ccr/branches/ohum/p/C0CIM2.m

@@ -1 @@
-C0CIM2   ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10
-        ;;1.0;C0C;;Feb 16, 2010;Build 1
-        ;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/branches/ohum/p/C0CIMMU.m

@@ -1 @@
-C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CIN.m

@@ -1 @@
-C0CIN     ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08
-        ;;1.0;C0C;;Sep 20, 2009;Build 1
-        ;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/branches/ohum/p/C0CLA7DD.m

@@ -1 @@
-C0CLA7DD        ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;
-        ; Tasked by C0C post-install routine C0CENV to create C0C cross-references on V LAB file.
-        ;
-        Q
-        ;
-        ;
-EN      ; Add new style cross-references to V LAB file if it exists.
-        ; OLD entry point - see new KIDS check points in C0CENV.
-        ;
-        ;
-        ; Quit if AUPNVLAB global does not exist.
-        I $$VFILE^DILFD(9000010.09)'=1 Q
-        ;
-        N MSG
-        ;
-        S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        D ALR1
-        S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        ;
-        S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        D ALR2
-        S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        ;
-        S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        D ALR3
-        S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        ;
-        S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        D ALR4
-        S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        ;
-        S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        D ALR5
-        S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
-        D BMES(MSG)
-        ;
-        Q
-        ;
-        ;
-ALR1    ; Installation of ALR1 cross-reference
-        ;
-        N C0CFLAG,C0CXR,C0CRES,C0COUT
-        ;
-        S C0CFLAG=""
-        ;
-        S C0CXR("FILE")=9000010.09
-        S C0CXR("NAME")="ALR1"
-        S C0CXR("TYPE")="R"
-        S C0CXR("USE")="S"
-        S C0CXR("EXECUTION")="R"
-        S C0CXR("ACTIVITY")="IR"
-        S C0CXR("SHORT DESCR")="X-ref to link entry with parent in LAB DATA file (#63)"
-        S C0CXR("VAL",1)=.02
-        S C0CXR("VAL",1,"SUBSCRIPT")=1
-        S C0CXR("VAL",1,"COLLATION")="F"
-        S C0CXR("VAL",2)=.06
-        S C0CXR("VAL",2,"SUBSCRIPT")=2
-        S C0CXR("VAL",2,"LENGTH")=30
-        S C0CXR("VAL",2,"COLLATION")="F"
-        S C0CXR("VAL",3)=.01
-        S C0CXR("VAL",3,"SUBSCRIPT")=3
-        S C0CXR("VAL",3,"COLLATION")="F"
-        S C0CXR("VAL",4)=1201
-        S C0CXR("VAL",4,"SUBSCRIPT")=4
-        S C0CXR("VAL",4,"COLLATION")="F"
-        D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
-        ;
-        Q
-        ;
-        ;
-ALR2    ; Installation of ALR2 cross-reference
-        ;
-        N C0CFLAG,C0CXR,C0CRES,C0COUT
-        ;
-        S C0CFLAG=""
-        ;
-        S C0CXR("FILE")=9000010.09
-        S C0CXR("NAME")="ALR2"
-        S C0CXR("TYPE")="MU"
-        S C0CXR("USE")="S"
-        S C0CXR("EXECUTION")="R"
-        S C0CXR("ACTIVITY")="IR"
-        S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result."
-        S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes"
-        S C0CXR("DESCR",2)="that has been assigned to a lab result. Allows queries to"
-        S C0CXR("DESCR",3)="retrieve the LOINC code associated with a specific test"
-        S C0CXR("DESCR",4)="result."
-        S C0CXR("SET")="S ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)="""""
-        S C0CXR("KILL")="K ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)"
-        S C0CXR("WHOLE KILL")="K ^AUPNVLAB(""ALR2"")"
-        S C0CXR("VAL",1)=.02
-        S C0CXR("VAL",1,"SUBSCRIPT")=1
-        S C0CXR("VAL",1,"COLLATION")="F"
-        S C0CXR("VAL",2)=1201
-        S C0CXR("VAL",2,"SUBSCRIPT")=2
-        S C0CXR("VAL",2,"COLLATION")="F"
-        S C0CXR("VAL",3)=.06
-        S C0CXR("VAL",3,"SUBSCRIPT")=3
-        S C0CXR("VAL",3,"COLLATION")="F"
-        S C0CXR("VAL",4)=.01
-        S C0CXR("VAL",4,"SUBSCRIPT")=4
-        S C0CXR("VAL",4,"COLLATION")="F"
-        S C0CXR("VAL",5)=1113
-        S C0CXR("VAL",5,"SUBSCRIPT")=5
-        S C0CXR("VAL",5,"COLLATION")="F"
-        D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
-        ;
-        Q
-        ;
-        ;
-ALR3    ; Installation of ALR3 cross-reference
-        ;
-        N C0CFLAG,C0CXR,C0CRES,C0COUT
-        ;
-        S C0CFLAG=""
-        ;
-        S C0CXR("FILE")=9000010.09
-        S C0CXR("NAME")="ALR3"
-        S C0CXR("TYPE")="R"
-        S C0CXR("USE")="S"
-        S C0CXR("EXECUTION")="F"
-        S C0CXR("ACTIVITY")="IR"
-        S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result - any patient"
-        S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes that has been assigned to a lab result. Allows queries"
-        S C0CXR("DESCR",2)="to retrieve the LOINC code associated with a specific test result. It allows any patient"
-        S C0CXR("DESCR",3)="lab results to be identified by LOINC"
-        S C0CXR("VAL",1)=1113
-        S C0CXR("VAL",1,"SUBSCRIPT")=1
-        S C0CXR("VAL",1,"COLLATION")="F"
-        ;
-        D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
-        ;
-        Q
-        ;
-        ;
-ALR4    ; Installation of ALR4 cross-reference
-        ;
-        N C0CFLAG,C0CXR,C0CRES,C0COUT
-        ;
-        S C0CFLAG=""
-        ;
-        S C0CXR("FILE")=9000010.09
-        S C0CXR("NAME")="ALR4"
-        S C0CXR("TYPE")="R"
-        S C0CXR("USE")="S"
-        S C0CXR("EXECUTION")="R"
-        S C0CXR("ACTIVITY")="IR"
-        S C0CXR("SHORT DESCR")="X-ref by patient and collection date/time"
-        S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a"
-        S C0CXR("DESCR",2)="patient by collection date/time. This includes results that are only in"
-        S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA"
-        S C0CXR("DESCR",4)="file (#63)."
-        S C0CXR("VAL",1)=.02
-        S C0CXR("VAL",1,"SUBSCRIPT")=1
-        S C0CXR("VAL",1,"COLLATION")="F"
-        S C0CXR("VAL",2)=1201
-        S C0CXR("VAL",2,"SUBSCRIPT")=2
-        S C0CXR("VAL",2,"COLLATION")="F"
-        ;
-        D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
-        ;
-        Q
-        ;
-        ;
-ALR5    ; Installation of ALR5 cross-reference
-        ;
-        N C0CFLAG,C0CXR,C0CRES,C0COUT
-        ;
-        S C0CFLAG=""
-        ;
-        S C0CXR("FILE")=9000010.09
-        S C0CXR("NAME")="ALR5"
-        S C0CXR("TYPE")="R"
-        S C0CXR("USE")="S"
-        S C0CXR("EXECUTION")="R"
-        S C0CXR("ACTIVITY")="IR"
-        S C0CXR("SHORT DESCR")="X-ref by patient and results availble date/time"
-        S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a"
-        S C0CXR("DESCR",2)="patient by results available date/time. This includes results that are only in"
-        S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA"
-        S C0CXR("DESCR",4)="file (#63)."
-        S C0CXR("VAL",1)=.02
-        S C0CXR("VAL",1,"SUBSCRIPT")=1
-        S C0CXR("VAL",1,"COLLATION")="F"
-        S C0CXR("VAL",2)=1212
-        S C0CXR("VAL",2,"SUBSCRIPT")=2
-        S C0CXR("VAL",2,"COLLATION")="F"
-        ;
-        D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
-        ;
-        Q
-        ;
-        ;
-REINDEX ; Set data into indexes for current entries.
-        ;
-        ;
-        N C0CHLOG,DA,DIK,MSG
-        ;
-        S C0CHLOG("START")=$H
-        S MSG="Starting indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z")
-        D BMES(MSG),SENDXQA(MSG)
-        ;
-        S DIK="^AUPNVLAB("
-        S DIK(1)=".02^ALR1^ALR2^ALR4^ALR5"
-        D ENALL^DIK
-        ;
-        S C0CHLOG("END")=$H
-        S MSG="Finished indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z")
-        D BMES(MSG),SENDXQA(MSG)
-        ;
-        S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3)
-        D BMES(MSG)
-        ;
-        S C0CHLOG("START")=$H
-        S MSG="Starting indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z")
-        D BMES(MSG),SENDXQA(MSG)
-        ;
-        K DA,DIK
-        S DIK="^AUPNVLAB("
-        S DIK(1)="1113^ALR3"
-        D ENALL^DIK
-        ;
-        S C0CHLOG("END")=$H
-        S MSG="Finished indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z")
-        D BMES(MSG),SENDXQA(MSG)
-        ;
-        S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3)
-        D BMES(MSG)
-        ;
-        Q
-        ;
-        ;
-BMES(STR)       ; Write BMES^XPDUTL statements
-        ;
-        D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
-        ;
-        Q
-        ;
-        ;
-SENDXQA(MSG)    ; Send alert for reindex status
-        ;
-        N XQA,XQAMSG
-        ;
-        S XQA(DUZ)=""
-        S XQAMSG=MSG
-        D SETUP^XQALERT
-        ;
-        Q
+C0CLA7DD ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009
+ ;;1.0;C0C;;May 19, 2009;
+ ;
+ ; Tasked by C0C post-install routine C0CENV to create C0C cross-references on V LAB file.
+ ;
+ Q
+ ;
+ ;
+EN ; Add new style cross-references to V LAB file if it exists.
+ ; OLD entry point - see new KIDS check points in C0CENV.
+ ;
+ ;
+ ; Quit if AUPNVLAB global does not exist.
+ I $$VFILE^DILFD(9000010.09)'=1 Q
+ ;
+ N MSG
+ ;
+ S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR1
+ S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ ;
+ S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR2
+ S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ ;
+ S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR3
+ S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ ;
+ S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR4
+ S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ ;
+ S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ D ALR5
+ S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z")
+ D BMES(MSG)
+ ;
+ Q
+ ;
+ ;
+ALR1 ; Installation of ALR1 cross-reference
+ ;
+ N C0CFLAG,C0CXR,C0CRES,C0COUT
+ ;
+ S C0CFLAG=""
+ ;
+ S C0CXR("FILE")=9000010.09
+ S C0CXR("NAME")="ALR1"
+ S C0CXR("TYPE")="R"
+ S C0CXR("USE")="S"
+ S C0CXR("EXECUTION")="R"
+ S C0CXR("ACTIVITY")="IR"
+ S C0CXR("SHORT DESCR")="X-ref to link entry with parent in LAB DATA file (#63)"
+ S C0CXR("VAL",1)=.02
+ S C0CXR("VAL",1,"SUBSCRIPT")=1
+ S C0CXR("VAL",1,"COLLATION")="F"
+ S C0CXR("VAL",2)=.06
+ S C0CXR("VAL",2,"SUBSCRIPT")=2
+ S C0CXR("VAL",2,"LENGTH")=30
+ S C0CXR("VAL",2,"COLLATION")="F"
+ S C0CXR("VAL",3)=.01
+ S C0CXR("VAL",3,"SUBSCRIPT")=3
+ S C0CXR("VAL",3,"COLLATION")="F"
+ S C0CXR("VAL",4)=1201
+ S C0CXR("VAL",4,"SUBSCRIPT")=4
+ S C0CXR("VAL",4,"COLLATION")="F"
+ D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
+ ;
+ Q
+ ;
+ ;
+ALR2 ; Installation of ALR2 cross-reference
+ ;
+ N C0CFLAG,C0CXR,C0CRES,C0COUT
+ ;
+ S C0CFLAG=""
+ ;
+ S C0CXR("FILE")=9000010.09
+ S C0CXR("NAME")="ALR2"
+ S C0CXR("TYPE")="MU"
+ S C0CXR("USE")="S"
+ S C0CXR("EXECUTION")="R"
+ S C0CXR("ACTIVITY")="IR"
+ S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result."
+ S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes"
+ S C0CXR("DESCR",2)="that has been assigned to a lab result. Allows queries to"
+ S C0CXR("DESCR",3)="retrieve the LOINC code associated with a specific test"
+ S C0CXR("DESCR",4)="result."
+ S C0CXR("SET")="S ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)="""""
+ S C0CXR("KILL")="K ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)"
+ S C0CXR("WHOLE KILL")="K ^AUPNVLAB(""ALR2"")"
+ S C0CXR("VAL",1)=.02
+ S C0CXR("VAL",1,"SUBSCRIPT")=1
+ S C0CXR("VAL",1,"COLLATION")="F"
+ S C0CXR("VAL",2)=1201
+ S C0CXR("VAL",2,"SUBSCRIPT")=2
+ S C0CXR("VAL",2,"COLLATION")="F"
+ S C0CXR("VAL",3)=.06
+ S C0CXR("VAL",3,"SUBSCRIPT")=3
+ S C0CXR("VAL",3,"COLLATION")="F"
+ S C0CXR("VAL",4)=.01
+ S C0CXR("VAL",4,"SUBSCRIPT")=4
+ S C0CXR("VAL",4,"COLLATION")="F"
+ S C0CXR("VAL",5)=1113
+ S C0CXR("VAL",5,"SUBSCRIPT")=5
+ S C0CXR("VAL",5,"COLLATION")="F"
+ D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
+ ;
+ Q
+ ;
+ ;
+ALR3 ; Installation of ALR3 cross-reference
+ ;
+ N C0CFLAG,C0CXR,C0CRES,C0COUT
+ ;
+ S C0CFLAG=""
+ ;
+ S C0CXR("FILE")=9000010.09
+ S C0CXR("NAME")="ALR3"
+ S C0CXR("TYPE")="R"
+ S C0CXR("USE")="S"
+ S C0CXR("EXECUTION")="F"
+ S C0CXR("ACTIVITY")="IR"
+ S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result - any patient"
+ S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes that has been assigned to a lab result. Allows queries"
+ S C0CXR("DESCR",2)="to retrieve the LOINC code associated with a specific test result. It allows any patient"
+ S C0CXR("DESCR",3)="lab results to be identified by LOINC"
+ S C0CXR("VAL",1)=1113
+ S C0CXR("VAL",1,"SUBSCRIPT")=1
+ S C0CXR("VAL",1,"COLLATION")="F"
+ ;
+ D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
+ ;
+ Q
+ ;
+ ;
+ALR4 ; Installation of ALR4 cross-reference
+ ;
+ N C0CFLAG,C0CXR,C0CRES,C0COUT
+ ;
+ S C0CFLAG=""
+ ;
+ S C0CXR("FILE")=9000010.09
+ S C0CXR("NAME")="ALR4"
+ S C0CXR("TYPE")="R"
+ S C0CXR("USE")="S"
+ S C0CXR("EXECUTION")="R"
+ S C0CXR("ACTIVITY")="IR"
+ S C0CXR("SHORT DESCR")="X-ref by patient and collection date/time"
+ S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a"
+ S C0CXR("DESCR",2)="patient by collection date/time. This includes results that are only in"
+ S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA"
+ S C0CXR("DESCR",4)="file (#63)."
+ S C0CXR("VAL",1)=.02
+ S C0CXR("VAL",1,"SUBSCRIPT")=1
+ S C0CXR("VAL",1,"COLLATION")="F"
+ S C0CXR("VAL",2)=1201
+ S C0CXR("VAL",2,"SUBSCRIPT")=2
+ S C0CXR("VAL",2,"COLLATION")="F"
+ ;
+ D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
+ ;
+ Q
+ ;
+ ;
+ALR5 ; Installation of ALR5 cross-reference
+ ;
+ N C0CFLAG,C0CXR,C0CRES,C0COUT
+ ;
+ S C0CFLAG=""
+ ;
+ S C0CXR("FILE")=9000010.09
+ S C0CXR("NAME")="ALR5"
+ S C0CXR("TYPE")="R"
+ S C0CXR("USE")="S"
+ S C0CXR("EXECUTION")="R"
+ S C0CXR("ACTIVITY")="IR"
+ S C0CXR("SHORT DESCR")="X-ref by patient and results availble date/time"
+ S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a"
+ S C0CXR("DESCR",2)="patient by results available date/time. This includes results that are only in"
+ S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA"
+ S C0CXR("DESCR",4)="file (#63)."
+ S C0CXR("VAL",1)=.02
+ S C0CXR("VAL",1,"SUBSCRIPT")=1
+ S C0CXR("VAL",1,"COLLATION")="F"
+ S C0CXR("VAL",2)=1212
+ S C0CXR("VAL",2,"SUBSCRIPT")=2
+ S C0CXR("VAL",2,"COLLATION")="F"
+ ;
+ D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT")
+ ;
+ Q
+ ;
+ ;
+REINDEX ; Set data into indexes for current entries.
+ ;
+ ;
+ N C0CHLOG,DA,DIK,MSG
+ ;
+ S C0CHLOG("START")=$H
+ S MSG="Starting indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z")
+ D BMES(MSG),SENDXQA(MSG)
+ ;
+ S DIK="^AUPNVLAB("
+ S DIK(1)=".02^ALR1^ALR2^ALR4^ALR5"
+ D ENALL^DIK
+ ;
+ S C0CHLOG("END")=$H
+ S MSG="Finished indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z")
+ D BMES(MSG),SENDXQA(MSG)
+ ;
+ S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3)
+ D BMES(MSG)
+ ;
+ S C0CHLOG("START")=$H
+ S MSG="Starting indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z")
+ D BMES(MSG),SENDXQA(MSG)
+ ;
+ K DA,DIK
+ S DIK="^AUPNVLAB("
+ S DIK(1)="1113^ALR3"
+ D ENALL^DIK
+ ;
+ S C0CHLOG("END")=$H
+ S MSG="Finished indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z")
+ D BMES(MSG),SENDXQA(MSG)
+ ;
+ S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3)
+ D BMES(MSG)
+ ;
+ Q
+ ;
+ ;
+BMES(STR) ; Write BMES^XPDUTL statements
+ ;
+ D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM))
+ ;
+ Q
+ ;
+ ;
+SENDXQA(MSG) ; Send alert for reindex status
+ ;
+ N XQA,XQAMSG
+ ;
+ S XQA(DUZ)=""
+ S XQAMSG=MSG
+ D SETUP^XQALERT
+ ;
+ Q

ccr/branches/ohum/p/C0CLA7Q.m

@@ -1 @@
-C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;
-        ;
-        Q
-        ;
-        ;
-LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7)  ; Entry point for Lab Result Query
-        ;
-        ;
-        K ^TMP("C0C-VLAB",$J)
-        ;
-        ; Check and retrieve lab results from LAB DATA file (#63)
-        S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7))
-        ;
-        ; If V LAB file present then check for lab results that are only in this file
-        ; If results found in V Lab file then build results and add to above results.
-        I $D(^AUPNVLAB) D
-        . D VCHECK
-        . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD
-        ;
-        ;K ^TMP("C0C-VLAB",$J)
-        ;
-        Q C0CDEST
-        ;
-        ;
-VCHECK  ; If V LAB file present then check for lab results that are only in this file.
-        ;
-        N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC
-        ;
-        S LA7PTID=C0CPTID
-        D PATID^LA7QRY2
-        I $D(LA7ERR) Q
-        ;
-        ; Resolve search codes to lab datanames
-        S LA7SC=$G(C0CSC)
-        I $T(SCLIST^LA7QRY2)'="" D
-        . N TMP
-        . S LA7SCRC=$G(C0CSC)
-        . S TMP=$$SCLIST^LA7QRY2(LA7SCRC)
-        . S LA7SC=TMP
-        ;
-        I LA7SC'="*" D CHKSC^LA7QRY1
-        ;
-        ; Convert specimen codes to file #61 Topography entries
-        S LA7SPEC=$G(C0CSPEC)
-        I LA7SPEC'="*"  D SPEC^LA7QRY1
-        ;
-        S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0
-        ;
-        F  S C0CROOT=$Q(@C0CROOT) Q:C0CROOT=""  D  Q:C0CEND
-        . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q  ; Left x-ref or patient
-        . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q  ; Exceeded end date/time
-        . S C0CDA=$QS(C0CROOT,4)
-        . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q  ; Already checked during scan of file #63
-        . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q  ; Source is LAB DATA file - skip
-        . D VCHK1
-        ;
-        ;
-        Q
-        ;
-        ;
-VBUILD  ; Build results found only in V LAB file into HL7 structure.
-        ;
-        ;
-        Q
-        ;
-        ;
-LNCHK   ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63.
-        ; Call from LA7QRY2
-        ;
-        N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X
-        ;
-        S DFN=$P(^LR(LRDFN,0),"^",3)
-        S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0)
-        S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5)
-        S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)=""
-        ;
-        ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)=""
-        ;
-        S C0C60=""
-        F  S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60  D  Q:C0CLN'=""
-        . D FINDDT
-        . I C0CDA<1 Q
-        . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q  ; Source is not LAB DATA file - skip
-        . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13)
-        . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8)
-        . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer
-        . I C0CPDA="" S C0CPDA=C0CDA
-        . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2)
-        . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2)
-        . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^")
-        . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2)
-        . S ^TMP("C0C-VLAB",$J,1,C0CDA)=""
-        . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)=""
-        . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST
-        ;
-        S X=$P(LA7X,"^",3)
-        ; If order NLT then update if no order NLT
-        I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64)
-        ;
-        ; If result NLT then update if no result NLT
-        I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64)
-        ;
-        ; If LOINC found then update variable with LN code
-        I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN
-        ;
-        S $P(LA7X,"^",3)=X
-        ;
-        Q
-        ;
-        ;
-TMPCHK  ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments
-        ; Called from LA7VOBX1
-        ;
-        N I,X
-        ;
-        S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB))
-        I X="" Q
-        F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I)
-        S $P(LA7VAL,"^",3)=LA7X
-        ;
-        Q
-        ;
-        ;
-VCHK1   ; Check the entry in V Lab to determine if it meets criteria
-        ;
-        N C0CVLAB,I
-        ;
-        F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I))
-        ;
-        ; JMC 04/13/09 - Store anything for now that meets date criteria.
-        D VSTORE
-        ;
-        Q
-        ;
-        ;
-VSTORE  ; Store entry for building in HL7 message when parent is from V LAB file.
-        ;
-        N C0CPDA,C0CPTEST
-        ;
-        ; Determine parent test to use for OBR segment
-        S C0CPDA=$P(C0CVLAB(12),"^",8)
-        I C0CPDA="" S C0CPDA=C0CDA
-        ;
-        ; Determine parent test
-        S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^")
-        ;
-        S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA
-        ;
-        Q
-        ;
-        ;
-FINDDT  ; Find entry in V LAB for the date/time or one close to it.
-        ; RPMS stores related specimen entries under the same date/time.
-        ; Lab file #63 creates unique entries with slightly different times.
-        ;
-        S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0))
-        I C0CDA>0 Q
-        ;
-        ; If entry found then confirm that specimen type matches.
-        N C0CDTY
-        S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0))
-        I C0CDTY D
-        . I $P(C0CDT,".")'=$P(C0CDTY,".") Q
-        . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0))
-        . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA=""
-        ;
-        Q
+C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009
+ ;;1.0;C0C;;May 19, 2009;Build 38
+ ;
+ ;
+ Q
+ ;
+ ;
+LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for Lab Result Query
+ ;
+ ;
+ K ^TMP("C0C-VLAB",$J)
+ ;
+ ; Check and retrieve lab results from LAB DATA file (#63)
+ S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7))
+ ;
+ ; If V LAB file present then check for lab results that are only in this file
+ ; If results found in V Lab file then build results and add to above results.
+ I $D(^AUPNVLAB) D
+ . D VCHECK
+ . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD
+ ;
+ ;K ^TMP("C0C-VLAB",$J)
+ ;
+ Q C0CDEST
+ ;
+ ;
+VCHECK ; If V LAB file present then check for lab results that are only in this file.
+ ;
+ N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC
+ ;
+ S LA7PTID=C0CPTID
+ D PATID^LA7QRY2
+ I $D(LA7ERR) Q
+ ;
+ ; Resolve search codes to lab datanames
+ S LA7SC=$G(C0CSC)
+ I $T(SCLIST^LA7QRY2)'="" D
+ . N TMP
+ . S LA7SCRC=$G(C0CSC)
+ . S TMP=$$SCLIST^LA7QRY2(LA7SCRC)
+ . S LA7SC=TMP
+ ;
+ I LA7SC'="*" D CHKSC^LA7QRY1
+ ;
+ ; Convert specimen codes to file #61 Topography entries
+ S LA7SPEC=$G(C0CSPEC)
+ I LA7SPEC'="*"  D SPEC^LA7QRY1
+ ;
+ S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0
+ ;
+ F  S C0CROOT=$Q(@C0CROOT) Q:C0CROOT=""  D  Q:C0CEND
+ . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q  ; Left x-ref or patient
+ . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q  ; Exceeded end date/time
+ . S C0CDA=$QS(C0CROOT,4)
+ . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q  ; Already checked during scan of file #63
+ . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q  ; Source is LAB DATA file - skip
+ . D VCHK1
+ ;
+ ;
+ Q
+ ;
+ ;
+VBUILD ; Build results found only in V LAB file into HL7 structure.
+ ;
+ ;
+ Q
+ ;
+ ;
+LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63.
+ ; Call from LA7QRY2
+ ;
+ N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X
+ ;
+ S DFN=$P(^LR(LRDFN,0),"^",3)
+ S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0)
+ S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5)
+ S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)=""
+ ;
+ ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)=""
+ ;
+ S C0C60=""
+ F  S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60  D  Q:C0CLN'=""
+ . D FINDDT
+ . I C0CDA<1 Q
+ . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q  ; Source is not LAB DATA file - skip
+ . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13)
+ . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8)
+ . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer
+ . I C0CPDA="" S C0CPDA=C0CDA
+ . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2)
+ . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2)
+ . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^")
+ . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2)
+ . S ^TMP("C0C-VLAB",$J,1,C0CDA)=""
+ . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)=""
+ . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST
+ ;
+ S X=$P(LA7X,"^",3)
+ ; If order NLT then update if no order NLT
+ I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64)
+ ;
+ ; If result NLT then update if no result NLT
+ I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64)
+ ;
+ ; If LOINC found then update variable with LN code
+ I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN
+ ;
+ S $P(LA7X,"^",3)=X
+ ;
+ Q
+ ;
+ ;
+TMPCHK ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments
+ ; Called from LA7VOBX1
+ ;
+ N I,X
+ ;
+ S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB))
+ I X="" Q
+ F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I)
+ S $P(LA7VAL,"^",3)=LA7X
+ ;
+ Q
+ ;
+ ;
+VCHK1 ; Check the entry in V Lab to determine if it meets criteria
+ ;
+ N C0CVLAB,I
+ ;
+ F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I))
+ ;
+ ; JMC 04/13/09 - Store anything for now that meets date criteria.
+ D VSTORE
+ ;
+ Q
+ ;
+ ;
+VSTORE ; Store entry for building in HL7 message when parent is from V LAB file.
+ ;
+ N C0CPDA,C0CPTEST
+ ;
+ ; Determine parent test to use for OBR segment
+ S C0CPDA=$P(C0CVLAB(12),"^",8)
+ I C0CPDA="" S C0CPDA=C0CDA
+ ;
+ ; Determine parent test
+ S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^")
+ ;
+ S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA
+ ;
+ Q
+ ;
+ ;
+FINDDT ; Find entry in V LAB for the date/time or one close to it.
+ ; RPMS stores related specimen entries under the same date/time.
+ ; Lab file #63 creates unique entries with slightly different times.
+ ;
+ S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0))
+ I C0CDA>0 Q
+ ;
+ ; If entry found then confirm that specimen type matches.
+ N C0CDTY
+ S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0))
+ I C0CDTY D
+ . I $P(C0CDT,".")'=$P(C0CDTY,".") Q
+ . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0))
+ . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA=""
+ ;
+ Q

ccr/branches/ohum/p/C0CLABS.m

@@ -1 @@
-C0CALABS        ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CMAIL.m

@@ -1 @@
-C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
-V       ;;0.1;C0C;nopatch;noreleasedate;Build 1
-        ;Copyright 2011 Chris Richardson, Richardson Computer Research
-        ; Modified 3110516@1818
-        ;   rcr@rcresearch.us
-        ;  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.
-        ;
-        ;  ------------------
-        ;Entry Points
-        ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
-        ;  Input:
-        ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
-        ;                      or "*" for all boxes, default is "IN" if missing]"
-        ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
-        ;                                     "*" for All or 9,999 maximum
-        ;                    MALL?1.n = that number of the n most recent
-        ;  Internally:
-        ;    BNAM = Box Name
-        ;  Output:
-        ;    C0CDATA
-        ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
-        ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
-        ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
-        ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
-        ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
-        ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
-        ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
-        ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
-        ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
-        ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
-        ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
-        ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
-        ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
-        ; 
-        ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
-        ;   Input;
-        ;     D0     - The IEN for the message in file 3.9, MESSAGE global
-        ;   Output
-        ;     OUTBF  - The array of your choice to save the expanded and decoded message.
-        ; 
-GETMSG(C0CDATA,C0CINPUT)        ; Common Entry Point for Mailbox Data
-        K:'$G(C0CDATA("KEEP")) C0CDATA
-        N U
-        S U="^"
-        D:$G(C0CINPUT)
-        . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
-        . S INPUT=C0CINPUT
-        . S DUZ=+INPUT
-        . D:$D(^XMB(3.7,DUZ,0))#2
-        . . S MBLST=$P(INPUT,";",2)
-        . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
-        . . S:MALL["*" MALL=99999
-        . . ; Only one of these can be correct
-        . . D
-        . . . ;  If nul, make it "IN" only
-        . . . I MBLST="" D  QUIT
-        . . . . S MBLST("IN")=0,I=0
-        . . . . D GATHER(DUZ,"IN",.LST)
-        . . . .QUIT
-        . . . ;
-        . . . ;  If "*", Get all Mailboxes and look for New Messages
-        . . . I MBLST["*" D  QUIT
-        . . . . N NAM,NUM
-        . . . . S NUM=0
-        . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
-        . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
-        . . . . . D GATHER(DUZ,NAM,.LST)
-        . . . . .QUIT
-        . . . .QUIT
-        . . . ;
-        . . . ;  If comma separated, look for mailboxes with new messages
-        . . . I $L(MBLST,",")>1 D  QUIT
-        . . . . S NAM=""
-        . . . . N T,V
-        . . . . F T=1:1:$L(MBLST,",")  S V=$P(MBLST,",",T)  I $L(V) D
-        . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
-        . . . . . S:NAM="" NAM=V
-        . . . . . D GATHER(DUZ,NAM,.LST)
-        . . . . .QUIT
-        . . . .QUIT
-        . . . ;
-        . . . ;  If only 1 mailbox named, go get it
-        . . . I $L(MBLST) D GATHER(DUZ,MBLST,.LST) QUIT
-        . . .QUIT
-        . . MERGE C0CDATA=LST
-        . .QUIT
-        .QUIT
-        QUIT
-        ;  ===================
-GATHER(DUZ,NAM,LST)     ; Gather Data about the Baskets and their mail
-        N I,J,K,L
-        S (I,K)=0
-        S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
-        F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
-        . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
-        . D   ; :L
-        . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
-        . . S LST(NAM,"MSG",I)=L
-        . . D GETTYP(I)
-        . .QUIT
-        .QUIT
-        S LST(NAM,"NUMBER")=K
-        QUIT
-        ;  ===================
-        ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
-        ; The products of these emails are scanned to identify
-        ;  the number of documents stored in the MIME package.
-        ;  The protocol runs like this;
-        ; Line 1 is the --separator
-        ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
-        ; Line n+2 thru t-1 where t does NOT have "Content-"
-        ; Line t   is Next Section Terminator, or Message Terminator, --separator
-        ; Line t+1 should not exist in the data set if Message Terminator
-        ; CON = "Content-"
-        ; FLG = "--"
-        ; SEP = FLG+7 or more characters  ; Separator
-        ; END = SEP+FLG
-        ; SGC = Segment Count
-        ; Note: separator is a string of specific characters of
-        ;        indeterminate length  
-        ; LST() the transfer array
-        ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
-        ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
-        ;
-GETTYP(D0)      ; Look for the goodies in the Mail
-        N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
-        S CON="Content-"
-        S FLG="--"
-        S SEP=""  ; Start SEP as null, so we can use this to help identify the type
-        S (BCN,CNT,D1,END,SGC)=0
-        S XX=$G(^XMB(3.9,D0,0))
-        S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
-        S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
-        F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
-        S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
-        S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
-        ; Get the folks the email is sent to.
-        S D1=0
-        F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
-        . N T
-        . S T=+$G(^XMB(3.9,D0,1,D1,0))
-        . S:T T=$P($G(^VA(200,+T,0)),"^")
-        . S LST("TO",D1)=T
-        . S T=$G(^XMB(3.9,D0,6,D1,0))
-        . S:T T=$P($G(^VA(200,+T,0)),"^")
-        . S:T="" T="<Unknown>"
-        . S LST("TO NAME",D1)=T
-        .QUIT
-        ; Preload first Segment (0) with beginning on Line 1
-        ;  if not a 64bit
-        S LST(NAM,"MSG",D0,"SEG",0)=1
-        S D1=.9999,SEP="--"
-        F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
-        . ; Clear any control characters (cr/lf/ff) off
-        . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
-        . ; Enter once to set the SEP to capture the separator
-        . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
-        . . S SEP=X,END=X_FLG
-        . . S (CNT,SGC)=1,BCN=0
-        . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
-        . .QUIT
-        . ;
-        . ; A new separator is set, process original 
-        . I X=SEP  D  QUIT
-        . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN
-        . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
-        . . S SGC=SGC+1,BCN=0
-        . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
-        . .QUIT
-        . ;
-        . S BCN=BCN+$L(X)
-        . I X[CON D  Q
-        . . S J=$P($P(X,";"),CON,2)
-        . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
-        . .QUIT
-        . ;
-        . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
-        .QUIT
-        QUIT
-        ;  ===================
-NAME(NM)        ; Return the name of the Sender
-        N NAME
-        S NAME="<Unknown Sender>"
-        D
-        . ; Look first for a value to use with the NEW PERSON file
-        . ;
-        . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
-        . ;
-        . I $L(NM) S NAME=NM                    Q
-        . ;
-        . ; Else, pull the data from the message and display the foreign source
-        . ;   of the message.
-        . N T
-        . S VAL=$G(^XMB(3.9,D0,.7))
-        . S:VAL T=$P(^VA(200,VAL,0),U)
-        . I $L($G(T)) S NAME=T                  Q
-        . ;
-        .QUIT
-        QUIT NAME
-        ;  ===================
-TIME(Y) ; The time and date of the sending
-        X ^DD("DD")
-        QUIT Y
-        ;  ===================
-        ;  Segments in Message need to be identified and decoded properly
-        ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
-        ;   ARRAY will have the details of this one call
-        ;    
-        ; Inputs;
-        ;   C0CINPUT    - The IEN of the message to expand
-        ; Outputs;
-        ;   C0CDATA     - Carrier for the returned structure of the Message
-        ;  C0CDATA(D0,"SEG")=number of SEGMENTS
-        ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details
-        ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
-        ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
-        ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
-        ;
-DETAIL(C0CDATA,C0CINPUT)        ; Message Detail Delivery
-        N LST,D0,D1,U
-        S U="^"
-        S D0=+$G(C0CINPUT)
-        I D0   D    QUIT
-        . D GETTYP2(D0)
-        . I $D(LST)   M C0CDATA(D0)=LST
-        .QUIT
-        QUIT
-        ;  ===================
-        ;  End note if needed
-        ; MSK   - Set of characters that do not exist in 64 bit encoding
-GETTYP2(D0)     ; Try to get the types and MSK for the 
-        N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
-        S CON="Content-",U="^"
-        S FLG="--"
-        S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
-        S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
-        S (BCN,CNT,D1,END,SGC)=0
-        S XX=$G(^XMB(3.9,D0,0))
-        ; S K=$P(^XMB(3.9,D0,2,0),U,3)
-        S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
-        S LST("CREATED")=$$TIME($P(XX,U,3))
-        F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
-        S LST("FROM")=$$NAME(XXNM)
-        ; Get the folks the email is sent to.
-        S D1=0
-        F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
-        . N I,T
-        . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
-        . S:T T=$P($G(^VA(200,T,0)),"^")
-        . S LST("TO",+D1)=T
-        . S T=$G(^XMB(3.9,D0,6,+D1,0))
-        . S:T="" T=$P($G(^VA(200,+T,0)),"^")
-        . S:T="" T="<Unknown>"
-        . S LST("TO NAME",D1)=T
-        .QUIT
-        ; Get the Header for the message
-        S D1=0
-        F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
-        . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
-        .QUIT
-        ; Start walking the different sections
-        S D1=.99999,SEP="--"
-        F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
-        . ; Clear any control characters (cr/lf/ff) off
-        . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
-        . ; Enter once to set the SEP to capture the separator
-        . I (SEP="--")&($E(X,1,2)=FLG)&($L(X,FLG)=2)  D   Q
-        . . S SEP=X,END=X_FLG
-        . . S (CNT,SGC)=1,BCN=0
-        . . S LST("SEG",SGC)=D1
-        . .QUIT
-        . ;
-        . ; A new SEGMENT separator is set, process original 
-        . I X=SEP  D  QUIT
-        . . ; Save Current Values
-        . . S LST("SEG",SGC,"SIZE")=BCN
-        . . ;  Close this Segment and prepare to start a New Segment
-        . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
-        . . ;  Put the result in LST("SEG",SGC,"XML")
-        . . I $L(BF) D
-        . . . S ZN=1
-        . . . N I,T,TBF
-        . . . S TBF=BF
-        . . . F I=1:1:($L(TBF,"="))  D
-        . . . . S BF=$P(TBF,"=",I)_"="
-        . . . . I BF'="="  D DECODER
-        . . . .QUIT
-        . . . S BF=""
-        . . .QUIT
-        . . S SGC=SGC+1,BCN=0
-        . . ; Incriment SGC to start a new Segment
-        . . S LST("SEG",SGC)=D1
-        . .QUIT
-        . ;
-        . ; Accumulate the 64 bit encoding
-        . I X=$TR(X,MSK)&$L(X) D   Q
-        . . S BF=BF_X
-        . . S BCN=BCN+$L(X)
-        . .QUIT 
-        . ;
-        . ; Ending Condition, close out the Segment
-        . I X=END D  QUIT
-        . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
-        . . I $L(BF) S ZN=1 D DECODER  S BF="" Q
-        . .QUIT
-        . ;
-        . S BCN=BCN+$L(X)
-        . ; Split out the Content Info
-        . I X[CON D  Q
-        . . S J=$P(X,CON,2)
-        . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9)
-        . .QUIT
-        . ;
-        . ; Everything else is Text
-        . S LST("SEG",SGC,"TXT",D1)=X
-        .QUIT
-        QUIT
-        ;  ===================
-        ; Break down the Buffer Array so it can be saved.
-        ;  BF is passed in.
-DECODER ; 
-        N RCNT,TBF,ZBF,ZI,ZJ,ZK,ZSIZE
-        S ZBF=BF
-        ;  Full Buffer, BF, now check for Encryption and Unpack
-        F RCNT=1:1:$L(ZBF,"=")   D
-        . N BF
-        . S BF=$P(ZBF,"=",RCNT)
-        . ;  Unpacking the 64 bit encoding
-        . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
-        . D:$L(TBF)
-        . . N XBF
-        . . S BF=BF_"="
-        . . D NORMAL(.XBF,.TBF)
-        . . M LST("SEG",SGC,"XML",RCNT)=XBF
-        . .QUIT
-        .QUIT
-        QUIT
-        ;  ===================
-        ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
-        ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
-        ;   >D NORMAL^C0CMAIL(.OUT,BF)
-NORMAL(OUTXML,INXML)       ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
-        ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
-        ;
-        N ZN,OUTBF
-        S ZN=1
-        S OUTBF(ZN)=$P(INXML,"><",ZN)_">"
-        F ZN=ZN+1:1 S OUTBF(ZN)="<"_$P(INXML,"><",ZN) Q:$P(INXML,"><",ZN+1)=""  D  ;
-        . S OUTBF(ZN)=OUTBF(ZN)_">"
-        .QUIT
-        M OUTXML=OUTBF
-        QUIT
-        ;  ===================
-        ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
-        ;  End note if needed
-        QUIT
-        ;  ===================
+C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
+V ;;0.1;C0C;nopatch;noreleasedate
+ ;Copyright 2011 Chris Richardson, Richardson Computer Research
+ ; Modified 3110516@1818
+ ;   rcr@rcresearch.us
+ ;  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.
+ ;
+ ;  ------------------
+ ;Entry Points
+ ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
+ ;  Input:
+ ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
+ ;                      or "*" for all boxes, default is "IN" if missing]"
+ ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
+ ;                                     "*" for All or 9,999 maximum
+ ;                    MALL?1.n = that number of the n most recent
+ ;  Internally:
+ ;    BNAM = Box Name
+ ;  Output:
+ ;    C0CDATA
+ ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
+ ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
+ ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
+ ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
+ ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
+ ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
+ ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
+ ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
+ ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
+ ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
+ ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
+ ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
+ ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
+ ; 
+ ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
+ ;   Input;
+ ;     D0     - The IEN for the message in file 3.9, MESSAGE global
+ ;   Output
+ ;     OUTBF  - The array of your choice to save the expanded and decoded message.
+ ; 
+GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data
+ K:'$G(C0CDATA("KEEP")) C0CDATA
+ N U
+ S U="^"
+ D:$G(C0CINPUT)
+ . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
+ . S INPUT=C0CINPUT
+ . S DUZ=+INPUT
+ . D:$D(^XMB(3.7,DUZ,0))#2
+ . . S MBLST=$P(INPUT,";",2)
+ . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
+ . . S:MALL["*" MALL=99999
+ . . ; Only one of these can be correct
+ . . D
+ . . . ;  If nul, make it "IN" only
+ . . . I MBLST="" D  QUIT
+ . . . . S MBLST("IN")=0,I=0
+ . . . . D GATHER(DUZ,"IN",.LST)
+ . . . .QUIT
+ . . . ;
+ . . . ;  If "*", Get all Mailboxes and look for New Messages
+ . . . I MBLST["*" D  QUIT
+ . . . . N NAM,NUM
+ . . . . S NUM=0
+ . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
+ . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
+ . . . . . D GATHER(DUZ,NAM,.LST)
+ . . . . .QUIT
+ . . . .QUIT
+ . . . ;
+ . . . ;  If comma separated, look for mailboxes with new messages
+ . . . I $L(MBLST,",")>1 D  QUIT
+ . . . . S NAM=""
+ . . . . N T,V
+ . . . . F T=1:1:$L(MBLST,",")  S V=$P(MBLST,",",T)  I $L(V) D
+ . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
+ . . . . . S:NAM="" NAM=V
+ . . . . . D GATHER(DUZ,NAM,.LST)
+ . . . . .QUIT
+ . . . .QUIT
+ . . . ;
+ . . . ;  If only 1 mailbox named, go get it
+ . . . I $L(MBLST) D GATHER(DUZ,MBLST,.LST) QUIT
+ . . .QUIT
+ . . MERGE C0CDATA=LST
+ . .QUIT
+ .QUIT
+ QUIT
+ ;  ===================
+GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail
+ N I,J,K,L
+ S (I,K)=0
+ S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
+ F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
+ . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
+ . D   ; :L
+ . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
+ . . S LST(NAM,"MSG",I)=L
+ . . D GETTYP(I)
+ . .QUIT
+ .QUIT
+ S LST(NAM,"NUMBER")=K
+ QUIT
+ ;  ===================
+ ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
+ ; The products of these emails are scanned to identify
+ ;  the number of documents stored in the MIME package.
+ ;  The protocol runs like this;
+ ; Line 1 is the --separator
+ ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
+ ; Line n+2 thru t-1 where t does NOT have "Content-"
+ ; Line t   is Next Section Terminator, or Message Terminator, --separator
+ ; Line t+1 should not exist in the data set if Message Terminator
+ ; CON = "Content-"
+ ; FLG = "--"
+ ; SEP = FLG+7 or more characters  ; Separator
+ ; END = SEP+FLG
+ ; SGC = Segment Count
+ ; Note: separator is a string of specific characters of
+ ;        indeterminate length  
+ ; LST() the transfer array
+ ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
+ ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
+ ;
+GETTYP(D0) ; Look for the goodies in the Mail
+ N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
+ S CON="Content-"
+ S FLG="--"
+ S SEP=""  ; Start SEP as null, so we can use this to help identify the type
+ S (BCN,CNT,D1,END,SGC)=0
+ S XX=$G(^XMB(3.9,D0,0))
+ S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
+ S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
+ F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
+ S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
+ S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
+ ; Get the folks the email is sent to.
+ S D1=0
+ F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
+ . N T
+ . S T=+$G(^XMB(3.9,D0,1,D1,0))
+ . S:T T=$P($G(^VA(200,+T,0)),"^")
+ . S LST("TO",D1)=T
+ . S T=$G(^XMB(3.9,D0,6,D1,0))
+ . S:T T=$P($G(^VA(200,+T,0)),"^")
+ . S:T="" T="<Unknown>"
+ . S LST("TO NAME",D1)=T
+ .QUIT
+ ; Preload first Segment (0) with beginning on Line 1
+ ;  if not a 64bit
+ S LST(NAM,"MSG",D0,"SEG",0)=1
+ S D1=.9999,SEP="--"
+ F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
+ . ; Clear any control characters (cr/lf/ff) off
+ . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
+ . ; Enter once to set the SEP to capture the separator
+ . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
+ . . S SEP=X,END=X_FLG
+ . . S (CNT,SGC)=1,BCN=0
+ . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
+ . .QUIT
+ . ;
+ . ; A new separator is set, process original 
+ . I X=SEP  D  QUIT
+ . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN
+ . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
+ . . S SGC=SGC+1,BCN=0
+ . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
+ . .QUIT
+ . ;
+ . S BCN=BCN+$L(X)
+ . I X[CON D  Q
+ . . S J=$P($P(X,";"),CON,2)
+ . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
+ . .QUIT
+ . ;
+ . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
+ .QUIT
+ QUIT
+ ;  ===================
+NAME(NM) ; Return the name of the Sender
+ N NAME
+ S NAME="<Unknown Sender>"
+ D
+ . ; Look first for a value to use with the NEW PERSON file
+ . ;
+ . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
+ . ;
+ . I $L(NM) S NAME=NM                    Q
+ . ;
+ . ; Else, pull the data from the message and display the foreign source
+ . ;   of the message.
+ . N T
+ . S VAL=$G(^XMB(3.9,D0,.7))
+ . S:VAL T=$P(^VA(200,VAL,0),U)
+ . I $L($G(T)) S NAME=T                  Q
+ . ;
+ .QUIT
+ QUIT NAME
+ ;  ===================
+TIME(Y) ; The time and date of the sending
+ X ^DD("DD")
+ QUIT Y
+ ;  ===================
+ ;  Segments in Message need to be identified and decoded properly
+ ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
+ ;   ARRAY will have the details of this one call
+ ;    
+ ; Inputs;
+ ;   C0CINPUT    - The IEN of the message to expand
+ ; Outputs;
+ ;   C0CDATA     - Carrier for the returned structure of the Message
+ ;  C0CDATA(D0,"SEG")=number of SEGMENTS
+ ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details
+ ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
+ ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
+ ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
+ ;
+DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery
+ N LST,D0,D1,U
+ S U="^"
+ S D0=+$G(C0CINPUT)
+ I D0   D    QUIT
+ . D GETTYP2(D0)
+ . I $D(LST)   M C0CDATA(D0)=LST
+ .QUIT
+ QUIT
+ ;  ===================
+ ;  End note if needed
+ ; MSK   - Set of characters that do not exist in 64 bit encoding
+GETTYP2(D0) ; Try to get the types and MSK for the 
+ N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
+ S CON="Content-",U="^"
+ S FLG="--"
+ S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
+ S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
+ S (BCN,CNT,D1,END,SGC)=0
+ S XX=$G(^XMB(3.9,D0,0))
+ ; S K=$P(^XMB(3.9,D0,2,0),U,3)
+ S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
+ S LST("CREATED")=$$TIME($P(XX,U,3))
+ F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
+ S LST("FROM")=$$NAME(XXNM)
+ ; Get the folks the email is sent to.
+ S D1=0
+ F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
+ . N I,T
+ . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
+ . S:T T=$P($G(^VA(200,T,0)),"^")
+ . S LST("TO",+D1)=T
+ . S T=$G(^XMB(3.9,D0,6,+D1,0))
+ . S:T="" T=$P($G(^VA(200,+T,0)),"^")
+ . S:T="" T="<Unknown>"
+ . S LST("TO NAME",D1)=T
+ .QUIT
+ ; Get the Header for the message
+ S D1=0
+ F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
+ . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
+ .QUIT
+ ; Start walking the different sections
+ S D1=.99999,SEP="--"
+ F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
+ . ; Clear any control characters (cr/lf/ff) off
+ . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
+ . ; Enter once to set the SEP to capture the separator
+ . I (SEP="--")&($E(X,1,2)=FLG)&($L(X,FLG)=2)  D   Q
+ . . S SEP=X,END=X_FLG
+ . . S (CNT,SGC)=1,BCN=0
+ . . S LST("SEG",SGC)=D1
+ . .QUIT
+ . ;
+ . ; A new SEGMENT separator is set, process original 
+ . I X=SEP  D  QUIT
+ . . ; Save Current Values
+ . . S LST("SEG",SGC,"SIZE")=BCN
+ . . ;  Close this Segment and prepare to start a New Segment
+ . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
+ . . ;  Put the result in LST("SEG",SGC,"XML")
+ . . I $L(BF) D
+ . . . S ZN=1
+ . . . N I,T,TBF
+ . . . S TBF=BF
+ . . . F I=1:1:($L(TBF,"="))  D
+ . . . . S BF=$P(TBF,"=",I)_"="
+ . . . . I BF'="="  D DECODER
+ . . . .QUIT
+ . . . S BF=""
+ . . .QUIT
+ . . S SGC=SGC+1,BCN=0
+ . . ; Incriment SGC to start a new Segment
+ . . S LST("SEG",SGC)=D1
+ . .QUIT
+ . ;
+ . ; Accumulate the 64 bit encoding
+ . I X=$TR(X,MSK)&$L(X) D   Q
+ . . S BF=BF_X
+ . . S BCN=BCN+$L(X)
+ . .QUIT 
+ . ;
+ . ; Ending Condition, close out the Segment
+ . I X=END D  QUIT
+ . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
+ . . I $L(BF) S ZN=1 D DECODER  S BF="" Q
+ . .QUIT
+ . ;
+ . S BCN=BCN+$L(X)
+ . ; Split out the Content Info
+ . I X[CON D  Q
+ . . S J=$P(X,CON,2)
+ . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9)
+ . .QUIT
+ . ;
+ . ; Everything else is Text
+ . S LST("SEG",SGC,"TXT",D1)=X
+ .QUIT
+ QUIT
+ ;  ===================
+ ; Break down the Buffer Array so it can be saved.
+ ;  BF is passed in.
+DECODER ; 
+ N RCNT,TBF,ZBF,ZI,ZJ,ZK,ZSIZE
+ S ZBF=BF
+ ;  Full Buffer, BF, now check for Encryption and Unpack
+ F RCNT=1:1:$L(ZBF,"=")   D
+ . N BF
+ . S BF=$P(ZBF,"=",RCNT)
+ . ;  Unpacking the 64 bit encoding
+ . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
+ . D:$L(TBF)
+ . . N XBF
+ . . S BF=BF_"="
+ . . D NORMAL(.XBF,.TBF)
+ . . M LST("SEG",SGC,"XML",RCNT)=XBF
+ . .QUIT
+ .QUIT
+ QUIT
+ ;  ===================
+ ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
+ ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
+ ;   >D NORMAL^C0CMAIL(.OUT,BF)
+NORMAL(OUTXML,INXML)    ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
+ ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
+ ;
+ N ZN,OUTBF
+ S ZN=1
+ S OUTBF(ZN)=$P(INXML,"><",ZN)_">"
+ F ZN=ZN+1:1 S OUTBF(ZN)="<"_$P(INXML,"><",ZN) Q:$P(INXML,"><",ZN+1)=""  D  ;
+ . S OUTBF(ZN)=OUTBF(ZN)_">"
+ .QUIT
+ M OUTXML=OUTBF
+ QUIT
+ ;  ===================
+ ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
+ ;  End note if needed
+ QUIT
+ ;  ===================

ccr/branches/ohum/p/C0CMAIL2.m

@@ -1 @@
-C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
-        ;;0.1;C0C;nopatch;noreleasedate;Build 1
-        ;Copyright 2011 Chris Richardson, Richardson Computer Research
-        ; Modified 3110615@1040
-        ;   rcr@rcresearch.us
-        ;  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.
-        ;
-        ;  ------------------
-        ;Entry Points
-        ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments
-        ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
-        ;  Input:
-        ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
-        ;                      or "*" for all boxes, default is "IN" if missing]"
-        ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
-        ;                                     "*" for All or 9,999 maximum
-        ;                    MALL?1.n = that number of the n most recent
-        ;  Internally:
-        ;    BNAM = Box Name
-        ;  Output:
-        ;    C0CDATA
-        ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
-        ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
-        ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
-        ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
-        ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
-        ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
-        ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
-        ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
-        ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
-        ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
-        ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
-        ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
-        ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
-        ; 
-        ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
-        ;   Input;
-        ;     D0     - The IEN for the message in file 3.9, MESSAGE global
-        ;   Output
-        ;     OUTBF  - The array of your choice to save the expanded and decoded message.
-        ; 
-GETMSG(C0CDATA,C0CINPUT)        ; Common Entry Point for Mailbox Data
-        K:'$G(C0CDATA("KEEP")) C0CDATA
-        N U
-        S U="^"
-        D:$G(C0CINPUT)
-        . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
-        . S INPUT=C0CINPUT
-        . S DUZ=+INPUT
-        . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0)))  D ERROR("ER06")  Q
-        . ;
-        . D:$D(^XMB(3.7,DUZ,0))#2
-        . . S MBLST=$P(INPUT,";",2)
-        . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
-        . . S:MALL["*" MALL=99999
-        . . ; Only one of these can be correct
-        . . D
-        . . . ;  If nul, make it "IN" only
-        . . . I MBLST="" D  QUIT
-        . . . . S MBLST("IN")=0,I=0
-        . . . . D GATHER(DUZ,"IN",.LST)
-        . . . .QUIT
-        . . . ;
-        . . . ;  If "*", Get all Mailboxes and look for New Messages
-        . . . I MBLST["*" D  QUIT
-        . . . . N NAM,NUM
-        . . . . S NUM=0
-        . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
-        . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
-        . . . . . D GATHER(DUZ,NAM,.LST)
-        . . . . .QUIT
-        . . . .QUIT
-        . . . ;
-        . . . ;  If comma separated, look for mailboxes with new messages
-        . . . I $L(MBLST,",")>1 D  QUIT
-        . . . . S NAM=""
-        . . . . N TN,V
-        . . . . F TN=1:1:$L(MBLST,",")  S V=$P(MBLST,",",TN)  D
-        . . . . . I $L(V) D   QUIT
-        . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
-        . . . . . . S:NAM="" NAM=V
-        . . . . . . D GATHER(DUZ,NAM,.LST)
-        . . . . . .QUIT
-        . . . . . ;
-        . . . . . D ERROR("ER08")
-        . . . . .QUIT
-        . . . .QUIT
-        . . . ;
-        . . . ;  If only 1 mailbox named, go get it
-        . . . I $L(MBLST)  D   QUIT
-        . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST))    D GATHER(DUZ,MBLST,.LST) QUIT
-        . . . . ;
-        . . . . D ERROR("ER07")
-        . . .QUIT
-        . . MERGE C0CDATA=LST
-        . .QUIT
-        .QUIT
-        QUIT
-        ;  ===================
-GATHER(DUZ,NAM,LST)     ; Gather Data about the Baskets and their mail
-        N I,J,K,L
-        S (I,K)=0
-        S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
-        F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
-        . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
-        . D   ; :L
-        . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
-        . . S LST(NAM,"MSG",I)=L
-        . . D GETTYP(I)
-        . .QUIT
-        .QUIT
-        S LST(NAM,"NUMBER")=K
-        QUIT
-        ;  ===================
-        ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
-        ; The products of these emails are scanned to identify
-        ;  the number of documents stored in the MIME package.
-        ;  The protocol runs like this;
-        ; Line 1 is the --separator
-        ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
-        ; Line n+2 thru t-1 where t does NOT have "Content-"
-        ; Line t   is Next Section Terminator, or Message Terminator, --separator
-        ; Line t+1 should not exist in the data set if Message Terminator
-        ; CON = "Content-"
-        ; FLG = "--"
-        ; SEP = FLG+7 or more characters  ; Separator
-        ; END = SEP+FLG
-        ; SGC = Segment Count
-        ; Note: separator is a string of specific characters of
-        ;        indeterminate length  
-        ; LST() the transfer array
-        ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
-        ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
-        ;
-GETTYP(D0)      ; Look for the goodies in the Mail
-        N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
-        S CON="Content-"
-        S FLG="--"
-        S SEP=""  ; Start SEP as null, so we can use this to help identify the type
-        S (BCN,CNT,D1,END,SGC)=0
-        S XX=$G(^XMB(3.9,D0,0))
-        S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
-        S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
-        F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
-        S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
-        S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
-        ; Get the folks the email is sent to.
-        S D1=0
-        F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
-        . N T
-        . S T=+$G(^XMB(3.9,D0,1,D1,0))
-        . S:T T=$P($G(^VA(200,+T,0)),"^")
-        . S LST("TO",D1)=T
-        . S T=$G(^XMB(3.9,D0,6,D1,0))
-        . S:T T=$P($G(^VA(200,+T,0)),"^")
-        . S:T="" T="<Unknown>"
-        . S LST("TO NAME",D1)=T
-        .QUIT
-        ; Preload first Segment (0) with beginning on Line 1
-        ;  if not a 64bit
-        S LST(NAM,"MSG",D0,"SEG",0)=1
-        S D1=.9999,SEP="@@"
-        F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
-        . ; Clear any control characters (cr/lf/ff) off
-        . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
-        . ; Enter once to set the SEP to capture the separator
-        . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
-        . . S SEP=X,END=X_FLG
-        . . S (CNT,SGC)=1,BCN=0
-        . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
-        . .QUIT
-        . ;
-        . ; A new separator is set, process original 
-        . I X=SEP  D  QUIT
-        . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF)
-        . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
-        . . S SGC=SGC+1,BCN=0
-        . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
-        . .QUIT
-        . ;
-        . S BCN=BCN+$L(X)
-        . I X[CON D  Q
-        . . S J=$P($P(X,";"),CON,2)
-        . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
-        . .QUIT
-        . ;
-        . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
-        .QUIT
-        QUIT
-        ;  ===================
-NAME(NM)        ; Return the name of the Sender
-        N NAME
-        S NAME="<Unknown Sender>"
-        D
-        . ; Look first for a value to use with the NEW PERSON file
-        . ;
-        . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
-        . ;
-        . I $L(NM) S NAME=NM                    Q
-        . ;
-        . ; Else, pull the data from the message and display the foreign source
-        . ;   of the message.
-        . N T
-        . S VAL=$G(^XMB(3.9,D0,.7))
-        . S:VAL T=$P(^VA(200,VAL,0),U)
-        . I $L($G(T)) S NAME=T                  Q
-        . ;
-        .QUIT
-        QUIT NAME
-        ;  ===================
-TIME(Y) ; The time and date of the sending
-        X ^DD("DD")
-        QUIT Y
-        ;  ===================
-        ;  Segments in Message need to be identified and decoded properly
-        ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
-        ;   ARRAY will have the details of this one call
-        ;    
-        ; Inputs;
-        ;   C0CINPUT    - The IEN of the message to expand
-        ; Outputs;
-        ;   C0CDATA     - Carrier for the returned structure of the Message
-        ;  C0CDATA(D0,"SEG")=number of SEGMENTS
-        ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type
-        ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
-        ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
-        ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
-        ;
-DETAIL(C0CDATA,C0CINPUT)        ; Message Detail Delivery
-        N LST,D0,D1,U
-        S U="^"
-        S D0=+$G(C0CINPUT)
-        I D0   D    QUIT
-        . I $D(^XMB(3.9,D0))<10 D ERROR("ER01")  QUIT
-        . ;
-        . D GETTYP2(D0)
-        . I $D(LST)   M C0CDATA(D0)=LST  Q
-        . ;
-        . D ERROR("ER02")
-        .QUIT
-        QUIT
-        ;  ===================
-        ;  End note if needed
-        ; MSK   - Set of characters that do not exist in 64 bit encoding
-GETTYP2(D0)     ; Try to get the types and MSK for the 
-        N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
-        S CON="Content-",U="^"
-        S FLG="--"
-        S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
-        S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
-        S (BCN,CNT,D1,END,SGC)=0
-        S XX=$G(^XMB(3.9,D0,0))
-        ; S K=$P(^XMB(3.9,D0,2,0),U,3)
-        S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
-        S LST("CREATED")=$$TIME($P(XX,U,3))
-        F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
-        S LST("FROM")=$$NAME(XXNM)
-        ; Get the folks the email is sent to.
-        S D1=0
-        F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
-        . N I,T
-        . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
-        . S:T T=$P($G(^VA(200,T,0)),"^")
-        . S LST("TO",+D1)=T
-        . S T=$G(^XMB(3.9,D0,6,+D1,0))
-        . S:T="" T=$P($G(^VA(200,+T,0)),"^")
-        . S:T="" T="<Unknown>"
-        . S LST("TO NAME",D1)=T
-        .QUIT
-        ; Get the Header for the message
-        S D1=0
-        F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
-        . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
-        .QUIT
-        ; Start walking the different sections
-        S D1=.99999,SEP="@@",SGC=0
-        F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
-        . ; Clear any control characters (cr/lf/ff) off
-        . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
-        . ; Enter once to set the SEP to capture the separator
-        . I (SEP="@@")&(X?2."--"5.AN.E)  D   Q
-        . . I $L(X,FLG)>2 D ERROR("ER10")
-        . . S SEP=X,END=X_FLG
-        . . S (CNT,SGC)=1,BCN=0
-        . . S LST("SEG",SGC)=D1
-        . .QUIT
-        . ;
-        . ; A new SEGMENT separator is set, process original 
-        . I X=SEP  D  QUIT
-        . . ; Save Current Values
-        . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF)
-        . . ;  Close this Segment and prepare to start a New Segment
-        . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1)
-        . . ;  Put the result in LST("SEG",SGC,"XML")
-        . . I $L(BF) D
-        . . . S ZN=1
-        . . . N I,T,TBF
-        . . . S TBF=BF
-        . . . F I=1:1:($L(TBF,"="))  D
-        . . . . S BF=$P(TBF,"=",I)_"="
-        . . . . I BF'="="  D DECODER
-        . . . .QUIT
-        . . . S BF=""
-        . . .QUIT
-        . . S SGC=SGC+1,BCN=0
-        . . ; Incriment SGC to start a new Segment
-        . . S LST("SEG",SGC)=D1
-        . .QUIT
-        . ;
-        . ; Accumulate the 64 bit encoding
-        . I X=$TR(X,MSK)&$L(X)  S BF=BF_X  QUIT
-        . ;
-        . ; Ending Condition, close out the Segment
-        . I X=END D  QUIT
-        . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
-        . . I $L(BF) S ZN=1 D DECODER  S BF="" Q
-        . .QUIT
-        . ;
-        . ; Accumulate the lengths of other lines of the message
-        . S BCN=BCN+$L(X)
-        . ; Split out the Content Info
-        . I X[CON D  Q
-        . . S J=$P(X,CON,2)
-        . . I J[" boundary=" D
-        . . . S SEP=$P($P(J," boundary=",2),"""",2),END=SEP_FLG
-        . . . Q:SEP?2"-"5.ANP
-        . . . ;
-        . . . D ERROR("ER11")
-        . . . Q:SEP'[" "
-        . . . ;
-        . . . D ERROR("ER12")
-        . . .QUIT
-        . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9)
-        . .QUIT
-        . ;
-        . ; Everything else is Text, Check for CCR/CCD.
-        . N KK,UBF
-        . D
-        . . S UBF=$$UPPER(X)
-        . . I UBF["<CONTINUITYOFCARERECORD"   S $P(LST("SEG",SGC),U,3)="CCR" Q
-        . . ;
-        . . I UBF["<CLINICALDOCUMENT"         S $P(LST("SEG",SGC),U,3)="CCD" Q
-        . .QUIT
-        . ; Look for directives in the text before it gets published
-        . ;  Look for "=3D" and replace it with a single "=".  I can do more parsing
-        . ;  but there may be situations where the line has been wrapped.
-        . D:X["=3D"
-        . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D"
-        . .QUIT
-        . S LST("SEG",SGC,"TXT",D1)=X
-        .QUIT
-        QUIT
-        ;  ===================
-        ; Break down the Buffer Array so it can be saved.
-        ;  BF is passed in.
-DECODER ; 
-        N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE
-        S ZBF=BF
-        ;  Full Buffer, BF, now check for Encryption and Unpack
-        F RCNT=1:1:$L(ZBF,"=")   D
-        . N BF
-        . S BF=$P(ZBF,"=",RCNT)
-        . ;  Unpacking the 64 bit encoding
-        . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
-        . D:$L(TBF)
-        . . N C,OK,OKCNT,KK,XBF,UBF
-        . . D
-        . . . S UBF=$$UPPER(TBF)
-        . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q
-        . . . ;
-        . . . I UBF["<CLINICALDOCUMENT XMLNS="       S $P(LST("SEG",SGC),U,3)="CCD" Q
-        . . .QUIT
-        . . ; Check for Bad Signature Decoding, after 100 bad characters
-        . . S OK=1,OKCNT=0
-        . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q
-        . . ;
-        . . D
-        . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q
-        . . . ;
-        . . . S BF=BF_"="
-        . . . D NORMAL(.XBF,.TBF)
-        . . .QUIT
-        . . M LST("SEG",SGC,"XML",RCNT)=XBF
-        . .QUIT
-        .QUIT
-        QUIT
-        ;  ===================
-        ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
-        ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
-        ;   >D NORMAL^C0CMAIL(.OUT,BF)
-NORMAL(OUTXML,INXML)       ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
-        ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
-        ;
-        N ZN,OUTBF,XX,ZSEP
-        S INXML=$TR(INXML,$C(10,12,13))
-        S ZN=1,ZSEP=">"
-        S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1
-        F ZN=ZN+1:1:$L(INXML,"><")  D   Q:XX=""
-        . S XX=$P(INXML,"><",ZN)
-        . S:$E($RE(XX))=">" ZSEP=""
-        . Q:XX=""
-        . ;
-        . S XX="<"_XX_ZSEP
-        . D
-        . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1   Q
-        . . ;
-        . . D ERROR("ER05")
-        . . F ZL=ZL+1:1 D   Q:XX=""
-        . . .  N XL
-        . . .  S XL=$E(XX,1,4000)
-        . . .  S $E(XX,1,4000)=""   ; S XX=$E(XX,4001,999999) ; Remove 4K characters
-        . . .  S OUTBF(ZL)=XL
-        . . .QUIT
-        . .QUIT
-        .QUIT
-        M OUTXML=OUTBF
-        QUIT
-        ;  ===================
-UPPER(X)        ; Convert any lowercase letters to Uppercase letters
-        QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
-        ;  ===================
-        ; EN is a counter that remains between error events
-ERROR(ER)       ; Error Handler
-        N TXXQ,XXXQ
-        S XXXQ="Unknown Error Encountered = "_ER
-        S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99)
-        I TXXQ'=""  D
-        . I TXXQ["_" X "S TXXQ="_TXXQ
-        . S XXXQ=TXXQ
-        .QUIT
-        S EN(ER)=$G(EN(ER))+1
-        S LST("ERR",ER,EN(ER))=XXXQ
-        QUIT
-        ;  ===================
-ER01    ;;Message Missing
-ER02    ;;Message Text Missing
-ER03    ;;Message Not Identifiable
-ER04    ;;Segment is too large
-ER05    ;;Mailbox Missing
-ER06    ;;"User Missing = "_$G(DUZ)
-ER07    ;;"Bad DUZ = "_DUZ
-ER08    ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN)
-ER10    ;;"Bad Separator found = "_X
-ER11    ;;"Non-Standard Separator Found:>"_$G(J)
-ER12    ;;"Spaces are not allowed in Separators:>"_$G(J)
-        ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
-        ;  End note if needed
-        QUIT
-        ;  ===================
+C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
+V ;;0.1;C0C;nopatch;noreleasedate
+ ;Copyright 2011 Chris Richardson, Richardson Computer Research
+ ; Modified 3110615@1040
+ ;   rcr@rcresearch.us
+ ;  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.
+ ;
+ ;  ------------------
+ ;Entry Points
+ ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments
+ ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
+ ;  Input:
+ ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
+ ;                      or "*" for all boxes, default is "IN" if missing]"
+ ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
+ ;                                     "*" for All or 9,999 maximum
+ ;                    MALL?1.n = that number of the n most recent
+ ;  Internally:
+ ;    BNAM = Box Name
+ ;  Output:
+ ;    C0CDATA
+ ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
+ ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
+ ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
+ ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
+ ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
+ ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
+ ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
+ ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
+ ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
+ ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
+ ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
+ ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
+ ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
+ ; 
+ ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
+ ;   Input;
+ ;     D0     - The IEN for the message in file 3.9, MESSAGE global
+ ;   Output
+ ;     OUTBF  - The array of your choice to save the expanded and decoded message.
+ ; 
+GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data
+ K:'$G(C0CDATA("KEEP")) C0CDATA
+ N U
+ S U="^"
+ D:$G(C0CINPUT)
+ . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
+ . S INPUT=C0CINPUT
+ . S DUZ=+INPUT
+ . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0)))  D ERROR("ER06")  Q
+ . ;
+ . D:$D(^XMB(3.7,DUZ,0))#2
+ . . S MBLST=$P(INPUT,";",2)
+ . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
+ . . S:MALL["*" MALL=99999
+ . . ; Only one of these can be correct
+ . . D
+ . . . ;  If nul, make it "IN" only
+ . . . I MBLST="" D  QUIT
+ . . . . S MBLST("IN")=0,I=0
+ . . . . D GATHER(DUZ,"IN",.LST)
+ . . . .QUIT
+ . . . ;
+ . . . ;  If "*", Get all Mailboxes and look for New Messages
+ . . . I MBLST["*" D  QUIT
+ . . . . N NAM,NUM
+ . . . . S NUM=0
+ . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
+ . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
+ . . . . . D GATHER(DUZ,NAM,.LST)
+ . . . . .QUIT
+ . . . .QUIT
+ . . . ;
+ . . . ;  If comma separated, look for mailboxes with new messages
+ . . . I $L(MBLST,",")>1 D  QUIT
+ . . . . S NAM=""
+ . . . . N TN,V
+ . . . . F TN=1:1:$L(MBLST,",")  S V=$P(MBLST,",",TN)  D
+ . . . . . I $L(V) D   QUIT
+ . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
+ . . . . . . S:NAM="" NAM=V
+ . . . . . . D GATHER(DUZ,NAM,.LST)
+ . . . . . .QUIT
+ . . . . . ;
+ . . . . . D ERROR("ER08")
+ . . . . .QUIT
+ . . . .QUIT
+ . . . ;
+ . . . ;  If only 1 mailbox named, go get it
+ . . . I $L(MBLST)  D   QUIT
+ . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST))    D GATHER(DUZ,MBLST,.LST) QUIT
+ . . . . ;
+ . . . . D ERROR("ER07")
+ . . .QUIT
+ . . MERGE C0CDATA=LST
+ . .QUIT
+ .QUIT
+ QUIT
+ ;  ===================
+GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail
+ N I,J,K,L
+ S (I,K)=0
+ S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
+ F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
+ . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
+ . D   ; :L
+ . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
+ . . S LST(NAM,"MSG",I)=L
+ . . D GETTYP(I)
+ . .QUIT
+ .QUIT
+ S LST(NAM,"NUMBER")=K
+ QUIT
+ ;  ===================
+ ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
+ ; The products of these emails are scanned to identify
+ ;  the number of documents stored in the MIME package.
+ ;  The protocol runs like this;
+ ; Line 1 is the --separator
+ ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
+ ; Line n+2 thru t-1 where t does NOT have "Content-"
+ ; Line t   is Next Section Terminator, or Message Terminator, --separator
+ ; Line t+1 should not exist in the data set if Message Terminator
+ ; CON = "Content-"
+ ; FLG = "--"
+ ; SEP = FLG+7 or more characters  ; Separator
+ ; END = SEP+FLG
+ ; SGC = Segment Count
+ ; Note: separator is a string of specific characters of
+ ;        indeterminate length  
+ ; LST() the transfer array
+ ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
+ ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
+ ;
+GETTYP(D0) ; Look for the goodies in the Mail
+ N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
+ S CON="Content-"
+ S FLG="--"
+ S SEP=""  ; Start SEP as null, so we can use this to help identify the type
+ S (BCN,CNT,D1,END,SGC)=0
+ S XX=$G(^XMB(3.9,D0,0))
+ S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
+ S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
+ F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
+ S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
+ S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
+ ; Get the folks the email is sent to.
+ S D1=0
+ F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
+ . N T
+ . S T=+$G(^XMB(3.9,D0,1,D1,0))
+ . S:T T=$P($G(^VA(200,+T,0)),"^")
+ . S LST("TO",D1)=T
+ . S T=$G(^XMB(3.9,D0,6,D1,0))
+ . S:T T=$P($G(^VA(200,+T,0)),"^")
+ . S:T="" T="<Unknown>"
+ . S LST("TO NAME",D1)=T
+ .QUIT
+ ; Preload first Segment (0) with beginning on Line 1
+ ;  if not a 64bit
+ S LST(NAM,"MSG",D0,"SEG",0)=1
+ S D1=.9999,SEP="@@"
+ F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
+ . ; Clear any control characters (cr/lf/ff) off
+ . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
+ . ; Enter once to set the SEP to capture the separator
+ . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
+ . . S SEP=X,END=X_FLG
+ . . S (CNT,SGC)=1,BCN=0
+ . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
+ . .QUIT
+ . ;
+ . ; A new separator is set, process original 
+ . I X=SEP  D  QUIT
+ . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF)
+ . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
+ . . S SGC=SGC+1,BCN=0
+ . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
+ . .QUIT
+ . ;
+ . S BCN=BCN+$L(X)
+ . I X[CON D  Q
+ . . S J=$P($P(X,";"),CON,2)
+ . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
+ . .QUIT
+ . ;
+ . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
+ .QUIT
+ QUIT
+ ;  ===================
+NAME(NM) ; Return the name of the Sender
+ N NAME
+ S NAME="<Unknown Sender>"
+ D
+ . ; Look first for a value to use with the NEW PERSON file
+ . ;
+ . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
+ . ;
+ . I $L(NM) S NAME=NM                    Q
+ . ;
+ . ; Else, pull the data from the message and display the foreign source
+ . ;   of the message.
+ . N T
+ . S VAL=$G(^XMB(3.9,D0,.7))
+ . S:VAL T=$P(^VA(200,VAL,0),U)
+ . I $L($G(T)) S NAME=T                  Q
+ . ;
+ .QUIT
+ QUIT NAME
+ ;  ===================
+TIME(Y) ; The time and date of the sending
+ X ^DD("DD")
+ QUIT Y
+ ;  ===================
+ ;  Segments in Message need to be identified and decoded properly
+ ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
+ ;   ARRAY will have the details of this one call
+ ;    
+ ; Inputs;
+ ;   C0CINPUT    - The IEN of the message to expand
+ ; Outputs;
+ ;   C0CDATA     - Carrier for the returned structure of the Message
+ ;  C0CDATA(D0,"SEG")=number of SEGMENTS
+ ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type
+ ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
+ ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
+ ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
+ ;
+DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery
+ N LST,D0,D1,U
+ S U="^"
+ S D0=+$G(C0CINPUT)
+ I D0   D    QUIT
+ . I $D(^XMB(3.9,D0))<10 D ERROR("ER01")  QUIT
+ . ;
+ . D GETTYP2(D0)
+ . I $D(LST)   M C0CDATA(D0)=LST  Q
+ . ;
+ . D ERROR("ER02")
+ .QUIT
+ QUIT
+ ;  ===================
+ ;  End note if needed
+ ; MSK   - Set of characters that do not exist in 64 bit encoding
+GETTYP2(D0) ; Try to get the types and MSK for the 
+ N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
+ S CON="Content-",U="^"
+ S FLG="--"
+ S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
+ S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
+ S (BCN,CNT,D1,END,SGC)=0
+ S XX=$G(^XMB(3.9,D0,0))
+ ; S K=$P(^XMB(3.9,D0,2,0),U,3)
+ S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
+ S LST("CREATED")=$$TIME($P(XX,U,3))
+ F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
+ S LST("FROM")=$$NAME(XXNM)
+ ; Get the folks the email is sent to.
+ S D1=0
+ F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
+ . N I,T
+ . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
+ . S:T T=$P($G(^VA(200,T,0)),"^")
+ . S LST("TO",+D1)=T
+ . S T=$G(^XMB(3.9,D0,6,+D1,0))
+ . S:T="" T=$P($G(^VA(200,+T,0)),"^")
+ . S:T="" T="<Unknown>"
+ . S LST("TO NAME",D1)=T
+ .QUIT
+ ; Get the Header for the message
+ S D1=0
+ F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
+ . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
+ .QUIT
+ ; Start walking the different sections
+ S D1=.99999,SEP="@@",SGC=0
+ F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
+ . ; Clear any control characters (cr/lf/ff) off
+ . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
+ . ; Enter once to set the SEP to capture the separator
+ . I (SEP="@@")&(X?2."--"5.AN.E)  D   Q
+ . . I $L(X,FLG)>2 D ERROR("ER10")
+ . . S SEP=X,END=X_FLG
+ . . S (CNT,SGC)=1,BCN=0
+ . . S LST("SEG",SGC)=D1
+ . .QUIT
+ . ;
+ . ; A new SEGMENT separator is set, process original 
+ . I X=SEP  D  QUIT
+ . . ; Save Current Values
+ . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF)
+ . . ;  Close this Segment and prepare to start a New Segment
+ . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1)
+ . . ;  Put the result in LST("SEG",SGC,"XML")
+ . . I $L(BF) D
+ . . . S ZN=1
+ . . . N I,T,TBF
+ . . . S TBF=BF
+ . . . F I=1:1:($L(TBF,"="))  D
+ . . . . S BF=$P(TBF,"=",I)_"="
+ . . . . I BF'="="  D DECODER
+ . . . .QUIT
+ . . . S BF=""
+ . . .QUIT
+ . . S SGC=SGC+1,BCN=0
+ . . ; Incriment SGC to start a new Segment
+ . . S LST("SEG",SGC)=D1
+ . .QUIT
+ . ;
+ . ; Accumulate the 64 bit encoding
+ . I X=$TR(X,MSK)&$L(X)  S BF=BF_X  QUIT
+ . ;
+ . ; Ending Condition, close out the Segment
+ . I X=END D  QUIT
+ . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1)
+ . . I $L(BF) S ZN=1 D DECODER  S BF="" Q
+ . .QUIT
+ . ;
+ . ; Accumulate the lengths of other lines of the message
+ . S BCN=BCN+$L(X)
+ . ; Split out the Content Info
+ . I X[CON D  Q
+ . . S J=$P(X,CON,2)
+ . . I J[" boundary=" D
+ . . . S SEP=$P($P(J," boundary=",2),"""",2),END=SEP_FLG
+ . . . Q:SEP?2"-"5.ANP
+ . . . ;
+ . . . D ERROR("ER11")
+ . . . Q:SEP'[" "
+ . . . ;
+ . . . D ERROR("ER12")
+ . . .QUIT
+ . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9)
+ . .QUIT
+ . ;
+ . ; Everything else is Text, Check for CCR/CCD.
+ . N KK,UBF
+ . D
+ . . S UBF=$$UPPER(X)
+ . . I UBF["<CONTINUITYOFCARERECORD"   S $P(LST("SEG",SGC),U,3)="CCR" Q
+ . . ;
+ . . I UBF["<CLINICALDOCUMENT"         S $P(LST("SEG",SGC),U,3)="CCD" Q
+ . .QUIT
+ . ; Look for directives in the text before it gets published
+ . ;  Look for "=3D" and replace it with a single "=".  I can do more parsing
+ . ;  but there may be situations where the line has been wrapped.
+ . D:X["=3D"
+ . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D"
+ . .QUIT
+ . S LST("SEG",SGC,"TXT",D1)=X
+ .QUIT
+ QUIT
+ ;  ===================
+ ; Break down the Buffer Array so it can be saved.
+ ;  BF is passed in.
+DECODER ; 
+ N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE
+ S ZBF=BF
+ ;  Full Buffer, BF, now check for Encryption and Unpack
+ F RCNT=1:1:$L(ZBF,"=")   D
+ . N BF
+ . S BF=$P(ZBF,"=",RCNT)
+ . ;  Unpacking the 64 bit encoding
+ . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
+ . D:$L(TBF)
+ . . N C,OK,OKCNT,KK,XBF,UBF
+ . . D
+ . . . S UBF=$$UPPER(TBF)
+ . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q
+ . . . ;
+ . . . I UBF["<CLINICALDOCUMENT XMLNS="       S $P(LST("SEG",SGC),U,3)="CCD" Q
+ . . .QUIT
+ . . ; Check for Bad Signature Decoding, after 100 bad characters
+ . . S OK=1,OKCNT=0
+ . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q
+ . . ;
+ . . D
+ . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q
+ . . . ;
+ . . . S BF=BF_"="
+ . . . D NORMAL(.XBF,.TBF)
+ . . .QUIT
+ . . M LST("SEG",SGC,"XML",RCNT)=XBF
+ . .QUIT
+ .QUIT
+ QUIT
+ ;  ===================
+ ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
+ ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
+ ;   >D NORMAL^C0CMAIL(.OUT,BF)
+NORMAL(OUTXML,INXML)    ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
+ ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
+ ;
+ N ZN,OUTBF,XX,ZSEP
+ S INXML=$TR(INXML,$C(10,12,13))
+ S ZN=1,ZSEP=">"
+ S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1
+ F ZN=ZN+1:1:$L(INXML,"><")  D   Q:XX=""
+ . S XX=$P(INXML,"><",ZN)
+ . S:$E($RE(XX))=">" ZSEP=""
+ . Q:XX=""
+ . ;
+ . S XX="<"_XX_ZSEP
+ . D
+ . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1   Q
+ . . ;
+ . . D ERROR("ER05")
+ . . F ZL=ZL+1:1 D   Q:XX=""
+ . . .  N XL
+ . . .  S XL=$E(XX,1,4000)
+ . . .  S $E(XX,1,4000)=""   ; S XX=$E(XX,4001,999999) ; Remove 4K characters
+ . . .  S OUTBF(ZL)=XL
+ . . .QUIT
+ . .QUIT
+ .QUIT
+ M OUTXML=OUTBF
+ QUIT
+ ;  ===================
+UPPER(X) ; Convert any lowercase letters to Uppercase letters
+ QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ ;  ===================
+ ; EN is a counter that remains between error events
+ERROR(ER) ; Error Handler
+ N TXXQ,XXXQ
+ S XXXQ="Unknown Error Encountered = "_ER
+ S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99)
+ I TXXQ'=""  D
+ . I TXXQ["_" X "S TXXQ="_TXXQ
+ . S XXXQ=TXXQ
+ .QUIT
+ S EN(ER)=$G(EN(ER))+1
+ S LST("ERR",ER,EN(ER))=XXXQ
+ QUIT
+ ;  ===================
+ER01 ;;Message Missing
+ER02 ;;Message Text Missing
+ER03 ;;Message Not Identifiable
+ER04 ;;Segment is too large
+ER05 ;;Mailbox Missing
+ER06 ;;"User Missing = "_$G(DUZ)
+ER07 ;;"Bad DUZ = "_DUZ
+ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN)
+ER10 ;;"Bad Separator found = "_X
+ER11 ;;"Non-Standard Separator Found:>"_$G(J)
+ER12 ;;"Spaces are not allowed in Separators:>"_$G(J)
+ ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
+ ;  End note if needed
+ QUIT
+ ;  ===================

ccr/branches/ohum/p/C0CMAIL3.m

@@ -1 @@
-C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
-        ;;0.1;C0C;nopatch;noreleasedate;Build 1
-        ;Copyright 2011 Chris Richardson, Richardson Computer Research
-        ; Modified 3110619@2038
-        ;   rcr@rcresearch.us
-        ;  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.
-        ;
-        ;  ------------------
-        ;Entry Points
-        ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments
-        ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
-        ;  Input:
-        ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
-        ;                      or "*" for all boxes, default is "IN" if missing]"
-        ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
-        ;                                     "*" for All or 9,999 maximum
-        ;                    MALL?1.n = that number of the n most recent
-        ;  Internally:
-        ;    BNAM = Box Name
-        ;  Output:
-        ;    C0CDATA
-        ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
-        ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
-        ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
-        ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
-        ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
-        ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
-        ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
-        ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
-        ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
-        ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
-        ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
-        ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
-        ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
-        ; 
-        ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
-        ;   Input;
-        ;     D0     - The IEN for the message in file 3.9, MESSAGE global
-        ;   Output
-        ;     OUTBF  - The array of your choice to save the expanded and decoded message.
-        ; 
-GETMSG(C0CDATA,C0CINPUT)        ; Common Entry Point for Mailbox Data
-        K:'$G(C0CDATA("KEEP")) C0CDATA
-        N U
-        S U="^"
-        D:$G(C0CINPUT)
-        . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
-        . S INPUT=C0CINPUT
-        . S DUZ=+INPUT
-        . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0)))  D ERROR("ER06")  Q
-        . ;
-        . D:$D(^XMB(3.7,DUZ,0))#2
-        . . S MBLST=$P(INPUT,";",2)
-        . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
-        . . S:MALL["*" MALL=99999
-        . . ; Only one of these can be correct
-        . . D
-        . . . ;  If nul, make it "IN" only
-        . . . I MBLST="" D  QUIT
-        . . . . S MBLST("IN")=0,I=0
-        . . . . D GATHER(DUZ,"IN",.LST)
-        . . . .QUIT
-        . . . ;
-        . . . ;  If "*", Get all Mailboxes and look for New Messages
-        . . . I MBLST["*" D  QUIT
-        . . . . N NAM,NUM
-        . . . . S NUM=0
-        . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
-        . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
-        . . . . . D GATHER(DUZ,NAM,.LST)
-        . . . . .QUIT
-        . . . .QUIT
-        . . . ;
-        . . . ;  If comma separated, look for mailboxes with new messages
-        . . . I $L(MBLST,",")>1 D  QUIT
-        . . . . S NAM=""
-        . . . . N TN,V
-        . . . . F TN=1:1:$L(MBLST,",")  S V=$P(MBLST,",",TN)  D
-        . . . . . I $L(V) D   QUIT
-        . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
-        . . . . . . S:NAM="" NAM=V
-        . . . . . . D GATHER(DUZ,NAM,.LST)
-        . . . . . .QUIT
-        . . . . . ;
-        . . . . . D ERROR("ER08")
-        . . . . .QUIT
-        . . . .QUIT
-        . . . ;
-        . . . ;  If only 1 mailbox named, go get it
-        . . . I $L(MBLST)  D   QUIT
-        . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST))    D GATHER(DUZ,MBLST,.LST) QUIT
-        . . . . ;
-        . . . . D ERROR("ER07")
-        . . .QUIT
-        . . MERGE C0CDATA=LST
-        . .QUIT
-        .QUIT
-        QUIT
-        ;  ===================
-GATHER(DUZ,NAM,LST)     ; Gather Data about the Baskets and their mail
-        N I,J,K,L
-        S (I,K)=0
-        S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
-        F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
-        . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
-        . D   ; :L
-        . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
-        . . S LST(NAM,"MSG",I)=L
-        . . D GETTYP(I)
-        . .QUIT
-        .QUIT
-        S LST(NAM,"NUMBER")=K
-        QUIT
-        ;  ===================
-        ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
-        ; The products of these emails are scanned to identify
-        ;  the number of documents stored in the MIME package.
-        ;  The protocol runs like this;
-        ; Line 1 is the --separator
-        ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
-        ; Line n+2 thru t-1 where t does NOT have "Content-"
-        ; Line t   is Next Section Terminator, or Message Terminator, --separator
-        ; Line t+1 should not exist in the data set if Message Terminator
-        ; CON = "Content-"
-        ; FLG = "--"
-        ; SEP = FLG+7 or more characters  ; Separator
-        ; END = SEP+FLG
-        ; SGC = Segment Count
-        ; Note: separator is a string of specific characters of
-        ;        indeterminate length  
-        ; LST() the transfer array
-        ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
-        ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
-        ;
-GETTYP(D0)      ; Look for the goodies in the Mail
-        N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
-        S CON="Content-"
-        S FLG="--"
-        S SEP=""  ; Start SEP as null, so we can use this to help identify the type
-        S (BCN,CNT,D1,END,SGC)=0
-        S XX=$G(^XMB(3.9,D0,0))
-        S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
-        S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
-        F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
-        S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
-        S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
-        ; Get the folks the email is sent to.
-        S D1=0
-        F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
-        . N T
-        . S T=+$G(^XMB(3.9,D0,1,D1,0))
-        . S:T T=$P($G(^VA(200,+T,0)),"^")
-        . S LST("TO",D1)=T
-        . S T=$G(^XMB(3.9,D0,6,D1,0))
-        . S:T T=$P($G(^VA(200,+T,0)),"^")
-        . S:T="" T="<Unknown>"
-        . S LST("TO NAME",D1)=T
-        .QUIT
-        ; Preload first Segment (0) with beginning on Line 1
-        ;  if not a 64bit
-        S LST(NAM,"MSG",D0,"SEG",0)=1
-        S D1=.9999,SEP="@@"
-        F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
-        . ; Clear any control characters (cr/lf/ff) off
-        . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
-        . ; Enter once to set the SEP to capture the separator
-        . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
-        . . S SEP=X,END=X_FLG
-        . . S (CNT,SGC)=1,BCN=0
-        . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
-        . .QUIT
-        . ;
-        . ; A new separator is set, process original 
-        . I X=SEP  D  QUIT
-        . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF)
-        . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
-        . . S SGC=SGC+1,BCN=0
-        . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
-        . .QUIT
-        . ;
-        . S BCN=BCN+$L(X)
-        . I X[CON D  Q
-        . . S J=$P($P(X,";"),CON,2)
-        . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
-        . .QUIT
-        . ;
-        . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
-        .QUIT
-        QUIT
-        ;  ===================
-NAME(NM)        ; Return the name of the Sender
-        N NAME
-        S NAME="<Unknown Sender>"
-        D
-        . ; Look first for a value to use with the NEW PERSON file
-        . ;
-        . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
-        . ;
-        . I $L(NM) S NAME=NM                    Q
-        . ;
-        . ; Else, pull the data from the message and display the foreign source
-        . ;   of the message.
-        . N T
-        . S VAL=$G(^XMB(3.9,D0,.7))
-        . S:VAL T=$P(^VA(200,VAL,0),U)
-        . I $L($G(T)) S NAME=T                  Q
-        . ;
-        .QUIT
-        QUIT NAME
-        ;  ===================
-TIME(Y) ; The time and date of the sending
-        X ^DD("DD")
-        QUIT Y
-        ;  ===================
-        ;  Segments in Message need to be identified and decoded properly
-        ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
-        ;   ARRAY will have the details of this one call
-        ;    
-        ; Inputs;
-        ;   C0CINPUT    - The IEN of the message to expand
-        ; Outputs;
-        ;   C0CDATA     - Carrier for the returned structure of the Message
-        ;  C0CDATA(D0,"SEG")=number of SEGMENTS
-        ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type
-        ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
-        ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
-        ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
-        ;
-DETAIL(C0CDATA,C0CINPUT)        ; Message Detail Delivery
-        N LST,D0,D1,U
-        S U="^"
-        S D0=+$G(C0CINPUT)
-        I D0   D    QUIT
-        . I $D(^XMB(3.9,D0))<10 D ERROR("ER01")  QUIT
-        . ;
-        . D GETTYP2(D0)
-        . I $D(LST)   M C0CDATA(D0)=LST  Q
-        . ;
-        . D ERROR("ER02")
-        .QUIT
-        QUIT
-        ;  ===================
-        ;  End note if needed
-        ; MSK   - Set of characters that do not exist in 64 bit encoding
-GETTYP2(D0)     ; Try to get the types and MSK for the 
-        N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
-        S CON="Content-",U="^"
-        S FLG="--",MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
-        S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
-        S (BCN,CNT,D1,END,SGC)=0
-        S XX=$G(^XMB(3.9,D0,0))
-        ; S K=$P(^XMB(3.9,D0,2,0),U,3)
-        S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
-        S LST("CREATED")=$$TIME($P(XX,U,3))
-        F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
-        S LST("FROM")=$$NAME(XXNM)
-        ; Get the folks the email is sent to.
-        S D1=0
-        F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
-        . N I,T
-        . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
-        . S:T T=$P($G(^VA(200,T,0)),"^")
-        . S LST("TO",+D1)=T
-        . S T=$G(^XMB(3.9,D0,6,+D1,0))
-        . S:T="" T=$P($G(^VA(200,+T,0)),"^")
-        . S:T="" T="<Unknown>"
-        . S LST("TO NAME",D1)=T
-        .QUIT
-        ; Get the Header for the message and store as "HDR"
-        S D1=0,SGC=0
-        F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
-        . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
-        .QUIT
-        N BNDRY,STKL,SEG
-        S STKL=0,SEG=0
-        ; Find boundaries and map them
-        S D1=0
-        F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
-        . ; Clear any control characters (cr/lf/ff) off
-        . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
-        . ; Look for " boundary=" in the various parts.  Map the establishment and the 
-        . ;  terminator markers and the actual boundary markers.
-        . I X[" boundary=" D  Q
-        . . S SEP=$P(X," boundary=",2)
-        . . S:$E(SEP)="""" SEP=$TR(SEP,"""")
-        . . S STKL=STKL+1
-        . . S END=SEP_FLG
-        . . S BNDRY(STKL,SEP)=0
-        . . S BNDRX(SEP)=STKL,BNDRZ(END)=0
-        . .QUIT
-        . ;
-        . ; Look for information as to how amy boudaries are present and where
-        . ;   they terminate
-        . D:X'=""&($E(X,1,2)="--")&($E(X,$L(X)-1,9999)'="--")
-        . . ; Boundary Found
-        . . I $D(BNDRX(X)) D  Q
-        . . . S SEG=SEG+1
-        . . . S BNDRE(X)=$G(BNDRE(X))_D1_";"
-        . . . S BND1(D1)=STKL_";B;"_SEG_";"_X
-        . . . S BNDR(X,D1,"B")=STKL
-        . . . I BNDRX(X)=X  D ERROR("ER13")
-        . . .QUIT
-        . . ;
-        . . ; Boundary Terminator
-        . . I $D(BNDRZ(X)) D  Q
-        . . . S BNDR(X,D1,"E")=STKL
-        . . . S BNDRZ(X)=BNDRZ(X)+1
-        . . . S BND1(D1)=STKL_";E;"_SEG_";"_X
-        . . . S SEG=SEG+1
-        . . . I BNDRX(X)=X  D ERROR("ER14")
-        . . . S STKL=STKL-1
-        . . .QUIT
-        . .QUIT
-        .QUIT
-        ; Start walking the TEXT/XML/64-BIT ENCODING sections of the message
-        N A,B,C,STACK,STYP,SEG,AX
-        S D1=.99999,SGC=0
-        F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
-        . ; Clear any control characters (cr/lf/ff) off
-        . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
-        . ;
-        . D
-        . . I $D(BND1(D1)) D BOUNDARY(X)    QUIT
-        . . ;
-        . . S DX=$O(BND1(D1))
-        . . I DX=""  D ERROR("ER15")   Q
-        . . ;
-        . . ; Good situation, extract the parts for the section
-        . . S A=$G(BND1(DX))
-        . . S STACK=+A,STYP=$P(A,";",2),SGC=$P(A,";",3),AX=$P(A,";",4,999)
-        . .QUIT
-        . ; Enter once to set the SEP to capture the separator
-        . ;
-        . ; A new SEGMENT separator is set, process original 
-        . I $D(BND1(X))  D  QUIT
-        . . ; Save Current Values
-        . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF)
-        . . ;  Close this Segment and prepare to start a New Segment
-        . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1)
-        . . ;  Put the result in LST("SEG",SGC,"XML")
-        . . I $L(BF) D
-        . . . S ZN=1
-        . . . N I,T,TBF
-        . . . S TBF=BF
-        . . . F I=1:1:($L(TBF,"="))  D
-        . . . . S BF=$P(TBF,"=",I)_"="
-        . . . . I "="'[BF  D DECODER(.BF,.TYP)
-        . . . .QUIT
-        . . . S BF=""
-        . . .QUIT
-        . . S SGC=SGC+1,BCN=0
-        . . ; Incriment SGC to start a new Segment
-        . . S LST("SEG",SGC)=D1
-        . .QUIT
-        . ;
-        . ; Accumulate the 64 bit encoding, no spaces, or other non-64bit characters
-        . I X=$TR(X,MSK)&$L(X)  S BF=BF_X  QUIT
-        . ;
-        . ; Ending Condition, close out the Segment
-        . I $D(BNDRZ(X)) D  QUIT
-        . . S $P(LST("SEG",SGC),"^",2)=D1-1
-        . . I $L(BF) S ZN=1 D DECODER(.BF,.TYP)  S BF="" Q
-        . .QUIT
-        . ;
-        . ; Accumulate the content lines of the message
-        . S BCN=BCN+$L(X)
-        . ; Split out the Content Info
-        . I X[CON D  Q
-        . . S J=$P(X,CON,2)
-        . . S TYP="CONTENT"
-        . . S LST("SEG",SGC,TYP,$P(J,":"))=$P(J,":",2,9)
-        . . D CONTENT(D1)
-        . .QUIT
-        . ;
-        . ; Everything else is Text, Check for CCR/CCD.
-        . N KK,UBF
-        . D
-        . . S UBF=$$UPPER(X)
-        . . I UBF["<CONTINUITYOFCARERECORD"   S $P(LST("SEG",SGC),U,3)="CCR" Q
-        . . ;
-        . . I UBF["<CLINICALDOCUMENT"         S $P(LST("SEG",SGC),U,3)="CCD" Q
-        . .QUIT
-        . ; Look for directives in the text before it gets published
-        . ;  Look for "=3D" and replace it with a single "=".  I can do more parsing
-        . ;  but there may be situations where the line has been wrapped.
-        . D:X["=3D"
-        . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D"
-        . .QUIT
-        . S LST("SEG",SGC,TYP,D1)=X
-        .QUIT
-        QUIT
-        ;  ===================
-CONTENT(D1)     ; Try pulling Content Statements
-        N J,UP,X
-        S X=$G(^XMB(3.9,D0,2,D1,0))
-        S J=$P(X,CON,2)
-        S UP=$TR($$UPPER(X),"""")
-        S:$G(TYP)="" TYP="TXT"
-        D
-        . I UP["NAME=",($L(UP,".")>1) S TYP=$P(UP,".",2) Q
-        . I UP["XML" S TYP="XML"                         Q
-        . I UP["P7S" S TYP="P7S"                         Q
-        . I J[" boundary=" D BOUNDARY(J)
-        .QUIT
-        S LIS("CON",SGC,D1)=X
-        S LIS("CON",SGC,D1,"TYP")=TYP
-        ; If there is a follow-on, look for another line after this.
-        I $E($RE(X),1)=";"   D CONTENT(D1+1)
-        QUIT
-        ;  ===================
-BOUNDARY(X)     ; Set an additional BOUNDARY, and activate another stack level
-        S SEP=$P($P(X," boundary=",2),"""",2),END=SEP_FLG
-        Q:SEP?2"-".ANP
-        ;
-        D ERROR("ER11")
-        Q:SEP'[" "
-        ;
-        D ERROR("ER12")
-        QUIT
-        ;  ===================
-        ; Break down the Buffer Array so it can be saved.
-        ;  BF is passed in.
-        ;  TYP is the type of 
-DECODER(BF,TYP) ; 
-        N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE
-        S:$G(TYP)="" TYP="XML"
-        S ZBF=BF
-        ;  Full Buffer, BF, now check for Encryption and Unpack
-        F RCNT=1:1:$L(ZBF,"=")   D
-        . N BF
-        . S BF=$P(ZBF,"=",RCNT)
-        . ;  Unpacking the 64 bit encoding
-        . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
-        . D:$L(TBF)
-        . . N C,OK,OKCNT,KK,XBF,UBF
-        . . D
-        . . . S UBF=$$UPPER(TBF)
-        . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q
-        . . . ;
-        . . . I UBF["<CLINICALDOCUMENT XMLNS="       S $P(LST("SEG",SGC),U,3)="CCD" Q
-        . . .QUIT
-        . . ; Check for Bad Signature Decoding, after 100 bad characters
-        . . S OK=1,OKCNT=0
-        . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q
-        . . ;
-        . . D
-        . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q
-        . . . ;
-        . . . S BF=BF_"="
-        . . . D NORMAL(.XBF,.TBF)
-        . . .QUIT
-        . . M LST("SEG",SGC,TYP,RCNT)=XBF
-        . .QUIT
-        .QUIT
-        QUIT
-        ;  ===================
-        ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
-        ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
-        ;   >D NORMAL^C0CMAIL(.OUT,BF)
-NORMAL(OUTXML,INXML)       ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
-        ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
-        ;
-        N ZN,OUTBF,XX,ZSEP
-        S INXML=$TR(INXML,$C(10,12,13))
-        S ZN=1,ZSEP=">"
-        S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1
-        F ZN=ZN+1:1:$L(INXML,"><")  D   Q:XX=""
-        . S XX=$P(INXML,"><",ZN)
-        . S:$E($RE(XX))=">" ZSEP=""
-        . Q:XX=""
-        . ;
-        . S XX="<"_XX_ZSEP
-        . D
-        . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1   Q
-        . . ;
-        . . D ERROR("ER05")
-        . . F ZL=ZL+1:1 D   Q:XX=""
-        . . .  N XL
-        . . .  S XL=$E(XX,1,4000)
-        . . .  S $E(XX,1,4000)=""   ; S XX=$E(XX,4001,999999) ; Remove 4K characters
-        . . .  S OUTBF(ZL)=XL
-        . . .QUIT
-        . .QUIT
-        .QUIT
-        M OUTXML=OUTBF
-        QUIT
-        ;  ===================
-UPPER(X)        ; Convert any lowercase letters to Uppercase letters
-        QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
-        ;  ===================
-        ; EN is a counter that remains between error events
-ERROR(ER)       ; Error Handler
-        N TXXQ,XXXQ
-        S XXXQ="Unknown Error Encountered = "_ER
-        S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99)
-        I TXXQ'=""  D
-        . I TXXQ["_" X "S TXXQ="_TXXQ
-        . S XXXQ=TXXQ
-        .QUIT
-        S EN(ER)=$G(EN(ER))+1
-        S LST("ERR",ER,EN(ER))=XXXQ
-        QUIT
-        ;  ===================
-ER01    ;;Message Missing
-ER02    ;;Message Text Missing
-ER03    ;;Message Not Identifiable
-ER04    ;;Segment is too large
-ER05    ;;Mailbox Missing
-ER06    ;;"User Missing = "_$G(DUZ)
-ER07    ;;"Bad DUZ = "_DUZ
-ER08    ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN)
-ER10    ;;"Bad Separator found = "_X
-ER11    ;;"Non-Standard Separator Found:>"_$G(J)
-ER12    ;;"Spaces are not allowed in Separators:>"_$G(J)
-ER13    ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X
-        ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
-        ;  End note if needed
-        QUIT
-        ;  ===================
+C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr
+V ;;0.1;C0C;nopatch;noreleasedate
+ ;Copyright 2011 Chris Richardson, Richardson Computer Research
+ ; Modified 3110619@2038
+ ;   rcr@rcresearch.us
+ ;  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.
+ ;
+ ;  ------------------
+ ;Entry Points
+ ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments
+ ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT)
+ ;  Input:
+ ;    C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL
+ ;                      or "*" for all boxes, default is "IN" if missing]"
+ ;                $P(C0CINPUT,";",3)=MALL, default=NUL means "New only",
+ ;                                     "*" for All or 9,999 maximum
+ ;                    MALL?1.n = that number of the n most recent
+ ;  Internally:
+ ;    BNAM = Box Name
+ ;  Output:
+ ;    C0CDATA
+ ;      = (BNAM,"NUMBER") = Number of NEW Emails in Basket
+ ;        (BNAM,"MSG",C0CIEN,"FROM")=Name
+ ;        (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address
+ ;        (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address
+ ;        (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title
+ ;        (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments
+ ;        (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text
+ ;        (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text
+ ;        (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes
+ ;        (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment)
+ ;   (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line
+ ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details
+ ;   (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data
+ ; 
+ ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments
+ ;   Input;
+ ;     D0     - The IEN for the message in file 3.9, MESSAGE global
+ ;   Output
+ ;     OUTBF  - The array of your choice to save the expanded and decoded message.
+ ; 
+GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data
+ K:'$G(C0CDATA("KEEP")) C0CDATA
+ N U
+ S U="^"
+ D:$G(C0CINPUT)
+ . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL
+ . S INPUT=C0CINPUT
+ . S DUZ=+INPUT
+ . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0)))  D ERROR("ER06")  Q
+ . ;
+ . D:$D(^XMB(3.7,DUZ,0))#2
+ . . S MBLST=$P(INPUT,";",2)
+ . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag
+ . . S:MALL["*" MALL=99999
+ . . ; Only one of these can be correct
+ . . D
+ . . . ;  If nul, make it "IN" only
+ . . . I MBLST="" D  QUIT
+ . . . . S MBLST("IN")=0,I=0
+ . . . . D GATHER(DUZ,"IN",.LST)
+ . . . .QUIT
+ . . . ;
+ . . . ;  If "*", Get all Mailboxes and look for New Messages
+ . . . I MBLST["*" D  QUIT
+ . . . . N NAM,NUM
+ . . . . S NUM=0
+ . . . . F  S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM  D
+ . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U)
+ . . . . . D GATHER(DUZ,NAM,.LST)
+ . . . . .QUIT
+ . . . .QUIT
+ . . . ;
+ . . . ;  If comma separated, look for mailboxes with new messages
+ . . . I $L(MBLST,",")>1 D  QUIT
+ . . . . S NAM=""
+ . . . . N TN,V
+ . . . . F TN=1:1:$L(MBLST,",")  S V=$P(MBLST,",",TN)  D
+ . . . . . I $L(V) D   QUIT
+ . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U)
+ . . . . . . S:NAM="" NAM=V
+ . . . . . . D GATHER(DUZ,NAM,.LST)
+ . . . . . .QUIT
+ . . . . . ;
+ . . . . . D ERROR("ER08")
+ . . . . .QUIT
+ . . . .QUIT
+ . . . ;
+ . . . ;  If only 1 mailbox named, go get it
+ . . . I $L(MBLST)  D   QUIT
+ . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST))    D GATHER(DUZ,MBLST,.LST) QUIT
+ . . . . ;
+ . . . . D ERROR("ER07")
+ . . .QUIT
+ . . MERGE C0CDATA=LST
+ . .QUIT
+ .QUIT
+ QUIT
+ ;  ===================
+GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail
+ N I,J,K,L
+ S (I,K)=0
+ S J=$O(^XMB(3.7,DUZ,2,"B",NAM,""))
+ F  S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I  D
+ . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3)
+ . D   ; :L
+ . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")=""  ; Flag NEW emails
+ . . S LST(NAM,"MSG",I)=L
+ . . D GETTYP(I)
+ . .QUIT
+ .QUIT
+ S LST(NAM,"NUMBER")=K
+ QUIT
+ ;  ===================
+ ; D0 is the IEN into the Message Global ^XMB(3.9,D0)
+ ; The products of these emails are scanned to identify
+ ;  the number of documents stored in the MIME package.
+ ;  The protocol runs like this;
+ ; Line 1 is the --separator
+ ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD
+ ; Line n+2 thru t-1 where t does NOT have "Content-"
+ ; Line t   is Next Section Terminator, or Message Terminator, --separator
+ ; Line t+1 should not exist in the data set if Message Terminator
+ ; CON = "Content-"
+ ; FLG = "--"
+ ; SEP = FLG+7 or more characters  ; Separator
+ ; END = SEP+FLG
+ ; SGC = Segment Count
+ ; Note: separator is a string of specific characters of
+ ;        indeterminate length  
+ ; LST() the transfer array
+ ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line
+ ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data
+ ;
+GETTYP(D0) ; Look for the goodies in the Mail
+ N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM
+ S CON="Content-"
+ S FLG="--"
+ S SEP=""  ; Start SEP as null, so we can use this to help identify the type
+ S (BCN,CNT,D1,END,SGC)=0
+ S XX=$G(^XMB(3.9,D0,0))
+ S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
+ S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6))
+ F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
+ S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM)
+ S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3))
+ ; Get the folks the email is sent to.
+ S D1=0
+ F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D
+ . N T
+ . S T=+$G(^XMB(3.9,D0,1,D1,0))
+ . S:T T=$P($G(^VA(200,+T,0)),"^")
+ . S LST("TO",D1)=T
+ . S T=$G(^XMB(3.9,D0,6,D1,0))
+ . S:T T=$P($G(^VA(200,+T,0)),"^")
+ . S:T="" T="<Unknown>"
+ . S LST("TO NAME",D1)=T
+ .QUIT
+ ; Preload first Segment (0) with beginning on Line 1
+ ;  if not a 64bit
+ S LST(NAM,"MSG",D0,"SEG",0)=1
+ S D1=.9999,SEP="@@"
+ F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
+ . ; Clear any control characters (cr/lf/ff) off
+ . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
+ . ; Enter once to set the SEP to capture the separator
+ . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5))   D   Q
+ . . S SEP=X,END=X_FLG
+ . . S (CNT,SGC)=1,BCN=0
+ . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
+ . .QUIT
+ . ;
+ . ; A new separator is set, process original 
+ . I X=SEP  D  QUIT
+ . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF)
+ . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1)
+ . . S SGC=SGC+1,BCN=0
+ . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1
+ . .QUIT
+ . ;
+ . S BCN=BCN+$L(X)
+ . I X[CON D  Q
+ . . S J=$P($P(X,";"),CON,2)
+ . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2)
+ . .QUIT
+ . ;
+ . ; S LST(NAM,"MSG",D0,"SEG",D1)=X
+ .QUIT
+ QUIT
+ ;  ===================
+NAME(NM) ; Return the name of the Sender
+ N NAME
+ S NAME="<Unknown Sender>"
+ D
+ . ; Look first for a value to use with the NEW PERSON file
+ . ;
+ . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q
+ . ;
+ . I $L(NM) S NAME=NM                    Q
+ . ;
+ . ; Else, pull the data from the message and display the foreign source
+ . ;   of the message.
+ . N T
+ . S VAL=$G(^XMB(3.9,D0,.7))
+ . S:VAL T=$P(^VA(200,VAL,0),U)
+ . I $L($G(T)) S NAME=T                  Q
+ . ;
+ .QUIT
+ QUIT NAME
+ ;  ===================
+TIME(Y) ; The time and date of the sending
+ X ^DD("DD")
+ QUIT Y
+ ;  ===================
+ ;  Segments in Message need to be identified and decoded properly
+ ; D DETAIL^C0CMAIL(.ARRAY,D0) ;  Call One for each message
+ ;   ARRAY will have the details of this one call
+ ;    
+ ; Inputs;
+ ;   C0CINPUT    - The IEN of the message to expand
+ ; Outputs;
+ ;   C0CDATA     - Carrier for the returned structure of the Message
+ ;  C0CDATA(D0,"SEG")=number of SEGMENTS
+ ;  C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type
+ ;  C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details
+ ;  C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details
+ ;  C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details
+ ;
+DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery
+ N LST,D0,D1,U
+ S U="^"
+ S D0=+$G(C0CINPUT)
+ I D0   D    QUIT
+ . I $D(^XMB(3.9,D0))<10 D ERROR("ER01")  QUIT
+ . ;
+ . D GETTYP2(D0)
+ . I $D(LST)   M C0CDATA(D0)=LST  Q
+ . ;
+ . D ERROR("ER02")
+ .QUIT
+ QUIT
+ ;  ===================
+ ;  End note if needed
+ ; MSK   - Set of characters that do not exist in 64 bit encoding
+GETTYP2(D0) ; Try to get the types and MSK for the 
+ N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM
+ S CON="Content-",U="^"
+ S FLG="--",MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~"
+ S (BF,SEP)=""  ; Start SEP as null, so we can use this to help identify the type
+ S (BCN,CNT,D1,END,SGC)=0
+ S XX=$G(^XMB(3.9,D0,0))
+ ; S K=$P(^XMB(3.9,D0,2,0),U,3)
+ S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1)
+ S LST("CREATED")=$$TIME($P(XX,U,3))
+ F I=4,2 S XXNM=$P(XX,U,I)  Q:$L(XXNM)
+ S LST("FROM")=$$NAME(XXNM)
+ ; Get the folks the email is sent to.
+ S D1=0
+ F  S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1  D   Q:D1=""
+ . N I,T
+ . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U)
+ . S:T T=$P($G(^VA(200,T,0)),"^")
+ . S LST("TO",+D1)=T
+ . S T=$G(^XMB(3.9,D0,6,+D1,0))
+ . S:T="" T=$P($G(^VA(200,+T,0)),"^")
+ . S:T="" T="<Unknown>"
+ . S LST("TO NAME",D1)=T
+ .QUIT
+ ; Get the Header for the message and store as "HDR"
+ S D1=0,SGC=0
+ F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1=""  Q:(D1>.99999)   D
+ . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0))
+ .QUIT
+ N BNDRY,STKL,SEG
+ S STKL=0,SEG=0
+ ; Find boundaries and map them
+ S D1=0
+ F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
+ . ; Clear any control characters (cr/lf/ff) off
+ . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
+ . ; Look for " boundary=" in the various parts.  Map the establishment and the 
+ . ;  terminator markers and the actual boundary markers.
+ . I X[" boundary=" D  Q
+ . . S SEP=$P(X," boundary=",2)
+ . . S:$E(SEP)="""" SEP=$TR(SEP,"""")
+ . . S STKL=STKL+1
+ . . S END=SEP_FLG
+ . . S BNDRY(STKL,SEP)=0
+ . . S BNDRX(SEP)=STKL,BNDRZ(END)=0
+ . .QUIT
+ . ;
+ . ; Look for information as to how amy boudaries are present and where
+ . ;   they terminate
+ . D:X'=""&($E(X,1,2)="--")&($E(X,$L(X)-1,9999)'="--")
+ . . ; Boundary Found
+ . . I $D(BNDRX(X)) D  Q
+ . . . S SEG=SEG+1
+ . . . S BNDRE(X)=$G(BNDRE(X))_D1_";"
+ . . . S BND1(D1)=STKL_";B;"_SEG_";"_X
+ . . . S BNDR(X,D1,"B")=STKL
+ . . . I BNDRX(X)=X  D ERROR("ER13")
+ . . .QUIT
+ . . ;
+ . . ; Boundary Terminator
+ . . I $D(BNDRZ(X)) D  Q
+ . . . S BNDR(X,D1,"E")=STKL
+ . . . S BNDRZ(X)=BNDRZ(X)+1
+ . . . S BND1(D1)=STKL_";E;"_SEG_";"_X
+ . . . S SEG=SEG+1
+ . . . I BNDRX(X)=X  D ERROR("ER14")
+ . . . S STKL=STKL-1
+ . . .QUIT
+ . .QUIT
+ .QUIT
+ ; Start walking the TEXT/XML/64-BIT ENCODING sections of the message
+ N A,B,C,STACK,STYP,SEG,AX
+ S D1=.99999,SGC=0
+ F  S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1  D
+ . ; Clear any control characters (cr/lf/ff) off
+ . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13))
+ . ;
+ . D
+ . . I $D(BND1(D1)) D BOUNDARY(X)    QUIT
+ . . ;
+ . . S DX=$O(BND1(D1))
+ . . I DX=""  D ERROR("ER15")   Q
+ . . ;
+ . . ; Good situation, extract the parts for the section
+ . . S A=$G(BND1(DX))
+ . . S STACK=+A,STYP=$P(A,";",2),SGC=$P(A,";",3),AX=$P(A,";",4,999)
+ . .QUIT
+ . ; Enter once to set the SEP to capture the separator
+ . ;
+ . ; A new SEGMENT separator is set, process original 
+ . I $D(BND1(X))  D  QUIT
+ . . ; Save Current Values
+ . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF)
+ . . ;  Close this Segment and prepare to start a New Segment
+ . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1)
+ . . ;  Put the result in LST("SEG",SGC,"XML")
+ . . I $L(BF) D
+ . . . S ZN=1
+ . . . N I,T,TBF
+ . . . S TBF=BF
+ . . . F I=1:1:($L(TBF,"="))  D
+ . . . . S BF=$P(TBF,"=",I)_"="
+ . . . . I "="'[BF  D DECODER(.BF,.TYP)
+ . . . .QUIT
+ . . . S BF=""
+ . . .QUIT
+ . . S SGC=SGC+1,BCN=0
+ . . ; Incriment SGC to start a new Segment
+ . . S LST("SEG",SGC)=D1
+ . .QUIT
+ . ;
+ . ; Accumulate the 64 bit encoding, no spaces, or other non-64bit characters
+ . I X=$TR(X,MSK)&$L(X)  S BF=BF_X  QUIT
+ . ;
+ . ; Ending Condition, close out the Segment
+ . I $D(BNDRZ(X)) D  QUIT
+ . . S $P(LST("SEG",SGC),"^",2)=D1-1
+ . . I $L(BF) S ZN=1 D DECODER(.BF,.TYP)  S BF="" Q
+ . .QUIT
+ . ;
+ . ; Accumulate the content lines of the message
+ . S BCN=BCN+$L(X)
+ . ; Split out the Content Info
+ . I X[CON D  Q
+ . . S J=$P(X,CON,2)
+ . . S TYP="CONTENT"
+ . . S LST("SEG",SGC,TYP,$P(J,":"))=$P(J,":",2,9)
+ . . D CONTENT(D1)
+ . .QUIT
+ . ;
+ . ; Everything else is Text, Check for CCR/CCD.
+ . N KK,UBF
+ . D
+ . . S UBF=$$UPPER(X)
+ . . I UBF["<CONTINUITYOFCARERECORD"   S $P(LST("SEG",SGC),U,3)="CCR" Q
+ . . ;
+ . . I UBF["<CLINICALDOCUMENT"         S $P(LST("SEG",SGC),U,3)="CCD" Q
+ . .QUIT
+ . ; Look for directives in the text before it gets published
+ . ;  Look for "=3D" and replace it with a single "=".  I can do more parsing
+ . ;  but there may be situations where the line has been wrapped.
+ . D:X["=3D"
+ . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D"
+ . .QUIT
+ . S LST("SEG",SGC,TYP,D1)=X
+ .QUIT
+ QUIT
+ ;  ===================
+CONTENT(D1) ; Try pulling Content Statements
+ N J,UP,X
+ S X=$G(^XMB(3.9,D0,2,D1,0))
+ S J=$P(X,CON,2)
+ S UP=$TR($$UPPER(X),"""")
+ S:$G(TYP)="" TYP="TXT"
+ D
+ . I UP["NAME=",($L(UP,".")>1) S TYP=$P(UP,".",2) Q
+ . I UP["XML" S TYP="XML"                         Q
+ . I UP["P7S" S TYP="P7S"                         Q
+ . I J[" boundary=" D BOUNDARY(J)
+ .QUIT
+ S LIS("CON",SGC,D1)=X
+ S LIS("CON",SGC,D1,"TYP")=TYP
+ ; If there is a follow-on, look for another line after this.
+ I $E($RE(X),1)=";"   D CONTENT(D1+1)
+ QUIT
+ ;  ===================
+BOUNDARY(X) ; Set an additional BOUNDARY, and activate another stack level
+ S SEP=$P($P(X," boundary=",2),"""",2),END=SEP_FLG
+ Q:SEP?2"-".ANP
+ ;
+ D ERROR("ER11")
+ Q:SEP'[" "
+ ;
+ D ERROR("ER12")
+ QUIT
+ ;  ===================
+ ; Break down the Buffer Array so it can be saved.
+ ;  BF is passed in.
+ ;  TYP is the type of 
+DECODER(BF,TYP) ; 
+ N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE
+ S:$G(TYP)="" TYP="XML"
+ S ZBF=BF
+ ;  Full Buffer, BF, now check for Encryption and Unpack
+ F RCNT=1:1:$L(ZBF,"=")   D
+ . N BF
+ . S BF=$P(ZBF,"=",RCNT)
+ . ;  Unpacking the 64 bit encoding
+ . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13))
+ . D:$L(TBF)
+ . . N C,OK,OKCNT,KK,XBF,UBF
+ . . D
+ . . . S UBF=$$UPPER(TBF)
+ . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q
+ . . . ;
+ . . . I UBF["<CLINICALDOCUMENT XMLNS="       S $P(LST("SEG",SGC),U,3)="CCD" Q
+ . . .QUIT
+ . . ; Check for Bad Signature Decoding, after 100 bad characters
+ . . S OK=1,OKCNT=0
+ . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q
+ . . ;
+ . . D
+ . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q
+ . . . ;
+ . . . S BF=BF_"="
+ . . . D NORMAL(.XBF,.TBF)
+ . . .QUIT
+ . . M LST("SEG",SGC,TYP,RCNT)=XBF
+ . .QUIT
+ .QUIT
+ QUIT
+ ;  ===================
+ ;  OUTXML = OUTBF  = OUT   = OUTPUT ARRAY TO BE BUILT
+ ;  BF     = INXML = INPUT ARRAY TO PROVIDE INPUT
+ ;   >D NORMAL^C0CMAIL(.OUT,BF)
+NORMAL(OUTXML,INXML)    ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
+ ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
+ ;
+ N ZN,OUTBF,XX,ZSEP
+ S INXML=$TR(INXML,$C(10,12,13))
+ S ZN=1,ZSEP=">"
+ S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1
+ F ZN=ZN+1:1:$L(INXML,"><")  D   Q:XX=""
+ . S XX=$P(INXML,"><",ZN)
+ . S:$E($RE(XX))=">" ZSEP=""
+ . Q:XX=""
+ . ;
+ . S XX="<"_XX_ZSEP
+ . D
+ . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1   Q
+ . . ;
+ . . D ERROR("ER05")
+ . . F ZL=ZL+1:1 D   Q:XX=""
+ . . .  N XL
+ . . .  S XL=$E(XX,1,4000)
+ . . .  S $E(XX,1,4000)=""   ; S XX=$E(XX,4001,999999) ; Remove 4K characters
+ . . .  S OUTBF(ZL)=XL
+ . . .QUIT
+ . .QUIT
+ .QUIT
+ M OUTXML=OUTBF
+ QUIT
+ ;  ===================
+UPPER(X) ; Convert any lowercase letters to Uppercase letters
+ QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ ;  ===================
+ ; EN is a counter that remains between error events
+ERROR(ER) ; Error Handler
+ N TXXQ,XXXQ
+ S XXXQ="Unknown Error Encountered = "_ER
+ S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99)
+ I TXXQ'=""  D
+ . I TXXQ["_" X "S TXXQ="_TXXQ
+ . S XXXQ=TXXQ
+ .QUIT
+ S EN(ER)=$G(EN(ER))+1
+ S LST("ERR",ER,EN(ER))=XXXQ
+ QUIT
+ ;  ===================
+ER01 ;;Message Missing
+ER02 ;;Message Text Missing
+ER03 ;;Message Not Identifiable
+ER04 ;;Segment is too large
+ER05 ;;Mailbox Missing
+ER06 ;;"User Missing = "_$G(DUZ)
+ER07 ;;"Bad DUZ = "_DUZ
+ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN)
+ER10 ;;"Bad Separator found = "_X
+ER11 ;;"Non-Standard Separator Found:>"_$G(J)
+ER12 ;;"Spaces are not allowed in Separators:>"_$G(J)
+ER13 ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X
+ ;  vvvvvvvvvvvvvvv  Not Needed  vvvvvvvvvvvvvvvvvvvvvvvvvv
+ ;  End note if needed
+ QUIT
+ ;  ===================

ccr/branches/ohum/p/C0CMCCD.m

@@ -1 @@
-C0CMCCD   ; GPL - MXML based CCD utilities;12/04/09  17:05
-        ;;0.1;C0C;nopatch;noreleasedate;Build 1
-        ;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
-        ;
-PARSCCD(DOC,OPTION)     ; THIS WAS COPIED FROM EN^MXMLDOM TO CUSTIMIZE FOR 
-        ; PROCESSING CCDS 
-        N CBK,SUCCESS,LEVEL,NODE,HANDLE
-        K ^TMP("MXMLERR",$J)
-        L +^TMP("MXMLDOM",$J):5
-        E  Q 0
-        S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)=""
-        L -^TMP("MXMLDOM",$J)
-        S CBK("STARTELEMENT")="STARTELE^C0CMCCD" ; ONLY THIS ONE IS CHANGED ;GPL
-        S CBK("ENDELEMENT")="ENDELE^MXMLDOM"
-        S CBK("COMMENT")="COMMENT^MXMLDOM"
-        S CBK("CHARACTERS")="CHAR^MXMLDOM"
-        S CBK("ENDDOCUMENT")="ENDDOC^MXMLDOM"
-        S CBK("ERROR")="ERROR^MXMLDOM"
-        S (SUCCESS,LEVEL,LEVEL(0),NODE)=0,OPTION=$G(OPTION,"V1")
-        D EN^MXMLPRSE(DOC,.CBK,OPTION)
-        D:'SUCCESS DELETE^MXMLDOM(HANDLE)
-        Q $S(SUCCESS:HANDLE,1:0)
-        ; Start element
-        ; Create new child node and push info on stack
-STARTELE(ELE,ATTR)      ; COPIED FROM STARTELE^MXMLDOM AND MODIFIED TO TREAT
-        ; ATTRIBUTES AS SUBELEMENTS TO MAKE CCD XPATH PROCESSING EASIER
-        N PARENT
-        S PARENT=LEVEL(LEVEL),NODE=NODE+1
-        S:PARENT ^TMP("MXMLDOM",$J,HANDLE,PARENT,"C",NODE)=ELE
-        S LEVEL=LEVEL+1,LEVEL(LEVEL)=NODE,LEVEL(LEVEL,0)=ELE
-        S ^TMP("MXMLDOM",$J,HANDLE,NODE)=ELE,^(NODE,"P")=PARENT
-        ;M ^("A")=ATTR
-        N ZI S ZI="" ; INDEX FOR ATTR
-        F  S ZI=$O(ATTR(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
-        . N ELE,TXT ; ABOUT TO RECURSE
-        . S ELE=ZI ; TAG
-        . S TXT=ATTR(ZI) ; DATA
-        . D STARTELE(ELE,"") ; CREATE A NEW SUBNODE
-        . D TXT^MXMLDOM("T") ; INSERT DATA TO TAG
-        . D ENDELE^MXMLDOM(ELE) ; POP BACK UP A LEVEL
-        Q
-        ;
-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
-        ;
-CLEANARY(OUTARY,INARY)  ; GOES THROUGH AN ARRAY AND CALLS CLEAN ON EACH NODE
-        ; INARY AND OUTARY PASSED BY NAME
-        N ZI S ZI=""
-        F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ; FOR EACH NODE
-        . S @OUTARY@(ZI)=$$CLEAN(@INARY@(ZI)) ; CLEAN THE NODE
-        Q
-        ;
-CLEAN(STR)      ; extrinsic function; returns string
-        ;; Removes all non printable characters from a string.
-        ;; STR by Value
-        N TR,I
-        F I=0:1:31 S TR=$G(TR)_$C(I)
-        S TR=TR_$C(127)
-        QUIT $TR(STR,TR)
-        ;
-STRIPTXT(OUTARY,ZARY)   ; STRIPS THE "TEXT" PORTION OUT OF AN XML FILE
-        ; THIS IS USED TO DELETE THE NARATIVE HTML OUT OF THE CCD XML FILES BECAUSE
-        ; THEY DO NOT WORK RIGHT WITH THE PARSER
-        ;N ZWRK,ZBLD,ZI ; WORK ARRAY,BUILD ARRAY, AND COUNTER
-        S ZI=$O(@ZARY@("")) ; GET FIRST LINE NUMBER
-        D C0CBEGIN("ZWRK",ZI) ; INSERT FIRST LINE IN WORK ARRAY
-        F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH LINE OF THE ARRAY
-        . I $O(@ZARY@(ZI))="" D  Q  ; AT THE END 
-        . . D C0CEND("ZWRK",ZI) ; INCLUDE LAST LINE IN WORK ARRAY
-        . I ZI=1 D C0CBEGIN("ZWRK",ZI) ; START WITH FIRST LINE
-        . I @ZARY@(ZI)["<text" D C0CEND("ZWRK",ZI-1) ;PREV LINE IS AN END
-        . I @ZARY@(ZI)["</text>" D C0CBEGIN("ZWRK",ZI+1) ;NEXT LINE IS A BEGIN
-        S ZI=""
-        F  S ZI=$O(ZWRK(ZI)) Q:ZI=""  D  ; MAKE A BUILD LIST FROM THE WORK ARRAY
-        . D QUEUE^C0CXPATH("ZBLD",ZARY,$P(ZWRK(ZI),"^",1),$P(ZWRK(ZI),"^",2))
-        D BUILD^C0CXPATH("ZBLD",OUTARY) ; BUILD NEW ARRAY WITHOUT TEXT SECTIONS
-        K @OUTARY@(0) ; GET RID OF THE LINE COUNT
-        Q
-        ;
-C0CBEGIN(ZA,LN) ; INSERTS A BEGIN LINE LN INTO ARRAY ZWRK, PASSED BY NAME
-        N ZI
-        S ZI=$O(@ZA@(""),-1)
-        I ZI="" S ZI=1
-        E  S ZI=ZI+1 ; INCREMENT COUNT IN WORK ARRAY
-        S $P(@ZA@(ZI),"^",1)=LN
-        Q
-        ;
-C0CEND(ZB,LN)   ; INSERTS AN END LINE LN INTO ARRAY ZWRK, PASSED BY NAME
-        N ZI
-        S ZI=$O(@ZB@(""),-1)
-        I ZI="" S ZI=1
-        S $P(@ZB@(ZI),"^",2)=LN
-        Q
-        ;
-SEPARATE(OUTARY,INARY)  ; SEPARATES XPATH VARIABLES ACCORDING TO THEIR
-        ; ROOT ; /Problems/etc/etc goes to @OUTARY@("Problems","/Problems/etc/etc")
-        S ZI=""
-        F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ; FOR EACH ELEMENT OF THE ARRAY
-        . I $P(ZI,"//",2)'="" D  ; FOR NON-BODY ENTRIES
-        . . S ZJ=$P(ZI,"/",4) ; things like From Patient Actor
-        . E  D  ; FOR BODY PARTS
-        . . S ZJ=$P(ZI,"/",2) ;
-        . . I ZJ="" S ZJ=$P(ZI,"/",3) ;
-        . S @OUTARY@(ZJ,ZI)=$G(@INARY@(ZI)) ;FIX THIS FOR MULTILINE COMMENTS
-        Q
-        ;
-FINDTID ; FIND TEMPLATE IDS IN DOM 1
-        S C0CDOCID=1
-        S ZD=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
-        S ZN=""
-        S CURSEC=""
-        S TID=""
-        F  S ZN=$O(@ZD@(ZN)) Q:ZN=""  D  ;
-        . I $$TAG(ZN)="root" D  ;
-        . . I $$TAG($$PARENT(ZN))="templateId" D  ; ONLY LOOKING FOR TEMPLATES
-        . . . S ZG=$$PARENT($$PARENT(ZN))
-        . . . S ZG2=$$PARENT(ZG) ;COMPONENT THAT HOLDS THIS SECTION
-        . . . S CMT=$G(@ZD@(ZG,"X",1))
-        . . . I CMT="" S CMT="?"
-        . . . I $$TAG(ZG)="section" D  ;START OF A SECTION
-        . . . . S CURSEC=$$PARENT(ZG)
-        . . . . S SECCMT=$G(@ZD@(CURSEC,"X",1))
-        . . . . I SECCMT="" S SECCMT="?"
-        . . . . S SECTID=$G(@ZD@(ZN,"T",1)) ;SECTION TEMPLATE ID
-        . . . S TID=$G(@ZD@(ZN,"T",1)) ;TEMPLATE ID
-        . . . I CURSEC'="" D  ; IF WE ARE IN A SECTION
-        . . . . S CCDDIR(ZG2,CURSEC,$$TAG(ZG2),CMT,SECCMT)=TID
-        . . . . S DOMMAP(ZG2)=CURSEC_U_$$TAG(ZG2)_U_TID_U_SECTID
-        . . . W !,$$TAG(ZG2)," ",$G(@ZD@(ZG,"X",1))
-        . . . W " root ",ZN," ",@ZD@(ZN,"T",1)
-        Q
-        ;
-FINDALT ; PROCESS THE DOMMAP AND FIND THE ALT TAGS FOR COMPONENTS
-        ;
-        S ZI=""
-        F  S ZI=$O(DOMMAP(ZI)) Q:ZI=""  D  ; FOR EACH NODE IN THE MAP
-        . S ZJ=DOMMAP(ZI) ;
-        . S PARNODE=$P(ZJ,U,1) ;PARENT NODE
-        . S TAG=$P(ZJ,U,2) ;THIS TAG
-        . S TID=$P(ZJ,U,3) ;THIS TEMPLATE ID
-        . S PARTID=$P(ZJ,U,4) ;PARENT TEMPLATE ID
-        . S ZIEN=$O(^C0CXDS(178.101,"TID",TID,"")) ;THIS NODE IEN
-        . S PARIEN=$O(^C0CXDS(178.101,"TID",PARTID,"")) ;PARENT NODE IEN
-        . I ZI=PARNODE D  ; IF THIS IS A SECTION NODE
-        . . S ALTTAG=$$GET1^DIQ(178.101,PARIEN_",",.03) ;ALT TAG FIELD FOR PARENT
-        . . S NAME=$$GET1^DIQ(178.101,ZIEN_",",.01) ;NAME OF THIS NODE'S TEMPLATE
-        . . W ZI," ",TAG," ",ALTTAG," ",NAME,!
-        . . S C0CTAGS(ZI)=ALTTAG
-        . E  D  ; NOT A SECTION NODE
-        . . N ZJ S ZJ=""
-        . . S ZJ=$O(^C0CXDS(178.101,"D",PARIEN,ZIEN,"")) ;A WHEREUSED POINTER?
-        . . I ZJ'="" D  ; THERE IS A NEW LABEL FOR THIS NODE
-        . . . N ZK
-        . . . S ZK=$$GET1^DIQ(178.111,ZJ_","_ZIEN_",",2)
-        . . . I ZK'="" D  ;
-        . . . . W "FOUND ",ZK,!
-        . . . . S C0CTAGS(ZI)=ZK ; NEW TAG FOR INTERSECTION
-        Q
-        ;
-ALTTAG(NODE)    ; SET Y EQUAL TO THE ALT TAG FOUND IN C0CTAGS IF NODE IF FOUND
-        ;
-        S Y=$G(C0CTAGS(NODE))
-        Q
-        ;
-SETCBK  ; SET THE TAG CALLBACK FOR XPATH PROCESSSING OF THE CCD
-        S C0CCBK("TAG")="D ALTTAG^C0CMCCD(ZOID)"
-        Q
-        ;
-OUTCCD(GARYIN)  ; OUTPUT THE PARSED CCD TO A TEXT FILE
-        ;D TEST3^C0CMXML
-        N ZT S ZT=$NA(^TMP("CCDOUT",$J))
-        N ZI,ZJ
-        S ZI=1 S ZJ=""
-        K @ZT
-        F  S ZJ=$O(GARYIN(ZJ)) Q:ZJ=""  D  ;
-        . S @ZT@(ZI)=ZJ_"^"_GARYIN(ZJ)
-        . S ZI=ZI+1
-        S ONAME=$NA(@ZT@(1))
-        W $$OUTPUT^C0CXPATH(ONAME,"CCDOUT.txt","/home/vademo2/CCR")
-        K @ZT
-        Q
-        ;
-GENXDS(ZD)      ; GENERATE THE XDS PROTOTYPE RECORDS FROM A CCDDIR ARRAY
-        ; ARRAY ELEMENTS LOOK LIKE:
-        ; CCDDIR(1659,1634,"observation"," Result observaion template "," Vital signs section template ")="2.16.840.1.113883.10.20.1.31"
-        ;or CCDDIR(cur node,section node,cur tag,cur name,sec name)=templateId
-        S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE
-        S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT
-        S DONE=0
-        F  Q:DONE  D  ;
-        . W @ZI,!
-        . S ZJ=$QS(ZI,5)
-        . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE
-        . S C0CFDA(ZF,"?+1,",.01)=ZJ
-        . S C0CFDA(ZF,"?+1,",.02)=$QS(ZI,4) ; TAG FOR THIS TEMPLATE
-        . S C0CFDA(ZF,"?+1,",1)=@ZI
-        . D UPDIE
-        . S ZI=$Q(@ZI)
-        . I ZI="" S DONE=1
-        Q
-        ;
-WHRUSD(ZD)      ; UPDATE THE C0C XDS FILE WITH WHERE USED DATA FROM
-        ; CCDDIR PASS BY NAME
-        ; ARRAY ELEMENTS LOOK LIKE:
-        ; CCDDIR(1634," Vital signs section template ",1659,"observation"," Result observaion template ")="2.16.840.1.113883.10.20.1.31"
-        ;or CCDDIR(section node,sec name, cur node,cur tag,cur name)=templateId
-        S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE
-        S ZSF=178.111 ; WHERE USED SUBFILE OF C0C XDS PROTOTYPE FILE
-        S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT
-        S DONE=0
-        F  Q:DONE  D  ;
-        . W @ZI
-        . S ZIEN=$O(^C0CXDS(178.101,"TID",@ZI,"")) ; IEN FOR THIS NODE'S TEMPLATE
-        . W " IEN:",ZIEN
-        . S ZJ=$QS(ZI,2)
-        . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE
-        . S ZPIEN=$O(^C0CXDS(178.101,"B",ZJ,"")) ; PARENT IEN
-        . W " PARENT IEN:",ZPIEN
-        . S ZTAG=$QS(ZI,4) ; TAG FOR THIS TEMPLATE
-        . W " TAG:",ZTAG,!
-        . I ZIEN'=ZPIEN D  ; ONLY FOR CHILD TEMPLATES
-        . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",.01)=ZPIEN ; NEW SUBFILE ENTRY WITH PAR PTR
-        . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",1)=ZTAG ; TAG FOR NEW ENTRY
-        . . D UPDIE
-        . ;S C0CFDA(ZF,"?+1,",1)=@ZI
-        . ;D UPDIE
-        . S ZI=$Q(@ZI)
-        . I ZI="" S DONE=1
-        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
-        ;
+C0CMCCD   ; GPL - MXML based CCD utilities;12/04/09  17:05
+ ;;0.1;C0C;nopatch;noreleasedate
+ ;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
+ ;
+PARSCCD(DOC,OPTION) ; THIS WAS COPIED FROM EN^MXMLDOM TO CUSTIMIZE FOR 
+ ; PROCESSING CCDS 
+ N CBK,SUCCESS,LEVEL,NODE,HANDLE
+ K ^TMP("MXMLERR",$J)
+ L +^TMP("MXMLDOM",$J):5
+ E  Q 0
+ S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)=""
+ L -^TMP("MXMLDOM",$J)
+ S CBK("STARTELEMENT")="STARTELE^C0CMCCD" ; ONLY THIS ONE IS CHANGED ;GPL
+ S CBK("ENDELEMENT")="ENDELE^MXMLDOM"
+ S CBK("COMMENT")="COMMENT^MXMLDOM"
+ S CBK("CHARACTERS")="CHAR^MXMLDOM"
+ S CBK("ENDDOCUMENT")="ENDDOC^MXMLDOM"
+ S CBK("ERROR")="ERROR^MXMLDOM"
+ S (SUCCESS,LEVEL,LEVEL(0),NODE)=0,OPTION=$G(OPTION,"V1")
+ D EN^MXMLPRSE(DOC,.CBK,OPTION)
+ D:'SUCCESS DELETE^MXMLDOM(HANDLE)
+ Q $S(SUCCESS:HANDLE,1:0)
+ ; Start element
+ ; Create new child node and push info on stack
+STARTELE(ELE,ATTR) ; COPIED FROM STARTELE^MXMLDOM AND MODIFIED TO TREAT
+ ; ATTRIBUTES AS SUBELEMENTS TO MAKE CCD XPATH PROCESSING EASIER
+ N PARENT
+ S PARENT=LEVEL(LEVEL),NODE=NODE+1
+ S:PARENT ^TMP("MXMLDOM",$J,HANDLE,PARENT,"C",NODE)=ELE
+ S LEVEL=LEVEL+1,LEVEL(LEVEL)=NODE,LEVEL(LEVEL,0)=ELE
+ S ^TMP("MXMLDOM",$J,HANDLE,NODE)=ELE,^(NODE,"P")=PARENT
+ ;M ^("A")=ATTR
+ N ZI S ZI="" ; INDEX FOR ATTR
+ F  S ZI=$O(ATTR(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
+ . N ELE,TXT ; ABOUT TO RECURSE
+ . S ELE=ZI ; TAG
+ . S TXT=ATTR(ZI) ; DATA
+ . D STARTELE(ELE,"") ; CREATE A NEW SUBNODE
+ . D TXT^MXMLDOM("T") ; INSERT DATA TO TAG
+ . D ENDELE^MXMLDOM(ELE) ; POP BACK UP A LEVEL
+ Q
+ ;
+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
+ ;
+CLEANARY(OUTARY,INARY) ; GOES THROUGH AN ARRAY AND CALLS CLEAN ON EACH NODE
+ ; INARY AND OUTARY PASSED BY NAME
+ N ZI S ZI=""
+ F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ; FOR EACH NODE
+ . S @OUTARY@(ZI)=$$CLEAN(@INARY@(ZI)) ; CLEAN THE NODE
+ Q
+ ;
+CLEAN(STR) ; extrinsic function; returns string
+ ;; Removes all non printable characters from a string.
+ ;; STR by Value
+ N TR,I
+ F I=0:1:31 S TR=$G(TR)_$C(I)
+ S TR=TR_$C(127)
+ QUIT $TR(STR,TR)
+ ;
+STRIPTXT(OUTARY,ZARY) ; STRIPS THE "TEXT" PORTION OUT OF AN XML FILE
+ ; THIS IS USED TO DELETE THE NARATIVE HTML OUT OF THE CCD XML FILES BECAUSE
+ ; THEY DO NOT WORK RIGHT WITH THE PARSER
+ ;N ZWRK,ZBLD,ZI ; WORK ARRAY,BUILD ARRAY, AND COUNTER
+ S ZI=$O(@ZARY@("")) ; GET FIRST LINE NUMBER
+ D C0CBEGIN("ZWRK",ZI) ; INSERT FIRST LINE IN WORK ARRAY
+ F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH LINE OF THE ARRAY
+ . I $O(@ZARY@(ZI))="" D  Q  ; AT THE END 
+ . . D C0CEND("ZWRK",ZI) ; INCLUDE LAST LINE IN WORK ARRAY
+ . I ZI=1 D C0CBEGIN("ZWRK",ZI) ; START WITH FIRST LINE
+ . I @ZARY@(ZI)["<text" D C0CEND("ZWRK",ZI-1) ;PREV LINE IS AN END
+ . I @ZARY@(ZI)["</text>" D C0CBEGIN("ZWRK",ZI+1) ;NEXT LINE IS A BEGIN
+ S ZI=""
+ F  S ZI=$O(ZWRK(ZI)) Q:ZI=""  D  ; MAKE A BUILD LIST FROM THE WORK ARRAY
+ . D QUEUE^C0CXPATH("ZBLD",ZARY,$P(ZWRK(ZI),"^",1),$P(ZWRK(ZI),"^",2))
+ D BUILD^C0CXPATH("ZBLD",OUTARY) ; BUILD NEW ARRAY WITHOUT TEXT SECTIONS
+ K @OUTARY@(0) ; GET RID OF THE LINE COUNT
+ Q
+ ;
+C0CBEGIN(ZA,LN) ; INSERTS A BEGIN LINE LN INTO ARRAY ZWRK, PASSED BY NAME
+ N ZI
+ S ZI=$O(@ZA@(""),-1)
+ I ZI="" S ZI=1
+ E  S ZI=ZI+1 ; INCREMENT COUNT IN WORK ARRAY
+ S $P(@ZA@(ZI),"^",1)=LN
+ Q
+ ;
+C0CEND(ZB,LN) ; INSERTS AN END LINE LN INTO ARRAY ZWRK, PASSED BY NAME
+ N ZI
+ S ZI=$O(@ZB@(""),-1)
+ I ZI="" S ZI=1
+ S $P(@ZB@(ZI),"^",2)=LN
+ Q
+ ;
+SEPARATE(OUTARY,INARY) ; SEPARATES XPATH VARIABLES ACCORDING TO THEIR
+ ; ROOT ; /Problems/etc/etc goes to @OUTARY@("Problems","/Problems/etc/etc")
+ S ZI=""
+ F  S ZI=$O(@INARY@(ZI)) Q:ZI=""  D  ; FOR EACH ELEMENT OF THE ARRAY
+ . I $P(ZI,"//",2)'="" D  ; FOR NON-BODY ENTRIES
+ . . S ZJ=$P(ZI,"/",4) ; things like From Patient Actor
+ . E  D  ; FOR BODY PARTS
+ . . S ZJ=$P(ZI,"/",2) ;
+ . . I ZJ="" S ZJ=$P(ZI,"/",3) ;
+ . S @OUTARY@(ZJ,ZI)=$G(@INARY@(ZI)) ;FIX THIS FOR MULTILINE COMMENTS
+ Q
+ ;
+FINDTID ; FIND TEMPLATE IDS IN DOM 1
+ S C0CDOCID=1
+ S ZD=$NA(^TMP("MXMLDOM",$J,C0CDOCID))
+ S ZN=""
+ S CURSEC=""
+ S TID=""
+ F  S ZN=$O(@ZD@(ZN)) Q:ZN=""  D  ;
+ . I $$TAG(ZN)="root" D  ;
+ . . I $$TAG($$PARENT(ZN))="templateId" D  ; ONLY LOOKING FOR TEMPLATES
+ . . . S ZG=$$PARENT($$PARENT(ZN))
+ . . . S ZG2=$$PARENT(ZG) ;COMPONENT THAT HOLDS THIS SECTION
+ . . . S CMT=$G(@ZD@(ZG,"X",1))
+ . . . I CMT="" S CMT="?"
+ . . . I $$TAG(ZG)="section" D  ;START OF A SECTION
+ . . . . S CURSEC=$$PARENT(ZG)
+ . . . . S SECCMT=$G(@ZD@(CURSEC,"X",1))
+ . . . . I SECCMT="" S SECCMT="?"
+ . . . . S SECTID=$G(@ZD@(ZN,"T",1)) ;SECTION TEMPLATE ID
+ . . . S TID=$G(@ZD@(ZN,"T",1)) ;TEMPLATE ID
+ . . . I CURSEC'="" D  ; IF WE ARE IN A SECTION
+ . . . . S CCDDIR(ZG2,CURSEC,$$TAG(ZG2),CMT,SECCMT)=TID
+ . . . . S DOMMAP(ZG2)=CURSEC_U_$$TAG(ZG2)_U_TID_U_SECTID
+ . . . W !,$$TAG(ZG2)," ",$G(@ZD@(ZG,"X",1))
+ . . . W " root ",ZN," ",@ZD@(ZN,"T",1)
+ Q
+ ;
+FINDALT ; PROCESS THE DOMMAP AND FIND THE ALT TAGS FOR COMPONENTS
+ ;
+ S ZI=""
+ F  S ZI=$O(DOMMAP(ZI)) Q:ZI=""  D  ; FOR EACH NODE IN THE MAP
+ . S ZJ=DOMMAP(ZI) ;
+ . S PARNODE=$P(ZJ,U,1) ;PARENT NODE
+ . S TAG=$P(ZJ,U,2) ;THIS TAG
+ . S TID=$P(ZJ,U,3) ;THIS TEMPLATE ID
+ . S PARTID=$P(ZJ,U,4) ;PARENT TEMPLATE ID
+ . S ZIEN=$O(^C0CXDS(178.101,"TID",TID,"")) ;THIS NODE IEN
+ . S PARIEN=$O(^C0CXDS(178.101,"TID",PARTID,"")) ;PARENT NODE IEN
+ . I ZI=PARNODE D  ; IF THIS IS A SECTION NODE
+ . . S ALTTAG=$$GET1^DIQ(178.101,PARIEN_",",.03) ;ALT TAG FIELD FOR PARENT
+ . . S NAME=$$GET1^DIQ(178.101,ZIEN_",",.01) ;NAME OF THIS NODE'S TEMPLATE
+ . . W ZI," ",TAG," ",ALTTAG," ",NAME,!
+ . . S C0CTAGS(ZI)=ALTTAG
+ . E  D  ; NOT A SECTION NODE
+ . . N ZJ S ZJ=""
+ . . S ZJ=$O(^C0CXDS(178.101,"D",PARIEN,ZIEN,"")) ;A WHEREUSED POINTER?
+ . . I ZJ'="" D  ; THERE IS A NEW LABEL FOR THIS NODE
+ . . . N ZK
+ . . . S ZK=$$GET1^DIQ(178.111,ZJ_","_ZIEN_",",2)
+ . . . I ZK'="" D  ;
+ . . . . W "FOUND ",ZK,!
+ . . . . S C0CTAGS(ZI)=ZK ; NEW TAG FOR INTERSECTION
+ Q
+ ;
+ALTTAG(NODE) ; SET Y EQUAL TO THE ALT TAG FOUND IN C0CTAGS IF NODE IF FOUND
+ ;
+ S Y=$G(C0CTAGS(NODE))
+ Q
+ ;
+SETCBK ; SET THE TAG CALLBACK FOR XPATH PROCESSSING OF THE CCD
+ S C0CCBK("TAG")="D ALTTAG^C0CMCCD(ZOID)"
+ Q
+ ;
+OUTCCD(GARYIN) ; OUTPUT THE PARSED CCD TO A TEXT FILE
+ ;D TEST3^C0CMXML
+ N ZT S ZT=$NA(^TMP("CCDOUT",$J))
+ N ZI,ZJ
+ S ZI=1 S ZJ=""
+ K @ZT
+ F  S ZJ=$O(GARYIN(ZJ)) Q:ZJ=""  D  ;
+ . S @ZT@(ZI)=ZJ_"^"_GARYIN(ZJ)
+ . S ZI=ZI+1
+ S ONAME=$NA(@ZT@(1))
+ W $$OUTPUT^C0CXPATH(ONAME,"CCDOUT.txt","/home/vademo2/CCR")
+ K @ZT
+ Q
+ ;
+GENXDS(ZD) ; GENERATE THE XDS PROTOTYPE RECORDS FROM A CCDDIR ARRAY
+ ; ARRAY ELEMENTS LOOK LIKE:
+ ; CCDDIR(1659,1634,"observation"," Result observaion template "," Vital signs section template ")="2.16.840.1.113883.10.20.1.31"
+ ;or CCDDIR(cur node,section node,cur tag,cur name,sec name)=templateId
+ S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE
+ S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT
+ S DONE=0
+ F  Q:DONE  D  ;
+ . W @ZI,!
+ . S ZJ=$QS(ZI,5)
+ . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE
+ . S C0CFDA(ZF,"?+1,",.01)=ZJ
+ . S C0CFDA(ZF,"?+1,",.02)=$QS(ZI,4) ; TAG FOR THIS TEMPLATE
+ . S C0CFDA(ZF,"?+1,",1)=@ZI
+ . D UPDIE
+ . S ZI=$Q(@ZI)
+ . I ZI="" S DONE=1
+ Q
+ ;
+WHRUSD(ZD) ; UPDATE THE C0C XDS FILE WITH WHERE USED DATA FROM
+ ; CCDDIR PASS BY NAME
+ ; ARRAY ELEMENTS LOOK LIKE:
+ ; CCDDIR(1634," Vital signs section template ",1659,"observation"," Result observaion template ")="2.16.840.1.113883.10.20.1.31"
+ ;or CCDDIR(section node,sec name, cur node,cur tag,cur name)=templateId
+ S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE
+ S ZSF=178.111 ; WHERE USED SUBFILE OF C0C XDS PROTOTYPE FILE
+ S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT
+ S DONE=0
+ F  Q:DONE  D  ;
+ . W @ZI
+ . S ZIEN=$O(^C0CXDS(178.101,"TID",@ZI,"")) ; IEN FOR THIS NODE'S TEMPLATE
+ . W " IEN:",ZIEN
+ . S ZJ=$QS(ZI,2)
+ . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE
+ . S ZPIEN=$O(^C0CXDS(178.101,"B",ZJ,"")) ; PARENT IEN
+ . W " PARENT IEN:",ZPIEN
+ . S ZTAG=$QS(ZI,4) ; TAG FOR THIS TEMPLATE
+ . W " TAG:",ZTAG,!
+ . I ZIEN'=ZPIEN D  ; ONLY FOR CHILD TEMPLATES
+ . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",.01)=ZPIEN ; NEW SUBFILE ENTRY WITH PAR PTR
+ . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",1)=ZTAG ; TAG FOR NEW ENTRY
+ . . D UPDIE
+ . ;S C0CFDA(ZF,"?+1,",1)=@ZI
+ . ;D UPDIE
+ . S ZI=$Q(@ZI)
+ . I ZI="" S DONE=1
+ 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/branches/ohum/p/C0CMED.m

@@ -1 @@
-C0CMED  ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ; 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/branches/ohum/p/C0CMED1.m

@@ -1 @@
-C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;;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 Q
-        ZWRITE:$G(DEBUG) MEDS
-        N RXIEN S RXIEN=0
-        F  S RXIEN=$O(MEDS(RXIEN)) Q:$G(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/branches/ohum/p/C0CMED2.m

@@ -1 @@
-C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;;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/branches/ohum/p/C0CMED3.m

@@ -1 @@
-C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;;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/branches/ohum/p/C0CMED4.m

@@ -1 @@
-C0CMED4         ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08
-        ;;0.1;CCDCCR;;;Build 1
-        ; 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)                ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
-        ;
-        ; MINXML is the Input XML Template, passed by name
-        ; DFN is Patient IEN
-        ; OUTXML is the resultant XML.
-        ;
-        ; MEDS is return array from API.
-        ; MED is holds each array element from MEDS, one medicine
-        ; MAP is a mapping variable map (store result) for each med
-        ;
-        ; Inpatient Meds will be extracted using this routine and and the one following.
-        ; Inpatient Meds Unit Dose is going to be C0CMED4
-        ; Inpatient Meds IVs is going to be C0CMED5
-        ;
-        ; We will use two Pharmacy ReEnginnering API's:
-        ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info
-        ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info
-        ; For more information, see the PRE documentation at:
-        ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf
-        ; 
-        ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient
-        ;
-        N MEDS,MAP
-        K ^TMP($J)
-        D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*)
-        I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT  ; No Meds - Quit
-        ; Otherwise, we go on...
-        M MEDS=^TMP($J,"UD")
-        I DEBUG ZWR MEDS
-        S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) 
-        N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array
-        N I S I=0 
-        F  S I=$O(MEDS("B",I)) Q:'I  D  ; For each medication in B index
-        . N MED M MED=MEDS(I)
-        . S MEDCOUNT=MEDCOUNT+1
-        . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter
-        . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT))
-        . N RXIEN S RXIEN=MED(.01) ; Order Number
-        . I DEBUG W "RXIEN IS ",RXIEN,!
-        . I DEBUG W "MAP= ",MAP,!
-        . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN 
-        . S @MAP@("MEDISSUEDATETXT")="Order Date"
-        . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT")
-        . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient
-        . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient
-        . S @MAP@("MEDRXNOTXT")="" ; For Outpatient
-        . S @MAP@("MEDRXNO")="" ; For Outpatient
-        . S @MAP@("MEDTYPETEXT")="Medication"
-        . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
-        . S @MAP@("MEDSTATUSTEXT")="ACTIVE" 
-        . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U)
-        . S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01)
-        . ; NDC is field 31 in the drug file.
-        . ; The actual drug entry in the drug file is not necessarily supplied.
-        . ; It' node 1, internal form.
-        . N MEDIEN S MEDIEN=MED(1,"I")
-        . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"")
-        . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"")
-        . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"")
-        . S @MAP@("MEDBRANDNAMETEXT")=""
-        . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE")
-        . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
-        . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"")
-        . S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"")
-        . ; 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.
-        . N NDFDATA,CONCDATA
-        . I $L(MEDIEN) D
-        . . D NDF^PSS50(MEDIEN,,,,,"CONC")
-        . . M NDFDATA=^TMP($J,"CONC",MEDIEN)
-        . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
-        . . N VAPROD S VAPROD=$P(NDFDATA(22),U)
-        . . ; 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)
-        . E  S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors.
-        . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"")
-        . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"")
-        . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"")
-        . 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
-        . I $L(MEDIEN) D
-        . . D DATA^PSS50(MEDIEN,,,,,"QTY")
-        . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
-        . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
-          E  S @MAP@("MEDQUANTITYUNIT")=""
-        . ;
-        . ; --- 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 @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@("MEDPTINSTRUCTIONS","F")="52.41^105"
-        . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field
-        . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
-        . S @MAP@("MEDRFNO")=""
-        . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED"))
-        . K @RESULT
-        . D MAP^GPLXPATH(MINXML,MAP,RESULT)
-        . ; D PARY^GPLXPATH(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^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
-        . D REPLACE^GPLXPATH(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^GPLXPATH(DIRXML1,MDZNA,DIRXML2)
-        . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication")
-        . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy
-        . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
-        N MEDTMP,MEDI
-        D MISSING^GPLXPATH(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
-        ;
+C0CMED4         ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08
+ ;;0.1;CCDCCR;;;
+ ; 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)           ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
+ ;
+ ; MINXML is the Input XML Template, passed by name
+ ; DFN is Patient IEN
+ ; OUTXML is the resultant XML.
+ ;
+ ; MEDS is return array from API.
+ ; MED is holds each array element from MEDS, one medicine
+ ; MAP is a mapping variable map (store result) for each med
+ ;
+ ; Inpatient Meds will be extracted using this routine and and the one following.
+ ; Inpatient Meds Unit Dose is going to be C0CMED4
+ ; Inpatient Meds IVs is going to be C0CMED5
+ ;
+ ; We will use two Pharmacy ReEnginnering API's:
+ ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info
+ ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info
+ ; For more information, see the PRE documentation at:
+ ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf
+ ; 
+ ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient
+ ;
+ N MEDS,MAP
+ K ^TMP($J)
+ D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*)
+ I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT  ; No Meds - Quit
+ ; Otherwise, we go on...
+ M MEDS=^TMP($J,"UD")
+ I DEBUG ZWR MEDS
+ S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) 
+ N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array
+ N I S I=0 
+ F  S I=$O(MEDS("B",I)) Q:'I  D  ; For each medication in B index
+ . N MED M MED=MEDS(I)
+ . S MEDCOUNT=MEDCOUNT+1
+ . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter
+ . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT))
+ . N RXIEN S RXIEN=MED(.01) ; Order Number
+ . I DEBUG W "RXIEN IS ",RXIEN,!
+ . I DEBUG W "MAP= ",MAP,!
+ . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN 
+ . S @MAP@("MEDISSUEDATETXT")="Order Date"
+ . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT")
+ . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient
+ . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient
+ . S @MAP@("MEDRXNOTXT")="" ; For Outpatient
+ . S @MAP@("MEDRXNO")="" ; For Outpatient
+ . S @MAP@("MEDTYPETEXT")="Medication"
+ . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
+ . S @MAP@("MEDSTATUSTEXT")="ACTIVE" 
+ . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U)
+ . S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01)
+ . ; NDC is field 31 in the drug file.
+ . ; The actual drug entry in the drug file is not necessarily supplied.
+ . ; It' node 1, internal form.
+ . N MEDIEN S MEDIEN=MED(1,"I")
+ . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"")
+ . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"")
+ . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"")
+ . S @MAP@("MEDBRANDNAMETEXT")=""
+ . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE")
+ . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
+ . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"")
+ . S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"")
+ . ; 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.
+ . N NDFDATA,CONCDATA
+ . I $L(MEDIEN) D
+ . . D NDF^PSS50(MEDIEN,,,,,"CONC")
+ . . M NDFDATA=^TMP($J,"CONC",MEDIEN)
+ . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
+ . . N VAPROD S VAPROD=$P(NDFDATA(22),U)
+ . . ; 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)
+ . E  S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors.
+ . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"")
+ . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"")
+ . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"")
+ . 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
+ . I $L(MEDIEN) D
+ . . D DATA^PSS50(MEDIEN,,,,,"QTY")
+ . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN)
+ . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
+   E  S @MAP@("MEDQUANTITYUNIT")=""
+ . ;
+ . ; --- 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 @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@("MEDPTINSTRUCTIONS","F")="52.41^105"
+ . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field
+ . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
+ . S @MAP@("MEDRFNO")=""
+ . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED"))
+ . K @RESULT
+ . D MAP^GPLXPATH(MINXML,MAP,RESULT)
+ . ; D PARY^GPLXPATH(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^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1)
+ . D REPLACE^GPLXPATH(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^GPLXPATH(DIRXML1,MDZNA,DIRXML2)
+ . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication")
+ . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy
+ . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
+ N MEDTMP,MEDI
+ D MISSING^GPLXPATH(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/branches/ohum/p/C0CMED6.m

@@ -1 @@
-C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ; 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,FLAGS)        ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
-        ;
-        ; MINXML and OUTXML are passed by name so globals can be used
-        ; MINXML will contain only the medications skeleton of the overall template
-        ; MEDCOUNT is a counter passed by Reference.
-        ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool)
-        ; FLAGS are set-up in C0CMED.
-        ;
-        ; 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
-        ; J is a counter.
-        ;
-        ; GETRXS^BEHORXFN(ARRAYNAME,DFN,DAYS) will be the the API used.
-        ; This API has been developed by Medsphere for IHS for getting
-        ; Medications from RPMS. It has most of what we need.
-        ; API written by Doug Martin when he worked for Medsphere (thanks Doug!)
-        ; -- ARRAYNAME is passed by name (required)
-        ; -- DFN is passed by value (required)
-        ; -- DAYS is passed by value (optional; if not passed defaults to 365)
-        ; 
-        ; Return:
-        ; ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID 
-        ; ^Status^LastFill^Chronic^Issued^Rx #^Provider^ 
-        ; Status Reason^DEA Handling
-        ; 
-        N MEDS,MEDS1,MAP
-        D GETRXS^BEHORXFN("MEDS1",DFN,$P($P(FLAGS,U,2),"-",2)) ; 2nd piece of FLAGS is # of days to retrieve, which comes in the form "T-360"
-        N ALL S ALL=+FLAGS
-        N ACTIVE S ACTIVE=$P(FLAGS,U,3)
-        N PENDING S PENDING=$P(FLAGS,U,4)
-        S @OUTXML@(0)=0  ;By default, no meds
-        ; If MEDS1 is not defined, then no meds
-        I '$D(MEDS1) QUIT
-        I DEBUG ZWR MEDS1,MINXML
-        N MEDCNT S MEDCNT=0 ; Med Count
-        ; The next line is a super line. It goes through the array return
-        ; and if the first characters are ~OP, it grabs the line.
-        ; This means that line is for a dispensed Outpatient Med.
-        ; That line has the metadata about the med that I need.
-        ; The next lines, however many, are the med and the sig.
-        ; I won't be using those because I have to get the sig parsed exactly.
-        N J S J="" F  S J=$O(MEDS1(J)) Q:J=""  I $E(MEDS1(J),1,3)="~OP" S MEDCNT=MEDCNT+1 S MEDS(MEDCNT)=MEDS1(J)
-        K MEDS1
-        S MEDCNT="" ; Initialize for $Order
-        F  S MEDCNT=$O(MEDS(MEDCNT)) Q:MEDCNT=""  D  ; for each medication in the list
-        . I 'ALL,ACTIVE,$P(MEDS(MEDCNT),U,10)'="ACTIVE" QUIT
-        . I 'ALL,PENDING,$P(MEDS(MEDCNT),U,10)'="PENDING" QUIT
-        . I DEBUG W "MEDCNT IS ",MEDCNT,!
-        . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCNT))
-        . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED
-        . I DEBUG W "MAP= ",MAP,!
-        . S @MAP@("MEDOBJECTID")="MED"_MEDCNT ; MEDCNT FOR ID
-        . S @MAP@("MEDISSUEDATETXT")="Issue Date"
-        . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,15),"DT")
-        . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date"
-        . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,11),"DT")
-        . S @MAP@("MEDRXNOTXT")="Prescription Number"
-        . S @MAP@("MEDRXNO")=$P(MEDS(MEDCNT),U,14)
-        . S @MAP@("MEDTYPETEXT")="Medication"
-        . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
-        . S @MAP@("MEDSTATUSTEXT")=$P(MEDS(MEDCNT),U,10)
-        . ; Provider only provided in API as text, not DUZ.
-        . ; We need to get DUZ from filman file 52 (Prescription)
-        . ; Field 4; IEN is Piece 2 of Meds stripped of trailing characters.
-        . ; Note that I will use RXIEN several times later
-        . N RXIEN S RXIEN=+$P(MEDS(MEDCNT),U,2)
-        . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52,RXIEN,4,"I")
-        . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MEDS(MEDCNT),U,3)
-        . ; --- RxNorm Stuff 
-        . ; 176.001 is the file for Concepts; 176.003 is the file for
-        . ; sources (i.e. for RxNorm Version)
-        . ; 
-        . ; I use 176.001 for the Vista version of this routine (files 1-3)
-        . ; Since IHS does not have VUID's, I will be getting RxNorm codes
-        . ; using NDCs. My specially crafted index (sounds evil) named "NDC"
-        . ; is in file 176.002. The file is called RxNorm NDC to VUID.
-        . ; Except that I don't need the VUID, but it's there if I need it.
-        . ; 
-        . ; We obviously need the NDC. That is easily obtained from the prescription.
-        . ; Field 27 in file 52
-        . N NDC S NDC=$$GET1^DIQ(52,RXIEN,27,"I")
-        . ; I discovered that file 176.002 might give you two codes for the NDC
-        . ; One for the Clinical Drug, and one for the ingredient.
-        . ; So the plan is to get the two RxNorm codes, and then find from
-        . ; file 176.001 which one is the Clinical Drug.
-        . ; ... I refactored this into GETRXN
-        . N RXNORM,SRCIEN,RXNNAME,RXNVER
-        . I +NDC,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
-        . . S RXNORM=$$GETRXN(NDC)
-        . . S SRCIEN=$$FIND1^DIC(176.003,,,"RXNORM","B")
-        . . 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
-        . ; --- End RxNorm section
-        . ;
-        . ; Brand name is 52 field 6.5
-        . S @MAP@("MEDBRANDNAMETEXT")=$$GET1^DIQ(52,RXIEN,6.5)
-        . ;
-        . ; Next I need Med Form (tab, cap etc), strength (250mg)
-        . ; concentration for liquids (250mg/mL)
-        . ; Since IHS does not have any of the new calls that 
-        . ; Vista has, I will be doing a crosswalk:
-        . ; File 52, field 6 is Drug IEN in file 50
-        . ; File 50, field 22 is VA Product IEN in file 50.68
-        . ; In file 50.68, I will get the following:
-        . ; -- 1: Dosage Form
-        . ; -- 2: Strength
-        . ; -- 3: Units
-        . ; -- 8: Dispense Units
-        . ; -- Conc is 2 concatenated with 3
-        . ; 
-        . ; *** If Drug is not matched to NDF, then VA Product will be "" ***
-        . ;
-        . N MEDIEN S MEDIEN=$$GET1^DIQ(52,RXIEN,6,"I") ; Drug IEN in 50
-        . N VAPROD S VAPROD=$$GET1^DIQ(50,MEDIEN,22,"I") ; VA Product in file 50.68
-        . I +VAPROD D
-        . . S @MAP@("MEDSTRENGTHVALUE")=$$GET1^DIQ(50.68,VAPROD,2)
-        . . S @MAP@("MEDSTRENGTHUNIT")=$$GET1^DIQ(50.68,VAPROD,3)
-        . . S @MAP@("MEDFORMTEXT")=$$GET1^DIQ(50.68,VAPROD,1)
-        . . S @MAP@("MEDCONCVALUE")=@MAP@("MEDSTRENGTHVALUE")
-        . . S @MAP@("MEDCONCUNIT")=@MAP@("MEDSTRENGTHUNIT")
-        . E  D
-        . . S @MAP@("MEDSTRENGTHVALUE")=""
-        . . S @MAP@("MEDSTRENGTHUNIT")=""
-        . . S @MAP@("MEDFORMTEXT")=""
-        . . S @MAP@("MEDCONCVALUE")=""
-        . . S @MAP@("MEDCONCUNIT")=""
-        . ; End Strengh/Conc stuff
-        . ;
-        . ; Quantity is in the prescription, field 7
-        . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52,RXIEN,7)
-        . ; Dispense unit is in the drug file, field 14.5
-        . S @MAP@("MEDQUANTITYUNIT")=$$GET1^DIQ(50,MEDIEN,14.5)
-        . ;
-        . ; --- START OF DIRECTIONS ---
-        . ; Sig data not in any API :-(  Oh yes, you can get the whole thing, but...
-        . ; we want the components.
-        . ; It's in multiple 113 in the Prescription File (52)
-        . ; #.01 DOSAGE ORDERED [1F]                    "20"
-        . ; #1 DISPENSE UNITS PER DOSE [2N]     "1"
-        . ; #2 UNITS [3P:50.607]                                "MG"
-        . ; #3 NOUN [4F]                                                "TABLET"
-        . ; #4 DURATION [5F]                                    "10D"
-        . ; #5 CONJUNCTION [6S]                                 "AND"
-        . ; #6 ROUTE [7P:51.2]                          "ORAL"
-        . ; #7 SCHEDULE [8F]                                    "BID"
-        . ; #8 VERB [9F]                                                "TAKE"
-        . ;
-        . ; Will use GETS^DIQ to get fields.
-        . ; Data comes out like this:
-        . ; SAMINS(52.0113,"1,23,",.01)=20
-        . ; SAMINS(52.0113,"1,23,",1)=1
-        . ; SAMINS(52.0113,"1,23,",2)="MG"
-        . ; SAMINS(52.0113,"1,23,",3)="TABLET"
-        . ; SAMINS(52.0113,"1,23,",4)="5D"
-        . ; SAMINS(52.0113,"1,23,",5)="THEN"
-        . ;
-        . N RAWDATA
-        . D GETS^DIQ(52,RXIEN,"113*",,"RAWDATA","DIERR")
-        . D:$D(DIERR) ^%ZTER  ; Log if there's an error in retrieving sig field
-        . ; none the less, continue; some parts are retrievable.
-        . N FMSIG M FMSIG=RAWDATA(52.0113) ; Merge into subfile...
-        . K RAWDATA
-        . N FMSIGNUM S FMSIGNUM="" ; Sigline number in fileman.
-        . ; FMSIGNUM gets outputted as "IEN,RXIEN,".
-        . ; DIRCNT is the proper Sigline numer.
-        . ; SIGDATA is the simplfied array. 
-        . F  S FMSIGNUM=$O(FMSIG(FMSIGNUM)) Q:FMSIGNUM=""  D
-        . . N DIRCNT S DIRCNT=$P(FMSIGNUM,",")
-        . . N SIGDATA M SIGDATA=FMSIG(FMSIGNUM)
-        . . 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")=$G(SIGDATA(8))
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$G(SIGDATA(.01))
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=$G(SIGDATA(2))
-        . . 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")=$G(SIGDATA(6))
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$G(SIGDATA(7))
-        . . ; 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.
-        . . ; Search B index of 51.1 (Admin Schedule) with schedule
-        . . ; First, remove "PRN" if it exists (don't ask, that's how the file
-        . . ; works; I wouldn't do it that way).
-        . . N SCHNOPRN S SCHNOPRN=$G(SIGDATA(7))
-        . . I SCHNOPRN["PRN" S SCHNOPRN=$E(SCHNOPRN,1,$F(SCHNOPRN,"PRN")-5)
-        . . ; Super call below:
-        . . ; 1=File 51.1 3=Field 2 (Frequency in Minutes)
-        . . ; 4=Packed format, Exact Match 5=Lookup Value
-        . . ; 6=# of entries to return 7=Index 10=Return Array
-        . . ; 
-        . . ; I do not account for the fact that two schedules can be
-        . . ; spelled identically (ie duplicate entry). In that case,
-        . . ; I get the first. That's just a bad pharmacy pkg maintainer.
-        . . N C0C515
-        . . D FIND^DIC(51.1,,"@;2","PX",SCHNOPRN,1,"B",,,"C0C515")
-        . . N INTERVAL S INTERVAL="" ; Default
-        . . ; If there are entries found, get it
-        . . I +$G(C0C515("DILIST",0)) S INTERVAL=$P(C0C515("DILIST",1,0),U,2) 
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
-        . . ; Duration is 10M minutes, 10H hours, 10D for Days
-        . . ; 10W for weeks, 10L for months. I smell $Select
-        . . ; But we don't need to do that if there isn't a duration
-        . . I +$G(SIGDATA(4)) D
-        . . . N DURUNIT S DURUNIT=$E(SIGDATA(4),$L(SIGDATA(4))) ; get last char
-        . . . N DURTXT S DURTXT=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"Days")
-        . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=+SIGDATA(4)
-        . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=DURTXT
-        . . E  D
-        . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=""
-        . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=""
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$G(SIGDATA(4))["PRN"
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" ; when avail
-        . . 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")="" ; not stored
-        . . ; Another confusing line; I am pretty bad:
-        . . ; If there is another entry in the FMSIG array (i.e. another line
-        . . ; in the sig), set the direction count indicator.
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=""  ; Default
-        . . S:+$O(FMSIG(FMSIGNUM)) @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRCNT
-        . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$G(SIGDATA(5))
-        . ;
-        . ; --- END OF DIRECTIONS ---
-        . ;
-        . ; Med instructions is a WP field, thus the acrobatics
-        . ; Notice buffer overflow protection set at 10,000 chars
-        . ; -- 1. Med Patient Instructions
-        . N MEDPTIN1 S MEDPTIN1=$$GET1^DIQ(52,RXIEN,115,,"MEDPTIN1")
-        . N MEDPTIN2,J  S (MEDPTIN2,J)="" 
-        . I $L(MEDPTIN1) F  S J=$O(@MEDPTIN1@(J)) Q:J=""  Q:$L(MEDPTIN2)>10000  S MEDPTIN2=MEDPTIN2_@MEDPTIN1@(J)_" "
-        . S @MAP@("MEDPTINSTRUCTIONS")=MEDPTIN2
-        . K J
-        . ; -- 2. Med Provider Instructions
-        . N MEDPVIN1 S MEDPVIN1=$$GET1^DIQ(52,RXIEN,39,,"MEDPVIN1")
-        . N MEDPVIN2,J S (MEDPVIN2,J)=""
-        . I $L(MEDPVIN1) F  S J=$O(@MEDPVIN1@(J)) Q:J=""  Q:$L(MEDPVIN2)>10000  S MEDPVIN2=MEDPVIN2_@MEDPVIN1@(J)_" "
-        . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MEDPVIN2
-        . ;
-        . ; Remaining refills
-        . S @MAP@("MEDRFNO")=$P(MEDS(MEDCNT),U,6)
-        . ; ------ END OF MAPPING
-        . ;
-        . ; ------ BEGIN XML INSERTION
-        . 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
-        . N DIRCNT S DIRCNT=""
-        . I +$O(@MAP@("M","DIRECTIONS",DIRCNT)) D  ; IF THERE ARE DIRCTIONS
-        . . F DIRCNT=$O(@MAP@("M","DIRECTIONS",DIRCNT)) D  ; FOR EACH DIRECTION
-        . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",DIRCNT))
-        . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
-        . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
-        . D:MEDCNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
-        . D:MEDCNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
-        . S MEDCOUNT=MEDCNT
-        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
-        ;
-GETRXN(NDC)     ; Extrinsic Function; PUBLIC; NDC to RxNorm
-        ;; Get RxNorm Concept Number for a Given NDC
-        ;
-        S NDC=$TR(NDC,"-")  ; Remove dashes
-        N RXNORM,C0CZRXN,DIERR
-        D FIND^DIC(176.002,,"@;.01","PX",NDC,"*","NDC",,,"C0CZRXN","DIERR")
-        I $D(DIERR) D ^%ZTER BREAK
-        S RXNORM(0)=+C0CZRXN("DILIST",0) ; RxNorm(0) will be # of entries
-        N I S I=0
-        F  S I=$O(C0CZRXN("DILIST",I)) Q:I=""  S RXNORM(I)=$P(C0CZRXN("DILIST",I,0),U,2)
-        ; At this point, RxNorm(0) is # of entries; RxNorm(1...) are the entries
-        ; If RxNorm(0) is 1, then we only have one entry, and that's it.
-        I RXNORM(0)=1 QUIT RXNORM(1)  ; RETURN RXNORM(1)
-        ; Otherwise, we need to find out which one is the semantic
-        ; clinical drug. I built an index on 176.001 (RxNorm Concepts)
-        ; for that purpose.
-        I RXNORM(0)>1 D
-        . S I=0
-        . F  S I=$O(RXNORM(I)) Q:I=""  D  Q:$G(RXNORM)
-        . . N RXNIEN S RXNIEN=$$FIND1^DIC(176.001,,,RXNORM(I),"SCD")
-        . . I +$G(RXNIEN)=0 QUIT  ; try the next entry... 
-        . . E  S RXNORM=RXNORM(I) QUIT  ; We found the right code
-        QUIT +$G(RXNORM)  ; RETURN RXNORM; if we couldn't find a clnical drug, return with 0
-        
+C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09
+ ;;1.0;C0C;;May 19, 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,FLAGS)  ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE
+ ;
+ ; MINXML and OUTXML are passed by name so globals can be used
+ ; MINXML will contain only the medications skeleton of the overall template
+ ; MEDCOUNT is a counter passed by Reference.
+ ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool)
+ ; FLAGS are set-up in C0CMED.
+ ;
+ ; 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
+ ; J is a counter.
+ ;
+ ; GETRXS^BEHORXFN(ARRAYNAME,DFN,DAYS) will be the the API used.
+ ; This API has been developed by Medsphere for IHS for getting
+ ; Medications from RPMS. It has most of what we need.
+ ; API written by Doug Martin when he worked for Medsphere (thanks Doug!)
+ ; -- ARRAYNAME is passed by name (required)
+ ; -- DFN is passed by value (required)
+ ; -- DAYS is passed by value (optional; if not passed defaults to 365)
+ ; 
+ ; Return:
+ ; ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID 
+ ; ^Status^LastFill^Chronic^Issued^Rx #^Provider^ 
+ ; Status Reason^DEA Handling
+ ; 
+ N MEDS,MEDS1,MAP
+ D GETRXS^BEHORXFN("MEDS1",DFN,$P($P(FLAGS,U,2),"-",2)) ; 2nd piece of FLAGS is # of days to retrieve, which comes in the form "T-360"
+ N ALL S ALL=+FLAGS
+ N ACTIVE S ACTIVE=$P(FLAGS,U,3)
+ N PENDING S PENDING=$P(FLAGS,U,4)
+ S @OUTXML@(0)=0  ;By default, no meds
+ ; If MEDS1 is not defined, then no meds
+ I '$D(MEDS1) QUIT
+ I DEBUG ZWR MEDS1,MINXML
+ N MEDCNT S MEDCNT=0 ; Med Count
+ ; The next line is a super line. It goes through the array return
+ ; and if the first characters are ~OP, it grabs the line.
+ ; This means that line is for a dispensed Outpatient Med.
+ ; That line has the metadata about the med that I need.
+ ; The next lines, however many, are the med and the sig.
+ ; I won't be using those because I have to get the sig parsed exactly.
+ N J S J="" F  S J=$O(MEDS1(J)) Q:J=""  I $E(MEDS1(J),1,3)="~OP" S MEDCNT=MEDCNT+1 S MEDS(MEDCNT)=MEDS1(J)
+ K MEDS1
+ S MEDCNT="" ; Initialize for $Order
+ F  S MEDCNT=$O(MEDS(MEDCNT)) Q:MEDCNT=""  D  ; for each medication in the list
+ . I 'ALL,ACTIVE,$P(MEDS(MEDCNT),U,10)'="ACTIVE" QUIT
+ . I 'ALL,PENDING,$P(MEDS(MEDCNT),U,10)'="PENDING" QUIT
+ . I DEBUG W "MEDCNT IS ",MEDCNT,!
+ . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCNT))
+ . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED
+ . I DEBUG W "MAP= ",MAP,!
+ . S @MAP@("MEDOBJECTID")="MED"_MEDCNT ; MEDCNT FOR ID
+ . S @MAP@("MEDISSUEDATETXT")="Issue Date"
+ . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,15),"DT")
+ . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date"
+ . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,11),"DT")
+ . S @MAP@("MEDRXNOTXT")="Prescription Number"
+ . S @MAP@("MEDRXNO")=$P(MEDS(MEDCNT),U,14)
+ . S @MAP@("MEDTYPETEXT")="Medication"
+ . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
+ . S @MAP@("MEDSTATUSTEXT")=$P(MEDS(MEDCNT),U,10)
+ . ; Provider only provided in API as text, not DUZ.
+ . ; We need to get DUZ from filman file 52 (Prescription)
+ . ; Field 4; IEN is Piece 2 of Meds stripped of trailing characters.
+ . ; Note that I will use RXIEN several times later
+ . N RXIEN S RXIEN=+$P(MEDS(MEDCNT),U,2)
+ . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52,RXIEN,4,"I")
+ . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MEDS(MEDCNT),U,3)
+ . ; --- RxNorm Stuff 
+ . ; 176.001 is the file for Concepts; 176.003 is the file for
+ . ; sources (i.e. for RxNorm Version)
+ . ; 
+ . ; I use 176.001 for the Vista version of this routine (files 1-3)
+ . ; Since IHS does not have VUID's, I will be getting RxNorm codes
+ . ; using NDCs. My specially crafted index (sounds evil) named "NDC"
+ . ; is in file 176.002. The file is called RxNorm NDC to VUID.
+ . ; Except that I don't need the VUID, but it's there if I need it.
+ . ; 
+ . ; We obviously need the NDC. That is easily obtained from the prescription.
+ . ; Field 27 in file 52
+ . N NDC S NDC=$$GET1^DIQ(52,RXIEN,27,"I")
+ . ; I discovered that file 176.002 might give you two codes for the NDC
+ . ; One for the Clinical Drug, and one for the ingredient.
+ . ; So the plan is to get the two RxNorm codes, and then find from
+ . ; file 176.001 which one is the Clinical Drug.
+ . ; ... I refactored this into GETRXN
+ . N RXNORM,SRCIEN,RXNNAME,RXNVER
+ . I +NDC,$D(^C0CRXN) D  ; $Data is for Systems that don't have our RxNorm file yet.
+ . . S RXNORM=$$GETRXN(NDC)
+ . . S SRCIEN=$$FIND1^DIC(176.003,,,"RXNORM","B")
+ . . 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
+ . ; --- End RxNorm section
+ . ;
+ . ; Brand name is 52 field 6.5
+ . S @MAP@("MEDBRANDNAMETEXT")=$$GET1^DIQ(52,RXIEN,6.5)
+ . ;
+ . ; Next I need Med Form (tab, cap etc), strength (250mg)
+ . ; concentration for liquids (250mg/mL)
+ . ; Since IHS does not have any of the new calls that 
+ . ; Vista has, I will be doing a crosswalk:
+ . ; File 52, field 6 is Drug IEN in file 50
+ . ; File 50, field 22 is VA Product IEN in file 50.68
+ . ; In file 50.68, I will get the following:
+ . ; -- 1: Dosage Form
+ . ; -- 2: Strength
+ . ; -- 3: Units
+ . ; -- 8: Dispense Units
+ . ; -- Conc is 2 concatenated with 3
+ . ; 
+ . ; *** If Drug is not matched to NDF, then VA Product will be "" ***
+ . ;
+ . N MEDIEN S MEDIEN=$$GET1^DIQ(52,RXIEN,6,"I") ; Drug IEN in 50
+ . N VAPROD S VAPROD=$$GET1^DIQ(50,MEDIEN,22,"I") ; VA Product in file 50.68
+ . I +VAPROD D
+ . . S @MAP@("MEDSTRENGTHVALUE")=$$GET1^DIQ(50.68,VAPROD,2)
+ . . S @MAP@("MEDSTRENGTHUNIT")=$$GET1^DIQ(50.68,VAPROD,3)
+ . . S @MAP@("MEDFORMTEXT")=$$GET1^DIQ(50.68,VAPROD,1)
+ . . S @MAP@("MEDCONCVALUE")=@MAP@("MEDSTRENGTHVALUE")
+ . . S @MAP@("MEDCONCUNIT")=@MAP@("MEDSTRENGTHUNIT")
+ . E  D
+ . . S @MAP@("MEDSTRENGTHVALUE")=""
+ . . S @MAP@("MEDSTRENGTHUNIT")=""
+ . . S @MAP@("MEDFORMTEXT")=""
+ . . S @MAP@("MEDCONCVALUE")=""
+ . . S @MAP@("MEDCONCUNIT")=""
+ . ; End Strengh/Conc stuff
+ . ;
+ . ; Quantity is in the prescription, field 7
+ . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52,RXIEN,7)
+ . ; Dispense unit is in the drug file, field 14.5
+ . S @MAP@("MEDQUANTITYUNIT")=$$GET1^DIQ(50,MEDIEN,14.5)
+ . ;
+ . ; --- START OF DIRECTIONS ---
+ . ; Sig data not in any API :-(  Oh yes, you can get the whole thing, but...
+ . ; we want the components.
+ . ; It's in multiple 113 in the Prescription File (52)
+ . ; #.01 DOSAGE ORDERED [1F]    "20"
+ . ; #1 DISPENSE UNITS PER DOSE [2N]  "1"
+ . ; #2 UNITS [3P:50.607]     "MG"
+ . ; #3 NOUN [4F]      "TABLET"
+ . ; #4 DURATION [5F]      "10D"
+ . ; #5 CONJUNCTION [6S]     "AND"
+ . ; #6 ROUTE [7P:51.2]     "ORAL"
+ . ; #7 SCHEDULE [8F]      "BID"
+ . ; #8 VERB [9F]       "TAKE"
+ . ;
+ . ; Will use GETS^DIQ to get fields.
+ . ; Data comes out like this:
+ . ; SAMINS(52.0113,"1,23,",.01)=20
+ . ; SAMINS(52.0113,"1,23,",1)=1
+ . ; SAMINS(52.0113,"1,23,",2)="MG"
+ . ; SAMINS(52.0113,"1,23,",3)="TABLET"
+ . ; SAMINS(52.0113,"1,23,",4)="5D"
+ . ; SAMINS(52.0113,"1,23,",5)="THEN"
+ . ;
+ . N RAWDATA
+ . D GETS^DIQ(52,RXIEN,"113*",,"RAWDATA","DIERR")
+ . D:$D(DIERR) ^%ZTER  ; Log if there's an error in retrieving sig field
+ . ; none the less, continue; some parts are retrievable.
+ . N FMSIG M FMSIG=RAWDATA(52.0113) ; Merge into subfile...
+ . K RAWDATA
+ . N FMSIGNUM S FMSIGNUM="" ; Sigline number in fileman.
+ . ; FMSIGNUM gets outputted as "IEN,RXIEN,".
+ . ; DIRCNT is the proper Sigline numer.
+ . ; SIGDATA is the simplfied array. 
+ . F  S FMSIGNUM=$O(FMSIG(FMSIGNUM)) Q:FMSIGNUM=""  D
+ . . N DIRCNT S DIRCNT=$P(FMSIGNUM,",")
+ . . N SIGDATA M SIGDATA=FMSIG(FMSIGNUM)
+ . . 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")=$G(SIGDATA(8))
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$G(SIGDATA(.01))
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=$G(SIGDATA(2))
+ . . 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")=$G(SIGDATA(6))
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$G(SIGDATA(7))
+ . . ; 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.
+ . . ; Search B index of 51.1 (Admin Schedule) with schedule
+ . . ; First, remove "PRN" if it exists (don't ask, that's how the file
+ . . ; works; I wouldn't do it that way).
+ . . N SCHNOPRN S SCHNOPRN=$G(SIGDATA(7))
+ . . I SCHNOPRN["PRN" S SCHNOPRN=$E(SCHNOPRN,1,$F(SCHNOPRN,"PRN")-5)
+ . . ; Super call below:
+ . . ; 1=File 51.1 3=Field 2 (Frequency in Minutes)
+ . . ; 4=Packed format, Exact Match 5=Lookup Value
+ . . ; 6=# of entries to return 7=Index 10=Return Array
+ . . ; 
+ . . ; I do not account for the fact that two schedules can be
+ . . ; spelled identically (ie duplicate entry). In that case,
+ . . ; I get the first. That's just a bad pharmacy pkg maintainer.
+ . . N C0C515
+ . . D FIND^DIC(51.1,,"@;2","PX",SCHNOPRN,1,"B",,,"C0C515")
+ . . N INTERVAL S INTERVAL="" ; Default
+ . . ; If there are entries found, get it
+ . . I +$G(C0C515("DILIST",0)) S INTERVAL=$P(C0C515("DILIST",1,0),U,2) 
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute"
+ . . ; Duration is 10M minutes, 10H hours, 10D for Days
+ . . ; 10W for weeks, 10L for months. I smell $Select
+ . . ; But we don't need to do that if there isn't a duration
+ . . I +$G(SIGDATA(4)) D
+ . . . N DURUNIT S DURUNIT=$E(SIGDATA(4),$L(SIGDATA(4))) ; get last char
+ . . . N DURTXT S DURTXT=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"Days")
+ . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=+SIGDATA(4)
+ . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=DURTXT
+ . . E  D
+ . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=""
+ . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=""
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$G(SIGDATA(4))["PRN"
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" ; when avail
+ . . 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")="" ; not stored
+ . . ; Another confusing line; I am pretty bad:
+ . . ; If there is another entry in the FMSIG array (i.e. another line
+ . . ; in the sig), set the direction count indicator.
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=""  ; Default
+ . . S:+$O(FMSIG(FMSIGNUM)) @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRCNT
+ . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$G(SIGDATA(5))
+ . ;
+ . ; --- END OF DIRECTIONS ---
+ . ;
+ . ; Med instructions is a WP field, thus the acrobatics
+ . ; Notice buffer overflow protection set at 10,000 chars
+ . ; -- 1. Med Patient Instructions
+ . N MEDPTIN1 S MEDPTIN1=$$GET1^DIQ(52,RXIEN,115,,"MEDPTIN1")
+ . N MEDPTIN2,J  S (MEDPTIN2,J)="" 
+ . I $L(MEDPTIN1) F  S J=$O(@MEDPTIN1@(J)) Q:J=""  Q:$L(MEDPTIN2)>10000  S MEDPTIN2=MEDPTIN2_@MEDPTIN1@(J)_" "
+ . S @MAP@("MEDPTINSTRUCTIONS")=MEDPTIN2
+ . K J
+ . ; -- 2. Med Provider Instructions
+ . N MEDPVIN1 S MEDPVIN1=$$GET1^DIQ(52,RXIEN,39,,"MEDPVIN1")
+ . N MEDPVIN2,J S (MEDPVIN2,J)=""
+ . I $L(MEDPVIN1) F  S J=$O(@MEDPVIN1@(J)) Q:J=""  Q:$L(MEDPVIN2)>10000  S MEDPVIN2=MEDPVIN2_@MEDPVIN1@(J)_" "
+ . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MEDPVIN2
+ . ;
+ . ; Remaining refills
+ . S @MAP@("MEDRFNO")=$P(MEDS(MEDCNT),U,6)
+ . ; ------ END OF MAPPING
+ . ;
+ . ; ------ BEGIN XML INSERTION
+ . 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
+ . N DIRCNT S DIRCNT=""
+ . I +$O(@MAP@("M","DIRECTIONS",DIRCNT)) D  ; IF THERE ARE DIRCTIONS
+ . . F DIRCNT=$O(@MAP@("M","DIRECTIONS",DIRCNT)) D  ; FOR EACH DIRECTION
+ . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",DIRCNT))
+ . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2)
+ . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication")
+ . D:MEDCNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
+ . D:MEDCNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML
+ . S MEDCOUNT=MEDCNT
+ 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
+ ;
+GETRXN(NDC) ; Extrinsic Function; PUBLIC; NDC to RxNorm
+ ;; Get RxNorm Concept Number for a Given NDC
+ ;
+ S NDC=$TR(NDC,"-")  ; Remove dashes
+ N RXNORM,C0CZRXN,DIERR
+ D FIND^DIC(176.002,,"@;.01","PX",NDC,"*","NDC",,,"C0CZRXN","DIERR")
+ I $D(DIERR) D ^%ZTER BREAK
+ S RXNORM(0)=+C0CZRXN("DILIST",0) ; RxNorm(0) will be # of entries
+ N I S I=0
+ F  S I=$O(C0CZRXN("DILIST",I)) Q:I=""  S RXNORM(I)=$P(C0CZRXN("DILIST",I,0),U,2)
+ ; At this point, RxNorm(0) is # of entries; RxNorm(1...) are the entries
+ ; If RxNorm(0) is 1, then we only have one entry, and that's it.
+ I RXNORM(0)=1 QUIT RXNORM(1)  ; RETURN RXNORM(1)
+ ; Otherwise, we need to find out which one is the semantic
+ ; clinical drug. I built an index on 176.001 (RxNorm Concepts)
+ ; for that purpose.
+ I RXNORM(0)>1 D
+ . S I=0
+ . F  S I=$O(RXNORM(I)) Q:I=""  D  Q:$G(RXNORM)
+ . . N RXNIEN S RXNIEN=$$FIND1^DIC(176.001,,,RXNORM(I),"SCD")
+ . . I +$G(RXNIEN)=0 QUIT  ; try the next entry... 
+ . . E  S RXNORM=RXNORM(I) QUIT  ; We found the right code
+ QUIT +$G(RXNORM)  ; RETURN RXNORM; if we couldn't find a clnical drug, return with 0
+ 

ccr/branches/ohum/p/C0CMIME.m

@@ -1 @@
-C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm
-        ;;1.0;C0C;;Mar 8, 2011;Build 1
-        ;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.
-        ;
-        Q
-        ;
-TEST(ZDFN)      ;
-        D CCRRPC^C0CCCR(.ZCCR,ZDFN) ; GET A CCR TO WORK WITH
-        ;M ZCOPY=ZCCR
-        S ZCOPY(1)=""
-        N ZI S ZI=0
-        F  S ZI=$O(ZCCR(ZI)) Q:ZI=""  D  ; FOR EACH LINE
-        . S ZCOPY(1)=ZCOPY(1)_ZCCR(ZI)
-        ;D ENCODE("ZCOPY",1,ZCOPY(1))
-        S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
-        D CHUNK("G2","G",45)
-        Q
-ENCODE(ZRTN,ZARY)       ;
-        ; ROUTINE TO ENCODE AN XML DOCUMENT FOR SENDING
-        ; ZARY IS PASSED BY NAME
-        ; ZRTN IS PASSED BY REFERENCE AND IS THE RETURN
-        ;
-        S ZCOPY(1)=""
-        N ZI S ZI=0
-        F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH LINE
-        . S ZCOPY(1)=ZCOPY(1)_@ZARY@(ZI)
-        N G
-        S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
-        D CHUNK(ZRTN,"G",45)
-        Q
-        ; THIS ROUTINE WAS COPIED FROM LRSRVR4 AND THEN MODIFIED . THANKS JOHN
-ENCODEOLD(IARY,LRNODE,LRSTR)    ; Encode a string, keep remainder for next line
-        ; Call with LRSTR by reference, Remainder returned in LRSTR
-        ; IARY IS PASSED BY NAME
-        S LRQUIT=0,LRLEN=$L(LRSTR)
-        F  D  Q:LRQUIT
-        . I $L(LRSTR)<45 S LRQUIT=1 Q
-        . S LRX=$E(LRSTR,1,45)
-        . S LRNODE=LRNODE+1,@IARY@(LRNODE)=$$UUEN^LRSRVR4(LRX)
-        . S LRSTR=$E(LRSTR,46,LRLEN)
-        Q
-        ;
-TESTMAIL        ;
-        ; TEST OF MAILSEND
-        ;S ZTO("glilly@glilly.net")=""
-        S ZTO("mish@nhin.openforum.opensourcevista.net")=""
-        ;S ZTO("martijn@djigzo.com")=""
-        ;S ZTO("profmish@gmail.com")=""
-        ;S ZTO("nanthracite@earthlink.net")=""
-        S ZFROM="ANTHRACITE.NANCY"
-        S ZATTACH=$NA(^GPL("CCR"))
-        I $G(@ZATTACH@(1))="" D  ; NO CCR THERE
-        . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
-        . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
-        S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
-        D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,,ZATTACH)
-        ZWR GR
-        Q
-        ;
-TESTMAIL2       ;
-        ; TEST OF MAILSEND TO gpl.mdc-crew.net
-        N C0CGM
-        S C0CGM(1)="This is a test message."
-        S C0CGM(2)="A Continuity of Care record is attached"
-        S C0CGM(3)="It contains no Protected Health Information (PHI)"
-        S C0CGM(4)="It is purely test data used for software development"
-        S C0CGM(5)="It does not represent information about any person living or dead"
-        ;S ZTO("glilly@glilly.net")=""
-        ;S ZTO("george.lilly@pobox.com")=""
-        ;S ZTO("george@nhin.openforum.opensourcevista.net")=""
-        ;S ZTO("mish@nhin.openforum.opensourcevista.net")="" 
-        S ZTO("brooks.richard@securemail.opensourcevista.net")="" 
-        ;S ZTO("LILLY.GEORGE@mdc-crew.net")=""
-        ;S ZTO("ncoal@live.com")=""
-        ;S ZTO("martijn@djigzo.com")=""
-        ;S ZTO("profmish@gmail.com")=""
-        ;S ZTO("nanthracite@earthlink.net")=""
-        S ZTO("gpl.doctortest@gmail.com")=""
-        S ZFROM="LILLY.GEORGE"
-        S ZATTACH=$NA(^GPL("CCR"))
-        I $G(@ZATTACH@(1))="" D  ; NO CCR THERE
-        . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
-        . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
-        S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
-        D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH,"CCR.xml")
-        ZWR GR
-        Q
-        ;
-LINE(C0CFILE,C0CTO)     ; read a file name passed in C0CFILE and send it to
-        ; the email address in C0CTO 
-        ; the directory and the "from" are all hard coded
-        ;
-        N ZZFROM S ZZFROM="LILLY.GEORGE"
-        N GN S GN=$NA(^TMP("C0CMIME2",$J))
-        N GN1 S GN1=$NA(@GN@(1))
-        K @GN
-        I '$D(C0CFILE) Q  ; NO FILENAME PASSED
-        I '$D(C0CTO) S C0CTO="brooks.richard@securemail.opensourcevista.net"
-        S ZZTO(C0CTO)=""
-        N ZMESS S ZMESS(1)="file transmission from wvehr3-09"
-        N GD S GD="/home/wvehr3-09/EHR/" ; directory
-        I '$$FTG^%ZISH(GD,C0CFILE,GN1,3) Q  D  ;
-        . W !,"error reading file",C0CFILE
-        D MAILSEND(.ZRTN,ZZFROM,"ZZTO",,"file transmission","ZMESS",GN,C0CFILE)
-        K @GN ; CLEAN UP
-        ;ZWR ZRTN
-        W !,$G(ZRTN(1))
-        Q
-        ;
-MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FNAME,FLAGS)     ; MAIL SENDING INTERFACE
-        ; RTN IS THE RETURN ARRAY PASSED BY REFERENCE
-        ; FROM IS PASSED BY VALUE AND IS THE EMAIL ADDRESS OF THE SENDER
-        ;  IF NULL, WILL SEND FROM THE CURRENT DUZ
-        ; TO AND CC ARE RECIEPIENT EMAIL ADDRESSES PASSED BY NAME
-        ;  @TO@("addr1@domain1.net") 
-        ;  @CC@("addr2@domain2.com")  both can be multiples
-        ; SUBJECT IS PASSED BY VALUE AND WILL GO IN THE SUBJECT LINE
-        ; MESSAGE IS PASSED BY NAME AND IS AN ARRAY OF TEXT
-        ; ATTACH IS PASSED BY NAME AND IS AN XML OR HTML FILE TO BE ATTACHED
-        ; FNAME IS THE FILENAME OF THE ATTACHMENT, DEFAULT IS ccr.xml
-        ;
-        I '$D(FNAME) S FNAME="ccr.xml" ; default filename
-        N GN
-        S GN=$NA(^TMP($J,"C0CMIME"))
-        K @GN
-        S GM(1)="MIME-Version: 1.0"
-        S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
-        S GM(3)=""
-        S GM(4)=""
-        ;S GM(5)="--123456788888"
-        ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
-        S GM(5)="--123456899999"
-        S GM(6)="Content-Type: text/xml; name="_FNAME
-        S GM(7)="Content-Transfer-Encoding: base64"
-        S GM(8)="Content-Disposition: attachment; filename="_FNAME
-        S GM(9)=""
-        S GM(10)="" ; FOR THE END
-        ;S GM(11)="--123456788888--"
-        S GM(11)="--123456899999--"
-        S GM(12)=""
-        S GM(13)=""
-        S GG(1)="--123456899999"
-        S GG(2)="Content-Type: text/plain; charset=ISO-8859-1; format=flowed"
-        S GG(3)="Content-Transfer-Encoding: 7bit"
-        S GG(4)=""
-        S GG(5)="This is a test message."
-        S GG(6)="A Continuity of Care record is attached"
-        S GG(7)="It contains no Protected Health Information (PHI)"
-        S GG(8)="It is purely test data used for software development"
-        S GG(9)="It does not represent information about any person living or dead"
-        S GG(10)=""
-        S GG(11)="--123456899999--"
-        ;S GG(11)="Content-Type: text/plain; charset=""us-ascii"""
-        S GG(12)=""
-        ;S GG(13)="This is a test message."
-        S GG(14)="A Continuity of Care record is attached"
-        S GG(15)="It contains no Protected Health Information (PHI)"
-        S GG(16)="It is purely test data used for software development"
-        S GG(17)="It does not represent information about any person living or dead"
-        S GG(18)=""
-        S GG(19)="--123456899999"
-        S GG(20)="--987654321--"
-        K GBLD
-        ;D QUEUE^C0CXPATH("GBLD","GGG",1,3) ; THE MESSAGE
-        ;D QUEUE^C0CXPATH("GBLD","GG",1,10) ; THE MESSAGE
-        I $D(MESSAGE)'="" D  ; THERE IS A MESSAGE
-        . D QUEUE^C0CXPATH("GBLD","GG",1,4) ; THE MIME BOUNDARY
-        . D QUEUE^C0CXPATH("GBLD",MESSAGE,1,$O(@MESSAGE@(""),-1)) ;THE MESSAGE
-        . D QUEUE^C0CXPATH("GBLD","GG",10,10) ;A BLANK LINE
-        D QUEUE^C0CXPATH("GBLD","GM",5,9)
-        I $D(ATTACH)'="" D  ; IF WE HAVE AN ATTACHMENT
-        . D ENCODE("G2",ATTACH) ; ENCODE FOR SENDING
-        . D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
-        D QUEUE^C0CXPATH("GBLD","GM",11,12)
-        D BUILD^C0CXPATH("GBLD",GN)
-        ;S GGG=$NA(^GPL("MIME2"))
-        K @GN@(0) ; KILL THE LINE COUNT
-        K LRINSTR,LRTASK,LRTO,XMERR,XMZ
-        M LRTO=@TO
-        I $D(CC) M LRTO=@CC
-        S LRINSTR("ADDR FLAGS")="R"
-        S LRINSTR("FROM")=$G(FROM)
-        S LRMSUBJ=$G(SUBJECT)
-        S LRMSUBJ=$E(LRMSUBJ,1,65)
-        D SENDMSG^XMXAPI(DUZ,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
-        I $G(XMERR)=1 S RTN(1)="ERROR SENDING MESSAGE" Q  ;
-        S RTN(1)="OK"
-        Q
-        ;
-MAILSEND0(LRMSUBJ)      ; Send extract back to requestor.
-        ;
-        ;D TEST
-        S GN=$NA(^TMP($J,"C0CMIME"))
-        K @GN
-        ;M @GN=G2
-        S GM(1)="MIME-Version: 1.0"
-        S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
-        S GM(3)=""
-        S GM(4)=""
-        S GM(5)="--1234567"
-        ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
-        S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
-        S GM(7)="Content-Transfer-Encoding: base64"
-        S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
-        ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
-        S GM(9)=""
-        S GM(10)="" ; FOR THE END
-        S GM(11)="--frontier--"
-        S GM(12)="."
-        S GM(13)=""
-        K GBLD
-        ;D QUEUE^C0CXPATH("GBLD","GM",1,9)
-        ;D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
-        ;D QUEUE^C0CXPATH("GBLD","GM",10,13)
-        ;D BUILD^C0CXPATH("GBLD",GN)
-        S GGG=$NA(^GPL("MIME2"))
-        ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
-        D QUEUE^C0CXPATH("GBLD",GGG,21,159)
-        D BUILD^C0CXPATH("GBLD",GN)
-        K @GN@(0) ; KILL THE LINE COUNT
-        K LRINSTR,LRTASK,LRTO,XMERR,XMZ
-        S XQSND="glilly@glilly.net"
-        ;S XQSND="nanthracite@earthlink.net"
-        ;S XQSND="dlefevre@orohosp.com"
-        ;S XQSND="gregwoodhouse@me.com"
-        ;S XQSND="rick.marshall@vistaexpertise.net"
-        S LRTO(XQSND)=""
-        S LRINSTR("ADDR FLAGS")="R"
-        S LRINSTR("FROM")="CCR_PACKAGE"
-        S LRMSUBJ="A SAMPLE CCR"
-        S LRMSUBJ=$E(LRMSUBJ,1,65)
-        D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
-        I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q  ;
-        ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
-        ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
-        Q
-        ;
-MAILSEND2(UDFN,ADDR)    ; Send extract back to requestor.
-        ;
-        I +$G(UDFN)=0 S UDFN=2 ;
-        D TEST(UDFN)
-        S GN=$NA(^TMP($J,"C0CMIME"))
-        K @GN
-        ;M @GN=G2
-        S GM(1)="MIME-Version: 1.0"
-        S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
-        S GM(3)=""
-        S GM(4)=""
-        S GM(5)="--1234567"
-        ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
-        S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
-        S GM(7)="Content-Transfer-Encoding: base64"
-        S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
-        ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
-        S GM(9)=""
-        S GM(10)="" ; FOR THE END
-        S GM(11)="--1234567--"
-        S GM(12)=""
-        S GM(13)=""
-        K GBLD
-        D QUEUE^C0CXPATH("GBLD","GM",5,9)
-        D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
-        D QUEUE^C0CXPATH("GBLD","GM",10,12)
-        D BUILD^C0CXPATH("GBLD",GN)
-        S GGG=$NA(^GPL("MIME2"))
-        ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
-        ;D QUEUE^C0CXPATH("GBLD",GGG,21,159)
-        ;D BUILD^C0CXPATH("GBLD",GN)
-        K @GN@(0) ; KILL THE LINE COUNT
-        K LRINSTR,LRTASK,LRTO,XMERR,XMZ
-        I $G(ADDR)'="" S XQSND=ADDR
-        E  S XQSND="glilly@glilly.net"
-        ;S XQSND="nanthracite@earthlink.net"
-        ;S XQSND="dlefevre@orohosp.com"
-        ;S XQSND="gregwoodhouse@me.com"
-        ;S XQSND="rick.marshall@vistaexpertise.net"
-        S LRTO(XQSND)=""
-        ;S LRTO("glilly@glilly.net")=""
-        S LRINSTR("ADDR FLAGS")="R"
-        S LRINSTR("FROM")="ANTHRACITE.NANCY"
-        S LRMSUBJ="Sending a CCR with Mailman"
-        S LRMSUBJ=$E(LRMSUBJ,1,65)
-        D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
-        I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q  ;
-        ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
-        ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
-        Q
-        ;
-SIMPLE  ;
-        S GN(1)="SIMPLE TEST MESSAGE"
-        K LRINSTR,LRTASK,LRTO,XMERR,XMZ
-        S XQSND="glilly@glilly.net"
-        S LRTO(XQSND)=""
-        S LRINSTR("ADDR FLAGS")="R"
-        S LRINSTR("FROM")="CCR_PACKAGE"
-        S LRMSUBJ="A SAMPLE CCR"
-        S LRMSUBJ=$E(LRMSUBJ,1,65)
-        D SENDMSG^XMXAPI(9,LRMSUBJ,"GN",.LRTO,.LRINSTR,.LRTASK)
-        Q
-CHUNK(OUTXML,INXML,ZSIZE)       ; BREAKS INXML INTO ZSIZE BLOCKS
-        ; INXML IS AN ARRAY PASSED BY NAME OF STRINGS
-        ; OUTXML IS ALSO PASSED BY NAME
-        ; IF ZSIZE IS NOT PASSED, 1000 IS USED
-        I '$D(ZSIZE) S ZSIZE=1000 ; DEFAULT BLOCK SIZE
-        N ZB,ZI,ZJ,ZK,ZL,ZN
-        S ZB=ZSIZE-1
-        S ZN=1
-        S ZI=0 ; BEGINNING OF INDEX TO INXML
-        F  S ZI=$O(@INXML@(ZI)) Q:+ZI=0  D  ; FOR EACH STRING IN INXML
-        . S ZL=$L(@INXML@(ZI)) ; LENGTH OF THE STRING
-        . F ZJ=1:ZSIZE:ZL D  ;
-        . . S ZK=$S(ZJ+ZB<ZL:ZJ+ZB,1:ZL) ; END FOR EXTRACT
-        . . S @OUTXML@(ZN)=$E(@INXML@(ZI),ZJ,ZK) ; PULL OUT THE PIECE
-        . . S ZN=ZN+1 ; INCREMENT OUT ARRAY INDEX
-        Q
-        ;
-CLEAN(IARY)     ; RUNS THROUGH AN ARRAY PASSED BY NAME AND STRIPS OUT $C(13)
-        ;
-        N ZI S ZI=0
-        F  S ZI=$O(@IARY@(ZI)) Q:+ZI=0  D  ;
-        . S @IARY@(ZI)=$TR(@IARY@(ZI),$C(13)) ;
-        . I $F(@IARY@(ZI)," <") S @IARY@(ZI)="<"_$P(@IARY@(ZI)," <",2) ; RM BLNKS
-        Q
-        ;
+C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm
+ ;;1.0;C0C;;Mar 8, 2011;
+ ;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.
+ ;
+ Q
+ ;
+TEST(ZDFN) ;
+ D CCRRPC^C0CCCR(.ZCCR,ZDFN) ; GET A CCR TO WORK WITH
+ ;M ZCOPY=ZCCR
+ S ZCOPY(1)=""
+ N ZI S ZI=0
+ F  S ZI=$O(ZCCR(ZI)) Q:ZI=""  D  ; FOR EACH LINE
+ . S ZCOPY(1)=ZCOPY(1)_ZCCR(ZI)
+ ;D ENCODE("ZCOPY",1,ZCOPY(1))
+ S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
+ D CHUNK("G2","G",45)
+ Q
+ENCODE(ZRTN,ZARY) ;
+ ; ROUTINE TO ENCODE AN XML DOCUMENT FOR SENDING
+ ; ZARY IS PASSED BY NAME
+ ; ZRTN IS PASSED BY REFERENCE AND IS THE RETURN
+ ;
+ S ZCOPY(1)=""
+ N ZI S ZI=0
+ F  S ZI=$O(@ZARY@(ZI)) Q:ZI=""  D  ; FOR EACH LINE
+ . S ZCOPY(1)=ZCOPY(1)_@ZARY@(ZI)
+ N G
+ S G(1)=$$ENCODE^RGUTUU(ZCOPY(1))
+ D CHUNK(ZRTN,"G",45)
+ Q
+ ; THIS ROUTINE WAS COPIED FROM LRSRVR4 AND THEN MODIFIED . THANKS JOHN
+ENCODEOLD(IARY,LRNODE,LRSTR) ; Encode a string, keep remainder for next line
+ ; Call with LRSTR by reference, Remainder returned in LRSTR
+ ; IARY IS PASSED BY NAME
+ S LRQUIT=0,LRLEN=$L(LRSTR)
+ F  D  Q:LRQUIT
+ . I $L(LRSTR)<45 S LRQUIT=1 Q
+ . S LRX=$E(LRSTR,1,45)
+ . S LRNODE=LRNODE+1,@IARY@(LRNODE)=$$UUEN^LRSRVR4(LRX)
+ . S LRSTR=$E(LRSTR,46,LRLEN)
+ Q
+ ;
+TESTMAIL ;
+ ; TEST OF MAILSEND
+ ;S ZTO("glilly@glilly.net")=""
+ S ZTO("mish@nhin.openforum.opensourcevista.net")=""
+ ;S ZTO("martijn@djigzo.com")=""
+ ;S ZTO("profmish@gmail.com")=""
+ ;S ZTO("nanthracite@earthlink.net")=""
+ S ZFROM="ANTHRACITE.NANCY"
+ S ZATTACH=$NA(^GPL("CCR"))
+ I $G(@ZATTACH@(1))="" D  ; NO CCR THERE
+ . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
+ . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
+ S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
+ D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,,ZATTACH)
+ ZWR GR
+ Q
+ ;
+TESTMAIL2 ;
+ ; TEST OF MAILSEND TO gpl.mdc-crew.net
+ N C0CGM
+ S C0CGM(1)="This is a test message."
+ S C0CGM(2)="A Continuity of Care record is attached"
+ S C0CGM(3)="It contains no Protected Health Information (PHI)"
+ S C0CGM(4)="It is purely test data used for software development"
+ S C0CGM(5)="It does not represent information about any person living or dead"
+ ;S ZTO("glilly@glilly.net")=""
+ ;S ZTO("george.lilly@pobox.com")=""
+ ;S ZTO("george@nhin.openforum.opensourcevista.net")=""
+ ;S ZTO("mish@nhin.openforum.opensourcevista.net")="" 
+ S ZTO("brooks.richard@securemail.opensourcevista.net")="" 
+ ;S ZTO("LILLY.GEORGE@mdc-crew.net")=""
+ ;S ZTO("ncoal@live.com")=""
+ ;S ZTO("martijn@djigzo.com")=""
+ ;S ZTO("profmish@gmail.com")=""
+ ;S ZTO("nanthracite@earthlink.net")=""
+ S ZTO("gpl.doctortest@gmail.com")=""
+ S ZFROM="LILLY.GEORGE"
+ S ZATTACH=$NA(^GPL("CCR"))
+ I $G(@ZATTACH@(1))="" D  ; NO CCR THERE
+ . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2
+ . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME
+ S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE"
+ D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH,"CCR.xml")
+ ZWR GR
+ Q
+ ;
+LINE(C0CFILE,C0CTO) ; read a file name passed in C0CFILE and send it to
+ ; the email address in C0CTO 
+ ; the directory and the "from" are all hard coded
+ ;
+ N ZZFROM S ZZFROM="LILLY.GEORGE"
+ N GN S GN=$NA(^TMP("C0CMIME2",$J))
+ N GN1 S GN1=$NA(@GN@(1))
+ K @GN
+ I '$D(C0CFILE) Q  ; NO FILENAME PASSED
+ I '$D(C0CTO) S C0CTO="brooks.richard@securemail.opensourcevista.net"
+ S ZZTO(C0CTO)=""
+ N ZMESS S ZMESS(1)="file transmission from wvehr3-09"
+ N GD S GD="/home/wvehr3-09/EHR/" ; directory
+ I '$$FTG^%ZISH(GD,C0CFILE,GN1,3) Q  D  ;
+ . W !,"error reading file",C0CFILE
+ D MAILSEND(.ZRTN,ZZFROM,"ZZTO",,"file transmission","ZMESS",GN,C0CFILE)
+ K @GN ; CLEAN UP
+ ;ZWR ZRTN
+ W !,$G(ZRTN(1))
+ Q
+ ;
+MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FNAME,FLAGS) ; MAIL SENDING INTERFACE
+ ; RTN IS THE RETURN ARRAY PASSED BY REFERENCE
+ ; FROM IS PASSED BY VALUE AND IS THE EMAIL ADDRESS OF THE SENDER
+ ;  IF NULL, WILL SEND FROM THE CURRENT DUZ
+ ; TO AND CC ARE RECIEPIENT EMAIL ADDRESSES PASSED BY NAME
+ ;  @TO@("addr1@domain1.net") 
+ ;  @CC@("addr2@domain2.com")  both can be multiples
+ ; SUBJECT IS PASSED BY VALUE AND WILL GO IN THE SUBJECT LINE
+ ; MESSAGE IS PASSED BY NAME AND IS AN ARRAY OF TEXT
+ ; ATTACH IS PASSED BY NAME AND IS AN XML OR HTML FILE TO BE ATTACHED
+ ; FNAME IS THE FILENAME OF THE ATTACHMENT, DEFAULT IS ccr.xml
+ ;
+ I '$D(FNAME) S FNAME="ccr.xml" ; default filename
+ N GN
+ S GN=$NA(^TMP($J,"C0CMIME"))
+ K @GN
+ S GM(1)="MIME-Version: 1.0"
+ S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
+ S GM(3)=""
+ S GM(4)=""
+ ;S GM(5)="--123456788888"
+ ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
+ S GM(5)="--123456899999"
+ S GM(6)="Content-Type: text/xml; name="_FNAME
+ S GM(7)="Content-Transfer-Encoding: base64"
+ S GM(8)="Content-Disposition: attachment; filename="_FNAME
+ S GM(9)=""
+ S GM(10)="" ; FOR THE END
+ ;S GM(11)="--123456788888--"
+ S GM(11)="--123456899999--"
+ S GM(12)=""
+ S GM(13)=""
+ S GG(1)="--123456899999"
+ S GG(2)="Content-Type: text/plain; charset=ISO-8859-1; format=flowed"
+ S GG(3)="Content-Transfer-Encoding: 7bit"
+ S GG(4)=""
+ S GG(5)="This is a test message."
+ S GG(6)="A Continuity of Care record is attached"
+ S GG(7)="It contains no Protected Health Information (PHI)"
+ S GG(8)="It is purely test data used for software development"
+ S GG(9)="It does not represent information about any person living or dead"
+ S GG(10)=""
+ S GG(11)="--123456899999--"
+ ;S GG(11)="Content-Type: text/plain; charset=""us-ascii"""
+ S GG(12)=""
+ ;S GG(13)="This is a test message."
+ S GG(14)="A Continuity of Care record is attached"
+ S GG(15)="It contains no Protected Health Information (PHI)"
+ S GG(16)="It is purely test data used for software development"
+ S GG(17)="It does not represent information about any person living or dead"
+ S GG(18)=""
+ S GG(19)="--123456899999"
+ S GG(20)="--987654321--"
+ K GBLD
+ ;D QUEUE^C0CXPATH("GBLD","GGG",1,3) ; THE MESSAGE
+ ;D QUEUE^C0CXPATH("GBLD","GG",1,10) ; THE MESSAGE
+ I $D(MESSAGE)'="" D  ; THERE IS A MESSAGE
+ . D QUEUE^C0CXPATH("GBLD","GG",1,4) ; THE MIME BOUNDARY
+ . D QUEUE^C0CXPATH("GBLD",MESSAGE,1,$O(@MESSAGE@(""),-1)) ;THE MESSAGE
+ . D QUEUE^C0CXPATH("GBLD","GG",10,10) ;A BLANK LINE
+ D QUEUE^C0CXPATH("GBLD","GM",5,9)
+ I $D(ATTACH)'="" D  ; IF WE HAVE AN ATTACHMENT
+ . D ENCODE("G2",ATTACH) ; ENCODE FOR SENDING
+ . D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
+ D QUEUE^C0CXPATH("GBLD","GM",11,12)
+ D BUILD^C0CXPATH("GBLD",GN)
+ ;S GGG=$NA(^GPL("MIME2"))
+ K @GN@(0) ; KILL THE LINE COUNT
+ K LRINSTR,LRTASK,LRTO,XMERR,XMZ
+ M LRTO=@TO
+ I $D(CC) M LRTO=@CC
+ S LRINSTR("ADDR FLAGS")="R"
+ S LRINSTR("FROM")=$G(FROM)
+ S LRMSUBJ=$G(SUBJECT)
+ S LRMSUBJ=$E(LRMSUBJ,1,65)
+ D SENDMSG^XMXAPI(DUZ,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
+ I $G(XMERR)=1 S RTN(1)="ERROR SENDING MESSAGE" Q  ;
+ S RTN(1)="OK"
+ Q
+ ;
+MAILSEND0(LRMSUBJ) ; Send extract back to requestor.
+ ;
+ ;D TEST
+ S GN=$NA(^TMP($J,"C0CMIME"))
+ K @GN
+ ;M @GN=G2
+ S GM(1)="MIME-Version: 1.0"
+ S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
+ S GM(3)=""
+ S GM(4)=""
+ S GM(5)="--1234567"
+ ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
+ S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
+ S GM(7)="Content-Transfer-Encoding: base64"
+ S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
+ ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
+ S GM(9)=""
+ S GM(10)="" ; FOR THE END
+ S GM(11)="--frontier--"
+ S GM(12)="."
+ S GM(13)=""
+ K GBLD
+ ;D QUEUE^C0CXPATH("GBLD","GM",1,9)
+ ;D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
+ ;D QUEUE^C0CXPATH("GBLD","GM",10,13)
+ ;D BUILD^C0CXPATH("GBLD",GN)
+ S GGG=$NA(^GPL("MIME2"))
+ ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
+ D QUEUE^C0CXPATH("GBLD",GGG,21,159)
+ D BUILD^C0CXPATH("GBLD",GN)
+ K @GN@(0) ; KILL THE LINE COUNT
+ K LRINSTR,LRTASK,LRTO,XMERR,XMZ
+ S XQSND="glilly@glilly.net"
+ ;S XQSND="nanthracite@earthlink.net"
+ ;S XQSND="dlefevre@orohosp.com"
+ ;S XQSND="gregwoodhouse@me.com"
+ ;S XQSND="rick.marshall@vistaexpertise.net"
+ S LRTO(XQSND)=""
+ S LRINSTR("ADDR FLAGS")="R"
+ S LRINSTR("FROM")="CCR_PACKAGE"
+ S LRMSUBJ="A SAMPLE CCR"
+ S LRMSUBJ=$E(LRMSUBJ,1,65)
+ D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
+ I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q  ;
+ ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
+ ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
+ Q
+ ;
+MAILSEND2(UDFN,ADDR) ; Send extract back to requestor.
+ ;
+ I +$G(UDFN)=0 S UDFN=2 ;
+ D TEST(UDFN)
+ S GN=$NA(^TMP($J,"C0CMIME"))
+ K @GN
+ ;M @GN=G2
+ S GM(1)="MIME-Version: 1.0"
+ S GM(2)="Content-Type: multipart/mixed; boudary=""1234567"""
+ S GM(3)=""
+ S GM(4)=""
+ S GM(5)="--1234567"
+ ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X))
+ S GM(6)="Content-Type: text/xml; name=""ccr.xml"""
+ S GM(7)="Content-Transfer-Encoding: base64"
+ S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
+ ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml")
+ S GM(9)=""
+ S GM(10)="" ; FOR THE END
+ S GM(11)="--1234567--"
+ S GM(12)=""
+ S GM(13)=""
+ K GBLD
+ D QUEUE^C0CXPATH("GBLD","GM",5,9)
+ D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
+ D QUEUE^C0CXPATH("GBLD","GM",10,12)
+ D BUILD^C0CXPATH("GBLD",GN)
+ S GGG=$NA(^GPL("MIME2"))
+ ;D QUEUE^C0CXPATH("GBLD","GM",1,1)
+ ;D QUEUE^C0CXPATH("GBLD",GGG,21,159)
+ ;D BUILD^C0CXPATH("GBLD",GN)
+ K @GN@(0) ; KILL THE LINE COUNT
+ K LRINSTR,LRTASK,LRTO,XMERR,XMZ
+ I $G(ADDR)'="" S XQSND=ADDR
+ E  S XQSND="glilly@glilly.net"
+ ;S XQSND="nanthracite@earthlink.net"
+ ;S XQSND="dlefevre@orohosp.com"
+ ;S XQSND="gregwoodhouse@me.com"
+ ;S XQSND="rick.marshall@vistaexpertise.net"
+ S LRTO(XQSND)=""
+ ;S LRTO("glilly@glilly.net")=""
+ S LRINSTR("ADDR FLAGS")="R"
+ S LRINSTR("FROM")="ANTHRACITE.NANCY"
+ S LRMSUBJ="Sending a CCR with Mailman"
+ S LRMSUBJ=$E(LRMSUBJ,1,65)
+ D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK)
+ I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q  ;
+ ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0"
+ ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9"
+ Q
+ ;
+SIMPLE ;
+ S GN(1)="SIMPLE TEST MESSAGE"
+ K LRINSTR,LRTASK,LRTO,XMERR,XMZ
+ S XQSND="glilly@glilly.net"
+ S LRTO(XQSND)=""
+ S LRINSTR("ADDR FLAGS")="R"
+ S LRINSTR("FROM")="CCR_PACKAGE"
+ S LRMSUBJ="A SAMPLE CCR"
+ S LRMSUBJ=$E(LRMSUBJ,1,65)
+ D SENDMSG^XMXAPI(9,LRMSUBJ,"GN",.LRTO,.LRINSTR,.LRTASK)
+ Q
+CHUNK(OUTXML,INXML,ZSIZE) ; BREAKS INXML INTO ZSIZE BLOCKS
+ ; INXML IS AN ARRAY PASSED BY NAME OF STRINGS
+ ; OUTXML IS ALSO PASSED BY NAME
+ ; IF ZSIZE IS NOT PASSED, 1000 IS USED
+ I '$D(ZSIZE) S ZSIZE=1000 ; DEFAULT BLOCK SIZE
+ N ZB,ZI,ZJ,ZK,ZL,ZN
+ S ZB=ZSIZE-1
+ S ZN=1
+ S ZI=0 ; BEGINNING OF INDEX TO INXML
+ F  S ZI=$O(@INXML@(ZI)) Q:+ZI=0  D  ; FOR EACH STRING IN INXML
+ . S ZL=$L(@INXML@(ZI)) ; LENGTH OF THE STRING
+ . F ZJ=1:ZSIZE:ZL D  ;
+ . . S ZK=$S(ZJ+ZB<ZL:ZJ+ZB,1:ZL) ; END FOR EXTRACT
+ . . S @OUTXML@(ZN)=$E(@INXML@(ZI),ZJ,ZK) ; PULL OUT THE PIECE
+ . . S ZN=ZN+1 ; INCREMENT OUT ARRAY INDEX
+ Q
+ ;
+CLEAN(IARY) ; RUNS THROUGH AN ARRAY PASSED BY NAME AND STRIPS OUT $C(13)
+ ;
+ N ZI S ZI=0
+ F  S ZI=$O(@IARY@(ZI)) Q:+ZI=0  D  ;
+ . S @IARY@(ZI)=$TR(@IARY@(ZI),$C(13)) ;
+ . I $F(@IARY@(ZI)," <") S @IARY@(ZI)="<"_$P(@IARY@(ZI)," <",2) ; RM BLNKS
+ Q
+ ;

ccr/branches/ohum/p/C0CMXML.m

@@ -1 @@
-C0CMXML   ; GPL - MXML based XPath utilities;10/13/09  17:05
-        ;;0.1;C0C;nopatch;noreleasedate;Build 1
-        ;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/branches/ohum/p/C0CMXMLB.m

@@ -1 @@
-MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09  16:55
-        ;;8.0;KERNEL;;;Build 1
-        QUIT
-        ;
-        ;DOC - The top level tag
-        ;DOCTYPE - Want to include a DOCTYPE node
-        ;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J,
-START(DOC,DOCTYPE,FLAG,NO1ST)   ;Call this once at the begining.
-        K ^TMP("MXMLBLD",$J)
-        S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0
-        I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1
-        I $G(NO1ST)'=1 D OUTPUT($$XMLHDR) 
-        D:$L($G(DOCTYPE)) OUTPUT("<!DOCTYPE "_DOCTYPE_">") D OUTPUT("<"_DOC_">")
-        Q
-        ;
-END     ;Call this once to close out the document
-        D OUTPUT("</"_$G(^TMP("MXMLBLD",$J,"DOC"))_">")
-        I '$G(^TMP("MXMLBLD",$J,"CNT")) K ^TMP("MXMLBLD",$J)
-        K ^TMP("MXMLBLD",$J,"DOC"),^("CNT"),^("STK")
-        Q
-        ;
-ITEM(INDENT,TAG,ATT,VALUE)      ;Output a Item
-        N I,X
-        S ATT=$G(ATT)
-        I '$D(VALUE) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_" />") Q
-        D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">"_$$CHARCHK(VALUE)_"</"_TAG_">")
-        Q
-        ;DOITEM is a callback to output the lower level.
-MULTI(INDENT,TAG,ATT,DOITEM)    ;Output a Multipule
-        N I,X,S
-        S ATT=$G(ATT)
-        D PUSH($G(INDENT),TAG,.ATT)
-        D @DOITEM
-        D POP
-        Q
-        ;
-ATT(ATT)        ;Output a string of attributes
-        I $D(ATT)<9 Q ""
-        N I,S,V
-        S S="",I=""
-        F  S I=$O(ATT(I)) Q:I=""  S S=S_" "_I_"="_$$Q(ATT(I))
-        Q S
-        ;
-Q(X)    ;Add Quotes - Changed by gpl to use single instead of double quotes 6/11
-        ;I X'[$C(34) Q $C(34)_X_$C(34)
-        I X'[$C(39) Q $C(39)_X_$C(39)
-        ;N Q,Y,I,Z S Q=$C(34),(Y,Z)=""
-        N Q,Y,I,Z S Q=$C(39),(Y,Z)=""
-        F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q
-        S Y=Y_$P(X,Q,$L(X,Q))
-        ;Q $C(34)_Y_$C(34)
-        Q $C(39)_Y_$C(39)
-        ;
-XMLHDR()        ; -- provides current XML standard header
-        Q "<?xml version=""1.0"" encoding=""utf-8"" ?>"
-        ;
-OUTPUT(S)       ;Output
-        N C S C=$G(^TMP("MXMLBLD",$J,"CNT"))
-        I C S ^TMP("MXMLBLD",$J,C)=S,^TMP("MXMLBLD",$J,"CNT")=C+1 Q
-        W S,!
-        Q
-        ;
-CHARCHK(STR)    ; -- replace xml character limits with entities
-        N A,I,X,Y,Z,NEWSTR
-        S (Y,Z)=""
-        ;IF STR["&" SET NEWSTR=STR DO  SET STR=Y_Z
-        ;. FOR X=1:1  SET Y=Y_$PIECE(NEWSTR,"&",X)_"&amp;",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&"
-        I STR["&" F I=1:1:$L(STR,"&")-1 S STR=$P(STR,"&",1,I)_"&amp;"_$P(STR,"&",I+1,999)
-        I STR["<" F  S STR=$PIECE(STR,"<",1)_"&lt;"_$PIECE(STR,"<",2,99) Q:STR'["<"
-        I STR[">" F  S STR=$PIECE(STR,">",1)_"&gt;"_$PIECE(STR,">",2,99) Q:STR'[">"
-        I STR["'" F  S STR=$PIECE(STR,"'",1)_"&apos;"_$PIECE(STR,"'",2,99) Q:STR'["'"
-        I STR["""" F  S STR=$PIECE(STR,"""",1)_"&quot;"_$PIECE(STR,"""",2,99) Q:STR'[""""
-        ;
-        S STR=$TR(STR,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31))
-        QUIT STR
-        ;
-COMMENT(VAL)    ;Add Comments
-        N I,L
-        ;I $D($G(VAL))=1 D OUTPUT("<!-- "_ATT_" -->") Q
-        I $D(VAL) D OUTPUT("<!-- "_ATT_" -->") Q  ;CHANGED BY GPL FOR GTM
-        S I="",L="<!--"
-        F  S I=$O(ATT(I)) Q:I=""  D OUTPUT(L_ATT(I)) S L=""
-        D OUTPUT("-->")
-        Q
-        ;
-PUSH(INDENT,TAG,ATT)    ;Write a TAG and save.
-        N CNT
-        S ATT=$G(ATT)
-        D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">")
-        S CNT=$G(^TMP("MXMLBLD",$J,"STK"))+1,^TMP("MXMLBLD",$J,"STK")=CNT,^TMP("MXMLBLD",$J,"STK",CNT)=INDENT_"^"_TAG
-        Q
-        ;
-POP     ;Write last pushed tag and pop
-        N CNT,TAG,INDENT,X
-        S CNT=$G(^TMP("MXMLBLD",$J,"STK")),X=^TMP("MXMLBLD",$J,"STK",CNT),^TMP("MXMLBLD",$J,"STK")=CNT-1
-        S INDENT=+X,TAG=$P(X,"^",2)
-        D OUTPUT($$BLS(INDENT)_"</"_TAG_">")
-        Q
-        ;
-BLS(I)  ;Return INDENT string
-        N S
-        S S="",I=$G(I) S:I>0 $P(S," ",I)=" "
-        Q S
-        ;
-INDENT()        ;Renturn indent level
-        Q +$G(^TMP("MXMLBLD",$J,"STK"))
+MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09  16:55
+ ;;8.0;KERNEL;;
+ QUIT
+ ;
+ ;DOC - The top level tag
+ ;DOCTYPE - Want to include a DOCTYPE node
+ ;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J,
+START(DOC,DOCTYPE,FLAG,NO1ST) ;Call this once at the begining.
+ K ^TMP("MXMLBLD",$J)
+ S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0
+ I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1
+ I $G(NO1ST)'=1 D OUTPUT($$XMLHDR) 
+ D:$L($G(DOCTYPE)) OUTPUT("<!DOCTYPE "_DOCTYPE_">") D OUTPUT("<"_DOC_">")
+ Q
+ ;
+END ;Call this once to close out the document
+ D OUTPUT("</"_$G(^TMP("MXMLBLD",$J,"DOC"))_">")
+ I '$G(^TMP("MXMLBLD",$J,"CNT")) K ^TMP("MXMLBLD",$J)
+ K ^TMP("MXMLBLD",$J,"DOC"),^("CNT"),^("STK")
+ Q
+ ;
+ITEM(INDENT,TAG,ATT,VALUE) ;Output a Item
+ N I,X
+ S ATT=$G(ATT)
+ I '$D(VALUE) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_" />") Q
+ D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">"_$$CHARCHK(VALUE)_"</"_TAG_">")
+ Q
+ ;DOITEM is a callback to output the lower level.
+MULTI(INDENT,TAG,ATT,DOITEM) ;Output a Multipule
+ N I,X,S
+ S ATT=$G(ATT)
+ D PUSH($G(INDENT),TAG,.ATT)
+ D @DOITEM
+ D POP
+ Q
+ ;
+ATT(ATT) ;Output a string of attributes
+ I $D(ATT)<9 Q ""
+ N I,S,V
+ S S="",I=""
+ F  S I=$O(ATT(I)) Q:I=""  S S=S_" "_I_"="_$$Q(ATT(I))
+ Q S
+ ;
+Q(X) ;Add Quotes - Changed by gpl to use single instead of double quotes 6/11
+ ;I X'[$C(34) Q $C(34)_X_$C(34)
+ I X'[$C(39) Q $C(39)_X_$C(39)
+ ;N Q,Y,I,Z S Q=$C(34),(Y,Z)=""
+ N Q,Y,I,Z S Q=$C(39),(Y,Z)=""
+ F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q
+ S Y=Y_$P(X,Q,$L(X,Q))
+ ;Q $C(34)_Y_$C(34)
+ Q $C(39)_Y_$C(39)
+ ;
+XMLHDR() ; -- provides current XML standard header
+ Q "<?xml version=""1.0"" encoding=""utf-8"" ?>"
+ ;
+OUTPUT(S) ;Output
+ N C S C=$G(^TMP("MXMLBLD",$J,"CNT"))
+ I C S ^TMP("MXMLBLD",$J,C)=S,^TMP("MXMLBLD",$J,"CNT")=C+1 Q
+ W S,!
+ Q
+ ;
+CHARCHK(STR) ; -- replace xml character limits with entities
+ N A,I,X,Y,Z,NEWSTR
+ S (Y,Z)=""
+ ;IF STR["&" SET NEWSTR=STR DO  SET STR=Y_Z
+ ;. FOR X=1:1  SET Y=Y_$PIECE(NEWSTR,"&",X)_"&amp;",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&"
+ I STR["&" F I=1:1:$L(STR,"&")-1 S STR=$P(STR,"&",1,I)_"&amp;"_$P(STR,"&",I+1,999)
+ I STR["<" F  S STR=$PIECE(STR,"<",1)_"&lt;"_$PIECE(STR,"<",2,99) Q:STR'["<"
+ I STR[">" F  S STR=$PIECE(STR,">",1)_"&gt;"_$PIECE(STR,">",2,99) Q:STR'[">"
+ I STR["'" F  S STR=$PIECE(STR,"'",1)_"&apos;"_$PIECE(STR,"'",2,99) Q:STR'["'"
+ I STR["""" F  S STR=$PIECE(STR,"""",1)_"&quot;"_$PIECE(STR,"""",2,99) Q:STR'[""""
+ ;
+ S STR=$TR(STR,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31))
+ QUIT STR
+ ;
+COMMENT(VAL) ;Add Comments
+ N I,L
+ ;I $D($G(VAL))=1 D OUTPUT("<!-- "_ATT_" -->") Q
+ I $D(VAL) D OUTPUT("<!-- "_ATT_" -->") Q  ;CHANGED BY GPL FOR GTM
+ S I="",L="<!--"
+ F  S I=$O(ATT(I)) Q:I=""  D OUTPUT(L_ATT(I)) S L=""
+ D OUTPUT("-->")
+ Q
+ ;
+PUSH(INDENT,TAG,ATT) ;Write a TAG and save.
+ N CNT
+ S ATT=$G(ATT)
+ D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">")
+ S CNT=$G(^TMP("MXMLBLD",$J,"STK"))+1,^TMP("MXMLBLD",$J,"STK")=CNT,^TMP("MXMLBLD",$J,"STK",CNT)=INDENT_"^"_TAG
+ Q
+ ;
+POP ;Write last pushed tag and pop
+ N CNT,TAG,INDENT,X
+ S CNT=$G(^TMP("MXMLBLD",$J,"STK")),X=^TMP("MXMLBLD",$J,"STK",CNT),^TMP("MXMLBLD",$J,"STK")=CNT-1
+ S INDENT=+X,TAG=$P(X,"^",2)
+ D OUTPUT($$BLS(INDENT)_"</"_TAG_">")
+ Q
+ ;
+BLS(I) ;Return INDENT string
+ N S
+ S S="",I=$G(I) S:I>0 $P(S," ",I)=" "
+ Q S
+ ;
+INDENT() ;Renturn indent level
+ Q +$G(^TMP("MXMLBLD",$J,"STK"))

ccr/branches/ohum/p/C0CMXP.m

@@ -1 @@
-C0CMXP    ; GPL - MXML based XPath utilities;12/04/09  17:05
-        ;;0.1;C0C;nopatch;noreleasedate;Build 1
-        ;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/branches/ohum/p/C0CNHIN.m

@@ -1 @@
-C0CNHIN   ; GPL - PROCESSING FOR OUTPUT OF NHINV ROUTINES;6/3/11  17:05
-        ;;0.1;C0C;nopatch;noreleasedate;Build 1
-        ;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
-EN(ZRTN,ZDFN,ZPART,KEEP)        ; GENERATE AN NHIN ARRAY FOR A PATIENT
-        ;
-        K GARY,GNARY,GIDX,C0CDOCID
-        N GN
-        K ^TMP("NHINV",$J) ; CLEAN UP FROM LAST CALL
-        K ^TMP("MXMLDOM",$J) ; CLEAN UP DOM
-        K ^TMP("MXMLERR",$J) ; CLEAN UP MXML ERRORS
-        D GET^NHINV(.GN,ZDFN,ZPART) ; CALL NHINV ROUTINES TO PULL XML
-        S GN=$P(GN,")",1)_")" ; CUT OFF THE REST OF LINE PROTOCOL
-        S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML
-        D DOMO^C0CDOM(C0CDOCID,"/","ZRTN","GIDX","GARY",,"/results/") ; BLD ARRAYS
-        I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
-        ;D PROCESS("ZRTN",GN,"/result/",$G(KEEP))
-        Q
-        ;
-PQRI(ZOUT,KEEP) ; RETURN THE NHIN ARRAY FOR THE PQRI XML TEMPLATE
-        ;
-        N ZG
-        S ZG=$NA(^TMP("PQRIXML",$J))
-        K @ZG
-        D GETXML^C0CMXP(ZG,"PQRIXML") ; GET THE XML FROM C0C MISC XML
-        N C0CDOCID
-        S C0CDOCID=$$PARSE^C0CDOM(ZG,"PQRIXML") ; PARSE THE XML
-        D DOMO^C0CDOM(C0CDOCID,"/","ZOUT","GIDX","GARY",,"//submission") ; BLD ARRAYS
-        I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
-        Q
-        ;
-PQRI2(ZRTN)     ; RETURN THE NHIN ARRAY FOR PQRI ONE MEASURE
-        ;
-        ;N GG
-        D GETXML^C0CMXP("GG","PQRI ONE MEASURE")
-        D PROCESS(ZRTN,"GG","root",1)
-        Q
-        ;
-PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP)        ; PARSE AND RUN DOMO ON XML
-        ; ZRTN IS PASSED BY REFERENCE
-        ; ZXML IS PASSED BY NAME
-        ; IF KEEP IS 1, GARY AND GIDX ARE NOT KILLED
-        ;
-        N GN
-        S GN=$NA(^TMP("C0CPROCESS",$J))
-        K @GN
-        M @GN=@ZXML
-        S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML
-        K @GN
-        D DOMO^C0CDOM(C0CDOCID,"/","ZRSLT","GIDX","GARY",,$G(ZREDUCE)) ; BLD ARRAYS
-        I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
-        Q
-        ;
-LOADSMRT        ; 
-        ;
-        K ^GPL("SMART")
-        S GN=$NA(^GPL("SMART",1))
-        I $$FTG^%ZISH("/home/george/","alex-lewis2.xml",GN,2) W !,"SMART FILE LOADED"
-        Q
-        ;
-SMART   ; TRY IT WITH SMART
-        ;
-        S GN=$NA(^GPL("SMART"))
-        ;K ^TMP("MXMLDOM",$J)
-        K ^TMP("MXMLERR",$J)
-        S C0CDOCID=$$PARSE(GN,"SMART")
-        D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//rdf:RDF/")
-        ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
-        Q
-        ;
-CCR     ; TRY IT WITH A CCR
-        ;
-        S GN=$NA(^GPL("CCR"))
-        ;K ^TMP("MXMLDOM",$J)
-        K ^TMP("MXMLERR",$J)
-        S C0CDOCID=$$PARSE(GN,"CCR")
-        D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ContinuityOfCareRecord/Body/")
-        ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
-        Q
-        ;
-MED     ; TRY IT WITH A CCR MED SECTION
-        ;
-        S GN=$NA(^GPL("MED"))
-        K ^TMP("MXMLDOM",$J)
-        K ^TMP("MXMLERR",$J)
-        S C0CDOCID=$$PARSE(GN,"MED")
-        D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//Medications/")
-        ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
-        Q
-        ;
-CCD     ; TRY IT WITH A CCD
-        ;
-        S GN=$NA(^GPL("CCD"))
-        ;K ^TMP("MXMLDOM",$J)
-        K ^TMP("MXMLERR",$J)
-        S C0CDOCID=$$PARSE(GN,"CCD")
-        D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ClinicalDocument/component/structuredBody/")
-        ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
-        Q
-        ;
-TEST1   ; TEST NHINV OUTPUT IN ^GPL("NIHIN") 
-        ; PARSED WITH MXML
-        ; RUN THROUGH XPATH
-        K GARY,GIDX,C0CDOCID
-        S GN=$NA(^GPL("NHIN"))
-        ;S GN=$NA(^GPL("DOMI"))
-        S C0CDOCID=$$PARSE(GN,"GPLTEST")
-        D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/")
-        K ^GPL("GNARY")
-        M ^GPL("GNARY")=GNARY
-        Q
-        ;
-TEST2   ; PUT GNARY THROUGH DOMI AND STORE XML IN ^GPL("DOMI")
-        ;
-        S GN=$NA(^GPL("GNARY"))
-        S C0CDOCID=$$DOMI^C0CDOM(GN,,"results")
-        D OUTXML^C0CDOM("G",C0CDOCID)
-        K ^GPL("DOMI")
-        M ^GPL("DOMI")=G
-        Q
-        ;
-TEST3   ; TEST NHINV OUTPUT IN ^GPL("NIHIN") 
-        ; PARSED WITH MXML
-        ; RUN THROUGH XPATH
-        K GARY,GIDX,C0CDOCID
-        ;S GN=$NA(^GPL("NHIN"))
-        S GN=$NA(^GPL("DOMI"))
-        S C0CDOCID=$$PARSE(GN,"GPLTEST")
-        D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/")
-        Q
-        ;
-DOMO(ZOID,ZPATH,ZNARY,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,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY
-        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 GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE
-        I $D(GA) D  ; PROCESS THE ATTRIBUTES
-        . N ZI S ZI=""
-        . F  S ZI=$O(GA(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
-        . . N ZP S ZP=NEWPATH_"/"_ZI ; PATH FOR ATTRIBUTE
-        . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY
-        . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE
-        N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
-        I $D(GD(2)) D  ;
-        . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
-        E  I $D(GD(1)) D  ;
-        . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
-        . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN 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 DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; 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 DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
-        . E  D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB
-        Q
-        ;
-ADDNARY(ZXP,ZVALUE)     ; ADD AN NHIN ARRAY VALUE TO ZNARY
-        ;
-        N ZZI,ZZJ,ZZN
-        S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY
-        I ZZI="" Q  ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE
-        S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY
-        S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH .
-        I ZZI'["]" D  ; A SINGLETON
-        . S ZZN=1
-        E  D  ; THERE IS AN [x] OCCURANCE
-        . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE
-        . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X]
-        I ZZJ'="" S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE
-        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
-        ;
-WNHIN(ZDFN)     ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE
-        ;
-        N GN,GN2
-        D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML
-        S GN2=$NA(@GN@(1))
-        W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/")
-        Q
-        ;
-TESTNARY        ; TEST MAKING A NHIN ARRAY
-        N ZI S ZI=""
-        N ZH ; DOM HANDLE
-        D TEST1 ; PARSE AN NHIN RESULT INTO THE DOM
-        S ZH=C0CDOCID ; SET THE HANDLE
-        N ZD S ZD=$NA(^TMP("MXMLDOM",$J,ZH))
-        F  S ZI=$O(@ZD@(ZI)) Q:ZI=""  D  ; FOR EACH NODE
-        . N ZATT
-        . D MNARY(.ZATT,ZH,ZI)
-        . N ZPRE,ZN
-        . S ZPRE=$$PRE(ZI)
-        . S ZN=$P(ZPRE,",",2)
-        . S ZPRE=$P(ZPRE,",",1)
-        . ;I $D(ZATT) ZWR ZATT
-        . N ZJ S ZJ=""
-        . F  S ZJ=$O(ZATT(ZJ)) Q:ZJ=""  D  ; FOR EACH ATTRIBUTE
-        . . W ZPRE_"["_ZN_"]"_$$TAG(ZI)_"."_ZJ_"="_ZATT(ZJ),!
-        . . S GOUT(ZPRE,ZN,$$TAG(ZI)_"."_ZJ)=ZATT(ZJ)
-        Q
-        ;
-PRE(ZNODE)      ; EXTRINSIC WHICH RETURNS THE PREFIX FOR A NODE
-        ;
-        N GI,GI2,GPT,GJ,GN
-        S GI=$$PARENT(ZNODE) ; PARENT NODE
-        I GI=0 Q ""  ; NO PARENT
-        S GPT=$$TAG(GI) ; TAG OF PARENT
-        S GI2=$$PARENT(GI) ; PARENT OF PARENT
-        I (GI2'=0)&($$TAG(GI2)'="results") S GPT=$$TAG(GI2)_"."_GPT
-        S GJ=$$FIRST(GI) ; NODE OF FIRST SIB
-        I GJ=ZNODE Q:$$TAG(GI)_",1"
-        F GN=2:1 Q:GJ=ZNODE  D  ;
-        . S GJ=$$NXTSIB(GJ) ; NEXT SIBLING 
-        Q GPT_","_GN
-        ;
-MNARY(ZRTN,ZHANDLE,ZOID)        ; MAKE A NHIN ARRAY FROM A DOM NODE
-        ; RETURNED IN ZRTN, PASSED BY REFERENCE
-        ; ZHANDLE IS THE DOM DOCUMENT ID
-        ; ZOID IS THE DOM NODE
-        D ATT("ZRTN",ZOID)
-        Q
-        ;
+C0CNHIN   ; GPL - PROCESSING FOR OUTPUT OF NHINV ROUTINES;6/3/11  17:05
+ ;;0.1;C0C;nopatch;noreleasedate;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.
+ ;
+ Q
+EN(ZRTN,ZDFN,ZPART,KEEP) ; GENERATE AN NHIN ARRAY FOR A PATIENT
+ ;
+ K GARY,GNARY,GIDX,C0CDOCID
+ N GN
+ K ^TMP("NHINV",$J) ; CLEAN UP FROM LAST CALL
+ K ^TMP("MXMLDOM",$J) ; CLEAN UP DOM
+ K ^TMP("MXMLERR",$J) ; CLEAN UP MXML ERRORS
+ D GET^NHINV(.GN,ZDFN,ZPART) ; CALL NHINV ROUTINES TO PULL XML
+ S GN=$P(GN,")",1)_")" ; CUT OFF THE REST OF LINE PROTOCOL
+ S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML
+ D DOMO^C0CDOM(C0CDOCID,"/","ZRTN","GIDX","GARY",,"/results/") ; BLD ARRAYS
+ I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
+ ;D PROCESS("ZRTN",GN,"/result/",$G(KEEP))
+ Q
+ ;
+PQRI(ZOUT,KEEP) ; RETURN THE NHIN ARRAY FOR THE PQRI XML TEMPLATE
+ ;
+ N ZG
+ S ZG=$NA(^TMP("PQRIXML",$J))
+ K @ZG
+ D GETXML^C0CMXP(ZG,"PQRIXML") ; GET THE XML FROM C0C MISC XML
+ N C0CDOCID
+ S C0CDOCID=$$PARSE^C0CDOM(ZG,"PQRIXML") ; PARSE THE XML
+ D DOMO^C0CDOM(C0CDOCID,"/","ZOUT","GIDX","GARY",,"//submission") ; BLD ARRAYS
+ I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
+ Q
+ ;
+PQRI2(ZRTN) ; RETURN THE NHIN ARRAY FOR PQRI ONE MEASURE
+ ;
+ ;N GG
+ D GETXML^C0CMXP("GG","PQRI ONE MEASURE")
+ D PROCESS(ZRTN,"GG","root",1)
+ Q
+ ;
+PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP) ; PARSE AND RUN DOMO ON XML
+ ; ZRTN IS PASSED BY REFERENCE
+ ; ZXML IS PASSED BY NAME
+ ; IF KEEP IS 1, GARY AND GIDX ARE NOT KILLED
+ ;
+ N GN
+ S GN=$NA(^TMP("C0CPROCESS",$J))
+ K @GN
+ M @GN=@ZXML
+ S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML
+ K @GN
+ D DOMO^C0CDOM(C0CDOCID,"/","ZRSLT","GIDX","GARY",,$G(ZREDUCE)) ; BLD ARRAYS
+ I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1
+ Q
+ ;
+LOADSMRT ; 
+ ;
+ K ^GPL("SMART")
+ S GN=$NA(^GPL("SMART",1))
+ I $$FTG^%ZISH("/home/george/","alex-lewis2.xml",GN,2) W !,"SMART FILE LOADED"
+ Q
+ ;
+SMART ; TRY IT WITH SMART
+ ;
+ S GN=$NA(^GPL("SMART"))
+ ;K ^TMP("MXMLDOM",$J)
+ K ^TMP("MXMLERR",$J)
+ S C0CDOCID=$$PARSE(GN,"SMART")
+ D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//rdf:RDF/")
+ ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
+ Q
+ ;
+CCR ; TRY IT WITH A CCR
+ ;
+ S GN=$NA(^GPL("CCR"))
+ ;K ^TMP("MXMLDOM",$J)
+ K ^TMP("MXMLERR",$J)
+ S C0CDOCID=$$PARSE(GN,"CCR")
+ D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ContinuityOfCareRecord/Body/")
+ ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
+ Q
+ ;
+MED ; TRY IT WITH A CCR MED SECTION
+ ;
+ S GN=$NA(^GPL("MED"))
+ K ^TMP("MXMLDOM",$J)
+ K ^TMP("MXMLERR",$J)
+ S C0CDOCID=$$PARSE(GN,"MED")
+ D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//Medications/")
+ ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
+ Q
+ ;
+CCD ; TRY IT WITH A CCD
+ ;
+ S GN=$NA(^GPL("CCD"))
+ ;K ^TMP("MXMLDOM",$J)
+ K ^TMP("MXMLERR",$J)
+ S C0CDOCID=$$PARSE(GN,"CCD")
+ D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ClinicalDocument/component/structuredBody/")
+ ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG
+ Q
+ ;
+TEST1 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") 
+ ; PARSED WITH MXML
+ ; RUN THROUGH XPATH
+ K GARY,GIDX,C0CDOCID
+ S GN=$NA(^GPL("NHIN"))
+ ;S GN=$NA(^GPL("DOMI"))
+ S C0CDOCID=$$PARSE(GN,"GPLTEST")
+ D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/")
+ K ^GPL("GNARY")
+ M ^GPL("GNARY")=GNARY
+ Q
+ ;
+TEST2 ; PUT GNARY THROUGH DOMI AND STORE XML IN ^GPL("DOMI")
+ ;
+ S GN=$NA(^GPL("GNARY"))
+ S C0CDOCID=$$DOMI^C0CDOM(GN,,"results")
+ D OUTXML^C0CDOM("G",C0CDOCID)
+ K ^GPL("DOMI")
+ M ^GPL("DOMI")=G
+ Q
+ ;
+TEST3 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") 
+ ; PARSED WITH MXML
+ ; RUN THROUGH XPATH
+ K GARY,GIDX,C0CDOCID
+ ;S GN=$NA(^GPL("NHIN"))
+ S GN=$NA(^GPL("DOMI"))
+ S C0CDOCID=$$PARSE(GN,"GPLTEST")
+ D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/")
+ Q
+ ;
+DOMO(ZOID,ZPATH,ZNARY,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,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY
+ 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 GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE
+ I $D(GA) D  ; PROCESS THE ATTRIBUTES
+ . N ZI S ZI=""
+ . F  S ZI=$O(GA(ZI)) Q:ZI=""  D  ; FOR EACH ATTRIBUTE
+ . . N ZP S ZP=NEWPATH_"/"_ZI ; PATH FOR ATTRIBUTE
+ . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY
+ . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE
+ N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
+ I $D(GD(2)) D  ;
+ . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
+ E  I $D(GD(1)) D  ;
+ . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
+ . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN 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 DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; 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 DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB
+ . E  D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB
+ Q
+ ;
+ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY
+ ;
+ N ZZI,ZZJ,ZZN
+ S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY
+ I ZZI="" Q  ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE
+ S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY
+ S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH .
+ I ZZI'["]" D  ; A SINGLETON
+ . S ZZN=1
+ E  D  ; THERE IS AN [x] OCCURANCE
+ . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE
+ . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X]
+ I ZZJ'="" S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE
+ 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
+ ;
+WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE
+ ;
+ N GN,GN2
+ D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML
+ S GN2=$NA(@GN@(1))
+ W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/")
+ Q
+ ;
+TESTNARY ; TEST MAKING A NHIN ARRAY
+ N ZI S ZI=""
+ N ZH ; DOM HANDLE
+ D TEST1 ; PARSE AN NHIN RESULT INTO THE DOM
+ S ZH=C0CDOCID ; SET THE HANDLE
+ N ZD S ZD=$NA(^TMP("MXMLDOM",$J,ZH))
+ F  S ZI=$O(@ZD@(ZI)) Q:ZI=""  D  ; FOR EACH NODE
+ . N ZATT
+ . D MNARY(.ZATT,ZH,ZI)
+ . N ZPRE,ZN
+ . S ZPRE=$$PRE(ZI)
+ . S ZN=$P(ZPRE,",",2)
+ . S ZPRE=$P(ZPRE,",",1)
+ . ;I $D(ZATT) ZWR ZATT
+ . N ZJ S ZJ=""
+ . F  S ZJ=$O(ZATT(ZJ)) Q:ZJ=""  D  ; FOR EACH ATTRIBUTE
+ . . W ZPRE_"["_ZN_"]"_$$TAG(ZI)_"."_ZJ_"="_ZATT(ZJ),!
+ . . S GOUT(ZPRE,ZN,$$TAG(ZI)_"."_ZJ)=ZATT(ZJ)
+ Q
+ ;
+PRE(ZNODE) ; EXTRINSIC WHICH RETURNS THE PREFIX FOR A NODE
+ ;
+ N GI,GI2,GPT,GJ,GN
+ S GI=$$PARENT(ZNODE) ; PARENT NODE
+ I GI=0 Q ""  ; NO PARENT
+ S GPT=$$TAG(GI) ; TAG OF PARENT
+ S GI2=$$PARENT(GI) ; PARENT OF PARENT
+ I (GI2'=0)&($$TAG(GI2)'="results") S GPT=$$TAG(GI2)_"."_GPT
+ S GJ=$$FIRST(GI) ; NODE OF FIRST SIB
+ I GJ=ZNODE Q:$$TAG(GI)_",1"
+ F GN=2:1 Q:GJ=ZNODE  D  ;
+ . S GJ=$$NXTSIB(GJ) ; NEXT SIBLING 
+ Q GPT_","_GN
+ ;
+MNARY(ZRTN,ZHANDLE,ZOID) ; MAKE A NHIN ARRAY FROM A DOM NODE
+ ; RETURNED IN ZRTN, PASSED BY REFERENCE
+ ; ZHANDLE IS THE DOM DOCUMENT ID
+ ; ZOID IS THE DOM NODE
+ D ATT("ZRTN",ZOID)
+ Q
+ ;

ccr/branches/ohum/p/C0CNMED2.m

@@ -1 @@
-C0CMED  ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ; 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
-        ; June 2011 - Redone to support all meds using the FOIA NHIN routines/gpl
-        ;
-        Q
-        ;
-        ; THIS VERSION IS DEPRECATED BECAUSE IT DOES NOT GENEREATE XML IN
-        ; THE RIGHT ORDER... AND IT HAS TO BE IN THE RIGHT ORDER... :(
-        ; GPL
-        ;
-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
-        ;
-        N GN
-        D EN^C0CNHIN(.GN,DFN,"MED;",1) ; RETRIEVE NHIN ARRAY OF MEDS
-        ; this call uses GET^NHINV to retrieve xml of the meds and then
-        ; parses with MXML and uses DOMO^C0CDOM to extract an NHIN array
-        ;
-        ; we now create an NHIN Array of the Meds section of the CCR
-        ;
-        N ZI S ZI=""
-        F  S ZI=$O(GN("med",ZI)) Q:ZI=""  D  ; for each med
-        . N GA S GA=$NA(GN("med",ZI))
-        . N GM S GM="Medication" ; to keep the lines shorter
-        . S GC(GM,ZI,"CCRDataObjectID")="MED_"_ZI
-        . N ZD,ZD2 S ZD=$G(@GA@("ordered@value")) ; FILEMAN DATE
-        . I ZD="" S ZD=$G(@GA@("start@value")) ; for inpatient meds
-        . S ZD2=$$FMDTOUTC^C0CUTIL(ZD,"DT")
-        . S GC(GM,ZI,"DateTime[1].ExactDateTime")=ZD2
-        . S GC(GM,ZI,"DateTime[1].Type.Text")="Documented Date"
-        . ;S GC(GM,ZI,"DateTime[2].ExactDateTime")=""
-        . ;S GC(GM,ZI,"DateTime[2].Type.Text")=""
-        . N GSIG S GSIG=$G(@GA@("sig"))
-        . I GSIG["|" S GSIG=$P(GSIG,"|",2) ; eRx has name of drug separated by |
-        . S GC(GM,ZI,"Description.Text")=GSIG
-        . N GD S GD="Directions.Direction" ; MAKING THE STRINGS SHORTER
-        . ;S GC(GM,ZI,GD_".DeliveryMethod.Text")="@@MEDDELIVERYMETHOD@@"
-        . ;S GC(GM,ZI,GD_".Description.Text")=""
-        . ;S GC(GM,ZI,GD_".DirectionSequenceModifier")="@@MEDDIRSEQ@@"
-        . ;S GC(GM,ZI,GD_".Dose.Rate.Units.Unit")="@@MEDRATEUNIT@@"
-        . ;S GC(GM,ZI,GD_".Dose.Rate.Value")="@@MEDRATEVALUE@@"
-        . ;S GC(GM,ZI,GD_".Dose.Units.Unit")="@@MEDDOSEUNIT@@"
-        . ;S GC(GM,ZI,GD_".Dose.Value")="@@MEDDOSEVALUE@@"
-        . ;S GC(GM,ZI,GD_".DoseIndicator.Text")="@@MEDDOSEINDICATOR@@"
-        . ;S GC(GM,ZI,GD_".Duration.Units.Unit")="@@MEDDURATIONUNIT@@"
-        . ;S GC(GM,ZI,GD_".Duration.Value")="@@MEDDURATIONVALUE@@"
-        . ;S GC(GM,ZI,GD_".Frequency.Value")="@@MEDFREQUENCYVALUE@@"
-        . ;S GC(GM,ZI,GD_".Indication.PRNFlag.Text")="@@MEDPRNFLAG@@"
-        . ;S GC(GM,ZI,GD_".Indication.Problem.CCRDataObjectID")=""
-        . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.CodingSystem")=""
-        . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Value")=""
-        . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Version")=""
-        . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Text")=""
-        . ;S GC(GM,ZI,GD_".Indication.Problem.Source.Actor.ActorID")=""
-        . ;S GC(GM,ZI,GD_".Indication.Problem.Type.Text")=""
-        . ;S GC(GM,ZI,GD_".Interval.Units.Unit")="@@MEDINTERVALUNIT@@"
-        . ;S GC(GM,ZI,GD_".Interval.Value")="@@MEDINTERVALVALUE@@"
-        . ;S GC(GM,ZI,GD_".MultipleDirectionModifier.Text")="@@MEDMULDIRMOD@@"
-        . S GC(GM,ZI,GD_".Route.Text")=$G(@GA@("doses.dose@route"))
-        . ;S GC(GM,ZI,GD_".StopIndicator.Text")="@@MEDSTOPINDICATOR@@"
-        . ;S GC(GM,ZI,GD_".Vehicle.Text")="@@MEDVEHICLETEXT@@"
-        . ;S GC(GM,ZI,"FullfillmentInstructions.Text")=""
-        . ;S GC(GM,ZI,"IDs.ID")="@@MEDRXNO@@"
-        . ;S GC(GM,ZI,"IDs.Type.Text")="@@MEDRXNOTXT@@"
-        . ;S GC(GM,ZI,"PatientInstructions.Instruction.Text")="@@MEDPTINSTRUCTIONS@@"
-        . ;S GC(GM,ZI,"Product.BrandName.Text")="@@MEDBRANDNAMETEXT@@"
-        . S GC(GM,ZI,"Product.Concentration.Units.Unit")=$G(@GA@("doses.dose@units"))
-        . S GC(GM,ZI,"Product.Concentration.Value")=$G(@GA@("doses.dose@dose"))
-        . S GC(GM,ZI,"Product.Form.Text")=$G(@GA@("form@value"))
-        . N GV S GV=$G(@GA@("products.product.vaProduct@vuid"))
-        . N GR S GR=$$RXNCUI3^C0PLKUP(GV)
-        . S GC(GM,ZI,"Product.ProductName.Code.CodingSystem")=$S(GR:"RxNorm",1:"VUID")
-        . S GC(GM,ZI,"Product.ProductName.Code.Value")=$S(GR:GR,1:GV)
-        . S GC(GM,ZI,"Product.ProductName.Code.Version")="08AB_081201F"
-        . S GC(GM,ZI,"Product.ProductName.Text")=$G(@GA@("name@value"))
-        . S GC(GM,ZI,"Product.Strength.Units.Unit")=$G(@GA@("doses.dose@units"))
-        . S GC(GM,ZI,"Product.Strength.Value")=$G(@GA@("doses.dose@dose"))
-        . ;S GC(GM,ZI,"Quantity.Units.Unit")="@@MEDQUANTITYUNIT@@"
-        . ;S GC(GM,ZI,"Quantity.Value")="@@MEDQUANTITYVALUE@@"
-        . ;S GC(GM,ZI,"Refills.Refill.Number")="@@MEDRFNO@@"
-        . N GDUZ S GDUZ=$G(@GA@("orderingProvider@code")) ;PROVIDER DUZ
-        . S GC(GM,ZI,"Source.Actor.ActorID")="PROVIDER_"_GDUZ
-        . S GC(GM,ZI,"Status.Text")=$G(@GA@("status@value"))
-        . S GC(GM,ZI,"Type.Text")="Medication"
-        N C0CDOCID
-        S C0CDOCID=$$DOMI^C0CDOM("GC",,"Medications") ; insert to dom
-        D OUTXML^C0CDOM(MEDOUTXML,C0CDOCID,1) ; render the xml
-        N ZSIZE S ZSIZE=$O(@MEDOUTXML@(""),-1)
-        S @MEDOUTXML@(0)=ZSIZE ; RETURN STATUS IS NUMBER OF LINES OF XML
-        W !,MEDOUTXML
-        ;ZWR GN
-        ;ZWR GC
-        ;B
-        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
+ ; June 2011 - Redone to support all meds using the FOIA NHIN routines/gpl
+ ;
+ Q
+ ;
+ ; THIS VERSION IS DEPRECATED BECAUSE IT DOES NOT GENEREATE XML IN
+ ; THE RIGHT ORDER... AND IT HAS TO BE IN THE RIGHT ORDER... :(
+ ; GPL
+ ;
+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
+ ;
+ N GN
+ D EN^C0CNHIN(.GN,DFN,"MED;",1) ; RETRIEVE NHIN ARRAY OF MEDS
+ ; this call uses GET^NHINV to retrieve xml of the meds and then
+ ; parses with MXML and uses DOMO^C0CDOM to extract an NHIN array
+ ;
+ ; we now create an NHIN Array of the Meds section of the CCR
+ ;
+ N ZI S ZI=""
+ F  S ZI=$O(GN("med",ZI)) Q:ZI=""  D  ; for each med
+ . N GA S GA=$NA(GN("med",ZI))
+ . N GM S GM="Medication" ; to keep the lines shorter
+ . S GC(GM,ZI,"CCRDataObjectID")="MED_"_ZI
+ . N ZD,ZD2 S ZD=$G(@GA@("ordered@value")) ; FILEMAN DATE
+ . I ZD="" S ZD=$G(@GA@("start@value")) ; for inpatient meds
+ . S ZD2=$$FMDTOUTC^C0CUTIL(ZD,"DT")
+ . S GC(GM,ZI,"DateTime[1].ExactDateTime")=ZD2
+ . S GC(GM,ZI,"DateTime[1].Type.Text")="Documented Date"
+ . ;S GC(GM,ZI,"DateTime[2].ExactDateTime")=""
+ . ;S GC(GM,ZI,"DateTime[2].Type.Text")=""
+ . N GSIG S GSIG=$G(@GA@("sig"))
+ . I GSIG["|" S GSIG=$P(GSIG,"|",2) ; eRx has name of drug separated by |
+ . S GC(GM,ZI,"Description.Text")=GSIG
+ . N GD S GD="Directions.Direction" ; MAKING THE STRINGS SHORTER
+ . ;S GC(GM,ZI,GD_".DeliveryMethod.Text")="@@MEDDELIVERYMETHOD@@"
+ . ;S GC(GM,ZI,GD_".Description.Text")=""
+ . ;S GC(GM,ZI,GD_".DirectionSequenceModifier")="@@MEDDIRSEQ@@"
+ . ;S GC(GM,ZI,GD_".Dose.Rate.Units.Unit")="@@MEDRATEUNIT@@"
+ . ;S GC(GM,ZI,GD_".Dose.Rate.Value")="@@MEDRATEVALUE@@"
+ . ;S GC(GM,ZI,GD_".Dose.Units.Unit")="@@MEDDOSEUNIT@@"
+ . ;S GC(GM,ZI,GD_".Dose.Value")="@@MEDDOSEVALUE@@"
+ . ;S GC(GM,ZI,GD_".DoseIndicator.Text")="@@MEDDOSEINDICATOR@@"
+ . ;S GC(GM,ZI,GD_".Duration.Units.Unit")="@@MEDDURATIONUNIT@@"
+ . ;S GC(GM,ZI,GD_".Duration.Value")="@@MEDDURATIONVALUE@@"
+ . ;S GC(GM,ZI,GD_".Frequency.Value")="@@MEDFREQUENCYVALUE@@"
+ . ;S GC(GM,ZI,GD_".Indication.PRNFlag.Text")="@@MEDPRNFLAG@@"
+ . ;S GC(GM,ZI,GD_".Indication.Problem.CCRDataObjectID")=""
+ . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.CodingSystem")=""
+ . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Value")=""
+ . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Version")=""
+ . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Text")=""
+ . ;S GC(GM,ZI,GD_".Indication.Problem.Source.Actor.ActorID")=""
+ . ;S GC(GM,ZI,GD_".Indication.Problem.Type.Text")=""
+ . ;S GC(GM,ZI,GD_".Interval.Units.Unit")="@@MEDINTERVALUNIT@@"
+ . ;S GC(GM,ZI,GD_".Interval.Value")="@@MEDINTERVALVALUE@@"
+ . ;S GC(GM,ZI,GD_".MultipleDirectionModifier.Text")="@@MEDMULDIRMOD@@"
+ . S GC(GM,ZI,GD_".Route.Text")=$G(@GA@("doses.dose@route"))
+ . ;S GC(GM,ZI,GD_".StopIndicator.Text")="@@MEDSTOPINDICATOR@@"
+ . ;S GC(GM,ZI,GD_".Vehicle.Text")="@@MEDVEHICLETEXT@@"
+ . ;S GC(GM,ZI,"FullfillmentInstructions.Text")=""
+ . ;S GC(GM,ZI,"IDs.ID")="@@MEDRXNO@@"
+ . ;S GC(GM,ZI,"IDs.Type.Text")="@@MEDRXNOTXT@@"
+ . ;S GC(GM,ZI,"PatientInstructions.Instruction.Text")="@@MEDPTINSTRUCTIONS@@"
+ . ;S GC(GM,ZI,"Product.BrandName.Text")="@@MEDBRANDNAMETEXT@@"
+ . S GC(GM,ZI,"Product.Concentration.Units.Unit")=$G(@GA@("doses.dose@units"))
+ . S GC(GM,ZI,"Product.Concentration.Value")=$G(@GA@("doses.dose@dose"))
+ . S GC(GM,ZI,"Product.Form.Text")=$G(@GA@("form@value"))
+ . N GV S GV=$G(@GA@("products.product.vaProduct@vuid"))
+ . N GR S GR=$$RXNCUI3^C0PLKUP(GV)
+ . S GC(GM,ZI,"Product.ProductName.Code.CodingSystem")=$S(GR:"RxNorm",1:"VUID")
+ . S GC(GM,ZI,"Product.ProductName.Code.Value")=$S(GR:GR,1:GV)
+ . S GC(GM,ZI,"Product.ProductName.Code.Version")="08AB_081201F"
+ . S GC(GM,ZI,"Product.ProductName.Text")=$G(@GA@("name@value"))
+ . S GC(GM,ZI,"Product.Strength.Units.Unit")=$G(@GA@("doses.dose@units"))
+ . S GC(GM,ZI,"Product.Strength.Value")=$G(@GA@("doses.dose@dose"))
+ . ;S GC(GM,ZI,"Quantity.Units.Unit")="@@MEDQUANTITYUNIT@@"
+ . ;S GC(GM,ZI,"Quantity.Value")="@@MEDQUANTITYVALUE@@"
+ . ;S GC(GM,ZI,"Refills.Refill.Number")="@@MEDRFNO@@"
+ . N GDUZ S GDUZ=$G(@GA@("orderingProvider@code")) ;PROVIDER DUZ
+ . S GC(GM,ZI,"Source.Actor.ActorID")="PROVIDER_"_GDUZ
+ . S GC(GM,ZI,"Status.Text")=$G(@GA@("status@value"))
+ . S GC(GM,ZI,"Type.Text")="Medication"
+ N C0CDOCID
+ S C0CDOCID=$$DOMI^C0CDOM("GC",,"Medications") ; insert to dom
+ D OUTXML^C0CDOM(MEDOUTXML,C0CDOCID,1) ; render the xml
+ N ZSIZE S ZSIZE=$O(@MEDOUTXML@(""),-1)
+ S @MEDOUTXML@(0)=ZSIZE ; RETURN STATUS IS NUMBER OF LINES OF XML
+ W !,MEDOUTXML
+ ;ZWR GN
+ ;ZWR GC
+ ;B
+ Q
+ ;

ccr/branches/ohum/p/C0CNMED4.m

@@ -1 @@
-C0CMED4         ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08
-        ;;0.1;CCDCCR;;;Build 1
-        ; 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
-        ;
-        ; this routine has be adapted to retrieve meds from GET^NHINV by gpl 6/2011
-        ;
-        ; MINXML is the Input XML Template, passed by name
-        ; DFN is Patient IEN
-        ; OUTXML is the resultant XML.
-        ;
-        ; MEDS is return array from API.
-        ; MED is holds each array element from MEDS, one medicine
-        ; MAP is a mapping variable map (store result) for each med
-        ;
-        ; Inpatient Meds will be extracted using this routine and and the one following.
-        ; Inpatient Meds Unit Dose is going to be C0CMED4
-        ; Inpatient Meds IVs is going to be C0CMED5
-        ;
-        ; We will use two Pharmacy ReEnginnering API's:
-        ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info
-        ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info
-        ; For more information, see the PRE documentation at:
-        ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf
-        ; 
-        ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient
-        ;
-        N MEDS,MAP
-        ;K ^TMP($J)
-        ;D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*)
-        ;I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT  ; No Meds - Quit
-        ;; Otherwise, we go on...
-        D EN^C0CNHIN(.MEDS,DFN,"MED;") ; gpl get the NHIN Array of meds
-        I '$D(MEDS) Q  ; no meds
-        N ZI S ZI=""
-        N ZCOUNT S ZCOUNT=0
-        F  S ZI=$O(MEDS("med",ZI)) Q:ZI=""  D  ; for each returned med
-        . I $G(MEDS("med",ZI,"vaType@value"))="I" S ZCOUNT=ZCOUNT+1
-        IF ZCOUNT=0 Q  ; no inpatient meds
-        ;M MEDS=^TMP($J,"UD")
-        I DEBUG ZWR MEDS
-        S MEDMAP=$NA(^TMP("C0CCCR",$J,"MEDMAP")) 
-        ;N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array
-        N I S I=0 
-        F  S I=$O(MEDS("med",I)) Q:'I  D  ; For each medication
-        . N MED M MED=MEDS("med",I)
-        . I $G(MED("vaType@value"))'="I" Q  ; not inpatient
-        . S MEDCOUNT=MEDCOUNT+1
-        . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter
-        . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
-        . ;N RXIEN S RXIEN=MED(.01) ; Order Number
-        . N RXIEN S RXIEN=$G(MED("orderID@value")) ; ien of the med
-        . I DEBUG W "RXIEN IS ",RXIEN,!
-        . I DEBUG W "MAP= ",MAP,!
-        . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN 
-        . S @MAP@("MEDISSUEDATETXT")="Order Date"
-        . ;S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT")
-        . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($G(MED("start@value")),"DT")
-        . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient
-        . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient
-        . S @MAP@("MEDRXNOTXT")="" ; For Outpatient
-        . S @MAP@("MEDRXNO")="" ; For Outpatient
-        . S @MAP@("MEDTYPETEXT")="Medication"
-        . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
-        . ;S @MAP@("MEDSTATUSTEXT")="ACTIVE" 
-        . N C0CMST S C0CMST=$G(MED("vaStatus@value")) ; need to filter status
-        . I C0CMST="EXPIRED" S C0CMST="Prior History No Longer Active"
-        . I C0CMST="ACTIVE" S C0CMST="Active" ;
-        . S @MAP@("MEDSTATUSTEXT")=C0CMST
-        . ;S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U)
-        . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$G(MED("orderingProvider@code"))
-        . ;S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01)
-        . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))
-        . ; NDC is field 31 in the drug file.
-        . ; The actual drug entry in the drug file is not necessarily supplied.
-        . ; It' node 1, internal form.
-        . ;N MEDIEN S MEDIEN=MED(1,"I")
-        . ;S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"")
-        . N ZVUID S ZVUID=$G(MED("products.product.vaProduct@vuid")) ; VUID
-        . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
-        . D  ;
-        . . S ZC=$$CODE^C0CUTIL(ZVUID)
-        . . 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
-        . ;N ZRXNORM S ZRXNORM=""
-        . ;S ZRXNORM=$$RXNCUI3^C0PLKUP(ZVUID)
-        . S @MAP@("MEDPRODUCTNAMECODEVALUE")=ZCD
-        . ;S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"")
-        . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=ZCDS
-        . ;S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"")
-        . S @MAP@("MEDPRODUCTNAMECODEVERSION")=ZCDSV
-        . S @MAP@("MEDBRANDNAMETEXT")=""
-        . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))_" "_ZCDS_": "_ZCD
-        . ;I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE")
-        . ;I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
-        . ;S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"")
-        . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("doses.dose@dose"))
-        . ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"")
-        . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("doses.dose@units"))
-        . ; 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.
-        . ;N NDFDATA,CONCDATA
-        . ;I $L(MEDIEN) D
-        . ;. D NDF^PSS50(MEDIEN,,,,,"CONC")
-        . ;. M NDFDATA=^TMP($J,"CONC",MEDIEN)
-        . ;. N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
-        . ;. N VAPROD S VAPROD=$P(NDFDATA(22),U)
-        . ;. ; 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)
-        . ;E  S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors.
-        . ;S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"")
-        . S @MAP@("MEDFORMTEXT")=$G(MED("form@value"))
-        . ;S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"")
-        . S @MAP@("MEDCONCVALUE")=$G(MED("doses.dose@dose"))
-        . ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"")
-        . S @MAP@("MEDCONCUNIT")=$G(MED("doses.does@units"))
-        . ;S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
-        . S @MAP@("MEDQUANTITYVALUE")=$G(MED("doses.dose@unitsPerDose")) ;
-        . ; 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
-        . ;I $L(MEDIEN) 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")=$G(MED("dose.dose@unitsPerDose"))
-        . ;
-        . ; --- 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 @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
-        . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=$G(MED("sig"))
-        . ; $G(MED("products.product.vaProduct@name"))
-        . 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@("MEDPTINSTRUCTIONS","F")="52.41^105"
-        . ;S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field
-        . S @MAP@("MEDPTINSTRUCTIONS")=""
-        . ;S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
-        . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=""
-        . S @MAP@("MEDRFNO")=""
-        . 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
-        . N DIRCNT S DIRCNT=1 ; THERE ARE ALWAYS DIRECTIONS
-        . 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")
-        . D:MEDCOUNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
-        . D:MEDCOUNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE 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
-        ;
+C0CMED4         ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08
+ ;;0.1;CCDCCR;;;
+ ; 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
+ ;
+ ; this routine has be adapted to retrieve meds from GET^NHINV by gpl 6/2011
+ ;
+ ; MINXML is the Input XML Template, passed by name
+ ; DFN is Patient IEN
+ ; OUTXML is the resultant XML.
+ ;
+ ; MEDS is return array from API.
+ ; MED is holds each array element from MEDS, one medicine
+ ; MAP is a mapping variable map (store result) for each med
+ ;
+ ; Inpatient Meds will be extracted using this routine and and the one following.
+ ; Inpatient Meds Unit Dose is going to be C0CMED4
+ ; Inpatient Meds IVs is going to be C0CMED5
+ ;
+ ; We will use two Pharmacy ReEnginnering API's:
+ ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info
+ ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info
+ ; For more information, see the PRE documentation at:
+ ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf
+ ; 
+ ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient
+ ;
+ N MEDS,MAP
+ ;K ^TMP($J)
+ ;D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*)
+ ;I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT  ; No Meds - Quit
+ ;; Otherwise, we go on...
+ D EN^C0CNHIN(.MEDS,DFN,"MED;") ; gpl get the NHIN Array of meds
+ I '$D(MEDS) Q  ; no meds
+ N ZI S ZI=""
+ N ZCOUNT S ZCOUNT=0
+ F  S ZI=$O(MEDS("med",ZI)) Q:ZI=""  D  ; for each returned med
+ . I $G(MEDS("med",ZI,"vaType@value"))="I" S ZCOUNT=ZCOUNT+1
+ IF ZCOUNT=0 Q  ; no inpatient meds
+ ;M MEDS=^TMP($J,"UD")
+ I DEBUG ZWR MEDS
+ S MEDMAP=$NA(^TMP("C0CCCR",$J,"MEDMAP")) 
+ ;N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array
+ N I S I=0 
+ F  S I=$O(MEDS("med",I)) Q:'I  D  ; For each medication
+ . N MED M MED=MEDS("med",I)
+ . I $G(MED("vaType@value"))'="I" Q  ; not inpatient
+ . S MEDCOUNT=MEDCOUNT+1
+ . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter
+ . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT))
+ . ;N RXIEN S RXIEN=MED(.01) ; Order Number
+ . N RXIEN S RXIEN=$G(MED("orderID@value")) ; ien of the med
+ . I DEBUG W "RXIEN IS ",RXIEN,!
+ . I DEBUG W "MAP= ",MAP,!
+ . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN 
+ . S @MAP@("MEDISSUEDATETXT")="Order Date"
+ . ;S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT")
+ . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($G(MED("start@value")),"DT")
+ . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient
+ . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient
+ . S @MAP@("MEDRXNOTXT")="" ; For Outpatient
+ . S @MAP@("MEDRXNO")="" ; For Outpatient
+ . S @MAP@("MEDTYPETEXT")="Medication"
+ . S @MAP@("MEDDETAILUNADORNED")=""  ; Leave blank, field has its uses
+ . ;S @MAP@("MEDSTATUSTEXT")="ACTIVE" 
+ . N C0CMST S C0CMST=$G(MED("vaStatus@value")) ; need to filter status
+ . I C0CMST="EXPIRED" S C0CMST="Prior History No Longer Active"
+ . I C0CMST="ACTIVE" S C0CMST="Active" ;
+ . S @MAP@("MEDSTATUSTEXT")=C0CMST
+ . ;S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U)
+ . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$G(MED("orderingProvider@code"))
+ . ;S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01)
+ . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))
+ . ; NDC is field 31 in the drug file.
+ . ; The actual drug entry in the drug file is not necessarily supplied.
+ . ; It' node 1, internal form.
+ . ;N MEDIEN S MEDIEN=MED(1,"I")
+ . ;S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"")
+ . N ZVUID S ZVUID=$G(MED("products.product.vaProduct@vuid")) ; VUID
+ . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION
+ . D  ;
+ . . S ZC=$$CODE^C0CUTIL(ZVUID)
+ . . 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
+ . ;N ZRXNORM S ZRXNORM=""
+ . ;S ZRXNORM=$$RXNCUI3^C0PLKUP(ZVUID)
+ . S @MAP@("MEDPRODUCTNAMECODEVALUE")=ZCD
+ . ;S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"")
+ . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=ZCDS
+ . ;S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"")
+ . S @MAP@("MEDPRODUCTNAMECODEVERSION")=ZCDSV
+ . S @MAP@("MEDBRANDNAMETEXT")=""
+ . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))_" "_ZCDS_": "_ZCD
+ . ;I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE")
+ . ;I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN)
+ . ;S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"")
+ . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("doses.dose@dose"))
+ . ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"")
+ . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("doses.dose@units"))
+ . ; 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.
+ . ;N NDFDATA,CONCDATA
+ . ;I $L(MEDIEN) D
+ . ;. D NDF^PSS50(MEDIEN,,,,,"CONC")
+ . ;. M NDFDATA=^TMP($J,"CONC",MEDIEN)
+ . ;. N NDFIEN S NDFIEN=$P(NDFDATA(20),U)
+ . ;. N VAPROD S VAPROD=$P(NDFDATA(22),U)
+ . ;. ; 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)
+ . ;E  S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors.
+ . ;S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"")
+ . S @MAP@("MEDFORMTEXT")=$G(MED("form@value"))
+ . ;S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"")
+ . S @MAP@("MEDCONCVALUE")=$G(MED("doses.dose@dose"))
+ . ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"")
+ . S @MAP@("MEDCONCUNIT")=$G(MED("doses.does@units"))
+ . ;S @MAP@("MEDQUANTITYVALUE")=""  ; not provided for in Non-VA meds.
+ . S @MAP@("MEDQUANTITYVALUE")=$G(MED("doses.dose@unitsPerDose")) ;
+ . ; 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
+ . ;I $L(MEDIEN) 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")=$G(MED("dose.dose@unitsPerDose"))
+ . ;
+ . ; --- 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 @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E")
+ . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=$G(MED("sig"))
+ . ; $G(MED("products.product.vaProduct@name"))
+ . 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@("MEDPTINSTRUCTIONS","F")="52.41^105"
+ . ;S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field
+ . S @MAP@("MEDPTINSTRUCTIONS")=""
+ . ;S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field
+ . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=""
+ . S @MAP@("MEDRFNO")=""
+ . 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
+ . N DIRCNT S DIRCNT=1 ; THERE ARE ALWAYS DIRECTIONS
+ . 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")
+ . D:MEDCOUNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy
+ . D:MEDCOUNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE 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/branches/ohum/p/C0CORSLT.m

@@ -1 @@
-C0CORSLT        ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11
-        ;;1.0;C0C;;Jan 21, 2010;Build 1
-        ;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
-        ; AN EXAMPLE IS EKG RESULTS THAT ARE FOUND IN NOTES AND CONSULTS
-        ; THIS IS CREATED FOR MU CERTIFICATION BY GPL
-        D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
-        N ZN ; RESULT NUMBER
-        S ZN=$O(@ZVARS@(""),-1) ; NEXT RESULT
-        N ZI S ZI=""
-        F  S ZI=$O(VISIT(ZI)) Q:ZI=""  D  ; FOR EACH VISIT
-        . I $G(VISIT(ZI,"TEXT",1))["ECG DONE" D  ; GOT AN ECG
-        . . S ZN=ZN+1 ; INCREMENT RESULT COUNT
-        . . N ZDATE,ZPRV,ZTXT
-        . . S ZDATE=$G(VISIT(ZI,"DATE",0)) ; DATE OF PROCEDURE
-        . . S ZPRV=$P($G(VISIT(ZI,"PRV",2)),"^",1) ;PROVIDER
-        . . S ZTXT=$P($G(VISIT(ZI,"TEXT",4)),"ECG RESULTS: ",2)
-        . . S @ZVARS@(ZN,"RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT")
-        . . S @ZVARS@(ZN,"RESULTCODE")="34534-8"
-        . . S @ZVARS@(ZN,"RESULTCODINGSYSTEM")="LOINC"
-        . . S @ZVARS@(ZN,"RESULTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8"
-        . . S @ZVARS@(ZN,"RESULTOBJECTID")="RESULT"_ZN
-        . . S @ZVARS@(ZN,"RESULTSOURCEACTORID")="ACTORPROVIDER_"_ZPRV
-        . . S @ZVARS@(ZN,"RESULTSTATUS")=""
-        . . S @ZVARS@(ZN,"M","TEST",0)=1
-        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODEVALUE")="34534-8"
-        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODINGSYSTEM")="LOINC"
-        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT")
-        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8"
-        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTFLAG")=""
-        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALDESCTEXT")=""
-        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALSOURCEACTORID")="ACTORORGANIZATION_VASTANUM"
-        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTOBJECTID")="RESULTTEST_ECG_"_ZN
-        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSOURCEACTORID")="ACTORPROVIDER"_ZPRV
-        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSTATUSTEXT")="F"
-        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTUNITS")=""
-        . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTVALUE")=ZTXT
-        . . S @ZVARS@(0)=ZN ; UPDATE RESULTS COUNT
-        Q
-        ;
-OLD     ; OLD CODE FOR OTHER WAYS OF DOING THE ECG
-        ; 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
-        Q
-        ;
+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
+ ;
+EN(ZVARS,DFN) ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS
+ ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE
+ ; AN EXAMPLE IS EKG RESULTS THAT ARE FOUND IN NOTES AND CONSULTS
+ ; THIS IS CREATED FOR MU CERTIFICATION BY GPL
+ D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE
+ N ZN ; RESULT NUMBER
+ S ZN=$O(@ZVARS@(""),-1) ; NEXT RESULT
+ N ZI S ZI=""
+ F  S ZI=$O(VISIT(ZI)) Q:ZI=""  D  ; FOR EACH VISIT
+ . I $G(VISIT(ZI,"TEXT",1))["ECG DONE" D  ; GOT AN ECG
+ . . S ZN=ZN+1 ; INCREMENT RESULT COUNT
+ . . N ZDATE,ZPRV,ZTXT
+ . . S ZDATE=$G(VISIT(ZI,"DATE",0)) ; DATE OF PROCEDURE
+ . . S ZPRV=$P($G(VISIT(ZI,"PRV",2)),"^",1) ;PROVIDER
+ . . S ZTXT=$P($G(VISIT(ZI,"TEXT",4)),"ECG RESULTS: ",2)
+ . . S @ZVARS@(ZN,"RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT")
+ . . S @ZVARS@(ZN,"RESULTCODE")="34534-8"
+ . . S @ZVARS@(ZN,"RESULTCODINGSYSTEM")="LOINC"
+ . . S @ZVARS@(ZN,"RESULTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8"
+ . . S @ZVARS@(ZN,"RESULTOBJECTID")="RESULT"_ZN
+ . . S @ZVARS@(ZN,"RESULTSOURCEACTORID")="ACTORPROVIDER_"_ZPRV
+ . . S @ZVARS@(ZN,"RESULTSTATUS")=""
+ . . S @ZVARS@(ZN,"M","TEST",0)=1
+ . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODEVALUE")="34534-8"
+ . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODINGSYSTEM")="LOINC"
+ . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT")
+ . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8"
+ . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTFLAG")=""
+ . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALDESCTEXT")=""
+ . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALSOURCEACTORID")="ACTORORGANIZATION_VASTANUM"
+ . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTOBJECTID")="RESULTTEST_ECG_"_ZN
+ . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSOURCEACTORID")="ACTORPROVIDER"_ZPRV
+ . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSTATUSTEXT")="F"
+ . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTUNITS")=""
+ . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTVALUE")=ZTXT
+ . . S @ZVARS@(0)=ZN ; UPDATE RESULTS COUNT
+ Q
+ ;
+OLD ; OLD CODE FOR OTHER WAYS OF DOING THE ECG
+ ; 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
+ Q
+ ;

ccr/branches/ohum/p/C0CPARMS.m

@@ -1 @@
-C0CPARMS        ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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
-        ;OHUM/RUT commented the hardcoded limits
-        ;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
-        S @C0CPARMS@("LABLIMIT")=^TMP("C0CCCR","LABLIMIT"),@C0CPARMS@("VITLIMIT")=^TMP("C0CCCR","VITLIMIT"),@C0CPARMS@("TIULIMIT")=^TMP("C0CCCR","TIULIMIT"),@C0CPARMS@("MEDLIMIT")=^TMP("C0CCCR","MEDLIMIT")
-        I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY
-        I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY
-        I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY
-        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")=1 ; NON-PENDING NON-ACTIVE
-        ;I '$D(@C0CPARMS@("RALIMIT")) S @C0CPARMS@("RALIMIT")="T-36500" ;ONE YR WORTH
-        ;I '$D(@C0CPARMS@("RASTART")) S @C0CPARMS@("RASTART")="T" ;TODAY
-        I '$D(@C0CPARMS@("TIUSTART")) S @C0CPARMS@("TIUSTART")="T" ;TODAY
-        ;OHUM/RUT
-        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/branches/ohum/p/C0CPROBS.m

@@ -1 @@
-C0CPROBS        ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CPROC.m

@@ -1 @@
-C0CPROC  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10
-        ;;1.0;C0C;;Jan 21, 2010;Build 1
-        ;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/branches/ohum/p/C0CPXRM.m

@@ -1 @@
-C0CPXRM ; 
-DOIT    ;
-        S G="PXRMXSEPCLINIC3110302.224804" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110302.223957" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110302.223738" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110302.223516" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110302.222158" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110302.213944" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110302.212219" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110302.211506" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110302.002714" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110302.001841" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110302.000846" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110115.141918" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110115.132312" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110115.131653" ZWR ^XTMP(G,*)
-        S G="PXRMXSEPCLINIC3110115.131008" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT988 3110224.210456" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT986 3110224.210456" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT932 3110224.210456" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT932 3110224.210455" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT8015 3110301.215142" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT8015 3110301.215141" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT5265 3110309.124047" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT5265 3110309.124046" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT4742 3101129.221201" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT4742 3101129.215741" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT4710 3101129.215701" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT3297 3101127.123134" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT32495 3110224.194246" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT32493 3110224.194246" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT32354 3110224.194246" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT32354 3110224.194245" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT31106 3110224.175105" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT31090 3110224.175105" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT30339 3110224.175105" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT30339 3110224.175103" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT2761 3110115.174109" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT2761 3110115.174108" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT27327 3110227.013658" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT27327 3110227.013657" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT27327 3110227.013523" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT27327 3110227.013522" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT27253 3110227.012747" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT27253 3110227.012746" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT2559 3110115.170835" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT25549 3110228.231135" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT25549 3110228.231134" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT2205 3101129.215343" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT21092 3110114.195621" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT21092 3110114.193803" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT19640 3110226.032943" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT19640 3110226.032941" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT19353 3101212.162833" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT18780 3110221.215603" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT18156 3101212.152654" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT17800 3110315.202432" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT1650 3110220.192925" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT16110 3110313.224636" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT16004 3110317.151215" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT16004 3110317.150834" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT14955 3110315.165018" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT14816 3110315.164839" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT14816 3110315.164512" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT12415 3110315.135514" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT11797 3110315.131141" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT11573 3110315.131811" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT10728 3110114.025022" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT10578 3110114.021524" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT10243 3110114.020338" ZWR ^XTMP(G,*)
-        S G="PXRM PXK EVENT10105 3101204.230554" ZWR ^XTMP(G,*)
-        Q
-        ;
+C0CPXRM ; 
+;;;
+DOIT ;
+ S G="PXRMXSEPCLINIC3110302.224804" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110302.223957" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110302.223738" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110302.223516" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110302.222158" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110302.213944" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110302.212219" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110302.211506" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110302.002714" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110302.001841" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110302.000846" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110115.141918" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110115.132312" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110115.131653" ZWR ^XTMP(G,*)
+ S G="PXRMXSEPCLINIC3110115.131008" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT988 3110224.210456" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT986 3110224.210456" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT932 3110224.210456" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT932 3110224.210455" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT8015 3110301.215142" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT8015 3110301.215141" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT5265 3110309.124047" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT5265 3110309.124046" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT4742 3101129.221201" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT4742 3101129.215741" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT4710 3101129.215701" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT3297 3101127.123134" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT32495 3110224.194246" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT32493 3110224.194246" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT32354 3110224.194246" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT32354 3110224.194245" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT31106 3110224.175105" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT31090 3110224.175105" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT30339 3110224.175105" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT30339 3110224.175103" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT2761 3110115.174109" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT2761 3110115.174108" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT27327 3110227.013658" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT27327 3110227.013657" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT27327 3110227.013523" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT27327 3110227.013522" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT27253 3110227.012747" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT27253 3110227.012746" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT2559 3110115.170835" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT25549 3110228.231135" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT25549 3110228.231134" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT2205 3101129.215343" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT21092 3110114.195621" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT21092 3110114.193803" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT19640 3110226.032943" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT19640 3110226.032941" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT19353 3101212.162833" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT18780 3110221.215603" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT18156 3101212.152654" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT17800 3110315.202432" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT1650 3110220.192925" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT16110 3110313.224636" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT16004 3110317.151215" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT16004 3110317.150834" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT14955 3110315.165018" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT14816 3110315.164839" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT14816 3110315.164512" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT12415 3110315.135514" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT11797 3110315.131141" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT11573 3110315.131811" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT10728 3110114.025022" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT10578 3110114.021524" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT10243 3110114.020338" ZWR ^XTMP(G,*)
+ S G="PXRM PXK EVENT10105 3101204.230554" ZWR ^XTMP(G,*)
+ Q
+ ;

ccr/branches/ohum/p/C0CQRY1.m

@@ -1 @@
-LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99  13:48
-               ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 1
-               ;
-               Q
-               ;
-CHKSC     ; Check search NLT/LOINC codes
-               ;
-               N J
-               ;
-               S J=0
-               F  S J=$O(LA7SC(J)) Q:'J  D
-               . N X
-               . S X=LA7SC(J)
-               . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D  Q
-               . . S ^TMP("LA7-NLT",$J,$P(X,"^"))=""
-               . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D  Q
-               . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))=""
-               . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed"
-               . K LA7SC(J)
-               Q
-               ;
-               ;
-SPEC       ; Convert HL7 Specimen Codes to File #61, Topography codes
-               ; Find all topographies that use this HL7 specimen code
-               N J,K,L
-               ;
-               S J=0
-               F  S J=$O(LA7SPEC(J)) Q:'J  D
-               . S K=LA7SPEC(J),L=0
-               . F  S L=$O(^LAB(61,"HL7",K,L)) Q:'L  S ^TMP("LA7-61",$J,L)=""
-               Q
-               ;
-               ;
-BUILDMSG               ; Build HL7 message with result of query
-               ;
-               N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X
-               ;
-               I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&"
-               S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5)
-               S (HLQ,HL("Q"))=""""""
-               ; Set flag to not send HL7 message
-               S LA7NOMSG=1
-               ; Create dummy MSH to pass HL7 delimiters
-               S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS
-               D FILESEG^LA7VHLU(GBL,.LA7MSH)
-               ;
-               F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)=""
-               ;
-               ; Take search results and put in HL7 message structure
-               S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0
-               ; F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT  D ;change per John M
-               F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""  D  Q:LA7QUIT
-               . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q
-               . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0
-               . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR
-               . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR
-               . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR
-               . D OBX
-               ;
-               Q
-               ;
-               ;
-PID         ; Build PID segment
-               ;
-               N LA7PID
-               ;
-               S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3)
-               S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
-               D DEM^LRX
-               D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL)
-               D FILESEG^LA7VHLU(GBL,.LA7PID)
-               S (LA("LRIDT"),LA("SUB"))=""
-               Q
-               ;
-               ;
-ORC         ; Build ORC segment
-               ;
-               N X
-               ;
-               S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5)
-               S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
-               S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU"))
-               S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4)
-               I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6)
-               S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0
-               D ORC^LA7VORU
-               S LA("NLT")=""
-               ;
-               Q
-               ;
-               ;
-OBR         ; Build OBR segment
-               ;
-               N LA764,LA7NLT
-               ;
-               S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))=""
-               I $L(LA7NLT) D
-               . S LA764=+$O(^LAM("E",LA7NLT,0))
-               . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01)
-               I LA("SUB")="CH" D
-               . D OBR^LA7VORU
-               . D NTE^LA7VORU
-               . S LA7OBXSN=0
-               ;
-               Q
-               ;
-               ;
-OBX         ; Build OBX segment
-               ;
-               N LA7DATA,LA7VT
-               ;
-               S LA7NTESN=0
-               I LA("SUB")="MI" D MI^LA7VORU1 Q
-               I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q
-               ;
-               S LA7VT=$QS(LA7ROOT,7)
-               D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH)
-               I '$D(LA7DATA) Q
-               D FILESEG^LA7VHLU(GBL,.LA7DATA)
-               ; Send any test interpretation from file #60
-               D INTRP^LA7VORUA
-               ;
-               Q
+LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99  13:48
+        ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 31
+        ;
+        Q
+        ;
+CHKSC   ; Check search NLT/LOINC codes
+        ;
+        N J
+        ;
+        S J=0
+        F  S J=$O(LA7SC(J)) Q:'J  D
+        . N X
+        . S X=LA7SC(J)
+        . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D  Q
+        . . S ^TMP("LA7-NLT",$J,$P(X,"^"))=""
+        . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D  Q
+        . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))=""
+        . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed"
+        . K LA7SC(J)
+        Q
+        ;
+        ;
+SPEC    ; Convert HL7 Specimen Codes to File #61, Topography codes
+        ; Find all topographies that use this HL7 specimen code
+        N J,K,L
+        ;
+        S J=0
+        F  S J=$O(LA7SPEC(J)) Q:'J  D
+        . S K=LA7SPEC(J),L=0
+        . F  S L=$O(^LAB(61,"HL7",K,L)) Q:'L  S ^TMP("LA7-61",$J,L)=""
+        Q
+        ;
+        ;
+BUILDMSG        ; Build HL7 message with result of query
+        ;
+        N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X
+        ;
+        I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&"
+        S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5)
+        S (HLQ,HL("Q"))=""""""
+        ; Set flag to not send HL7 message
+        S LA7NOMSG=1
+        ; Create dummy MSH to pass HL7 delimiters
+        S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS
+        D FILESEG^LA7VHLU(GBL,.LA7MSH)
+        ;
+        F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)=""
+        ;
+        ; Take search results and put in HL7 message structure
+        S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0
+        ; F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT  D ;change per John M
+        F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""  D  Q:LA7QUIT
+        . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q
+        . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0
+        . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR
+        . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR
+        . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR
+        . D OBX
+        ;
+        Q
+        ;
+        ;
+PID     ; Build PID segment
+        ;
+        N LA7PID
+        ;
+        S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3)
+        S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3)
+        D DEM^LRX
+        D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL)
+        D FILESEG^LA7VHLU(GBL,.LA7PID)
+        S (LA("LRIDT"),LA("SUB"))=""
+        Q
+        ;
+        ;
+ORC     ; Build ORC segment
+        ;
+        N X
+        ;
+        S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5)
+        S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
+        S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU"))
+        S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4)
+        I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6)
+        S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0
+        D ORC^LA7VORU
+        S LA("NLT")=""
+        ;
+        Q
+        ;
+        ;
+OBR     ; Build OBR segment
+        ;
+        N LA764,LA7NLT
+        ;
+        S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))=""
+        I $L(LA7NLT) D
+        . S LA764=+$O(^LAM("E",LA7NLT,0))
+        . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01)
+        I LA("SUB")="CH" D
+        . D OBR^LA7VORU
+        . D NTE^LA7VORU
+        . S LA7OBXSN=0
+        ;
+        Q
+        ;
+        ;
+OBX     ; Build OBX segment
+        ;
+        N LA7DATA,LA7VT
+        ;
+        S LA7NTESN=0
+        I LA("SUB")="MI" D MI^LA7VORU1 Q
+        I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q
+        ;
+        S LA7VT=$QS(LA7ROOT,7)
+        D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH)
+        I '$D(LA7DATA) Q
+        D FILESEG^LA7VHLU(GBL,.LA7DATA)
+        ; Send any test interpretation from file #60
+        D INTRP^LA7VORUA
+        ;
+        Q

ccr/branches/ohum/p/C0CQRY2.m

@@ -1 @@
-LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09
-        ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994;Build 1
-        ; JMC - mods to check for IHS V LAB file
-        ;
-        Q
-        ;
-PATID   ; Resolve patient id and establish patient environment
-        ;
-        N LA7X
-        ;
-        S (DFN,LRDFN)="",LA7PTYP=0
-        ;
-        ; SSN passed as patient identifier
-        I LA7PTID?9N.1A D
-        . S LA7PTYP=1
-        . S LA7X=$O(^DPT("SSN",LA7PTID,0))
-        . I LA7X>0 D SETDFN(LA7X)
-        ;
-        ; MPI/ICN (integration control number) passed as patient identifier
-        I LA7PTID?10N1"V"6N D
-        . S LA7PTYP=2
-        . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V"))
-        . I LA7X>0 D SETDFN(LA7X)
-        ;
-        ; If no patient identified/no laboratory record - return exception message
-        I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed"
-        I 'DFN S LA7ERR(2)="No patient found with requested identifier"
-        I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient"
-        I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient"
-        Q
-        ;
-        ;
-BCD     ; Search by specimen collection date.
-        ;
-        N LA763,LA7QUIT
-        ;
-        S (LA7SDT(0),LA7EDT(0))=0
-        I LA7SDT S LA7SDT(0)=9999999-LA7SDT
-        I LA7EDT S LA7EDT(0)=9999999-LA7EDT
-        ;
-        F LRSS="CH","MI","SP" D
-        . S (LA7QUIT,LRIDT)=0
-        . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1)
-        . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT  D
-        . . ; Quit if reached end of data or outside date criteria
-        . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q
-        . . D SEARCH
-        ;
-        Q
-        ;
-        ;
-BRAD    ; Search by results available date (completion date).
-        ; Assumes cross-references still exist for dates in LRO(69) global.
-        ; Collects specimen date/time values for a given LRDFN and completion date.
-        ; Cross-reference is by date only, time stripped from start date.
-        ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)=""
-        ;
-        N LA763,LA7DT,LA7ROOT,LA7SRC,X
-        ;
-        ; Check if orders still exist Iin file #69 for search range
-        S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0
-        S X=$O(^LRO(69,LA7SDT(1)))
-        I X,X<LA7EDT(1) S LA7SRC=1
-        ;
-        ; Search "AN" cross-reference in file #69.
-        I LA7SRC D
-        . S LA7DT=LA7SDT(1)
-        . F  S LA7DT=$O(^LRO(69,LA7DT)) Q:'LA7DT!(LA7DT>LA7EDT(1))  D
-        . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")"
-        . . F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN")  D
-        . . . I $QS(LA7ROOT,6)'=LRDFN Q
-        . . . S LRIDT=$QS(LA7ROOT,7)
-        . . . F LRSS="CH","MI","SP" D SEARCH
-        ;
-        ; If no orders in #69 then do long search through file #63.
-        I 'LA7SRC D
-        . F LRSS="CH","MI","SP" D
-        . . S LRIDT=0
-        . . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT  D
-        . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
-        . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)<LA7EDT(1) D SEARCH
-        ;
-        Q
-        ;
-        ;
-SEARCH  ; Search subscript for a specific collection date/time
-        ;
-        K LA763
-        S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
-        ;
-        ; Only CH, MI, and BB subscripts store pointer to file #61 in 5th piece of zeroth node.
-        ; Quit if specific specimen codes and they do not match
-        I "CHMIBB"[LRSS S LA761=+$P(LA763(0),"^",5)
-        E  S LA761=0
-        I LA761,$D(^TMP("LA7-61",$J)),'$D(^TMP("LA7-61",$J,LA761)) Q
-        ;
-        ; --- Chemistry
-        I LRSS="CH" D CHSS Q
-        ; --- Microbiology
-        I LRSS="MI" D MISS Q
-        ; --- Surgical pathology
-        I LRSS="SP" D APSS Q
-        ; --- Cytology
-        I LRSS="CY" D APSS Q
-        ; --- Electron Micrscopsy
-        I LRSS="EM" D APSS Q
-        ; --- Autopsy
-        I LRSS="AU" D APSS Q
-        ; --- Blood Bank
-        I LRSS="BB" D BBSS Q
-        Q
-        ;
-        ;
-CHSS    ; Search "CH" datanames for matching codes
-        ;
-        N LA7X,LRSB
-        ;
-        S LRSB=1
-        F  S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB  D
-        . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
-        . I $D(^AUPNVLAB) D LNCHK^C0CLA7Q ; WV check for IHS.
-        . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761)
-        . D CHECK
-        ;
-        Q
-        ;
-        ;
-MISS    ; Search "MI" subscripts for matching codes
-        ;
-        N LA7ND,LRSB
-        ;
-        S LA7ND=0
-        F LA7ND=1,5,8,11,16 I $D(^LR(LRDFN,LRSS,LRIDT,LA7ND)) D
-        . S LRSB=$S(LA7ND=1:11,LA7ND=5:14,LA7ND=8:18,LA7ND=11:22,LA7ND=16:33,1:11)
-        . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"",LA761)
-        . D CHECK
-        Q
-        ;
-        ;
-APSS    ; Search AP subscripts for matching codes
-        ; AP results are currently not coded - use defaults
-        ;
-        N LA7CODE,LRSB
-        ;
-        S LRSB=.012
-        S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"","")
-        D CHECK
-        ;
-        Q
-        ;
-        ;
-BBSS    ; Search BB subscript for matching codes
-        ; *** This subscript currently not supported ***
-        Q
-        ;
-        ;
-CHECK   ; Check NLT order/result and LOINC codes.
-        ;
-        N LA7QUIT
-        ;
-        ; If wildcard then store
-        ; Otherwise check for specific NLT order/result and LOINC codes
-        I LA7SC="*" D STORE Q
-        S LA7QUIT=0
-        F I=1:1:3 D  Q:LA7QUIT
-        . ; If no test code then skip
-        . I '$L($P(LA7CODE,"!",I)) Q
-        . ; If test code does not match a search code then quit
-        . I '$D(^TMP($S(I=3:"LA7-LN",1:"LA7-NLT"),$J,$P(LA7CODE,"!",I))) Q
-        . D STORE S LA7QUIT=1
-        ;
-        Q
-        ;
-        ;
-STORE   ; Store entry for building in HL7 message
-        ;
-        S ^TMP("LA7-QRY",$J,LRDFN,LRIDT,LRSS,LA7CODE,LRSB)=""
-        Q
-        ;
-        ;
-SETDFN(LA7X)    ; Setup DFN and other lab variables.
-        ;
-        S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^")
-        Q
+LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09
+ ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994
+ ; JMC - mods to check for IHS V LAB file
+ ;
+ Q
+ ;
+PATID ; Resolve patient id and establish patient environment
+ ;
+ N LA7X
+ ;
+ S (DFN,LRDFN)="",LA7PTYP=0
+ ;
+ ; SSN passed as patient identifier
+ I LA7PTID?9N.1A D
+ . S LA7PTYP=1
+ . S LA7X=$O(^DPT("SSN",LA7PTID,0))
+ . I LA7X>0 D SETDFN(LA7X)
+ ;
+ ; MPI/ICN (integration control number) passed as patient identifier
+ I LA7PTID?10N1"V"6N D
+ . S LA7PTYP=2
+ . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V"))
+ . I LA7X>0 D SETDFN(LA7X)
+ ;
+ ; If no patient identified/no laboratory record - return exception message
+ I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed"
+ I 'DFN S LA7ERR(2)="No patient found with requested identifier"
+ I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient"
+ I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient"
+ Q
+ ;
+ ;
+BCD ; Search by specimen collection date.
+ ;
+ N LA763,LA7QUIT
+ ;
+ S (LA7SDT(0),LA7EDT(0))=0
+ I LA7SDT S LA7SDT(0)=9999999-LA7SDT
+ I LA7EDT S LA7EDT(0)=9999999-LA7EDT
+ ;
+ F LRSS="CH","MI","SP" D
+ . S (LA7QUIT,LRIDT)=0
+ . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1)
+ . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT  D
+ . . ; Quit if reached end of data or outside date criteria
+ . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q
+ . . D SEARCH
+ ;
+ Q
+ ;
+ ;
+BRAD ; Search by results available date (completion date).
+ ; Assumes cross-references still exist for dates in LRO(69) global.
+ ; Collects specimen date/time values for a given LRDFN and completion date.
+ ; Cross-reference is by date only, time stripped from start date.
+ ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)=""
+ ;
+ N LA763,LA7DT,LA7ROOT,LA7SRC,X
+ ;
+ ; Check if orders still exist Iin file #69 for search range
+ S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0
+ S X=$O(^LRO(69,LA7SDT(1)))
+ I X,X<LA7EDT(1) S LA7SRC=1
+ ;
+ ; Search "AN" cross-reference in file #69.
+ I LA7SRC D
+ . S LA7DT=LA7SDT(1)
+ . F  S LA7DT=$O(^LRO(69,LA7DT)) Q:'LA7DT!(LA7DT>LA7EDT(1))  D
+ . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")"
+ . . F  S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN")  D
+ . . . I $QS(LA7ROOT,6)'=LRDFN Q
+ . . . S LRIDT=$QS(LA7ROOT,7)
+ . . . F LRSS="CH","MI","SP" D SEARCH
+ ;
+ ; If no orders in #69 then do long search through file #63.
+ I 'LA7SRC D
+ . F LRSS="CH","MI","SP" D
+ . . S LRIDT=0
+ . . F  S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT  D
+ . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
+ . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)<LA7EDT(1) D SEARCH
+ ;
+ Q
+ ;
+ ;
+SEARCH ; Search subscript for a specific collection date/time
+ ;
+ K LA763
+ S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
+ ;
+ ; Only CH, MI, and BB subscripts store pointer to file #61 in 5th piece of zeroth node.
+ ; Quit if specific specimen codes and they do not match
+ I "CHMIBB"[LRSS S LA761=+$P(LA763(0),"^",5)
+ E  S LA761=0
+ I LA761,$D(^TMP("LA7-61",$J)),'$D(^TMP("LA7-61",$J,LA761)) Q
+ ;
+ ; --- Chemistry
+ I LRSS="CH" D CHSS Q
+ ; --- Microbiology
+ I LRSS="MI" D MISS Q
+ ; --- Surgical pathology
+ I LRSS="SP" D APSS Q
+ ; --- Cytology
+ I LRSS="CY" D APSS Q
+ ; --- Electron Micrscopsy
+ I LRSS="EM" D APSS Q
+ ; --- Autopsy
+ I LRSS="AU" D APSS Q
+ ; --- Blood Bank
+ I LRSS="BB" D BBSS Q
+ Q
+ ;
+ ;
+CHSS ; Search "CH" datanames for matching codes
+ ;
+ N LA7X,LRSB
+ ;
+ S LRSB=1
+ F  S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB  D
+ . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
+ . I $D(^AUPNVLAB) D LNCHK^C0CLA7Q ; WV check for IHS.
+ . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761)
+ . D CHECK
+ ;
+ Q
+ ;
+ ;
+MISS ; Search "MI" subscripts for matching codes
+ ;
+ N LA7ND,LRSB
+ ;
+ S LA7ND=0
+ F LA7ND=1,5,8,11,16 I $D(^LR(LRDFN,LRSS,LRIDT,LA7ND)) D
+ . S LRSB=$S(LA7ND=1:11,LA7ND=5:14,LA7ND=8:18,LA7ND=11:22,LA7ND=16:33,1:11)
+ . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"",LA761)
+ . D CHECK
+ Q
+ ;
+ ;
+APSS ; Search AP subscripts for matching codes
+ ; AP results are currently not coded - use defaults
+ ;
+ N LA7CODE,LRSB
+ ;
+ S LRSB=.012
+ S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"","")
+ D CHECK
+ ;
+ Q
+ ;
+ ;
+BBSS ; Search BB subscript for matching codes
+ ; *** This subscript currently not supported ***
+ Q
+ ;
+ ;
+CHECK ; Check NLT order/result and LOINC codes.
+ ;
+ N LA7QUIT
+ ;
+ ; If wildcard then store
+ ; Otherwise check for specific NLT order/result and LOINC codes
+ I LA7SC="*" D STORE Q
+ S LA7QUIT=0
+ F I=1:1:3 D  Q:LA7QUIT
+ . ; If no test code then skip
+ . I '$L($P(LA7CODE,"!",I)) Q
+ . ; If test code does not match a search code then quit
+ . I '$D(^TMP($S(I=3:"LA7-LN",1:"LA7-NLT"),$J,$P(LA7CODE,"!",I))) Q
+ . D STORE S LA7QUIT=1
+ ;
+ Q
+ ;
+ ;
+STORE ; Store entry for building in HL7 message
+ ;
+ S ^TMP("LA7-QRY",$J,LRDFN,LRIDT,LRSS,LA7CODE,LRSB)=""
+ Q
+ ;
+ ;
+SETDFN(LA7X) ; Setup DFN and other lab variables.
+ ;
+ S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^")
+ Q

ccr/branches/ohum/p/C0CRIMA.m

@@ -1 @@
-C0CRIMA   ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CRNF.m

@@ -1 @@
-C0CRNF    ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CRNFRP.m

@@ -1 @@
-C0CRNFRPC         ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09
-        ;;1.0;C0C;;Dec 9, 2009;Build 1
-        ;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) RPC Library ",!
-        W !
-        Q
-        ;
-        ;This routine will be mirroring C0CRNF and transform the output
-        ;of the tags into an RPC friendly format
-        ;The tags will be exactly as they are in C0CRNF
-FIELDS(C0CFRTN,C0CFILE) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF,
-        ;C0CFRTN IS PASSED BY REFERENCE, C0CF IS PASSED BY VALUE
-        ;RETURN FORMAT:
-        ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS
-        ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER"
-        ;
-        ;SAMPLE OUTPUT FROM FIELDS^C0CRNF:
-        ;C0CRNFFIELDS("*AMOUNT OF MILITARY RETIREMENT")="2^.3625"
-        ;
-        ;FORMAT APPEARS TO BE:
-        ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER"
-        ;
-        ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON
-        S DEBUG=0
-        ;SET RETURN VALUE
-        S C0CFRTN=$NA(^TMP("C0CRNF",$J))
-        K @C0CFRTN
-        ;RUN WRAPPED CALL
-        D FIELDS^C0CRNF("C0CRTN",C0CFILE)
-        S J=""
-        S I=1
-        ;FORMAT RETURN
-        F  S J=$O(C0CRTN(J)) Q:J=""  D  ; FOR EACH FIELD IN THE ARRAY
-        . S @C0CFRTN@(I)=J_"^"_C0CRTN(J)
-        . S I=I+1
-        S @C0CFRTN@(0)=I-1
-        ;CLEAN UP
-        K J,I
-        Q
-        ;
-GETNOLD(GRTN,GFILE,GIEN,GNN)    ; GET FIELDS FOR ACCESS BY NAME
-        ; GRTN IS PASSED BY NAME
-        ;
-        ; OLD TAG DO NOT USE!
-        Q
-        ;
-GETN(C0CGRTN,GFILE,GREF,GNDX,GNN)       ; GET BY NAME ; RETURN A FIELD VALUE MAP
-        ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
-        ; 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
-        ; .. 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
-        ; .. NULL 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
-        ;
-        ;
-        ;RETURN FORMAT:
-        ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS^FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ_$C(30)"
-        ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER^VALUE^INTERNAL_VALUE_$C(30)"
-        ;
-        ;SAMPLE OUTPUT FROM FIELDS^C0CRNF:
-        ;C0CRNFGETN(0)="2^RNF1^5095^3091209^2908^3268"
-        ;C0CRNFGETN("1U4N")="2^.0905^H5369"
-        ;C0CRNFGETN("1U4N","I")="^^H5369"
-        ;C0CRNFGETN("ADDRESS CHANGE DT/TM")="2^.118^OCT 21,2009@08:03:26"
-        ;C0CRNFGETN("ADDRESS CHANGE DT/TM","I")="^^3091021.080326"
-        ;
-        ;FORMAT APPEARS TO BE:
-        ;VARIABLENAME(0)="FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ"
-        ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER^VALUE"
-        ;VARIABLENAME("FIELD_NAME","I")="^^INTERNAL_VALUE"
-        ;
-        ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON
-        S DEBUG=0
-        ;SET RETURN VALUE
-        S C0CGRTN=$NA(^TMP("C0CRNF",$J))
-        K @C0CGRTN
-        ;RUN WRAPPED CALL
-        D GETN^C0CRNF("C0CRTN",$G(GFILE),$G(GREF),$G(GNDX),$G(GNN))
-        S J=""
-        S I=1
-        ;FORMAT RETURN
-        F  S J=$O(C0CRTN(J)) Q:J=""  D  ; FOR EACH FIELD IN THE ARRAY
-        . I J=0 S J=$O(C0CRTN(J)) ; SKIP THE 0 NODE
-        . S @C0CGRTN@(I)=J_"^"_C0CRTN(J)_"^" ; GETS THE FIRST LINE
-        . ;S J=$O(C0CRTN(J)) ; INCREMENT J SO WE CAN GET THE INTERNAL DATA
-        . ;TEST TO SEE IF INTERNAL DATA EXISTS
-        . I $D(C0CRTN(J,"I"))=1 D
-        . . S @C0CGRTN@(I)=@C0CGRTN@(I)_$P(C0CRTN(J,"I"),U,3) ; GETS THE INTERNAL VALUE PIECE 3
-        . S I=I+1
-        S @C0CGRTN@(0)=I-1_"^"_C0CRTN(0)
-        ;CLEAN UP
-        K J,I
-        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^GPLXPATH(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^GPLXPATH(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="""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^GPLXPATH(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 RNX=RNX_""""_@RNR@(RNI,RNJ,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^GPLXPATH(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^GPLXPATH($NA(@FOARY@(1)),FONAM,^TMP("GPLCCR","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
-        ;
-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)
-        ;
+C0CRNFRPC   ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09
+ ;;1.0;C0C;;Dec 9, 2009;
+ ;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) RPC Library ",!
+ W !
+ Q
+ ;
+ ;This routine will be mirroring C0CRNF and transform the output
+ ;of the tags into an RPC friendly format
+ ;The tags will be exactly as they are in C0CRNF
+FIELDS(C0CFRTN,C0CFILE) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF,
+ ;C0CFRTN IS PASSED BY REFERENCE, C0CF IS PASSED BY VALUE
+ ;RETURN FORMAT:
+ ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS
+ ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER"
+ ;
+ ;SAMPLE OUTPUT FROM FIELDS^C0CRNF:
+ ;C0CRNFFIELDS("*AMOUNT OF MILITARY RETIREMENT")="2^.3625"
+ ;
+ ;FORMAT APPEARS TO BE:
+ ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER"
+ ;
+ ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON
+ S DEBUG=0
+ ;SET RETURN VALUE
+ S C0CFRTN=$NA(^TMP("C0CRNF",$J))
+ K @C0CFRTN
+ ;RUN WRAPPED CALL
+ D FIELDS^C0CRNF("C0CRTN",C0CFILE)
+ S J=""
+ S I=1
+ ;FORMAT RETURN
+ F  S J=$O(C0CRTN(J)) Q:J=""  D  ; FOR EACH FIELD IN THE ARRAY
+ . S @C0CFRTN@(I)=J_"^"_C0CRTN(J)
+ . S I=I+1
+ S @C0CFRTN@(0)=I-1
+ ;CLEAN UP
+ K J,I
+ Q
+ ;
+GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME
+ ; GRTN IS PASSED BY NAME
+ ;
+ ; OLD TAG DO NOT USE!
+ Q
+ ;
+GETN(C0CGRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP
+ ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL
+ ; 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
+ ; .. 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
+ ; .. NULL 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
+ ;
+ ;
+ ;RETURN FORMAT:
+ ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS^FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ_$C(30)"
+ ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER^VALUE^INTERNAL_VALUE_$C(30)"
+ ;
+ ;SAMPLE OUTPUT FROM FIELDS^C0CRNF:
+ ;C0CRNFGETN(0)="2^RNF1^5095^3091209^2908^3268"
+ ;C0CRNFGETN("1U4N")="2^.0905^H5369"
+ ;C0CRNFGETN("1U4N","I")="^^H5369"
+ ;C0CRNFGETN("ADDRESS CHANGE DT/TM")="2^.118^OCT 21,2009@08:03:26"
+ ;C0CRNFGETN("ADDRESS CHANGE DT/TM","I")="^^3091021.080326"
+ ;
+ ;FORMAT APPEARS TO BE:
+ ;VARIABLENAME(0)="FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ"
+ ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER^VALUE"
+ ;VARIABLENAME("FIELD_NAME","I")="^^INTERNAL_VALUE"
+ ;
+ ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON
+ S DEBUG=0
+ ;SET RETURN VALUE
+ S C0CGRTN=$NA(^TMP("C0CRNF",$J))
+ K @C0CGRTN
+ ;RUN WRAPPED CALL
+ D GETN^C0CRNF("C0CRTN",$G(GFILE),$G(GREF),$G(GNDX),$G(GNN))
+ S J=""
+ S I=1
+ ;FORMAT RETURN
+ F  S J=$O(C0CRTN(J)) Q:J=""  D  ; FOR EACH FIELD IN THE ARRAY
+ . I J=0 S J=$O(C0CRTN(J)) ; SKIP THE 0 NODE
+ . S @C0CGRTN@(I)=J_"^"_C0CRTN(J)_"^" ; GETS THE FIRST LINE
+ . ;S J=$O(C0CRTN(J)) ; INCREMENT J SO WE CAN GET THE INTERNAL DATA
+ . ;TEST TO SEE IF INTERNAL DATA EXISTS
+ . I $D(C0CRTN(J,"I"))=1 D
+ . . S @C0CGRTN@(I)=@C0CGRTN@(I)_$P(C0CRTN(J,"I"),U,3) ; GETS THE INTERNAL VALUE PIECE 3
+ . S I=I+1
+ S @C0CGRTN@(0)=I-1_"^"_C0CRTN(0)
+ ;CLEAN UP
+ K J,I
+ 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^GPLXPATH(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^GPLXPATH(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="""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^GPLXPATH(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 RNX=RNX_""""_@RNR@(RNI,RNJ,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^GPLXPATH(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^GPLXPATH($NA(@FOARY@(1)),FONAM,^TMP("GPLCCR","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
+ ;
+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/branches/ohum/p/C0CRPMS.m

@@ -1 @@
-C0CRPMS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR RPMS ;1/14/09  14:33
-        ;;0.1;CCDCCR;;JUL 16,2008;Build 1
-        ;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 FROM TOP",!
-        Q
-        ;
-DISPLAY ; RUN THE PCC DISPLAY ROUTINE
-        D ^APCDDISP
-        Q
-        ;
-VTYPES  ;
-        D GETN2^C0CRNF("G1",9999999.07)
-        ZWR G1
-        Q
-        ;
-VISITS(C0CDFN,C0CCNT)   ;LIST VISIT DATES FOR PATIENT DFN
-        ; C0CCNT IS A LIMIT ON HOW MANY VISITS TO DISPLAY ; DEFAULTS TO ALL
-        I '$D(C0CCNT) S C0CCNT=999999999
-        N G,GN
-        S G="" S GN=0
-        F  S G=$O(^AUPNVSIT("AA",C0CDFN,G)) Q:(G="")!(GN>C0CCNT)  D  ;
-        . S GN=GN+1
-        . W $$FMDTOUTC^C0CUTIL(9999999-G),!
-        Q
-        ;
-VISITS2(C0CDFN,C0CCNT)  ;SECOND VERSION USING NEXTV
-        ;
-        N C0CG,GN
-        S C0CG=""
-        S GN=0
-        I '$D(C0CCNT) S C0CCNT=99999999
-        F  S C0CG=$$NEXTV(C0CDFN,C0CG) Q:(C0CG="")!(GN'<C0CCNT)  D  ;
-        . S GN=GN+1
-        . W $$FMDTOUTC^C0CUTIL(C0CG),!
-        Q
-        ;
-NEXTV(C0CDFN,C0CVDT)    ;EXTRINSIC WHICH RETURNS THE NEXT VISIT DATE
-        ;FOR PATIENT C0CDFN IN REVERSE TIME ORDER; PASS "" TO GET THE MOST
-        ; RECENT VISIT
-        N G
-        S G=C0CVDT
-        I G'="" S G=9999999-C0CVDT ;INVERT FOR INDEX
-        S G=$O(^AUPNVSIT("AA",C0CDFN,G))
-        I G="" Q ""
-        E  Q 9999999-G
-        ;
-GETV(C0CDFN,C0CVDT)     ; GET VISIT USING DATE C0CVDT . IF C0CVDT IS NULL,
-        ; GET MOST RECENT VISIT
-        N C0CG
-        I '$D(C0CVDT) S C0CVDT=$$NEXTV(C0CDFN,"")
-        S APCDVLDT=C0CVDT
-        S APCDPAT=C0CDFN
-        D ^APCDVLK
-        D ^APCDVD
-        ;K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE
-        Q
-        ;
-GETNV(C0CDFN)   ;GET MANY VISITS
-        ;
-        S APCDPAT=C0CDFN ;
-        N C0CG S C0CG=""
-        F  S C0CG=$$NEXTV(C0CDFN,C0CG) Q:C0CG=""  D  ; LOOP BACKWARD THROUGH VISITS
-        . W C0CG,"    ",$$FMDTOUTC^C0CUTIL(C0CG),!
-        . S APCDVLDT=C0CG
-        . D ^APCDVLK
-        . D ^APCDVD
-        . K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE
-        Q
-        ;
-GETTBL(C0CTBL)  ; SCAN FOR AND DISPLAY PATIENTS IN A RIMTBL, PASSED BY VALUE
-        ;
-        N ZG S ZG=$NA(^TMP("GPLRIM","RIMTBL","PATS",C0CTBL))
-        N C0CG S C0CG=""
-        N C0CQ S C0CQ=0
-        F  S C0CG=$O(@ZG@(C0CG),-1) Q:(C0CG="")  D  ;
-        . W "PAT: ",C0CG,!
-        . D GETNV^C0CRPMS(C0CG)
-        . K X R X
-        . I X="Q" S C0CQ=1 ; QUIT IF Q
-        Q
-        ;
-CMPDRG  ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES
-        ;
-        S C0CZI=0 ;
-        F  S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI=""  D  ;ALL DRUGS IN RPMS DRUG FILE
-        . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE
-        . ;W "C0CZI:",C0CZI
-        . F  S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ=""  D  ;
-        . . ;W " C0CZJ:",C0CZJ
-        . . N C0CZN,C0CZV ;
-        . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE
-        . . ;W " C0CZN:",C0CZN,!
-        . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF
-        . . I $D(C0CZV) D  ;FOUND A MATCH
-        . . . S C0CVO="FOUND:^"_C0CZI_"^"_C0CZJ_"^"_C0CZN
-        . . . S C0CVO=C0CVO_"^RXNORM:^"_$$ZVALUE^C0CRNF("MEDIATION CODE","C0CZV")
-        . . . D PUSH^GPLXPATH("^C0CZRX",C0CVO)
-        . . . W C0CVO,!
-        Q
-        ;
-CMPDRG2 ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES
-        ;
-        S C0CZI=0 ;
-        F  S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI=""  D  ;ALL DRUGS IN RPMS DRUG FILE
-        . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE
-        . W "C0CZI:",C0CZI
-        . F  S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ=""  D  ;
-        . . W " C0CZJ:",C0CZJ
-        . . N C0CZN,C0CZV ;
-        . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE
-        . . W " C0CZN:",C0CZN,!
-        . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF
-        . . I $D(C0CZV) D  ;FOUND A MATCH
-        . . . W "FOUND: ",C0CZI," ",C0CZJ," ",C0CZN
-        . . . W " VUID:",$$ZVALUE^C0CRNF("VUID","C0CZV"),!
-        Q
-        ;
+C0CRPMS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR RPMS ;1/14/09  14:33
+ ;;0.1;CCDCCR;;JUL 16,2008;Build 7
+ ;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 FROM TOP",!
+ Q
+ ;
+DISPLAY ; RUN THE PCC DISPLAY ROUTINE
+ D ^APCDDISP
+ Q
+ ;
+VTYPES ;
+ D GETN2^C0CRNF("G1",9999999.07)
+ ZWR G1
+ Q
+ ;
+VISITS(C0CDFN,C0CCNT) ;LIST VISIT DATES FOR PATIENT DFN
+ ; C0CCNT IS A LIMIT ON HOW MANY VISITS TO DISPLAY ; DEFAULTS TO ALL
+ I '$D(C0CCNT) S C0CCNT=999999999
+ N G,GN
+ S G="" S GN=0
+ F  S G=$O(^AUPNVSIT("AA",C0CDFN,G)) Q:(G="")!(GN>C0CCNT)  D  ;
+ . S GN=GN+1
+ . W $$FMDTOUTC^C0CUTIL(9999999-G),!
+ Q
+ ;
+VISITS2(C0CDFN,C0CCNT) ;SECOND VERSION USING NEXTV
+ ;
+ N C0CG,GN
+ S C0CG=""
+ S GN=0
+ I '$D(C0CCNT) S C0CCNT=99999999
+ F  S C0CG=$$NEXTV(C0CDFN,C0CG) Q:(C0CG="")!(GN'<C0CCNT)  D  ;
+ . S GN=GN+1
+ . W $$FMDTOUTC^C0CUTIL(C0CG),!
+ Q
+ ;
+NEXTV(C0CDFN,C0CVDT) ;EXTRINSIC WHICH RETURNS THE NEXT VISIT DATE
+ ;FOR PATIENT C0CDFN IN REVERSE TIME ORDER; PASS "" TO GET THE MOST
+ ; RECENT VISIT
+ N G
+ S G=C0CVDT
+ I G'="" S G=9999999-C0CVDT ;INVERT FOR INDEX
+ S G=$O(^AUPNVSIT("AA",C0CDFN,G))
+ I G="" Q ""
+ E  Q 9999999-G
+ ;
+GETV(C0CDFN,C0CVDT) ; GET VISIT USING DATE C0CVDT . IF C0CVDT IS NULL,
+ ; GET MOST RECENT VISIT
+ N C0CG
+ I '$D(C0CVDT) S C0CVDT=$$NEXTV(C0CDFN,"")
+ S APCDVLDT=C0CVDT
+ S APCDPAT=C0CDFN
+ D ^APCDVLK
+ D ^APCDVD
+ ;K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE
+ Q
+ ;
+GETNV(C0CDFN) ;GET MANY VISITS
+ ;
+ S APCDPAT=C0CDFN ;
+ N C0CG S C0CG=""
+ F  S C0CG=$$NEXTV(C0CDFN,C0CG) Q:C0CG=""  D  ; LOOP BACKWARD THROUGH VISITS
+ . W C0CG,"    ",$$FMDTOUTC^C0CUTIL(C0CG),!
+ . S APCDVLDT=C0CG
+ . D ^APCDVLK
+ . D ^APCDVD
+ . K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE
+ Q
+ ;
+GETTBL(C0CTBL) ; SCAN FOR AND DISPLAY PATIENTS IN A RIMTBL, PASSED BY VALUE
+ ;
+ N ZG S ZG=$NA(^TMP("GPLRIM","RIMTBL","PATS",C0CTBL))
+ N C0CG S C0CG=""
+ N C0CQ S C0CQ=0
+ F  S C0CG=$O(@ZG@(C0CG),-1) Q:(C0CG="")  D  ;
+ . W "PAT: ",C0CG,!
+ . D GETNV^C0CRPMS(C0CG)
+ . K X R X
+ . I X="Q" S C0CQ=1 ; QUIT IF Q
+ Q
+ ;
+CMPDRG ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES
+ ;
+ S C0CZI=0 ;
+ F  S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI=""  D  ;ALL DRUGS IN RPMS DRUG FILE
+ . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE
+ . ;W "C0CZI:",C0CZI
+ . F  S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ=""  D  ;
+ . . ;W " C0CZJ:",C0CZJ
+ . . N C0CZN,C0CZV ;
+ . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE
+ . . ;W " C0CZN:",C0CZN,!
+ . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF
+ . . I $D(C0CZV) D  ;FOUND A MATCH
+ . . . S C0CVO="FOUND:^"_C0CZI_"^"_C0CZJ_"^"_C0CZN
+ . . . S C0CVO=C0CVO_"^RXNORM:^"_$$ZVALUE^C0CRNF("MEDIATION CODE","C0CZV")
+ . . . D PUSH^GPLXPATH("^C0CZRX",C0CVO)
+ . . . W C0CVO,!
+ Q
+ ;
+CMPDRG2 ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES
+ ;
+ S C0CZI=0 ;
+ F  S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI=""  D  ;ALL DRUGS IN RPMS DRUG FILE
+ . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE
+ . W "C0CZI:",C0CZI
+ . F  S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ=""  D  ;
+ . . W " C0CZJ:",C0CZJ
+ . . N C0CZN,C0CZV ;
+ . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE
+ . . W " C0CZN:",C0CZN,!
+ . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF
+ . . I $D(C0CZV) D  ;FOUND A MATCH
+ . . . W "FOUND: ",C0CZI," ",C0CZJ," ",C0CZN
+ . . . W " VUID:",$$ZVALUE^C0CRNF("VUID","C0CZV"),!
+ Q
+ ;

ccr/branches/ohum/p/C0CRXN.m

@@ -1 @@
-C0CRXN    ; CCDCCR/GPL - CCR RXN utilities; 12/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CRXNRD.m

@@ -1 @@
-C0CRXNRD        ; WV/SMH - CCR/CCD PROJECT: Routine to Read RxNorm files;11/15/08
-        ;;0.1;C0C;nopatch;noreleasedate;Build 1
-        W "No entry from top" Q
-IMPORT(PATH)    
-        I PATH="" QUIT
-        D READSRC(PATH),READCON(PATH),READNDC(PATH)
-        QUIT
-        ;
-DELFILED(FN)    ; Delete file data; PEP procedure; only for RxNorm files
-        ; FN is Filenumber passed by Value
-        QUIT:$E(FN,1,3)'=176  ; Quit if not RxNorm files
-        D CLEAN^DILF ; Clean FM variables
-        N ROOT S ROOT=$$ROOT^DILFD(FN,"",1) ; global root
-        N ZERO S ZERO=@ROOT@(0) ; Save zero node
-        S $P(ZERO,U,3,9999)="" ; Remove entry # and last edited
-        K @ROOT ; Kill the file -- so sad!
-        S @ROOT@(0)=ZERO ; It riseth again!
-        QUIT
-GETLINES(PATH,FILENAME) ; Get number of lines in a file
-        D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
-        U IO
-        N I
-        F I=1:1 R LINE Q:$$STATUS^%ZISH
-        D CLOSE^%ZISH("FILE")
-        Q I-1
-READCON(PATH,INCRES)    ; Open and read concepts file: RXNCONSO.RRF; EP
-        ; PATH ByVal, path of RxNorm files
-        ; INCRES ByVal, include restricted sources. 1 for yes, 0 for no
-        I PATH="" QUIT
-        S INCRES=+$G(INCRES) ; if not passed, becomes zero.
-        N FILENAME S FILENAME="RXNCONSO.RRF"
-        D DELFILED(176.001) ; delete data
-        N LINES S LINES=$$GETLINES(PATH,FILENAME)
-        D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
-        IF POP D EN^DDIOL("Error reading file..., Please check...") G EX
-        N C0CCOUNT
-        F C0CCOUNT=1:1 D  Q:$$STATUS^%ZISH
-        . U IO
-        . N LINE R LINE
-        . IF $$STATUS^%ZISH QUIT
-        . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
-        . N RXCUI,RXAUI,SAB,TTY,CODE,STR  ; Fileman fields numbers below
-        . S RXCUI=$P(LINE,"|",1)        ; .01
-        . S RXAUI=$P(LINE,"|",8)        ; 1
-        . S SAB=$P(LINE,"|",12) ; 2
-        . ; If the source is a restricted source, decide what to do based on what's asked.
-        . N SRCIEN S SRCIEN=$$FIND1^DIC(176.003,"","QX",SAB,"B") ; SrcIEN in RXNORM SOURCES file
-        . N RESTRIC S RESTRIC=$$GET1^DIQ(176.003,SRCIEN,14,"I") ; 14 is restriction field; values 0-4
-        . ; If RESTRIC is zero, then it's unrestricted. Everything else is restricted.
-        . ; If user didn't ask to include restricted sources, and the source is restricted, then quit
-        . I 'INCRES,RESTRIC QUIT
-        . S TTY=$P(LINE,"|",13) ; 3
-        . S CODE=$P(LINE,"|",14)        ; 4
-        . S STR=$P(LINE,"|",15) ; 5
-        . ; Remove embedded "^"
-        . S STR=$TR(STR,"^")
-        . ; Convert STR into an array of 80 characters on each line
-        . N STRLINE S STRLINE=$L(STR)\80+1
-        . ; In each line, chop 80 characters off, reset STR to be the rest
-        . N J F J=1:1:STRLINE S STR(J)=$E(STR,1,80) S STR=$E(STR,81,$L(STR))
-        . ; Now, construct the FDA array
-        . N RXNFDA
-        . S RXNFDA(176.001,"+1,",.01)=RXCUI
-        . S RXNFDA(176.001,"+1,",1)=RXAUI
-        . S RXNFDA(176.001,"+1,",2)=SAB
-        . S RXNFDA(176.001,"+1,",3)=TTY
-        . S RXNFDA(176.001,"+1,",4)=CODE
-        . N RXNIEN S RXNIEN(1)=C0CCOUNT
-        . D UPDATE^DIE("","RXNFDA","RXNIEN")
-        . I $D(^TMP("DIERR",$J)) D EN^DDIOL("ERROR") G EX
-        . ; Now, file WP field STR
-        . D WP^DIE(176.001,C0CCOUNT_",",5,,$NA(STR))
-EX      D CLOSE^%ZISH("FILE")
-        QUIT
-READNDC(PATH)   ; Open and read NDC/RxNorm/VANDF relationship file: RXNSAT.RRF
-        I PATH="" QUIT
-        N FILENAME S FILENAME="RXNSAT.RRF"
-        D DELFILED(176.002) ; delete data
-        N LINES S LINES=$$GETLINES(PATH,FILENAME)
-        D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
-        IF POP W "Error reading file..., Please check...",! G EX2
-        F C0CCOUNT=1:1 Q:$$STATUS^%ZISH  D
-        . U IO
-        . N LINE R LINE
-        . IF $$STATUS^%ZISH QUIT
-        . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
-        . IF LINE'["NDC|RXNORM"  QUIT
-        . ; Otherwise, we are good to go
-        . N RXCUI,NDC ; Fileman fields below
-        . S RXCUI=$P(LINE,"|",1)        ; .01
-        . S NDC=$P(LINE,"|",11) ; 2
-        . ; Using classic call to update.
-        . N DIC,X,DA,DR
-        . K DO
-        . S DIC="^C0CRXN(176.002,",DIC(0)="F",X=RXCUI,DIC("DR")="2////"_NDC
-        . D FILE^DICN
-        . I Y<1 U $P W !,"THERE IS TROUBLE IN RIVER CITY",! G EX2
-EX2     D CLOSE^%ZISH("FILE")
-        QUIT
-READSRC(PATH)   ; Open the read RxNorm Sources file: RXNSAB.RRF
-        I PATH="" QUIT
-        N FILENAME S FILENAME="RXNSAB.RRF"
-        D DELFILED(176.003) ; delete data
-        D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
-        IF POP W "Error reading file..., Please check...",! G EX3
-        F I=1:1 Q:$$STATUS^%ZISH  D
-        . U IO
-        . N LINE R LINE
-        . IF $$STATUS^%ZISH QUIT
-        . U $P W I,! U IO  ; Write I to the screen, then go back to reading the file
-        . N VCUI,RCUI,VSAB,RSAB,SON,SF,SVER,SRL,SCIT ; Fileman fields numbers below
-        . S VCUI=$P(LINE,"|",1)        ; .01
-        . S RCUI=$P(LINE,"|",2)        ; 2
-        . S VSAB=$P(LINE,"|",3)        ; 3
-        . S RSAB=$P(LINE,"|",4)        ; 4
-        . S SON=$P(LINE,"|",5)         ; 5
-        . S SF=$P(LINE,"|",6)          ; 6
-        . S SVER=$P(LINE,"|",7)        ; 7
-        . S SRL=$P(LINE,"|",14)         ; 14
-        . S SCIT=$P(LINE,"|",25)       ; 25
-        . ; Remove embedded "^"
-        . S SCIT=$TR(SCIT,"^")
-        . ; Convert SCIT into an array of 80 characters on each line
-        . ; In each line, chop 80 characters off, reset SCIT to be the rest
-        . N SCITLINE S SCITLINE=$L(SCIT)\80+1
-        . F J=1:1:SCITLINE S SCIT(J)=$E(SCIT,1,80) S SCIT=$E(SCIT,81,$L(SCIT))
-        . ; Now, construct the FDA array
-        . N RXNFDA
-        . S RXNFDA(176.003,"+"_I_",",.01)=VCUI
-        . S RXNFDA(176.003,"+"_I_",",2)=RCUI
-        . S RXNFDA(176.003,"+"_I_",",3)=VSAB
-        . S RXNFDA(176.003,"+"_I_",",4)=RSAB
-        . S RXNFDA(176.003,"+"_I_",",5)=SON
-        . S RXNFDA(176.003,"+"_I_",",6)=SF
-        . S RXNFDA(176.003,"+"_I_",",7)=SVER
-        . S RXNFDA(176.003,"+"_I_",",14)=SRL
-        . D UPDATE^DIE("","RXNFDA")
-        . I $D(^TMP("DIERR",$J)) U $P W "ERR" G EX
-        . ; Now, file WP field SCIT
-        . D WP^DIE(176.003,I_",",25,,$NA(SCIT))
-EX3     D CLOSE^%ZISH("FILE")
-        Q
-        
+C0CRXNRD ; WV/SMH - CCR/CCD PROJECT: Routine to Read RxNorm files;11/15/08
+ ;;0.1;C0C;nopatch;noreleasedate
+ W "No entry from top" Q
+IMPORT(PATH)
+ I PATH="" QUIT
+ D READSRC(PATH),READCON(PATH),READNDC(PATH)
+ QUIT
+ ;
+DELFILED(FN) ; Delete file data; PEP procedure; only for RxNorm files
+ ; FN is Filenumber passed by Value
+ QUIT:$E(FN,1,3)'=176  ; Quit if not RxNorm files
+ D CLEAN^DILF ; Clean FM variables
+ N ROOT S ROOT=$$ROOT^DILFD(FN,"",1) ; global root
+ N ZERO S ZERO=@ROOT@(0) ; Save zero node
+ S $P(ZERO,U,3,9999)="" ; Remove entry # and last edited
+ K @ROOT ; Kill the file -- so sad!
+ S @ROOT@(0)=ZERO ; It riseth again!
+ QUIT
+GETLINES(PATH,FILENAME) ; Get number of lines in a file
+ D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
+ U IO
+ N I
+ F I=1:1 R LINE Q:$$STATUS^%ZISH
+ D CLOSE^%ZISH("FILE")
+ Q I-1
+READCON(PATH,INCRES) ; Open and read concepts file: RXNCONSO.RRF; EP
+ ; PATH ByVal, path of RxNorm files
+ ; INCRES ByVal, include restricted sources. 1 for yes, 0 for no
+ I PATH="" QUIT
+ S INCRES=+$G(INCRES) ; if not passed, becomes zero.
+ N FILENAME S FILENAME="RXNCONSO.RRF"
+ D DELFILED(176.001) ; delete data
+ N LINES S LINES=$$GETLINES(PATH,FILENAME)
+ D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
+ IF POP D EN^DDIOL("Error reading file..., Please check...") G EX
+ N C0CCOUNT
+ F C0CCOUNT=1:1 D  Q:$$STATUS^%ZISH
+ . U IO
+ . N LINE R LINE
+ . IF $$STATUS^%ZISH QUIT
+ . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
+ . N RXCUI,RXAUI,SAB,TTY,CODE,STR  ; Fileman fields numbers below
+ . S RXCUI=$P(LINE,"|",1) ; .01
+ . S RXAUI=$P(LINE,"|",8) ; 1
+ . S SAB=$P(LINE,"|",12) ; 2
+ . ; If the source is a restricted source, decide what to do based on what's asked.
+ . N SRCIEN S SRCIEN=$$FIND1^DIC(176.003,"","QX",SAB,"B") ; SrcIEN in RXNORM SOURCES file
+ . N RESTRIC S RESTRIC=$$GET1^DIQ(176.003,SRCIEN,14,"I") ; 14 is restriction field; values 0-4
+ . ; If RESTRIC is zero, then it's unrestricted. Everything else is restricted.
+ . ; If user didn't ask to include restricted sources, and the source is restricted, then quit
+ . I 'INCRES,RESTRIC QUIT
+ . S TTY=$P(LINE,"|",13) ; 3
+ . S CODE=$P(LINE,"|",14) ; 4
+ . S STR=$P(LINE,"|",15) ; 5
+ . ; Remove embedded "^"
+ . S STR=$TR(STR,"^")
+ . ; Convert STR into an array of 80 characters on each line
+ . N STRLINE S STRLINE=$L(STR)\80+1
+ . ; In each line, chop 80 characters off, reset STR to be the rest
+ . N J F J=1:1:STRLINE S STR(J)=$E(STR,1,80) S STR=$E(STR,81,$L(STR))
+ . ; Now, construct the FDA array
+ . N RXNFDA
+ . S RXNFDA(176.001,"+1,",.01)=RXCUI
+ . S RXNFDA(176.001,"+1,",1)=RXAUI
+ . S RXNFDA(176.001,"+1,",2)=SAB
+ . S RXNFDA(176.001,"+1,",3)=TTY
+ . S RXNFDA(176.001,"+1,",4)=CODE
+ . N RXNIEN S RXNIEN(1)=C0CCOUNT
+ . D UPDATE^DIE("","RXNFDA","RXNIEN")
+ . I $D(^TMP("DIERR",$J)) D EN^DDIOL("ERROR") G EX
+ . ; Now, file WP field STR
+ . D WP^DIE(176.001,C0CCOUNT_",",5,,$NA(STR))
+EX D CLOSE^%ZISH("FILE")
+ QUIT
+READNDC(PATH) ; Open and read NDC/RxNorm/VANDF relationship file: RXNSAT.RRF
+ I PATH="" QUIT
+ N FILENAME S FILENAME="RXNSAT.RRF"
+ D DELFILED(176.002) ; delete data
+ N LINES S LINES=$$GETLINES(PATH,FILENAME)
+ D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
+ IF POP W "Error reading file..., Please check...",! G EX2
+ F C0CCOUNT=1:1 Q:$$STATUS^%ZISH  D
+ . U IO
+ . N LINE R LINE
+ . IF $$STATUS^%ZISH QUIT
+ . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
+ . IF LINE'["NDC|RXNORM"  QUIT
+ . ; Otherwise, we are good to go
+ . N RXCUI,NDC ; Fileman fields below
+ . S RXCUI=$P(LINE,"|",1) ; .01
+ . S NDC=$P(LINE,"|",11) ; 2
+ . ; Using classic call to update.
+ . N DIC,X,DA,DR
+ . K DO
+ . S DIC="^C0CRXN(176.002,",DIC(0)="F",X=RXCUI,DIC("DR")="2////"_NDC
+ . D FILE^DICN
+ . I Y<1 U $P W !,"THERE IS TROUBLE IN RIVER CITY",! G EX2
+EX2 D CLOSE^%ZISH("FILE")
+ QUIT
+READSRC(PATH) ; Open the read RxNorm Sources file: RXNSAB.RRF
+ I PATH="" QUIT
+ N FILENAME S FILENAME="RXNSAB.RRF"
+ D DELFILED(176.003) ; delete data
+ D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
+ IF POP W "Error reading file..., Please check...",! G EX3
+ F I=1:1 Q:$$STATUS^%ZISH  D
+ . U IO
+ . N LINE R LINE
+ . IF $$STATUS^%ZISH QUIT
+ . U $P W I,! U IO  ; Write I to the screen, then go back to reading the file
+ . N VCUI,RCUI,VSAB,RSAB,SON,SF,SVER,SRL,SCIT ; Fileman fields numbers below
+ . S VCUI=$P(LINE,"|",1)        ; .01
+ . S RCUI=$P(LINE,"|",2)        ; 2
+ . S VSAB=$P(LINE,"|",3)        ; 3
+ . S RSAB=$P(LINE,"|",4)        ; 4
+ . S SON=$P(LINE,"|",5)         ; 5
+ . S SF=$P(LINE,"|",6)          ; 6
+ . S SVER=$P(LINE,"|",7)        ; 7
+ . S SRL=$P(LINE,"|",14)  ; 14
+ . S SCIT=$P(LINE,"|",25)       ; 25
+ . ; Remove embedded "^"
+ . S SCIT=$TR(SCIT,"^")
+ . ; Convert SCIT into an array of 80 characters on each line
+ . ; In each line, chop 80 characters off, reset SCIT to be the rest
+ . N SCITLINE S SCITLINE=$L(SCIT)\80+1
+ . F J=1:1:SCITLINE S SCIT(J)=$E(SCIT,1,80) S SCIT=$E(SCIT,81,$L(SCIT))
+ . ; Now, construct the FDA array
+ . N RXNFDA
+ . S RXNFDA(176.003,"+"_I_",",.01)=VCUI
+ . S RXNFDA(176.003,"+"_I_",",2)=RCUI
+ . S RXNFDA(176.003,"+"_I_",",3)=VSAB
+ . S RXNFDA(176.003,"+"_I_",",4)=RSAB
+ . S RXNFDA(176.003,"+"_I_",",5)=SON
+ . S RXNFDA(176.003,"+"_I_",",6)=SF
+ . S RXNFDA(176.003,"+"_I_",",7)=SVER
+ . S RXNFDA(176.003,"+"_I_",",14)=SRL
+ . D UPDATE^DIE("","RXNFDA")
+ . I $D(^TMP("DIERR",$J)) U $P W "ERR" G EX
+ . ; Now, file WP field SCIT
+ . D WP^DIE(176.003,I_",",25,,$NA(SCIT))
+EX3 D CLOSE^%ZISH("FILE")
+ Q
+

ccr/branches/ohum/p/C0CSNOA.m

@@ -1 @@
-C0CSNOA   ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/08
-        ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1
-        ;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 ANALYZE THE POTENTIAL RETRIEVAL OF SNOMED CT CODES
-        ; FOR PATIENT DRUG ALLERGIES FOR INCLUSION IN THE CCR OR CCD
-        ; USING THE VISTA LEXICON ^LEX
-        ;
-ANALYZE(BEGIEN,IENCNT)  ; SNOMED RETRIEVAL ANALYSIS ROUTINE
-           ; BEGINS AT BEGIEN AND GOES FOR IENCNT DRUGS IN GMRD
-           ; TO RESUME AT NEXT DRUG, USE BEGIEN=""
-           ; USE RESET^C0CSNOA TO RESET TO TOP OF DRUG LIST
-           ;
-           N SNOARY,SNOTMP,SNOI,SNOIEN,RATTR
-           N CCRGLO
-           D ASETUP ; SET UP VARIABLES AND GLOBALS
-           D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE
-           I '$D(@SNOBASE@("RESUME")) S @SNOBASE@("RESUME")=$O(@GMRBASE@(1)) ;1ST TME
-           S RESUME=@SNOBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN
-           S SNOIEN=BEGIEN ; BEGIN WITH THE BEGIEN RECORD
-           I SNOIEN="" S SNOIEN=RESUME
-           I +SNOIEN=0 D  Q  ; AT THE END OF THE ALLERGY LIST
-           . W "END OF DRUG LIST, CALL RESET^C0CSNOA",!
-           F SNOI=1:1:IENCNT  D  Q:+SNOIEN=0  ; FOR IENCNT NUMBER OF PATIENTS OR END
-           . ;D CCRRPC^C0CCCR(.CCRGLO,SNOIEN,"CCR","","","") ;PROCESS THE CCR
-           . W SNOIEN,@GMRBASE@(SNOIEN,0),!
-           . N SNORTN,TTERM ; RETURN ARRAY
-           . S TTERM=$P(@GMRBASE@(SNOIEN,0),"^",1)_" ALLERGY"
-           . D TEXTRPC(.SNORTN,TTERM)
-           . I $D(SNORTN) ZWR SNORTN
-           . K @SNOBASE@("VARS",SNOIEN) ; CLEAR OUT OLD VARS
-           . I $P(TTMP,"^",1)=1 S @SNOBASE@("VARS",SNOIEN)=TTERM_"^"_TTMP_"^"_SNORTN(0)
-           . ;
-           . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP
-           . ;
-           . S RATTR=$$SETATTR(SNOIEN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS
-           . S @SNOBASE@("ATTR",SNOIEN)=RATTR ; SAVE THE ATRIBUTES FOR THIS DRUG
-           . ;
-           . N CATNAME,CATTBL
-           . S CATNAME=""
-           . D CPUSH(.CATNAME,SNOBASE,"SNOTBL",SNOIEN,RATTR) ; ADD TO CATEGORY
-           . ; W "CATEGORY NAME: ",CATNAME,!
-           . ;
-           . S SNOIEN=$O(@GMRBASE@(SNOIEN)) ; NEXT RECORD
-           . S @SNOBASE@("RESUME")=SNOIEN ; WHERE WE ARE LEAVING OFF THIS RUN
-           ; D PARY^C0CXPATH(@SNOBASE@("ATTRTBL"))
-           Q
-           ;
-TEXTRPC(ORTN,ITEXT)     ; CALL THE LEXICON WITH ITEXT AND RETURN RESULTS IN ORTN
-        ;
-        ;N TTMP
-        W ITEXT,!
-        S TTMP=$$TEXT^LEXTRAN(ITEXT,"","","SCT","ORTN")
-        Q
-        ;
-ASETUP  ; SET UP GLOBALS AND VARS SNOBASE AND SNOTBL
-             I '$D(SNOBASE) S SNOBASE=$NA(^TMP("C0CSNO"))
-             I '$D(@SNOBASE) S @SNOBASE=""
-             I '$D(GMRBASE) S GMRBASE=$NA(^GMRD(120.82))
-             I '$D(SNOTBL) S SNOTBL=$NA(^TMP("C0CSNO","SNOTBL","TABLE")) ; ATTR TABLE
-             S ^TMP("C0CSNO","TABLES","SNOTBL")=SNOTBL ; TABLE OF TABLES
-             Q
-             ;
-AINIT   ; INITIALIZE ATTRIBUTE TABLE
-             I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS
-             K @SNOTBL
-             D APUSH^C0CRIMA(SNOTBL,"CODE")
-             D APUSH^C0CRIMA(SNOTBL,"NOCODE")
-             D APUSH^C0CRIMA(SNOTBL,"MULTICODE")
-             D APUSH^C0CRIMA(SNOTBL,"SUBMULTI")
-             D APUSH^C0CRIMA(SNOTBL,"DONE")
-             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 @SNOBASE@("TABLES") - "SNOTBL"=ALL VALUES
-           ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL))
-           I '$D(SNOBASE) D ASETUP ; FOR COMMANDLINE PROCESSING
-           N USETBL
-           I '$D(@SNOBASE@("TABLES",PTBL)) D  Q  ; NO TABLE
-           . W "ERROR NO SUCH TABLE",!
-           S USETBL=@SNOBASE@("TABLES",PTBL)
-           S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL
-           Q
-SETATTR(SDFN)   ; SET ATTRIBUTES BASED ON VARS
-           N SBASE,SATTR
-           S SBASE=$NA(@SNOBASE@("VARS",SDFN))
-           D APOST("SATTR","SNOTBL","DONE")
-           I $P(TTMP,"^",1)=1 D APOST("SATTR","SNOTBL","CODE")
-           I $P(TTMP,"^",1)=-1 D APOST("SATTR","SNOTBL","NOCODE")
-           Q SATTR  ; C0C
-           I $D(@SBASE@("PROBLEMS",1)) D  ;
-           . D APOST("SATTR","SNOTBL","PROBLEMS")
-           . ; W "POSTING PROBLEMS",!
-           I $D(@SBASE@("VITALS",1)) D APOST("SATTR","SNOTBL","VITALS")
-           I $D(@SBASE@("MEDS",1)) D  ; IF THE PATIENT HAS MEDS VARIABLES
-           . D APOST("SATTR","SNOTBL","MEDS")
-           . N ZR,ZI
-           . D GETPA^C0CRIMA(.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","SNOTBL","MEDSCODE") ;CODES
-           . ; D PATD^C0CSNOA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES
-           D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED
-           ; W "ATTRIBUTES: ",SATTR,!
-           Q SATTR
-           ;
-RESET   ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES
-           K ^TMP("C0CSNO","RESUME")
-           K ^TMP("C0CSNO")
-           Q
-           ;
-CLIST   ; LIST THE CATEGORIES
-           ;
-           I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS
-           N CLBASE,CLNUM,ZI,CLIDX
-           S CLBASE=$NA(@SNOBASE@("SNOTBL","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,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT
-           ; W "IENS BASE: ",CPATLIST,!
-           S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST
-           ;
-           Q
-           ;
-REUSE   ; GET SAVED VALUES FROM ^TMP("C0CSAV") AND PUT THEM IN A DATABASE
-        ;
-        D ASETUP
-        D AINIT
-        N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH
-        S SAVBASE=$NA(^TMP("C0CSAV","VARS"))
-        S SNOI=""
-        F  D  Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST
-        . S SNOI=$O(@SAVBASE@(SNOI))
-        . S SNOJ=@SAVBASE@(SNOI)
-        . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1)
-        . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE
-        . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON
-        . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE
-        . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE
-        . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE
-        . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,!
-        . W SNOK,!
-        . W SNOJ,!
-        Q
-        ;
+C0CSNOA   ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/08
+ ;;0.1;CCDCCR;nopatch;noreleasedate
+ ;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 ANALYZE THE POTENTIAL RETRIEVAL OF SNOMED CT CODES
+ ; FOR PATIENT DRUG ALLERGIES FOR INCLUSION IN THE CCR OR CCD
+ ; USING THE VISTA LEXICON ^LEX
+ ;
+ANALYZE(BEGIEN,IENCNT) ; SNOMED RETRIEVAL ANALYSIS ROUTINE
+    ; BEGINS AT BEGIEN AND GOES FOR IENCNT DRUGS IN GMRD
+    ; TO RESUME AT NEXT DRUG, USE BEGIEN=""
+    ; USE RESET^C0CSNOA TO RESET TO TOP OF DRUG LIST
+    ;
+    N SNOARY,SNOTMP,SNOI,SNOIEN,RATTR
+    N CCRGLO
+    D ASETUP ; SET UP VARIABLES AND GLOBALS
+    D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE
+    I '$D(@SNOBASE@("RESUME")) S @SNOBASE@("RESUME")=$O(@GMRBASE@(1)) ;1ST TME
+    S RESUME=@SNOBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN
+    S SNOIEN=BEGIEN ; BEGIN WITH THE BEGIEN RECORD
+    I SNOIEN="" S SNOIEN=RESUME
+    I +SNOIEN=0 D  Q  ; AT THE END OF THE ALLERGY LIST
+    . W "END OF DRUG LIST, CALL RESET^C0CSNOA",!
+    F SNOI=1:1:IENCNT  D  Q:+SNOIEN=0  ; FOR IENCNT NUMBER OF PATIENTS OR END
+    . ;D CCRRPC^C0CCCR(.CCRGLO,SNOIEN,"CCR","","","") ;PROCESS THE CCR
+    . W SNOIEN,@GMRBASE@(SNOIEN,0),!
+    . N SNORTN,TTERM ; RETURN ARRAY
+    . S TTERM=$P(@GMRBASE@(SNOIEN,0),"^",1)_" ALLERGY"
+    . D TEXTRPC(.SNORTN,TTERM)
+    . I $D(SNORTN) ZWR SNORTN
+    . K @SNOBASE@("VARS",SNOIEN) ; CLEAR OUT OLD VARS
+    . I $P(TTMP,"^",1)=1 S @SNOBASE@("VARS",SNOIEN)=TTERM_"^"_TTMP_"^"_SNORTN(0)
+    . ;
+    . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP
+    . ;
+    . S RATTR=$$SETATTR(SNOIEN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS
+    . S @SNOBASE@("ATTR",SNOIEN)=RATTR ; SAVE THE ATRIBUTES FOR THIS DRUG
+    . ;
+    . N CATNAME,CATTBL
+    . S CATNAME=""
+    . D CPUSH(.CATNAME,SNOBASE,"SNOTBL",SNOIEN,RATTR) ; ADD TO CATEGORY
+    . ; W "CATEGORY NAME: ",CATNAME,!
+    . ;
+    . S SNOIEN=$O(@GMRBASE@(SNOIEN)) ; NEXT RECORD
+    . S @SNOBASE@("RESUME")=SNOIEN ; WHERE WE ARE LEAVING OFF THIS RUN
+    ; D PARY^C0CXPATH(@SNOBASE@("ATTRTBL"))
+    Q
+    ;
+TEXTRPC(ORTN,ITEXT) ; CALL THE LEXICON WITH ITEXT AND RETURN RESULTS IN ORTN
+ ;
+ ;N TTMP
+ W ITEXT,!
+ S TTMP=$$TEXT^LEXTRAN(ITEXT,"","","SCT","ORTN")
+ Q
+ ;
+ASETUP ; SET UP GLOBALS AND VARS SNOBASE AND SNOTBL
+      I '$D(SNOBASE) S SNOBASE=$NA(^TMP("C0CSNO"))
+      I '$D(@SNOBASE) S @SNOBASE=""
+      I '$D(GMRBASE) S GMRBASE=$NA(^GMRD(120.82))
+      I '$D(SNOTBL) S SNOTBL=$NA(^TMP("C0CSNO","SNOTBL","TABLE")) ; ATTR TABLE
+      S ^TMP("C0CSNO","TABLES","SNOTBL")=SNOTBL ; TABLE OF TABLES
+      Q
+      ;
+AINIT ; INITIALIZE ATTRIBUTE TABLE
+      I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS
+      K @SNOTBL
+      D APUSH^C0CRIMA(SNOTBL,"CODE")
+      D APUSH^C0CRIMA(SNOTBL,"NOCODE")
+      D APUSH^C0CRIMA(SNOTBL,"MULTICODE")
+      D APUSH^C0CRIMA(SNOTBL,"SUBMULTI")
+      D APUSH^C0CRIMA(SNOTBL,"DONE")
+      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 @SNOBASE@("TABLES") - "SNOTBL"=ALL VALUES
+    ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL))
+    I '$D(SNOBASE) D ASETUP ; FOR COMMANDLINE PROCESSING
+    N USETBL
+    I '$D(@SNOBASE@("TABLES",PTBL)) D  Q  ; NO TABLE
+    . W "ERROR NO SUCH TABLE",!
+    S USETBL=@SNOBASE@("TABLES",PTBL)
+    S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL
+    Q
+SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS
+    N SBASE,SATTR
+    S SBASE=$NA(@SNOBASE@("VARS",SDFN))
+    D APOST("SATTR","SNOTBL","DONE")
+    I $P(TTMP,"^",1)=1 D APOST("SATTR","SNOTBL","CODE")
+    I $P(TTMP,"^",1)=-1 D APOST("SATTR","SNOTBL","NOCODE")
+    Q SATTR  ; C0C
+    I $D(@SBASE@("PROBLEMS",1)) D  ;
+    . D APOST("SATTR","SNOTBL","PROBLEMS")
+    . ; W "POSTING PROBLEMS",!
+    I $D(@SBASE@("VITALS",1)) D APOST("SATTR","SNOTBL","VITALS")
+    I $D(@SBASE@("MEDS",1)) D  ; IF THE PATIENT HAS MEDS VARIABLES
+    . D APOST("SATTR","SNOTBL","MEDS")
+    . N ZR,ZI
+    . D GETPA^C0CRIMA(.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","SNOTBL","MEDSCODE") ;CODES
+    . ; D PATD^C0CSNOA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES
+    D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED
+    ; W "ATTRIBUTES: ",SATTR,!
+    Q SATTR
+    ;
+RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES
+    K ^TMP("C0CSNO","RESUME")
+    K ^TMP("C0CSNO")
+    Q
+    ;
+CLIST ; LIST THE CATEGORIES
+    ;
+    I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS
+    N CLBASE,CLNUM,ZI,CLIDX
+    S CLBASE=$NA(@SNOBASE@("SNOTBL","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,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT
+    ; W "IENS BASE: ",CPATLIST,!
+    S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST
+    ;
+    Q
+    ;
+REUSE ; GET SAVED VALUES FROM ^TMP("C0CSAV") AND PUT THEM IN A DATABASE
+ ;
+ D ASETUP
+ D AINIT
+ N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH
+ S SAVBASE=$NA(^TMP("C0CSAV","VARS"))
+ S SNOI=""
+ F  D  Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST
+ . S SNOI=$O(@SAVBASE@(SNOI))
+ . S SNOJ=@SAVBASE@(SNOI)
+ . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1)
+ . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE
+ . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON
+ . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE
+ . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE
+ . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE
+ . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,!
+ . W SNOK,!
+ . W SNOJ,!
+ Q
+ ;

ccr/branches/ohum/p/C0CSOAP.m

@@ -1 @@
-C0CSOAP  ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CSUB1.m

@@ -1 @@
-C0CSUB1   ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CSYS.m

@@ -1 @@
-C0CSYS  ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ; 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/branches/ohum/p/C0CUNIT.m

@@ -1 @@
-C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/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 1
-        ;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 
-        ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR
-        N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT
-        I $G(ZVUID)="" Q ""
-        I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED
-        N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID")
-        S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES
-        N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01)
-        S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED
-        I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F"
-        Q ZRSLT
-        ;
-NISTMAP(ZRXN)   ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO 
-        ; CONFORM TO NIST REQUIREMENTS
-        ;INPATIENT CERTIFICATION
-        I ZRXN=309362 S ZRXN=213169
-        I ZRXN=855318 S ZRXN=855320
-        I ZRXN=197361 S ZRXN=212549
-        ;OUTPATIENT CERTIFICATION
-        I ZRXN=310534 S ZRXN=205875
-        I ZRXN=617312 S ZRXN=617314
-        I ZRXN=310429 S ZRXN=200801
-        I ZRXN=628953 S ZRXN=628958
-        I ZRXN=745679 S ZRXN=630208
-        I ZRXN=311564 S ZRXN=979334
-        I ZRXN=836343 S ZRXN=836370
-        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
-        
+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 
+ ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR
+ N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT
+ I $G(ZVUID)="" Q ""
+ I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED
+ N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID")
+ S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES
+ N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01)
+ S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED
+ I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F"
+ Q ZRSLT
+ ;
+NISTMAP(ZRXN) ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO 
+ ; CONFORM TO NIST REQUIREMENTS
+ ;INPATIENT CERTIFICATION
+ I ZRXN=309362 S ZRXN=213169
+ I ZRXN=855318 S ZRXN=855320
+ I ZRXN=197361 S ZRXN=212549
+ ;OUTPATIENT CERTIFICATION
+ I ZRXN=310534 S ZRXN=205875
+ I ZRXN=617312 S ZRXN=617314
+ I ZRXN=310429 S ZRXN=200801
+ I ZRXN=628953 S ZRXN=628958
+ I ZRXN=745679 S ZRXN=630208
+ I ZRXN=311564 S ZRXN=979334
+ I ZRXN=836343 S ZRXN=836370
+ 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
+ 

ccr/branches/ohum/p/C0CVA200.m

@@ -1 @@
-C0CVA200        ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CVIT2.m

@@ -1 @@
-C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
-        ;;1.0;C0C;;Feb 16, 2010;Build 1
-        ;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/branches/ohum/p/C0CVITAL.m

@@ -1 @@
-C0CVITAL        ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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 @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
-        ;
+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 @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
+ ;

ccr/branches/ohum/p/C0CVOBX1.m

@@ -1 @@
-LA7VOBX1        ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09
-        ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994;Build 1
-        ; JMC - mods to check for IHS V LAB file
-        ;
-CH      ; Observation/Result segment for "CH" subscript results.
-        ; Called by LA7VOBX
-        ;
-        N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X
-        ;
-        ; "CH" subscript requires a dataname
-        I '$G(LRSB) Q
-        ;
-        ; get result node from LR global.
-        S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
-        S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
-        ;
-        ; Check if test is OK to send - (O)utput or (B)oth
-        S LA7X=$P(LA7VAL,"^",12)
-        I LA7X]"","BO"'[LA7X Q
-        I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q
-        ;
-        ; If no result NLT or LOINC try to determine from file #60
-        S LA7X=$P(LA7VAL,"^",3)
-        ; WV check for IHS - NLT/LN codes from V LAB file
-        I $D(^AUPNVLAB) D TMPCHK^C0CLA7Q
-        ;
-        I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5))
-        ; No result NLT code - log error
-        I $P($P(LA7VAL,"^",3),"!",2)="" D
-        . N LA7X
-        . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL")
-        . D CREATE^LA7LOG(36)
-        ;
-        ; something missing - No NLT code, etc.
-        I LA7VAL="" Q
-        ;
-        ; Check for missing units/reference ranges
-        S LA7X=$P(LA7VAL,"^",5)
-        ;
-        ; Results missing units, lookup in file #60
-        I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3)
-        ;
-        ; If results missing reference ranges, use values from file #60.
-        I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D
-        . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5))
-        . S $P(LA7X,"!",2)=$P(LA7Y,"^")
-        . S $P(LA7X,"!",3)=$P(LA7Y,"^",2)
-        . S $P(LA7X,"!",11)=$P(LA7Y,"^",6)
-        . S $P(LA7X,"!",12)=$P(LA7Y,"^",7)
-        ; Use therapeutic low/high if low/high missing.
-        I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D
-        . S $P(LA7X,"!",2)=$P(LA7X,"!",11)
-        . S $P(LA7X,"!",3)=$P(LA7X,"!",12)
-        ;
-        ; Evaluate low/high reference ranges in case M code in these fields.
-        S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99
-        F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D
-        . S @("X="_$P(LA7X,"!",LA7I))
-        . S $P(LA7X,"!",LA7I)=X
-        ;
-        ; Put units/reference ranges back in variable LA7VAL
-        S $P(LA7VAL,"^",5)=LA7X
-        ;
-        ; Initialize OBX segment
-        S LA7OBX(0)="OBX"
-        S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
-        ;
-        ; Value type
-        S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB)
-        ;
-        ; Observation identifer
-        ; build alternate code based on dataname from file #63 in case it's needed
-        S LA7X=$P(LA7VAL,"^",3)
-        S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63"
-        S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH)
-        ;
-        ; Test value
-        S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH)
-        ;
-        ; Units - remove leading and trailing spaces
-        S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ")
-        S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH)
-        ;
-        ; Reference range
-        S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH)
-        ;
-        ; Abnormal flags
-        S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2))
-        ;
-        ; "P"artial or "F"inal results
-        S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F"))
-        ;
-        ; Observation date/time - collection date/time per HL7 standard
-        I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^"))
-        ;
-        S LA7DIV=$P(LA7VAL,"^",9)
-        I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0))
-        ;
-        ; Facility that performed the testing
-        S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH)
-        ;
-        ; Person that verified the test
-        S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH)
-        ;
-        ; Observation method
-        S LA7X=$P($P(LA7VAL,"^",3),"!",4)
-        I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH)
-        ;
-        ; Equipment entity identifier
-        I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH)
-        ;
-        D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS)
-        ;
-        Q
+LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09
+ ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994
+ ; JMC - mods to check for IHS V LAB file
+ ;
+CH ; Observation/Result segment for "CH" subscript results.
+ ; Called by LA7VOBX
+ ;
+ N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X
+ ;
+ ; "CH" subscript requires a dataname
+ I '$G(LRSB) Q
+ ;
+ ; get result node from LR global.
+ S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
+ S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB))
+ ;
+ ; Check if test is OK to send - (O)utput or (B)oth
+ S LA7X=$P(LA7VAL,"^",12)
+ I LA7X]"","BO"'[LA7X Q
+ I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q
+ ;
+ ; If no result NLT or LOINC try to determine from file #60
+ S LA7X=$P(LA7VAL,"^",3)
+ ; WV check for IHS - NLT/LN codes from V LAB file
+ I $D(^AUPNVLAB) D TMPCHK^C0CLA7Q
+ ;
+ I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5))
+ ; No result NLT code - log error
+ I $P($P(LA7VAL,"^",3),"!",2)="" D
+ . N LA7X
+ . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL")
+ . D CREATE^LA7LOG(36)
+ ;
+ ; something missing - No NLT code, etc.
+ I LA7VAL="" Q
+ ;
+ ; Check for missing units/reference ranges
+ S LA7X=$P(LA7VAL,"^",5)
+ ;
+ ; Results missing units, lookup in file #60
+ I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3)
+ ;
+ ; If results missing reference ranges, use values from file #60.
+ I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D
+ . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5))
+ . S $P(LA7X,"!",2)=$P(LA7Y,"^")
+ . S $P(LA7X,"!",3)=$P(LA7Y,"^",2)
+ . S $P(LA7X,"!",11)=$P(LA7Y,"^",6)
+ . S $P(LA7X,"!",12)=$P(LA7Y,"^",7)
+ ; Use therapeutic low/high if low/high missing.
+ I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D
+ . S $P(LA7X,"!",2)=$P(LA7X,"!",11)
+ . S $P(LA7X,"!",3)=$P(LA7X,"!",12)
+ ;
+ ; Evaluate low/high reference ranges in case M code in these fields.
+ S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99
+ F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D
+ . S @("X="_$P(LA7X,"!",LA7I))
+ . S $P(LA7X,"!",LA7I)=X
+ ;
+ ; Put units/reference ranges back in variable LA7VAL
+ S $P(LA7VAL,"^",5)=LA7X
+ ;
+ ; Initialize OBX segment
+ S LA7OBX(0)="OBX"
+ S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN)
+ ;
+ ; Value type
+ S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB)
+ ;
+ ; Observation identifer
+ ; build alternate code based on dataname from file #63 in case it's needed
+ S LA7X=$P(LA7VAL,"^",3)
+ S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63"
+ S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH)
+ ;
+ ; Test value
+ S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH)
+ ;
+ ; Units - remove leading and trailing spaces
+ S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ")
+ S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH)
+ ;
+ ; Reference range
+ S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH)
+ ;
+ ; Abnormal flags
+ S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2))
+ ;
+ ; "P"artial or "F"inal results
+ S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F"))
+ ;
+ ; Observation date/time - collection date/time per HL7 standard
+ I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^"))
+ ;
+ S LA7DIV=$P(LA7VAL,"^",9)
+ I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0))
+ ;
+ ; Facility that performed the testing
+ S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH)
+ ;
+ ; Person that verified the test
+ S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH)
+ ;
+ ; Observation method
+ S LA7X=$P($P(LA7VAL,"^",3),"!",4)
+ I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH)
+ ;
+ ; Equipment entity identifier
+ I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH)
+ ;
+ D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS)
+ ;
+ Q

ccr/branches/ohum/p/C0CVORU.m

@@ -1 @@
-C0C7VORU        ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009
-        ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994;Build 1
-        ;
-EN(LA)  ; called from C0CVLAB
-        ; variables
-        ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68)
-        ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4)
-        ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68)
-        ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64)
-        ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64)
-        ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time)
-        ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60)
-        ; LA("LRDFN") - IEN in LAB DATA file (#63)
-        ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results.
-        ; LA("AUTO-INST") - Auto-Instrument
-        ;
-        N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY
-        ;
-        S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")=""
-        I $G(PRIMARY)'="" D
-        . S PRIMARY=$$SITE^VASITE(DT,PRIMARY)
-        . S PRIMARY=$P(PRIMARY,U,3)
-        . S LA("AUTO-INST")="LA7V HOST "_PRIMARY
-        ;
-        I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D  Q
-        . ; need to add error logging when no entry in 63.
-        ;
-        ; Get zeroth node of entry in #63.
-        S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
-        S LA7NLT=$G(LA("NLT"))
-        ;
-        S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))
-        S LA7NTESN=0
-        D ORC
-        ;
-        I $G(LA("SUB"))="CH" D CH
-        ;I $G(LA("SUB"))="MI" D MI^LA7VORU1
-        ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2
-        Q
-        ;
-        ;
-CH      ; Build segments for "CH" subscript
-        ;
-        D OBR
-        D NTE
-        S LA7OBXSN=0
-        D OBX
-        ;
-        Q
-        ;
-        ;
-ORC     ; Build ORC segment
-        ;
-        N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC
-        ;
-        S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
-        ;
-        S ORC(0)="ORC"
-        ;
-        ; Order control
-        S ORC(1)=$$ORC1^LA7VORC("RE")
-        ;
-        ; Remote UID
-        S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH)
-        ;
-        ; Host UID
-        S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH)
-        ;
-        ; Return shipping manifest if found
-        S LA7SM="",LA7696=0
-        I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0))
-        I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14)
-        I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH)
-        ;
-        ; Order status
-        ; DoD/CHCS requires ORC-5 valued otherwise will not process message
-        I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH)
-        ;
-        ; Ordering provider
-        S (LA7X,LA7Y)=""
-        ; "CH" subscript stores requesting provider and requesting div/location.
-        I LA("SUB")="CH" D
-        . N LA7J
-        . S LA7J=$P(LA763(0),"^",13)
-        . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
-        . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
-        . S LA7X=$P(LA763(0),"^",10)
-        ;
-        ; Other subscripts only store requesting provider
-        I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
-        ; Get default institution from MailMan Site Parameters file
-        I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
-        S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
-        ;
-        ; Entering organization
-        S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH)
-        ;
-        D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
-        D FILESEG^LA7VHLU(GBL,.LA7DATA)
-        ;
-        ; Check for flag to only build message but do not file
-        I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA)
-        ;
-        Q
-        ;
-        ;
-OBR     ;Observation Request segment for Lab Order
-        ;
-        N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR
-        ;
-        ; Retrieve placer's OBR information stored in #69.6
-        D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR)
-        ;
-        ; Initialize OBR segment
-        S OBR(0)="OBR"
-        S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
-        ;
-        ; Remote UID
-        S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH)
-        ;
-        ; Host UID
-        S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH)
-        ;
-        ; Universal service ID, build from info stored in #69.6
-        S LA7X=""
-        I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH)
-        E  S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH)
-        ;
-        ; Collection D/T
-        S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U))
-        ;
-        ; Specimen action code
-        ; If no OBR from PENDING ORDER file (#69.6) then assume added test.
-        I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A")
-        ;
-        ; Infection Warning
-        S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
-        ;
-        ; Lab Arrival Time
-        ; "CH" subscript does not store lab arrival time, use collection time.
-        ; Other subscripts do store lab arrival time (date/time received).
-        I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10))
-        I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^"))
-        ;
-        ; Specimen source 
-        S (LA761,LA762)=""
-        I "CHMI"[LA("SUB") D
-        . S LA761=$P(LA763(0),U,5)
-        . I LA761="" D CREATE^LA7LOG(27)
-        . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11)
-        S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH)
-        ;
-        ; Ordering provider
-        S (LA7X,LA7Y)=""
-        ; "CH" subscript stores requesting provider and requesting div/location.
-        I LA("SUB")="CH" D
-        . N LA7J
-        . S LA7J=$P(LA763(0),"^",13)
-        . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
-        . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
-        . S LA7X=$P(LA763(0),"^",10)
-        ;
-        ; Other subscripts only store requesting provider
-        I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
-        ; Get default institution from MailMan Site Parameters file
-        I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
-        S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
-        ;
-        ; Placer Field #1 (remote auto-inst)
-        ; Build from info stored in #69.6
-        I $G(LA7PLOBR("OBR-18"))'="" D
-        . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH)
-        ; Else build "auto instrument" if sending to VA facility
-        I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D
-        . N LA7X
-        . S LA7X(1)=LA("AUTO-INST")
-        . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
-        ;
-        ; Placer Field #2
-        I $G(LA7PLOBR("OBR-19"))'="" D
-        . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH)
-        ; Else build collecting UID if sending to VA facility
-        I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D
-        . K LA7X
-        . S LA7X(7)=LA("RUID")
-        . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
-        ;
-        ; Filler Field #1
-        ; Send file #63 ien info - used by HDR to track patient/specimen
-        K LA7X
-        S LA7X(1)=LA("LRDFN")
-        S LA7X(2)=LA("SUB")
-        S LA7X(3)=LA("LRIDT")
-        S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
-        ;
-        ; Date Report Completed
-        I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3))
-        ;
-        ; Diagnostic service id
-        S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB))
-        ;
-        ; Parent Result and Parent
-        I $D(LA7PARNT) D
-        . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH)
-        . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH)
-        ;
-        ; Principle result interpreter
-        ; Get default institution from MailMan Site Parameters file
-        I "CYEMMISP"[LA("SUB") D
-        . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4)
-        . E  S LA7X=$P(LA763(0),"^",2)
-        . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
-        . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
-        ; 
-        ; Assistant result interpreter
-        ; Get default institution from MailMan Site Parameters file
-        I "EMSP"[LA("SUB") D
-        . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
-        . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
-        ; 
-        ; Technician
-        ; Get default institution from MailMan Site Parameters file
-        I "CYEM"[LA("SUB") D
-        . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
-        . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
-        ; 
-        ; Typist - VistA stores as free text
-        ; Get default institution from MailMan Site Parameters file
-        I "CYEMSP"[LA("SUB") D
-        . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
-        . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
-        ; 
-        D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
-        D FILESEG^LA7VHLU(GBL,.LA7DATA)
-        ;
-        ; Check for flag to only build message but do not file
-        I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
-        ;
-        Q
-        ;
-        ;
-OBX     ;Observation/Result segment for Lab Results
-        ;
-        N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X
-        ;
-        S LA7VTIEN=0
-        F  S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN  D
-        . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2)
-        . ; Build OBX segment
-        . K LA7DATA
-        . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF))
-        . ; If OBX failed to build then don't store
-        . I '$D(LA7DATA) Q
-        . ;
-        . D FILESEG^LA7VHLU(GBL,.LA7DATA)
-        . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
-        . ;
-        . ; Send performing lab comment and interpretation from file #60
-        . S LA7NTESN=0
-        . I LA7NVAF=1 D PLC^LA7VORUA
-        . D INTRP^LA7VORUA
-        . ;
-        . ; Mark result as sent - set to 1, if corrected results set to 2
-        . I LA("SUB")="CH" D
-        . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q
-        . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1)
-        ;
-        Q
-        ;
-        ;
-NTE     ; Build NTE segment
-        ;
-        D NTE^LA7VORUA
-        Q
+C0C7VORU ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009
+ ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
+ ;
+EN(LA) ; called from C0CVLAB
+ ; variables
+ ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68)
+ ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4)
+ ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68)
+ ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64)
+ ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64)
+ ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time)
+ ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60)
+ ; LA("LRDFN") - IEN in LAB DATA file (#63)
+ ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results.
+ ; LA("AUTO-INST") - Auto-Instrument
+ ;
+ N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY
+ ;
+ S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")=""
+ I $G(PRIMARY)'="" D
+ . S PRIMARY=$$SITE^VASITE(DT,PRIMARY)
+ . S PRIMARY=$P(PRIMARY,U,3)
+ . S LA("AUTO-INST")="LA7V HOST "_PRIMARY
+ ;
+ I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D  Q
+ . ; need to add error logging when no entry in 63.
+ ;
+ ; Get zeroth node of entry in #63.
+ S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
+ S LA7NLT=$G(LA("NLT"))
+ ;
+ S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE"))
+ S LA7NTESN=0
+ D ORC
+ ;
+ I $G(LA("SUB"))="CH" D CH
+ ;I $G(LA("SUB"))="MI" D MI^LA7VORU1
+ ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2
+ Q
+ ;
+ ;
+CH ; Build segments for "CH" subscript
+ ;
+ D OBR
+ D NTE
+ S LA7OBXSN=0
+ D OBX
+ ;
+ Q
+ ;
+ ;
+ORC ; Build ORC segment
+ ;
+ N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC
+ ;
+ S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0))
+ ;
+ S ORC(0)="ORC"
+ ;
+ ; Order control
+ S ORC(1)=$$ORC1^LA7VORC("RE")
+ ;
+ ; Remote UID
+ S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH)
+ ;
+ ; Host UID
+ S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH)
+ ;
+ ; Return shipping manifest if found
+ S LA7SM="",LA7696=0
+ I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0))
+ I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14)
+ I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH)
+ ;
+ ; Order status
+ ; DoD/CHCS requires ORC-5 valued otherwise will not process message
+ I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH)
+ ;
+ ; Ordering provider
+ S (LA7X,LA7Y)=""
+ ; "CH" subscript stores requesting provider and requesting div/location.
+ I LA("SUB")="CH" D
+ . N LA7J
+ . S LA7J=$P(LA763(0),"^",13)
+ . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
+ . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
+ . S LA7X=$P(LA763(0),"^",10)
+ ;
+ ; Other subscripts only store requesting provider
+ I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
+ ; Get default institution from MailMan Site Parameters file
+ I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
+ S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
+ ;
+ ; Entering organization
+ S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH)
+ ;
+ D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS)
+ D FILESEG^LA7VHLU(GBL,.LA7DATA)
+ ;
+ ; Check for flag to only build message but do not file
+ I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA)
+ ;
+ Q
+ ;
+ ;
+OBR ;Observation Request segment for Lab Order
+ ;
+ N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR
+ ;
+ ; Retrieve placer's OBR information stored in #69.6
+ D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR)
+ ;
+ ; Initialize OBR segment
+ S OBR(0)="OBR"
+ S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN)
+ ;
+ ; Remote UID
+ S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH)
+ ;
+ ; Host UID
+ S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH)
+ ;
+ ; Universal service ID, build from info stored in #69.6
+ S LA7X=""
+ I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH)
+ E  S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH)
+ ;
+ ; Collection D/T
+ S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U))
+ ;
+ ; Specimen action code
+ ; If no OBR from PENDING ORDER file (#69.6) then assume added test.
+ I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A")
+ ;
+ ; Infection Warning
+ S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH)
+ ;
+ ; Lab Arrival Time
+ ; "CH" subscript does not store lab arrival time, use collection time.
+ ; Other subscripts do store lab arrival time (date/time received).
+ I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10))
+ I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^"))
+ ;
+ ; Specimen source 
+ S (LA761,LA762)=""
+ I "CHMI"[LA("SUB") D
+ . S LA761=$P(LA763(0),U,5)
+ . I LA761="" D CREATE^LA7LOG(27)
+ . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11)
+ S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH)
+ ;
+ ; Ordering provider
+ S (LA7X,LA7Y)=""
+ ; "CH" subscript stores requesting provider and requesting div/location.
+ I LA("SUB")="CH" D
+ . N LA7J
+ . S LA7J=$P(LA763(0),"^",13)
+ . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I")
+ . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";")
+ . S LA7X=$P(LA763(0),"^",10)
+ ;
+ ; Other subscripts only store requesting provider
+ I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7)
+ ; Get default institution from MailMan Site Parameters file
+ I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
+ S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH)
+ ;
+ ; Placer Field #1 (remote auto-inst)
+ ; Build from info stored in #69.6
+ I $G(LA7PLOBR("OBR-18"))'="" D
+ . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH)
+ ; Else build "auto instrument" if sending to VA facility
+ I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D
+ . N LA7X
+ . S LA7X(1)=LA("AUTO-INST")
+ . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH)
+ ;
+ ; Placer Field #2
+ I $G(LA7PLOBR("OBR-19"))'="" D
+ . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH)
+ ; Else build collecting UID if sending to VA facility
+ I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D
+ . K LA7X
+ . S LA7X(7)=LA("RUID")
+ . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH)
+ ;
+ ; Filler Field #1
+ ; Send file #63 ien info - used by HDR to track patient/specimen
+ K LA7X
+ S LA7X(1)=LA("LRDFN")
+ S LA7X(2)=LA("SUB")
+ S LA7X(3)=LA("LRIDT")
+ S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH)
+ ;
+ ; Date Report Completed
+ I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3))
+ ;
+ ; Diagnostic service id
+ S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB))
+ ;
+ ; Parent Result and Parent
+ I $D(LA7PARNT) D
+ . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH)
+ . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH)
+ ;
+ ; Principle result interpreter
+ ; Get default institution from MailMan Site Parameters file
+ I "CYEMMISP"[LA("SUB") D
+ . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4)
+ . E  S LA7X=$P(LA763(0),"^",2)
+ . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
+ . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
+ ; 
+ ; Assistant result interpreter
+ ; Get default institution from MailMan Site Parameters file
+ I "EMSP"[LA("SUB") D
+ . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
+ . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
+ ; 
+ ; Technician
+ ; Get default institution from MailMan Site Parameters file
+ I "CYEM"[LA("SUB") D
+ . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
+ . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
+ ; 
+ ; Typist - VistA stores as free text
+ ; Get default institution from MailMan Site Parameters file
+ I "CYEMSP"[LA("SUB") D
+ . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I")
+ . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH)
+ ; 
+ D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS)
+ D FILESEG^LA7VHLU(GBL,.LA7DATA)
+ ;
+ ; Check for flag to only build message but do not file
+ I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
+ ;
+ Q
+ ;
+ ;
+OBX ;Observation/Result segment for Lab Results
+ ;
+ N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X
+ ;
+ S LA7VTIEN=0
+ F  S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN  D
+ . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2)
+ . ; Build OBX segment
+ . K LA7DATA
+ . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF))
+ . ; If OBX failed to build then don't store
+ . I '$D(LA7DATA) Q
+ . ;
+ . D FILESEG^LA7VHLU(GBL,.LA7DATA)
+ . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA)
+ . ;
+ . ; Send performing lab comment and interpretation from file #60
+ . S LA7NTESN=0
+ . I LA7NVAF=1 D PLC^LA7VORUA
+ . D INTRP^LA7VORUA
+ . ;
+ . ; Mark result as sent - set to 1, if corrected results set to 2
+ . I LA("SUB")="CH" D
+ . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q
+ . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1)
+ ;
+ Q
+ ;
+ ;
+NTE ; Build NTE segment
+ ;
+ D NTE^LA7VORUA
+ Q

ccr/branches/ohum/p/C0CXEWD.m

@@ -1 @@
-C0CXEWD   ; C0C/GPL - EWD based XPath utilities; 10/11/09
-        ;;0.1;C0C;nopatch;noreleasedate;Build 1
-        ;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
-        ;
-TEST    ;
-        D XPATH($$FIRST($$ID("CCR1")),"/","GIDX","GARY")
-        Q
-        ;
-TEST2   ;
-        S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail"
-        D XPATH($$FIRST($$ID("gpl")),"/","GIDX","GARY","",REDUX)
-        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 '$D(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
-        I GD'="" S @ZXPARY@(NEWPATH)=GD ; IF YES, ADD IT TO THE XPATH ARRAY
-        N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
-        I ZFRST'="" D  ; THERE IS A CHILD
-        . 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 GNXT'="" D  ; MOVE ON TO THE NEXT SIBLING
-        . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB
-        Q
-        ;
-PARSE(INXML,INDOC)      ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
-        ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
-        ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
-        N ZR
-        M ^CacheTempEWD($j)=@INXML ;
-        S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
-        Q ZR
-        ;
-ISMULT(ZOID)    ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
-        N ZN
-        S ZN=$$NXTSIB(ZOID)
-        I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
-        Q 0
-        ;
-DETAIL(ZRTN,ZOID)       ; RETURNS DETAIL FOR NODE ZOID IN ZRTN, PASSED BY NAME
-        N DET
-        D getElementDetails^%zewdXPath(ZOID,.DET)
-        M @ZRTN=DET
-        Q
-        ;
-ID(ZNAME)       ;RETURNS THE docOID OF THE DOCUMENT NAMED ZNAME
-        Q $$getDocumentNode^%zewdDOM(ZNAME)
-        ;
-NAME(ZOID)      ;RETURNS THE NAME OF THE DOCUMENAT WITH docOID ZOID
-        Q $$getDocumentName^%zewdDOM(ZOID)
-        ;
-FIRST(ZOID)     ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
-        N GOID
-        S GOID=ZOID
-        S GOID=$$getFirstChild^%zewdDOM(GOID)
-        I GOID="" Q ""
-        I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
-        Q GOID
-        ;
-HASCHILD(ZOID)  ; RETURNS TRUE IF ZOID HAS CHILD NODES
-        Q $$hasChildNodes^%zewdDOM(ZOID)
-        ;
-CHILDREN(ZRTN,ZOID)     ;RETURNS CHILDREN OF ZOID IN ARRAY ZRTN, PASSED BY NAME
-        N childArray
-        d getChildrenInOrder^%zewdDOM(ZOID,.childArray)
-        m @ZRTN=childArray
-        q
-        ;
-TAG(ZOID)       ; RETURNS THE XML TAG FOR THE NODE
-        Q $$getName^%zewdDOM(ZOID)
-        ;
-NXTSIB(ZOID)    ; RETURNS THE NEXT SIBLING
-        Q $$getNextSibling^%zewdDOM(ZOID)
-        ;
-NXTCHLD(ZOID)   ; RETURNS THE NEXT CHILD IN PARENT ZPAR
-        N GOID
-        S GOID=$$getNextChild^%zewdDOM($$PARENT(ZOID),ZOID)
-        I GOID="" Q ""
-        I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
-        Q GOID
-        ;
-PARENT(ZOID)    ; RETURNS PARENT OF ZOID
-        Q $$getParentNode^%zewdDOM(ZOID)
-        ;
-DATA(ZT,ZOID)   ; RETURNS DATA FOR THE NODE
-        N ZT2
-        S ZT2=$$getElementText^%zewdDOM(ZOID,.ZT2)
-        M @ZT=ZT2
-        Q
-        ;Q $$getTextValue^%zewdXPath(ZOID)
-        ;Q $$getData^%zewdDOM(ZOID,.ZT)
-        ;
+C0CXEWD   ; C0C/GPL - EWD based XPath utilities; 10/11/09
+ ;;0.1;C0C;nopatch;noreleasedate
+ ;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
+ ;
+TEST ;
+ D XPATH($$FIRST($$ID("CCR1")),"/","GIDX","GARY")
+ Q
+ ;
+TEST2 ;
+ S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail"
+ D XPATH($$FIRST($$ID("gpl")),"/","GIDX","GARY","",REDUX)
+ 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 '$D(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
+ I GD'="" S @ZXPARY@(NEWPATH)=GD ; IF YES, ADD IT TO THE XPATH ARRAY
+ N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
+ I ZFRST'="" D  ; THERE IS A CHILD
+ . 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 GNXT'="" D  ; MOVE ON TO THE NEXT SIBLING
+ . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB
+ Q
+ ;
+PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
+ ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
+ ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
+ N ZR
+ M ^CacheTempEWD($j)=@INXML ;
+ S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
+ Q ZR
+ ;
+ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
+ N ZN
+ S ZN=$$NXTSIB(ZOID)
+ I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
+ Q 0
+ ;
+DETAIL(ZRTN,ZOID) ; RETURNS DETAIL FOR NODE ZOID IN ZRTN, PASSED BY NAME
+ N DET
+ D getElementDetails^%zewdXPath(ZOID,.DET)
+ M @ZRTN=DET
+ Q
+ ;
+ID(ZNAME) ;RETURNS THE docOID OF THE DOCUMENT NAMED ZNAME
+ Q $$getDocumentNode^%zewdDOM(ZNAME)
+ ;
+NAME(ZOID) ;RETURNS THE NAME OF THE DOCUMENAT WITH docOID ZOID
+ Q $$getDocumentName^%zewdDOM(ZOID)
+ ;
+FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
+ N GOID
+ S GOID=ZOID
+ S GOID=$$getFirstChild^%zewdDOM(GOID)
+ I GOID="" Q ""
+ I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
+ Q GOID
+ ;
+HASCHILD(ZOID) ; RETURNS TRUE IF ZOID HAS CHILD NODES
+ Q $$hasChildNodes^%zewdDOM(ZOID)
+ ;
+CHILDREN(ZRTN,ZOID) ;RETURNS CHILDREN OF ZOID IN ARRAY ZRTN, PASSED BY NAME
+ N childArray
+ d getChildrenInOrder^%zewdDOM(ZOID,.childArray)
+ m @ZRTN=childArray
+ q
+ ;
+TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE
+ Q $$getName^%zewdDOM(ZOID)
+ ;
+NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING
+ Q $$getNextSibling^%zewdDOM(ZOID)
+ ;
+NXTCHLD(ZOID) ; RETURNS THE NEXT CHILD IN PARENT ZPAR
+ N GOID
+ S GOID=$$getNextChild^%zewdDOM($$PARENT(ZOID),ZOID)
+ I GOID="" Q ""
+ I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
+ Q GOID
+ ;
+PARENT(ZOID) ; RETURNS PARENT OF ZOID
+ Q $$getParentNode^%zewdDOM(ZOID)
+ ;
+DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE
+ N ZT2
+ S ZT2=$$getElementText^%zewdDOM(ZOID,.ZT2)
+ M @ZT=ZT2
+ Q
+ ;Q $$getTextValue^%zewdXPath(ZOID)
+ ;Q $$getData^%zewdDOM(ZOID,.ZT)
+ ;

ccr/branches/ohum/p/C0CXPAT0.m

@@ -1 @@
-C0CXPAT0          ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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/branches/ohum/p/C0CXPATH.m

@@ -1 @@
-C0CXPATH          ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
-        ;;1.0;C0C;;May 19, 2009;Build 1
-        ;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
+ ;