Changeset 1544 for ccr/trunk/p

Timestamp:

Oct 1, 2012, 9:32:46 PM (12 years ago)

Author:

Sam Habiel

Message:

Merged Routines in OHUM branch back in main tree

Location:

ccr/trunk/p

Files:

• . (modified) (1 prop)
• C0CACTOR.m (modified) (1 diff, 1 prop)
• C0CALERT.m (modified) (1 diff, 1 prop)
• C0CBAT.m (modified) (1 diff, 1 prop)
• C0CCCD.m (modified) (1 diff, 1 prop)
• C0CCCD1.m (modified) (1 diff, 1 prop)
• C0CCCR.m (modified) (1 diff, 1 prop)
• C0CCCR0.m (modified) (1 diff, 1 prop)
• C0CCMT.m (modified) (1 diff, 1 prop)
• C0CCPT.m (modified) (1 diff, 1 prop)
• C0CDIC.m (modified) (1 diff, 1 prop)
• C0CDOM.m (modified) (1 diff, 1 prop)
• C0CDPT.m (modified) (1 diff, 1 prop)
• C0CENC.m (modified) (1 diff, 1 prop)
• C0CENV.m (modified) (1 diff, 1 prop)
• C0CEVC.m (modified) (1 diff, 1 prop)
• C0CEWD.m (modified) (1 diff, 1 prop)
• C0CEWD1.m (modified) (1 diff, 1 prop)
• C0CFM1.m (modified) (1 diff, 1 prop)
• C0CFM2.m (modified) (1 diff, 1 prop)
• C0CFM3.m (modified) (1 diff, 1 prop)
• C0CIM2.m (modified) (1 diff, 1 prop)
• C0CIMMU.m (modified) (1 diff, 1 prop)
• C0CIN.m (modified) (1 diff, 1 prop)
• C0CLA7DD.m (modified) (1 diff, 1 prop)
• C0CLA7Q.m (modified) (1 diff, 1 prop)
• C0CLABS.m (modified) (1 diff, 1 prop)
• C0CMAIL.m (modified) (1 diff, 1 prop)
• C0CMAIL2.m (modified) (1 diff, 1 prop)
• C0CMAIL3.m (modified) (1 diff, 1 prop)
• C0CMCCD.m (modified) (1 diff, 1 prop)
• C0CMED.m (modified) (1 diff, 1 prop)
• C0CMED1.m (modified) (1 diff, 1 prop)
• C0CMED2.m (modified) (1 diff, 1 prop)
• C0CMED3.m (modified) (1 diff, 1 prop)
• C0CMED4.m (modified) (1 diff, 1 prop)
• C0CMED6.m (modified) (1 diff, 1 prop)
• C0CMIME.m (modified) (1 diff, 1 prop)
• C0CMXML.m (modified) (1 diff, 1 prop)
• C0CMXMLB.m (modified) (1 diff, 1 prop)
• C0CMXP.m (modified) (1 diff, 1 prop)
• C0CNHIN.m (modified) (1 diff, 1 prop)
• C0CNMED2.m (modified) (1 diff, 1 prop)
• C0CNMED4.m (modified) (1 diff, 1 prop)
• C0CORSLT.m (modified) (1 diff, 1 prop)
• C0COVREL.m (added)
• C0COVRES.m (added)
• C0COVREU.m (added)
• C0CPARMS.m (modified) (1 diff, 1 prop)
• C0CPROBS.m (modified) (1 diff, 1 prop)
• C0CPROC.m (modified) (1 diff, 1 prop)
• C0CPXRM.m (modified) (1 diff, 1 prop)
• C0CQRY1.m (modified) (1 diff, 1 prop)
• C0CQRY2.m (modified) (1 diff, 1 prop)
• C0CRAHL7.m (added)
• C0CRARPT.m (added)
• C0CRIMA.m (modified) (1 diff, 1 prop)
• C0CRNF.m (modified) (1 diff, 1 prop)
• C0CRNFRP.m (modified) (1 diff, 1 prop)
• C0CRPMS.m (modified) (1 diff, 1 prop)
• C0CRXN.m (modified) (1 diff, 1 prop)
• C0CRXNRD.m (modified) (1 diff, 1 prop)
• C0CSNOA.m (modified) (1 diff, 1 prop)
• C0CSOAP.m (modified) (1 diff, 1 prop)
• C0CSQMB.m (added)
• C0CSUB1.m (modified) (1 diff, 1 prop)
• C0CSYS.m (modified) (1 diff, 1 prop)
• C0CTIU.m (added)
• C0CTIU1.m (added)
• C0CUNIT.m (modified) (1 diff, 1 prop)
• C0CUTIL.m (modified) (1 diff, 1 prop)
• C0CVA200.m (modified) (1 diff, 1 prop)
• C0CVALID.m (added)
• C0CVIT2.m (modified) (1 diff, 1 prop)
• C0CVITAL.m (modified) (1 diff, 1 prop)
• C0CVOBX1.m (modified) (1 diff, 1 prop)
• C0CVORU.m (modified) (1 diff, 1 prop)
• C0CXEWD.m (modified) (1 diff, 1 prop)
• C0CXPAT0.m (modified) (1 diff, 1 prop)
• C0CXPATH.m (modified) (1 diff, 1 prop)

ccr/trunk/p/C0CACTOR.m

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

ccr/trunk/p/C0CALERT.m

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

ccr/trunk/p/C0CBAT.m

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

ccr/trunk/p/C0CCCD.m

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

ccr/trunk/p/C0CCCD1.m

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

ccr/trunk/p/C0CCCR.m

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

ccr/trunk/p/C0CCCR0.m

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

ccr/trunk/p/C0CCMT.m

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

ccr/trunk/p/C0CCPT.m

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

ccr/trunk/p/C0CDIC.m

@@ -1 @@
-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)
- ;
+C0CDIC    ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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/trunk/p/C0CDOM.m

@@ -1 +1 @@
 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
- ;
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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
- ;
+        ; 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")
- ;
+        ; 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
- ;
+        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)
- ;
+        Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
+        ;
 PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID
- Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
- ;
+        Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
+        ;
 ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID
- S HANDLE=C0CDOCID
- K @RTN
- D GETTXT^MXMLDOM("A")
- Q
- ;
+        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
- ;
+        ;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)
- ;
+        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
- ;
+        ;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
- ;
+        ;
+        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
- ;
+        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/trunk/p/C0CDPT.m

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

ccr/trunk/p/C0CENC.m

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

ccr/trunk/p/C0CENV.m

@@ -1 @@
-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
+C0CENV  ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;
+        ;
+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/trunk/p/C0CEVC.m

@@ -1 +1 @@
 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
- ;
+        ;;1.2;C0C;;May 11, 2012;Build 47
+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/trunk/p/C0CEWD.m

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

ccr/trunk/p/C0CEWD1.m

@@ -1 @@
-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
+C0CEWD1   ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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/trunk/p/C0CFM1.m

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

ccr/trunk/p/C0CFM2.m

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

ccr/trunk/p/C0CFM3.m

@@ -1 @@
-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
- ;
+C0CFM3    ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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/trunk/p/C0CIM2.m

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

ccr/trunk/p/C0CIMMU.m

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

ccr/trunk/p/C0CIN.m

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

ccr/trunk/p/C0CLA7DD.m

@@ -1 @@
-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
- ;
- ;
+C0CLA7DD        ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009
+        ;;1.2;C0C;;May 11, 2012;Build 47
+ ;
+        ; 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
  ;

ccr/trunk/p/C0CLA7Q.m

@@ -1 @@
-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
+C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;
+        ;
+        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/trunk/p/C0CLABS.m

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

ccr/trunk/p/C0CMAIL.m

@@ -1 +1 @@
 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
- ;  ===================
+V       ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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/trunk/p/C0CMAIL2.m

@@ -1 @@
-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
- ;  ===================
+C0CMAIL2        ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr  ; 5/10/12 2:50pm
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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/trunk/p/C0CMAIL3.m

@@ -1 @@
-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
- ;  ===================
+C0CMAIL3        ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr   ; 5/10/12 2:51pm
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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/trunk/p/C0CMCCD.m

@@ -1 +1 @@
 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
- ; 
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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
- ;
+        K ZERR
+        D CLEAN^DILF
+        D UPDATE^DIE("","C0CFDA","","ZERR")
+        I $D(ZERR) D  ;
+        . W "ERROR",!
+        . ZWR ZERR
+        . B
+        K C0CFDA
+        Q
+        ;

ccr/trunk/p/C0CMED.m

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

ccr/trunk/p/C0CMED1.m

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

ccr/trunk/p/C0CMED2.m

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

ccr/trunk/p/C0CMED3.m

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

ccr/trunk/p/C0CMED4.m

@@ -1 @@
-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
- ;
+C0CMED4         ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 ; 5/10/12 2:38pm
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ; 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($L(MEDIEN):$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/trunk/p/C0CMED6.m

@@ -1 @@
-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
- 
+C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ; 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/trunk/p/C0CMIME.m

@@ -1 @@
-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
- ;
+C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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/trunk/p/C0CMXML.m

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

ccr/trunk/p/C0CMXMLB.m

@@ -1 @@
-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"))
+C0CMXMLB        ;;ISF/RWF - Tool to build XML ; 5/10/12 2:51pm
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        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/trunk/p/C0CMXP.m

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

ccr/trunk/p/C0CNHIN.m

@@ -1 +1 @@
 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
- ;
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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
- ;
+        ; 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")
- ;
+        ; 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
- ;
+        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)
- ;
+        Q $$CHILD^MXMLDOM(C0CDOCID,ZOID)
+        ;
 PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID
- Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
- ;
+        Q $$PARENT^MXMLDOM(C0CDOCID,ZOID)
+        ;
 ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID
- S HANDLE=C0CDOCID
- K @RTN
- D GETTXT^MXMLDOM("A")
- Q
- ;
+        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
- ;
+        ;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)
- ;
+        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
- ;
+        ;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
- ;
+        ;
+        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
- ;
+        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/trunk/p/C0CNMED2.m

@@ -1 @@
-C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
- ;;1.0;C0C;;May 19, 2009;Build 38
- ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel.
- ; Licensed under the terms of the GNU General Public License.
- ; See attached copy of the License.
- ; 
- ; This program is free software; you can redistribute it and/or modify
- ; it under the terms of the GNU General Public License as published by
- ; the Free Software Foundation; either version 2 of the License, or
- ; (at your option) any later version.
- ; 
- ; This program is distributed in the hope that it will be useful,
- ; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
- ; GNU General Public License for more details.
- ; 
- ; You should have received a copy of the GNU General Public License along
- ; with this program; if not, write to the Free Software Foundation, Inc.,
- ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- ;
- ; --Revision History
- ; July 2008 - Initial Version/GPL
- ; July 2008 - March 2009 various revisions
- ; March 2009 - Reconstruction of routine as driver for other med routines/SMH
- ; 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
- ;
+C0CNMED2        ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 ; 5/10/12 2:53pm
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ; 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/trunk/p/C0CNMED4.m

@@ -1 @@
-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
- ;
+C0CNMED4        ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 ; 5/10/12 2:54pm
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ; 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
+        S C0CMFLAG=$$GET^C0CPARMS("MEDALL")_"^"_$$GET^C0CPARMS("MEDLIMIT")_"^"_$$GET^C0CPARMS("MEDACTIVE")_"^"_$$GET^C0CPARMS("MEDPENDING") ;SETTING FLAG
+        N I S I=0 
+        F  S I=$O(MEDS("med",I)) Q:'I  D  ; For each medication
+        . ;OHUM/RUT 3120507 ;STATUS VALIDATION FOR INPATIENT
+               . I ($P(C0CMFLAG,"^",1)'=1) D
+               . . I ($P(C0CMFLAG,"^",3)=1)&(MEDS("med",I,"vaStatus@value")'="ACTIVE") D
+               . . . K MEDS("med",I) Q
+               . . I ($P(C0CMFLAG,"^",4)=1)&(MEDS("med",I,"vaStatus@value")'="PENDING") D
+               . . . K MEDS("med",I) Q
+               . ;OHUM/RUT
+        . 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/trunk/p/C0CORSLT.m

@@ -1 @@
-C0CORSLT ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11
- ;;1.0;C0C;;Jan 21, 2010;Build 38
- ;Copyright 2011 George Lilly.
- ;Licensed under the terms of the GNU General Public License.
- ;See attached copy of the License.
- ;
- ;This program is free software; you can redistribute it and/or modify
- ;it under the terms of the GNU General Public License as published by
- ;the Free Software Foundation; either version 2 of the License, or
- ;(at your option) any later version.
- ;
- ;This program is distributed in the hope that it will be useful,
- ;but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
- ;GNU General Public License for more details.
- ;
- ;You should have received a copy of the GNU General Public License along
- ;with this program; if not, write to the Free Software Foundation, Inc.,
- ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- ;
- W "NO ENTRY FROM TOP",!
- Q
- ;
-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.2;C0C;;May 11, 2012;Build 47
+        ;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/trunk/p/C0CPARMS.m

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

ccr/trunk/p/C0CPROBS.m

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

ccr/trunk/p/C0CPROC.m

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

ccr/trunk/p/C0CPXRM.m

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

@@ -1 @@
-LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99  13:48
-        ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 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
+LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99  13:48
+               ;;1.2;C0C;;May 11, 2012;Build 47
+               ;
+               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/trunk/p/C0CQRY2.m

@@ -1 @@
-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
+LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ; 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/trunk/p/C0CRIMA.m

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

ccr/trunk/p/C0CRNF.m

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

ccr/trunk/p/C0CRNFRP.m

@@ -1 @@
-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)
- ;
+C0CRNFRP        ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09 ; 5/10/12 2:56pm
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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/trunk/p/C0CRPMS.m

@@ -1 @@
-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
- ;
+C0CRPMS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR RPMS ;1/14/09  14:33
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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/trunk/p/C0CRXN.m

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

ccr/trunk/p/C0CRXNRD.m

@@ -1 @@
-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
-
+C0CRXNRD        ; WV/SMH - CCR/CCD PROJECT: Routine to Read RxNorm files;11/15/08
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        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/trunk/p/C0CSNOA.m

@@ -1 @@
-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
- ;
+C0CSNOA   ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/08
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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/trunk/p/C0CSOAP.m

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

ccr/trunk/p/C0CSUB1.m

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

ccr/trunk/p/C0CSYS.m

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

ccr/trunk/p/C0CUNIT.m

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

ccr/trunk/p/C0CUTIL.m

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

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

ccr/trunk/p/C0CVIT2.m

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

ccr/trunk/p/C0CVITAL.m

@@ -1 @@
-C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
- ;;1.0;C0C;;May 19, 2009;Build 38
- ;Copyright 2008,2009 George Lilly, University of Minnesota and others.
- ;Licensed under the terms of the GNU General Public License.
- ;See attached copy of the License.
- ;
- ;This program is free software; you can redistribute it and/or modify
- ;it under the terms of the GNU General Public License as published by
- ;the Free Software Foundation; either version 2 of the License, or
- ;(at your option) any later version.
- ;
- ;This program is distributed in the hope that it will be useful,
- ;but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
- ;GNU General Public License for more details.
- ;
- ;You should have received a copy of the GNU General Public License along
- ;with this program; if not, write to the Free Software Foundation, Inc.,
- ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- ;
- W "NO ENTRY FROM TOP",!
- Q
- ;
-EXTRACT(VITXML,DFN,VITOUTXML) ; EXTRACT VITALS INTO PROVIDED XML TEMPLATE
- ;
- ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
- ; IVITXML CONTAINS ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE
- ;
- N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF,VORDR
- S C0CVLMT=$$GET^C0CPARMS("VITLIMIT") ; GET THE LIMIT PARM
- S C0CVSTRT=$$GET^C0CPARMS("VITSTART") ; GET START PARM
- D DT^DILF(,C0CVLMT,.C0CEDT) ;
- D DT^DILF(,C0CVSTRT,.C0CSDT) ; 
- ;D DT^DILF(,C0CVLMT,.C0CSDT) ; GPL TESTING
- ;D DT^DILF(,C0CVSTRT,.C0CEDT) ; 
- W "VITALS START: ",C0CVSTRT," LIMIT: ",C0CVLMT,!
- I $$RPMS^C0CUTIL() D VITRPMS QUIT
- I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VITVISTA QUIT
- ;I $$SYSNAME^C0CSYS()="RPMS" D VITRPMS
- ;E  D VITVISTA
- Q
- ;
-VITVISTA ; EXTRACT VITALS FROM VISTA INTO PROVIDED XML TEMPLATE
- D FASTVIT^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) ; GPL THIS ONE WORKS FOR AT
- ; LEAST ONE SET OF VITALS - TO DO, CALL IT REPETIVELY TO GET EARLIER VITALS
- ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT)
- ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CSDT,C0CEDT)
- ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CVSTRT,C0CVLMT) ; GPL LET GMR HANDLE THE DATES
- I '$D(VITRSLT(1)) S @VITOUTXML@(0)=0 Q  ; RETURN NOT FOUND AND QUIT
- I $P(VITRSLT(1),U,2)="No vitals found." D  Q  ; NULL RESULT FROM RPC
- . I DEBUG W "NO VITALS FOUND FROM VITALS RPC",!
- . S @VITOUTXML@(0)=0
- I $P(VITRSLT(1),U,2)="No vitals found." Q  ; QUIT
- ; ZWR RPCRSLT
- S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS"))
- S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP"))
- K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES
- N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX
- D VITDVISTA(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY
- I DEBUG ZWR VDATES ;DEBUG
- S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE
- ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY
- S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS
- F J=1:1:VCNT  D  ; FOR EACH VITAL IN THE LIST
- . I $D(VITRSLT(VSORT(J))) D
- . . S VITVMAP=$NA(@VITTVMAP@(J))
- . . K @VITVMAP
- . . I DEBUG W "VMAP= ",VITVMAP,!
- . . S VITPTMP=VITRSLT(VSORT(J)) ; DATE SORTED VITAL FROM RETURN ARRAY
- . . I DEBUG W "VITAL ",VSORT(J),!
- . . I DEBUG W VITRSLT(VSORT(J))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),!
- . . I DEBUG W $P(VITPTMP,U,4),!
- . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID
-        . . ;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.2;C0C;;May 11, 2012;Build 47
+        ;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/trunk/p/C0CVOBX1.m

@@ -1 @@
-LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09
- ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994
- ; 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
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ; 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/trunk/p/C0CVORU.m

@@ -1 @@
-C0C7VORU ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009
- ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994
- ;
-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/10/12 5:19pm
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;
+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/trunk/p/C0CXEWD.m

@@ -1 @@
-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)
- ;
+C0CXEWD   ; C0C/GPL - EWD based XPath utilities; 10/11/09
+        ;;1.2;C0C;;May 11, 2012;Build 47
+        ;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/trunk/p/C0CXPAT0.m

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

ccr/trunk/p/C0CXPATH.m

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