iSharkFly-Open
/
VistA-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

updates for MU Certification

This commit is contained in:
george 2011-06-23 19:01:41 +00:00
parent ac1f7a441b
commit 07194d2d80
47 changed files with 10597 additions and 9632 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

546
p/C0CACTOR.m
View File

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

255
p/C0CALERT.m
View File

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

444
p/C0CBAT.m
View File

@ -1,234 +1,234 @@
C0CBAT ; CCDCCR/GPL - CCR Batch utilities; 4/21/09
;;1.0;C0C;;May 19, 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 CCR Batch Utility Library ",!
Q
;
;;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
;
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
;
;
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
;
; 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
;
; 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
;
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
;
; 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
;
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
; 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
; 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
;
; 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
;
; 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
;

520
p/C0CCCD.m
View File

@ -1,272 +1,272 @@
C0CCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08
;;1.0;C0C;;May 19, 2009;
;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
;
;;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
;
; 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
;
; 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
;
; 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
;
; 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
;
; 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
;
; 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
;
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
;
; 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
;
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
;
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>
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>

524
p/C0CCCD1.m
View File

@ -1,268 +1,268 @@
C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08
;;1.0;C0C;;May 19, 2009;
;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
;
;;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
;
; 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
;
; 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
;
D ZLOAD(ARY,"C0CCCD1")
; ZWR @ARY
Q
;
TRMCCD ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD
Q
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>
;;<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>

530
p/C0CCCR.m
View File

@ -1,277 +1,277 @@
C0CCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08
;;1.0;C0C;;May 19, 2009;
;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
;
;;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
;
; 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
;
;
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")
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")
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
;
; 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")
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")
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"")")
Q
;
; 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"")")
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
;
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
;
; 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
;
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
;
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>"
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>"

1834
p/C0CCCR0.m
View File

File diff suppressed because it is too large Load Diff

132
p/C0CCMT.m
View File

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

42
p/C0CCPT.m
View File

@ -1,5 +1,5 @@
C0CCPT ;;BSL;RETURN CPT DATA;
;Sequence Managers Software GPL
;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
@ -8,27 +8,27 @@ ENTRY(DFN,STDT,ENDDT,TXT) ;BUILD TOTAL ARRAY OF ALL IEN'S FOR TIU NOTES
;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)
;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
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))

78
p/C0CDOM.m
View File

@ -125,10 +125,11 @@ DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE
S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT)
Q
;
OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM
OUTXML(ZRTN,INID,NO1ST) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM
;
S C0CDOCID=INID
D START^C0CMXMLB($$TAG(1),,"G")
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)
@ -157,6 +158,14 @@ WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE
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)
;
@ -216,36 +225,43 @@ DOMI(INARY,HANDLE,PARENT) ; EXTRINSIC TO INSERT NHIN ARRAYS TO A DOM
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(PARENT)>0 D ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL
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
D MAJOR(INARY,"",0) ; PROCESS ALL THE NODES TO BE ADDED
I $L(PARENT)>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE
Q 1 ; SUCCESS
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,ZTAG,ZNUM) ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES
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
. . N ZS S ZS=""
. . I $O(@ZARY@(ZI,ZN,ZS))'["." D ; END NODES HERE
. . . N NEWARY
. . . S NEWARY=$NA(@ZARY@(ZI,ZN))
. . . D MINOR("NEWARY") ; INSERT THE END NODES
. . E F S ZS=$O(@ZARY@(ZI,ZN,ZS)) Q:ZS="" D ; FOR EACH STRING
. . . I ZS["." D ; INTERMEDIATE NODE FOUND
. . . . W !,"IM:",ZS
. . . W !,ZI,":",ZN,":",ZS_" : ",@ZARY@(ZI,ZN,ZS)
Q
;
MINOR(ZINARY) ; DOES THE WORK FOR END NODES, HANDLES ATTRIBUTES
;
N ZZI S ZZI=""
F S ZZI=$O(@ZINARY@(ZZI)) Q:ZZI="" D ;
. W !,"MINOR",ZZI,":",@ZINARY@(ZZI)
. . 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
@ -267,6 +283,7 @@ EXPAND(ZZOUT,ZZIN) ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED
. . . 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]
@ -291,19 +308,6 @@ EXPAND(ZZOUT,ZZIN) ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED
. . . S @GZI2=ZZV ; REMEMBER THE VALUE?
Q
;
POP(OSTR,ISTR) ; EXTRINSIC WHICH RETURNS TRUE IF ISTR IS EMPTY
; IF ISTR IS NOT EMPTY, LOOKS FOR "." AND "@" AND RETURNS
; xxx,1,yyyetc for xxx.yyyetc and xx@,1,yyy for xxx@yyyetc
; OSTR IS PASSED BY REFERENCE AND CONTAINS yyyetc
I $L(ISTR)=0 Q 1 ; WE ARE DONE
N ZG,ZN,ZR
S ZN=1
I ISTR["." D ;
. S ZG=$P(ISTR,".",1)
. S OSTR=$P(ISTR,".",2)
. S ZR=ZG_","_ZN_","_OSTR
Q ZR
;
NEWDOM() ; extrinsic which creates a new DOM and returns the HANDLE
N CBK,SUCCESS,LEVEL,NODE,HANDLE
K ^TMP("MXMLERR",$J)
@ -313,5 +317,3 @@ NEWDOM() ; extrinsic which creates a new DOM and returns the HANDLE
L -^TMP("MXMLDOM",$J)
Q HANDLE
;

412
p/C0CDPT.m
View File

@ -1,269 +1,269 @@
C0CDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
;;1.0;C0C;;May 19, 2009;
;
; 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
;
;;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")
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")
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")
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")
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")
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")
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") ;
Q $$GET1^DIQ(2,DFN,.02,"I")_"^"_$$GET1^DIQ(2,DFN,.02,"E") ;
SSN(DFN) ; SSN
Q $$GET1^DIQ(2,DFN,.09)
Q $$GET1^DIQ(2,DFN,.09)
ADDRTYPE(DFN) ; Address Type
; Vista only stores a home address for the patient.
Q "Home"
; Vista only stores a home address for the patient.
Q "Home"
ADDR1(DFN) ; Get Home Address line 1
Q $$GET1^DIQ(2,DFN,.111)
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
; 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)
Q $$GET1^DIQ(2,DFN,.114)
STATE(DFN) ; Get State for Home Address
Q $$GET1^DIQ(2,DFN,.115)
Q $$GET1^DIQ(2,DFN,.115)
ZIP(DFN) ; Get Zip code for Home Address
Q $$GET1^DIQ(2,DFN,.116)
Q $$GET1^DIQ(2,DFN,.116)
COUNTY(DFN) ; Get County for our Address
Q $$GET1^DIQ(2,DFN,.117)
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"
; Unfortunately, it's not stored anywhere in Vista, so the inevitable...
Q "USA"
RESTEL(DFN) ; Residential Telephone
Q $$GET1^DIQ(2,DFN,.131)
Q $$GET1^DIQ(2,DFN,.131)
WORKTEL(DFN) ; Work Telephone
Q $$GET1^DIQ(2,DFN,.132)
Q $$GET1^DIQ(2,DFN,.132)
EMAIL(DFN) ; Email Adddress
Q $$GET1^DIQ(2,DFN,.133)
Q $$GET1^DIQ(2,DFN,.133)
CELLTEL(DFN) ; Cell Phone
Q $$GET1^DIQ(2,DFN,.134)
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")
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")
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")
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")
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")
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)
Q $$GET1^DIQ(2,DFN,.212)
NOK1ADD1(DFN) ; NOK1 Address 1
Q $$GET1^DIQ(2,DFN,.213)
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
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)
Q $$GET1^DIQ(2,DFN,.216)
NOK1STAT(DFN) ; NOK1 State
Q $$GET1^DIQ(2,DFN,.217)
Q $$GET1^DIQ(2,DFN,.217)
NOK1ZIP(DFN) ; NOK1 Zip Code
Q $$GET1^DIQ(2,DFN,.218)
Q $$GET1^DIQ(2,DFN,.218)
NOK1HTEL(DFN) ; NOK1 Home Telephone
Q $$GET1^DIQ(2,DFN,.219)
Q $$GET1^DIQ(2,DFN,.219)
NOK1WTEL(DFN) ; NOK1 Work Telephone
Q $$GET1^DIQ(2,DFN,.21011)
Q $$GET1^DIQ(2,DFN,.21011)
NOK1SAME(DFN) ; Is NOK1's Address the same the patient?
Q $$GET1^DIQ(2,DFN,.2125)
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")
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")
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")
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")
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")
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)
Q $$GET1^DIQ(2,DFN,.2192)
NOK2ADD1(DFN) ; NOK2 Address 1
Q $$GET1^DIQ(2,DFN,.2193)
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
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)
Q $$GET1^DIQ(2,DFN,.2196)
NOK2STAT(DFN) ; NOK2 State
Q $$GET1^DIQ(2,DFN,.2197)
Q $$GET1^DIQ(2,DFN,.2197)
NOK2ZIP(DFN) ; NOK2 Zip Code
Q $$GET1^DIQ(2,DFN,.2198)
Q $$GET1^DIQ(2,DFN,.2198)
NOK2HTEL(DFN) ; NOK2 Home Telephone
Q $$GET1^DIQ(2,DFN,.2199)
Q $$GET1^DIQ(2,DFN,.2199)
NOK2WTEL(DFN) ; NOK2 Work Telephone
Q $$GET1^DIQ(2,DFN,.211011)
Q $$GET1^DIQ(2,DFN,.211011)
NOK2SAME(DFN) ; Is NOK2's Address the same the patient?
Q $$GET1^DIQ(2,DFN,.21925)
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")
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")
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")
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")
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")
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)
Q $$GET1^DIQ(2,DFN,.331)
EMERADD1(DFN) ; EMER Address 1
Q $$GET1^DIQ(2,DFN,.333)
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
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)
Q $$GET1^DIQ(2,DFN,.336)
EMERSTAT(DFN) ; EMER State
Q $$GET1^DIQ(2,DFN,.337)
Q $$GET1^DIQ(2,DFN,.337)
EMERZIP(DFN) ; EMER Zip Code
Q $$GET1^DIQ(2,DFN,.338)
Q $$GET1^DIQ(2,DFN,.338)
EMERHTEL(DFN) ; EMER Home Telephone
Q $$GET1^DIQ(2,DFN,.339)
Q $$GET1^DIQ(2,DFN,.339)
EMERWTEL(DFN) ; EMER Work Telephone
Q $$GET1^DIQ(2,DFN,.33011)
Q $$GET1^DIQ(2,DFN,.33011)
EMERSAME(DFN) ; Is EMER's Address the same the NOK?
Q $$GET1^DIQ(2,DFN,.3305)
Q $$GET1^DIQ(2,DFN,.3305)

378
p/C0CENC.m
View File

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

177
p/C0CEVC.m Normal file
View File

@ -0,0 +1,177 @@
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
;

140
p/C0CEWD.m
View File

@ -1,71 +1,71 @@
C0CEWD ; CCDCCR/GPL - CCR EWD utilities; 1/6/11
;;0.1;CCDCCR;nopatch;noreleasedate
;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
;
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
;
;
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
;

332
p/C0CFM1.m
View File

@ -1,177 +1,177 @@
C0CFM1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
;;1.0;C0C;;May 19, 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 CCR FILEMAN Utility Library ",!
W !
Q
;
;;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
;
;
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
;
; 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
;
; ^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
;
; 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
;
; 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
;
; 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
; 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
; 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
;
; 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
;
; 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
;

688
p/C0CFM2.m
View File

@ -1,362 +1,362 @@
C0CFM2 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08
;;1.0;C0C;;May 19, 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 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
;
;;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
;
;
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
;
;
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
;
; 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
;
; 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
;
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
;
;
;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
;
;
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
;
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
;
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
;
; 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
;
; 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
;
; 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
;
; 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
; 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
; 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
;
; 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
;
; 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
;

266
p/C0CIM2.m
View File

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

208
p/C0CIMMU.m
View File

@ -1,107 +1,107 @@
C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09
;;1.0;C0C;;May 19, 2009;
;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
;
;;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
;
;
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
;
;
; 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
;

382
p/C0CIN.m
View File

@ -1,193 +1,193 @@
C0CIN ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08
;;1.0;C0C;;Sep 20, 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 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
;
;;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
;
K ZERR,C0CIEN
D CLEAN^DILF
D UPDATE^DIE("","C0CFDA","C0CIEN","ZERR")
I $D(ZERR) D ;
. W "ERROR",!
. ZWR ZERR
. B
K C0CFDA
Q
;

2
p/C0CLA7Q.m
View File

@ -1,5 +1,5 @@
C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009
;;1.0;C0C;;May 19, 2009;
;;1.0;C0C;;May 19, 2009;Build 38
;
;
Q

781
p/C0CLABS.m
View File

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

464
p/C0CMAIL2.m Normal file
View File

@ -0,0 +1,464 @@
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
; ===================

209
p/C0CMED.m
View File

@ -1,105 +1,114 @@
C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009
;;1.0;C0C;;May 19, 2009;
; 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
;;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
; 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
;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 ; Inpatient UD Meds
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
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",!
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
Q
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

472
p/C0CMED1.m
View File

@ -1,238 +1,238 @@
C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09
;;1.0;C0C;;May 19, 2009;
;;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
;
;;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(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
;
;
; 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
;

530
p/C0CMED2.m
View File

@ -1,267 +1,267 @@
C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista
;;1.0;C0C;;May 19, 2009;
;;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
;
;;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
;
;
; 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
;

520
p/C0CMED3.m
View File

@ -1,262 +1,262 @@
C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista
;;1.0;C0C;;May 19, 2009;
;;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
;
;;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
. . 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")=""
. 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
. 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")=""
. 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
;
;
; 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
. . 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")=""
. 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
. 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")=""
. 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
;

86
p/C0CMIME.m
View File

@ -1,4 +1,4 @@
C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11
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.
@ -80,23 +80,49 @@ TESTMAIL2 ;
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("LILLY.GEORGE@mdc-crew.net")=""
;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 ZFROM="ANTHRACITE.NANCY"
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)
D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH,"CCR.xml")
ZWR GR
Q
;
MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FLAGS) ; MAIL SENDING INTERFACE
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
@ -106,45 +132,47 @@ MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FLAGS) ; MAIL SENDING INTERFACE
; 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(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=""ccr.xml"""
S GM(6)="Content-Type: text/xml; name="_FNAME
S GM(7)="Content-Transfer-Encoding: base64"
S GM(8)="Content-Disposition: attachment; filename=""ccr.xml"""
S GM(9)=" "
S GM(10)=" " ; FOR THE END
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 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(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(10)=""
S GG(11)="--123456899999--"
;S GG(11)="Content-Type: text/plain; charset=""us-ascii"""
S GG(12)=" "
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(18)=""
S GG(19)="--123456899999"
S GG(20)="--987654321--"
K GBLD
@ -182,19 +210,19 @@ MAILSEND0(LRMSUBJ) ; Send extract back to requestor.
;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(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(9)=""
S GM(10)="" ; FOR THE END
S GM(11)="--frontier--"
S GM(12)="."
S GM(13)=" "
S GM(13)=""
K GBLD
;D QUEUE^C0CXPATH("GBLD","GM",1,9)
;D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))
@ -231,19 +259,19 @@ MAILSEND2(UDFN,ADDR) ; Send extract back to requestor.
;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(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(9)=""
S GM(10)="" ; FOR THE END
S GM(11)="--1234567--"
S GM(12)=" "
S GM(13)=" "
S GM(12)=""
S GM(13)=""
K GBLD
D QUEUE^C0CXPATH("GBLD","GM",5,9)
D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1))

538
p/C0CMXML.m
View File

@ -1,286 +1,254 @@
C0CMXML ; GPL - MXML based XPath utilities;10/13/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
; 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 ; TEST DRIVER ASSUMES A CCR IN ^GPL("CCR")
; LOOK FOR TEST RESULTS IN VARIABLE G
; ACTUALLY, IF NO CCR IS THERE, IT WILL PUT ONE THERE FOR PAT DFN 2
;
N GPLCCR S GPLCCR=$NA(^GPL("CCR"))
I '$D(@GPLCCR@(1)) D ; NO CCR THERE
. N TGPL
. D CCRRPC^C0CCCR(.TGPL,2) ; GET A CCR FOR PAT 2
. M @GPLCCR=TGPL ; PUT IT IN THE TEST GLOBAL
. K @GPLCCR@(0) ; KILL THE LINE COUNT FOR THE PARSER
D EN(.G,GPLCCR)
Q
;
EN(ZRTN,C0CIN) ; PARSE THE CCR PASSED BY NAME IN C0CIN
; AND RETURN THE XPATH ARRAY THAT RESULTS IN ZRTN, PASSED BY REFERENCE
I '$D(@C0CIN@(1)) Q ;NOTHING PASSED IN
K ZRTN
N C0CDOCID,REDUX,GARY,GARY2,GARY3
S C0CDOCID=$$PARSE(C0CIN)
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
M ZRTN=GARY3
Q
;
TEST0 ;
S C0CXMLIN=$NA(^TMP("C0CMXML",$J))
K GARY
M @C0CXMLIN=^GPL("CCR")
;W $$FTG^%ZISH("/home/vademo2/CCR/","PAT_774_CCR_V1_0_0.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
;
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
;
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
;

16
p/C0CMXMLB.m
View File

@ -5,11 +5,12 @@ MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09 16:55
;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) ;Call this once at the begining.
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
D OUTPUT($$XMLHDR) D:$L($G(DOCTYPE)) OUTPUT("<!DOCTYPE "_DOCTYPE_">") D OUTPUT("<"_DOC_">")
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
@ -40,12 +41,15 @@ ATT(ATT) ;Output a string of attributes
F S I=$O(ATT(I)) Q:I="" S S=S_" "_I_"="_$$Q(ATT(I))
Q S
;
Q(X) ;Add Quotes
I X'[$C(34) Q $C(34)_X_$C(34)
N Q,Y,I,Z S Q=$C(34),(Y,Z)=""
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(34)_Y_$C(34)
Q $C(39)_Y_$C(39)
;
XMLHDR() ; -- provides current XML standard header
Q "<?xml version=""1.0"" encoding=""utf-8"" ?>"

580
p/C0CMXP.m
View File

@ -1,292 +1,292 @@
C0CMXP ; GPL - MXML based XPath 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
;
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
;
;;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
;
K ZERR
D CLEAN^DILF
D UPDATE^DIE("","C0CFDA","","ZERR")
I $D(ZERR) D ;
. W "ERROR",!
. ZWR ZERR
. B
K C0CFDA
Q
;

72
p/C0CNHIN.m
View File

@ -18,17 +18,53 @@ C0CNHIN ; GPL - PROCESSING FOR OUTPUT OF NHINV ROUTINES;6/3/11 17:05
;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
;
Q
EN(ZRTN,ZDFN) ; GENERATE AN NHIN ARRAY FOR A PATIENT
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) ; CALL NHINV ROUTINES TO PULL XML
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 ;
@ -58,6 +94,16 @@ CCR ; TRY IT WITH A CCR
;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"))
@ -73,6 +119,28 @@ TEST1 ; TEST NHINV OUTPUT IN ^GPL("NIHIN")
; 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

218
p/C0CNMED4.m Normal file
View File

@ -0,0 +1,218 @@
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"
. S @MAP@("MEDSTATUSTEXT")=$G(MED("vaStatus@value")) ; need to filter status
. ;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("dose.dose@dose"))
. ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"")
. S @MAP@("MEDSTRENGTHUNIT")=$G(MED("dose.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("dose.dose@dose"))
. ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"")
. S @MAP@("MEDCONCUNIT")=$G(MED("dose.does@units"))
. ;S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds.
. S @MAP@("MEDQUANTITYVALUE")=""
. ; 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
;

116
p/C0CPARMS.m
View File

@ -1,62 +1,62 @@
C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/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.
;
;;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
;
; 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
;
;
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
;
;
D CHECK ; SHOULDN'T HAPPEN BUT TO BE SAFE
N GTMP
Q $G(@C0CPARMS@(WHICHP)) ;PULL THE PARM FROM THE TABLE
;

356
p/C0CPROBS.m
View File

@ -1,180 +1,180 @@
C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08
;;1.0;C0C;;May 19, 2009;
;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)
. 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
. 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)
. 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
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)
. 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
. 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)
. 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
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
;
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
;

274
p/C0CPROC.m
View File

@ -1,137 +1,137 @@
C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10
;;1.0;C0C;;Jan 21, 2010;
;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))
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
. . . 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
. . . S PREVCPT=ZCPT
. . . S PREVDT=ZDATE
N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"PROCEDURES"))
M @ZRIM=@C0CPRC@("V")
Q
;
PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME
N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN=""
F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH PRV SEG
. I ZR'="" Q ;ONLY WANT THE FIRST PRIMARY PROVIDER
. I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1)
I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR
Q ZRTN
;
DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT
Q $$FMDTOUTC^C0CUTIL(ISTR,"DT")
;
CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS
; CPT^CATEGORY^TEXT
N Z1,Z2,Z3,ZRTN
S Z1=$P(ISTR,U,1)
I Z1="" D ;
. I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1)
I Z1'="" D ; IF THERE IS A CPT CODE IN THERE
. ;S Z1=$P(ISTR,U,1)
. S Z2=$P(ISTR,U,2)
. S Z3=$P(ISTR,U,3)
. S ZRTN=Z1_U_Z2_U_Z3
E S ZRTN=""
Q ZRTN
;
MAP(PROCXML,C0CPRC,PROCOUT) ; MAP PROCEDURES XML
;
N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"PROCTEMP")) ;WORK AREA FOR TEMPLATE
K @ZTEMP
N ZBLD
S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"PROCBLD")) ; BUILD LIST AREA
D QUEUE^C0CXPATH(ZBLD,PROCXML,1,1) ; FIRST LINE
N ZINNER
D QUERY^C0CXPATH(PROCXML,"//Procedures/Procedure","ZINNER") ;ONE PROC
N ZTMP,ZVAR,ZI
S ZI=""
F S ZI=$O(@C0CPRC@("V",ZI)) Q:ZI="" D ;FOR EACH PROCEDURE
. S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS PROCEDURE XML
. S ZVAR=$NA(@C0CPRC@("V",ZI)) ;THIS PROCEDURE VARIABLES
. D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE
. D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD
D QUEUE^C0CXPATH(ZBLD,PROCXML,@PROCXML@(0),@PROCXML@(0))
N ZZTMP
D BUILD^C0CXPATH(ZBLD,PROCOUT) ;BUILD FINAL XML
K @ZTEMP,@ZBLD,@C0CPRC
Q
;
C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10
;;1.0;C0C;;Jan 21, 2010;Build 38
;Copyright 2010 George Lilly, University of Minnesota and others.
;Licensed under the terms of the GNU General Public License.
;See attached copy of the License.
;
;This program is free software; you can redistribute it and/or modify
;it under the terms of the GNU General Public License as published by
;the Free Software Foundation; either version 2 of the License, or
;(at your option) any later version.
;
;This program is distributed in the hope that it will be useful,
;but WITHOUT ANY WARRANTY; without even the implied warranty of
;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;GNU General Public License for more details.
;
;You should have received a copy of the GNU General Public License along
;with this program; if not, write to the Free Software Foundation, Inc.,
;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
;
W "NO ENTRY FROM TOP",!
Q
;
SETVARS ; SET UP VARIABLES FOR PROCEDURES, ENCOUNTERS, AND NOTES
S C0CENC=$NA(^TMP("C0CCCR",$J,"C0CENC",DFN))
S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN))
S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN))
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
. . . 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
. . . 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
;

1011
p/C0CRIMA.m
View File

File diff suppressed because it is too large Load Diff

888
p/C0CRNF.m
View File

@ -1,462 +1,462 @@
C0CRNF ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08
;;1.0;C0C;;May 19, 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) Utility Library ",!
W !
Q
;
;;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
;
; 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
;
; 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
;
; 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
;
; 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
;
; 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
;
;
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
;
; 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
;
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)
;
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
;
;
;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
;
;
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
;
;
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
;
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)
; 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)
; 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)
;
; 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)
;
; 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)
;

564
p/C0CRXN.m
View File

@ -1,290 +1,290 @@
C0CRXN ; CCDCCR/GPL - CCR RXN utilities; 12/6/08
;;1.0;C0C;;May 19, 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 CCR RXNORM Utility Library ",!
W !
Q
;
;;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
;
; 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
; 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
; 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
; 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
; 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
;
; 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
;
; 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
;

538
p/C0CSOAP.m
View File

@ -1,273 +1,273 @@
C0CSOAP ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09
;;1.0;C0C;;May 19, 2009;
;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
;
;;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=""
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
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
;
; 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
;

252
p/C0CSUB1.m
View File

@ -1,136 +1,136 @@
C0CSUB1 ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08
;;1.0;C0C;;May 19, 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 CCR SUBSCRIPTIONN Utility Library ",!
Q
;
;;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
;
;
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
;
;
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
;
;
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
;
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
;
; 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
; 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
; 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
;
; 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
;
; 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
;

110
p/C0CSYS.m
View File

@ -1,59 +1,59 @@
C0CSYS ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008
;;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 "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.
;
;;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"
;
Q:$G(DUZ("AG"))="I" "RPMS"
Q "WorldVistA EHR/VOE"
;
SYSVER() ;Get EHR System Version; PUBLIC; Extrinsic
Q "1.0"
;
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
;
; 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
;

352
p/C0CUNIT.m
View File

@ -1,186 +1,186 @@
C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08
;;1.0;C0C;;May 19, 2009;
;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
;
;;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
;
; 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
;
; 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
;
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
;
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
;
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
;
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
;
; 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
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
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

298
p/C0CUTIL.m
View File

@ -1,145 +1,161 @@
C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08
;;0.1;C0C;;Jun 15, 2008;Build 29
;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)
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.
;
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
;This program is free software; you can redistribute it and/or modify
;it under the terms of the GNU General Public License as published by
;the Free Software Foundation; either version 2 of the License, or
;(at your option) any later version.
;
;This program is distributed in the hope that it will be useful,
;but WITHOUT ANY WARRANTY; without even the implied warranty of
;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;GNU General Public License for more details.
;
;You should have received a copy of the GNU General Public 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
;
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")
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)
I ZRXN=309362 S ZRXN=213169
I ZRXN=855318 S ZRXN=855320
I ZRXN=197361 S ZRXN=212549
I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F"
Q ZRSLT
;
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
;
RPMS() ; Are we running on an RPMS system rather than Vista?
Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service
VISTA() ; Are we running on Vanilla Vista?
Q $G(DUZ("AG"))="V" ; If User Agency is VA
WV() ; Are we running on WorldVista?
Q $G(DUZ("AG"))="E" ; Code for WV.
OV() ; Are we running on OpenVista?
Q $G(DUZ("AG"))="O" ; Code for OpenVista
RPMS() ; Are we running on an RPMS system rather than Vista?
Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service
VISTA() ; Are we running on Vanilla Vista?
Q $G(DUZ("AG"))="V" ; If User Agency is VA
WV() ; Are we running on WorldVista?
Q $G(DUZ("AG"))="E" ; Code for WV.
OV() ; Are we running on OpenVista?
Q $G(DUZ("AG"))="O" ; Code for OpenVista

304
p/C0CVA200.m
View File

@ -1,168 +1,168 @@
C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008
;;1.0;C0C;;May 19, 2009;
;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,*)
;
;;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")
;
; 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")
;
; 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")
;
; 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")
;
; 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)
;
; 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"
;
; 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)
;
; 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"
;
; 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 ""
;
; 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 ""
;
;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 ""
;
; 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 ""
;
; 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)
;
; 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"
;
; 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)
;
; INPUT: DUZ ByVal
; OUTPUT: String
; Direct global access
N EMAIL S EMAIL=$G(^VA(200,DUZ,.15))
Q $P(EMAIL,U)
;

924
p/C0CVIT2.m
View File

@ -1,478 +1,478 @@
C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08
;;1.0;C0C;;Feb 16, 2010;
;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
;
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
;
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
;
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
;
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
;
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
;
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
;
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
;
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)
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
;
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
;
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
;
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
;
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
;
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
;
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
;
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
;
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
;

422
p/C0CXPAT0.m
View File

@ -1,212 +1,212 @@
C0CXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08
;;1.0;C0C;;May 19, 2009;
;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>
;;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>

1376
p/C0CXPATH.m
View File

File diff suppressed because it is too large Load Diff