Changeset 1337 for ccr/branches

ccr/branches/ohum/p/C0CACTOR.m

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-              r1333
+              r1337
 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^Subspecialty^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^Subspecialty^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

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

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

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

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

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

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

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

Context Navigation

Legend:

Download in other formats: