Index: ccr/branches/ohum/p/C0CACTOR.m =================================================================== --- ccr/branches/ohum/p/C0CACTOR.m (revision 1333) +++ ccr/branches/ohum/p/C0CACTOR.m (revision 1337) @@ -1,273 +1,273 @@ -C0CACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008,2009 George Lilly, University of Minnesota. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; PROCESS THE ACTORS SECTION OF THE CCR - ; - ; ===Revision History=== - ; 0.1 Initial Writing of Skeleton--GPL - ; 0.2 Patient Data Extraction--SMH - ; 0.3 Information System Info Extraction--SMH - ; 0.4 Patient data rouine refactored; adjustments here--SMH - ; -EXTRACT(IPXML,ALST,AXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE - ; IPXML is the Input Actor Template into which we substitute values - ; This is straight XML. Values to be substituted are in @@VAL@@ format. - ; ALST is the actor list global generated by ACTLST^C0CCCR and has format: - ; ^TMP(7542,1,"ACTORS",0)=Count - ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN" - ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM" - ; AXML is the output arrary, to contain XML. - ; - N I,J,AMAP,AOID,ATYP,AIEN - D CP^C0CXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML - D REPLACE^C0CXPATH(AXML,"","//Actors") ; DELETE THE INSIDES - I DEBUG W "PROCESSING ACTORS ",! - F I=1:1:@ALST@(0) D ; PROCESS ALL ACTORS IN THE LIST - . I @ALST@(I)["@@" Q ; NOT A VALID ACTOR - . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID - . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE - . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER - . I AIEN="" D Q ; IEN CAN'T BE NULL - . . W "WARING NUL ACTOR: ",ATYP,! - . I ATYP="" Q ; NOT A VALID ACTOR - . ; - . I DEBUG W AOID_" "_ATYP_" "_AIEN,! - . I ATYP="PATIENT" D ; PATIENT ACTOR TYPE - . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP") - . . D PATIENT("ATMP",AIEN,AOID,"ATMP2") - . ; - . I ATYP="SYSTEM" D ; SYSTEM ACTOR TYPE - . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP") - . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2") - . ; - . I ATYP="NOK" D ; NOK ACTOR TYPE - . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP") - . . D NOK("ATMP",AIEN,AOID,"ATMP2") - . ; - . I ATYP="PROVIDER" D ; PROVIDER ACTOR TYPE - . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP") - . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2") - . ; - . I ATYP="ORGANIZATION" D ; PROVIDER ACTOR TYPE - . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP") - . . D ORG("ATMP",AIEN,AOID,"ATMP2") - . ; - . W "PROCESSING:",ATYP," ",AIEN,! - . ;I @ATMP2@(0)=0 Q ; NOTHING RETURNED, SKIP THIS ONE - . D INSINNER^C0CXPATH(AXML,"ATMP2") ; INSERT INTO ROOT - . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE - ; - N ACTTMP - D MISSING^C0CXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS - I ACTTMP(0)>0 D ; IF THERE ARE MISSING VARS - - . ; STRINGS MARKED AS @@X@@ - . W "ACTORS Missing list: ",! - . F I=1:1:ACTTMP(0) W ACTTMP(I),! - Q - ; -PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR - I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,! - ;GPL SEPARATED EXTRACT FROM MAP FOR PROCESSING PATIENTS - TO MAKE - ; CODE REUSABLE FROM ERX - N AMAP - S AMAP=$NA(^TMP($J,"AMAP")) - K @AMAP - D PEXTRACT(AMAP,AIEN,AOID) ;EXTRACT THE PATIENT ACTOR - I $P($$SITE^VASITE(),U,2)="OROVILLE HOSPITAL" S C0CDE=1 - I $G(C0CDE)'="" D DEIDENT(AMAP,AIEN) ; DEIDENTIFY THE CCR - D MAP(INXML,AMAP,OUTXML) ;MAP TO XML - K @AMAP ; CLEAN UP BEHIND US - Q - ; -DEIDENT(GPL,ZDFN) ; QUICK WAY TO DEIDENTIFY THE CCR - S @GPL@("ACTORADDRESSCITY")="ALTON" - S @GPL@("ACTORADDRESSLINE1")="1234 Somewhere Lane" - S @GPL@("ACTORADDRESSLINE2")="" - S @GPL@("ACTORADDRESSSOURCEID")="ACTORPATIENT_"_ZDFN - S @GPL@("ACTORADDRESSSTATE")="KANSAS" - S @GPL@("ACTORADDRESSTYPE")="Home" - S @GPL@("ACTORADDRESSZIPCODE")=67623 - S @GPL@("ACTORCELLTEL")="" - S @GPL@("ACTORCELLTELTEXT")="" - S @GPL@("ACTORDATEOFBIRTH")="1957-12-25" - S @GPL@("ACTOREMAIL")="" - S @GPL@("ACTORFAMILYNAME")="ZZ PATIENT"_ZDFN - ;S @GPL@("ACTORGENDER")="MALE" - S @GPL@("ACTORGIVENNAME")="TEST"_ZDFN - S @GPL@("ACTORIEN")=2 - S @GPL@("ACTORMIDDLENAME")="TWO" - S @GPL@("ACTOROBJECTID")="ACTORPATIENT_"_ZDFN - S @GPL@("ACTORRESTEL")="888-555-1212" - S @GPL@("ACTORRESTELTEXT")="Residential Telephone" - S @GPL@("ACTORSOURCEID")="ACTORSYSTEM_1" - S @GPL@("ACTORSSN")="769122557P" - S @GPL@("ACTORSSNSOURCEID")="ACTORPATIENT_"_ZDFN - S @GPL@("ACTORSSNTEXT")="SSN" - S @GPL@("ACTORSUFFIXNAME")="" - S @GPL@("ACTORWORKTEL")="888-121-1212" - S @GPL@("ACTORWORKTELTEXT")="Work Telephone" - Q - ; -PEXTRACT(AMAP,AIEN,AOID) ; EXTRACT TO RETURN ARRAY RARY PASSED BY NAME - N ZX - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID - S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CDPT(AIEN) - S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CDPT(AIEN) - S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CDPT(AIEN) - S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^C0CDPT(AIEN) - S @AMAP@("ACTORGENDER")=$P($$GENDER^C0CDPT(AIEN),U,2) - S @AMAP@("ACTORGENDERCODE")=$P($$GENDER^C0CDPT(AIEN),U,1) - S @AMAP@("ACTORSSN")="" - S @AMAP@("ACTORSSNTEXT")="" - S @AMAP@("ACTORSSNSOURCEID")="" - S X="MSCDPTID" ; ROUTINE TO TEST FOR MRN ON OPENVISTA - X ^%ZOSF("TEST") ; TEST TO SEE IF THE ROUTINE EXISTS - I $T S MRN=$$^MSCDPTID(DFN) ;TEST FOR MRN ON OPENVISTA ;GPL - I $G(MRN)'="" D ; IF MRN IS PRESENT - . S @AMAP@("ACTORSSN")=MRN - . S @AMAP@("ACTORSSNTEXT")="MRN" - . S @AMAP@("ACTORSSNSOURCEID")=AOID - E D ; NO MRN, USE SSN - . S ZX=$$SSN^C0CDPT(AIEN) - . I ZX'="" D ; IF THERE IS A SSN IN THE RECORD - . . S @AMAP@("ACTORSSN")=ZX - . . S @AMAP@("ACTORSSNTEXT")="SSN" - . . S @AMAP@("ACTORSSNSOURCEID")=AOID - S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^C0CDPT(AIEN) - S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^C0CDPT(AIEN) - S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^C0CDPT(AIEN) - S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CDPT(AIEN) - S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CDPT(AIEN) - S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^C0CDPT(AIEN) - S @AMAP@("ACTORRESTEL")="" - S @AMAP@("ACTORRESTELTEXT")="" - S ZX=$$RESTEL^C0CDPT(AIEN) - I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD - . S @AMAP@("ACTORRESTEL")=ZX - . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone" - S @AMAP@("ACTORWORKTEL")="" - S @AMAP@("ACTORWORKTELTEXT")="" - S ZX=$$WORKTEL^C0CDPT(AIEN) - I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD - . S @AMAP@("ACTORWORKTEL")=ZX - . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone" - S @AMAP@("ACTORCELLTEL")="" - S @AMAP@("ACTORCELLTELTEXT")="" - S ZX=$$CELLTEL^C0CDPT(AIEN) - I ZX'="" D ; IF THERE IS A CELL PHONE IN THE RECORD - . S @AMAP@("ACTORCELLTEL")=ZX - . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone" - S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CDPT(AIEN) - S @AMAP@("ACTORADDRESSSOURCEID")=AOID - S @AMAP@("ACTORIEN")=AIEN - S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE - Q - ; -MAP(INXML,AMAP,OUTXML) ;MAP ANY ACTOR TO XML - D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE - Q - ; -SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR - ; - ; N AMAP - S AMAP=$NA(^TMP($J,"AMAP")) - K @AMAP - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID - S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^C0CSYS - S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^C0CSYS - S @AMAP@("ACTORINFOSYSSOURCEID")=AOID - D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE - Q - ; -NOK(INXML,AIEN,AOID,OUTXML) ; PROCESS A NEXT OF KIN TYPE ACTOR - ; - ; N AMAP - S AMAP=$NA(^TMP($J,"AMAP")) - K @AMAP - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID - S @AMAP@("ACTORDISPLAYNAME")="" - S @AMAP@("ACTORRELATION")="" - S @AMAP@("ACTORRELATIONSOURCEID")="" - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE - D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE - Q - ; -ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR - ; - N AMAP,ZIEN,ZSITE - S AMAP=$NA(^TMP($J,"AMAP")) - K @AMAP - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID - S ZSITE=$$SITE^VASITE ; SITE FORMAT IEN^NAME^DATE - S ZIEN=$P(ZSITE,"^",1) - S @AMAP@("ORGANIZATIONNAME")=$P(ZSITE,U,2) - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" - S @AMAP@("ACTORADDRESSTYPE")="Office" - S @AMAP@("ACTORADDRESSLINE1")=$$GET1^DIQ(4,ZIEN_",",1.01) - S @AMAP@("ACTORADDRESSLINE2")=$$GET1^DIQ(4,ZIEN_",",1.02) - S @AMAP@("ACTORADDRESSCITY")=$$GET1^DIQ(4,ZIEN_",",1.03) - S @AMAP@("ACTORADDRESSSTATE")=$$GET1^DIQ(4,ZIEN_",",.02) - S @AMAP@("ACTORPOSTALCODE")=$$GET1^DIQ(4,ZIEN_",",1.04) - S @AMAP@("ACTORTELEPHONE")="" - S @AMAP@("ACTORTELEPHONETYPE")="" - S ZX=$$GET1^DIQ(4.03,"1,"_ZIEN_",",.03) - I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE - . S @AMAP@("ACTORTELEPHONE")=ZX - . S @AMAP@("ACTORTELEPHONETYPE")="Office" - D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE - K @AMAP - Q - ; -PROVIDER(INXML,AIEN,AOID,OUTXML) ; PROCESS A PROVIDER TYPE ACTOR - ; - ; N AMAP - S AMAP=$NA(^TMP($J,"AMAP")) - K @AMAP - I '$D(^VA(200,AIEN,0)) D Q ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN) - . W "WARNING - MISSING PROVIDER: ",AIEN,! - . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID - S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CVA200(AIEN) - S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CVA200(AIEN) - S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CVA200(AIEN) - S @AMAP@("ACTORTITLE")=$$TITLE^C0CVA200(AIEN) - S @AMAP@("IDTYPE")=$P($$NPI^C0CVA200(AIEN),U,1) - S @AMAP@("ID")=$P($$NPI^C0CVA200(AIEN),U,2) - S @AMAP@("IDDESC")=$P($$NPI^C0CVA200(AIEN),U,3) - S @AMAP@("ACTORSPECIALITY")=$$SPEC^C0CVA200(AIEN) - S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^C0CVA200(AIEN) - S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^C0CVA200(AIEN) - S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CVA200(AIEN) - S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CVA200(AIEN) - S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^C0CVA200(AIEN) - S @AMAP@("ACTORTELEPHONE")="" - S @AMAP@("ACTORTELEPHONETYPE")="" - S ZX=$$TEL^C0CVA200(AIEN) - I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE - . S @AMAP@("ACTORTELEPHONE")=ZX - . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^C0CVA200(AIEN) - S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CVA200(AIEN) - S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1" - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE - S @AMAP@("ACTORORGLINK")="ACTORORGANIZATION_1" - D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE - Q - ; +C0CACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008,2009 George Lilly, University of Minnesota. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; PROCESS THE ACTORS SECTION OF THE CCR + ; + ; ===Revision History=== + ; 0.1 Initial Writing of Skeleton--GPL + ; 0.2 Patient Data Extraction--SMH + ; 0.3 Information System Info Extraction--SMH + ; 0.4 Patient data rouine refactored; adjustments here--SMH + ; +EXTRACT(IPXML,ALST,AXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE + ; IPXML is the Input Actor Template into which we substitute values + ; This is straight XML. Values to be substituted are in @@VAL@@ format. + ; ALST is the actor list global generated by ACTLST^C0CCCR and has format: + ; ^TMP(7542,1,"ACTORS",0)=Count + ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN" + ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM" + ; AXML is the output arrary, to contain XML. + ; + N I,J,AMAP,AOID,ATYP,AIEN + D CP^C0CXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML + D REPLACE^C0CXPATH(AXML,"","//Actors") ; DELETE THE INSIDES + I DEBUG W "PROCESSING ACTORS ",! + F I=1:1:@ALST@(0) D ; PROCESS ALL ACTORS IN THE LIST + . I @ALST@(I)["@@" Q ; NOT A VALID ACTOR + . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID + . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE + . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER + . I AIEN="" D Q ; IEN CAN'T BE NULL + . . W "WARING NUL ACTOR: ",ATYP,! + . I ATYP="" Q ; NOT A VALID ACTOR + . ; + . I DEBUG W AOID_" "_ATYP_" "_AIEN,! + . I ATYP="PATIENT" D ; PATIENT ACTOR TYPE + . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP") + . . D PATIENT("ATMP",AIEN,AOID,"ATMP2") + . ; + . I ATYP="SYSTEM" D ; SYSTEM ACTOR TYPE + . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP") + . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2") + . ; + . I ATYP="NOK" D ; NOK ACTOR TYPE + . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP") + . . D NOK("ATMP",AIEN,AOID,"ATMP2") + . ; + . I ATYP="PROVIDER" D ; PROVIDER ACTOR TYPE + . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP") + . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2") + . ; + . I ATYP="ORGANIZATION" D ; PROVIDER ACTOR TYPE + . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP") + . . D ORG("ATMP",AIEN,AOID,"ATMP2") + . ; + . W "PROCESSING:",ATYP," ",AIEN,! + . ;I @ATMP2@(0)=0 Q ; NOTHING RETURNED, SKIP THIS ONE + . D INSINNER^C0CXPATH(AXML,"ATMP2") ; INSERT INTO ROOT + . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE + ; + N ACTTMP + D MISSING^C0CXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS + I ACTTMP(0)>0 D ; IF THERE ARE MISSING VARS - + . ; STRINGS MARKED AS @@X@@ + . W "ACTORS Missing list: ",! + . F I=1:1:ACTTMP(0) W ACTTMP(I),! + Q + ; +PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR + I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,! + ;GPL SEPARATED EXTRACT FROM MAP FOR PROCESSING PATIENTS - TO MAKE + ; CODE REUSABLE FROM ERX + N AMAP + S AMAP=$NA(^TMP($J,"AMAP")) + K @AMAP + D PEXTRACT(AMAP,AIEN,AOID) ;EXTRACT THE PATIENT ACTOR + I $P($$SITE^VASITE(),U,2)="OROVILLE HOSPITAL" S C0CDE=1 + I $G(C0CDE)'="" D DEIDENT(AMAP,AIEN) ; DEIDENTIFY THE CCR + D MAP(INXML,AMAP,OUTXML) ;MAP TO XML + K @AMAP ; CLEAN UP BEHIND US + Q + ; +DEIDENT(GPL,ZDFN) ; QUICK WAY TO DEIDENTIFY THE CCR + S @GPL@("ACTORADDRESSCITY")="ALTON" + S @GPL@("ACTORADDRESSLINE1")="1234 Somewhere Lane" + S @GPL@("ACTORADDRESSLINE2")="" + S @GPL@("ACTORADDRESSSOURCEID")="ACTORPATIENT_"_ZDFN + S @GPL@("ACTORADDRESSSTATE")="KANSAS" + S @GPL@("ACTORADDRESSTYPE")="Home" + S @GPL@("ACTORADDRESSZIPCODE")=67623 + S @GPL@("ACTORCELLTEL")="" + S @GPL@("ACTORCELLTELTEXT")="" + S @GPL@("ACTORDATEOFBIRTH")="1957-12-25" + S @GPL@("ACTOREMAIL")="" + S @GPL@("ACTORFAMILYNAME")="ZZ PATIENT"_ZDFN + ;S @GPL@("ACTORGENDER")="MALE" + S @GPL@("ACTORGIVENNAME")="TEST"_ZDFN + S @GPL@("ACTORIEN")=2 + S @GPL@("ACTORMIDDLENAME")="TWO" + S @GPL@("ACTOROBJECTID")="ACTORPATIENT_"_ZDFN + S @GPL@("ACTORRESTEL")="888-555-1212" + S @GPL@("ACTORRESTELTEXT")="Residential Telephone" + S @GPL@("ACTORSOURCEID")="ACTORSYSTEM_1" + S @GPL@("ACTORSSN")="769122557P" + S @GPL@("ACTORSSNSOURCEID")="ACTORPATIENT_"_ZDFN + S @GPL@("ACTORSSNTEXT")="SSN" + S @GPL@("ACTORSUFFIXNAME")="" + S @GPL@("ACTORWORKTEL")="888-121-1212" + S @GPL@("ACTORWORKTELTEXT")="Work Telephone" + Q + ; +PEXTRACT(AMAP,AIEN,AOID) ; EXTRACT TO RETURN ARRAY RARY PASSED BY NAME + N ZX + S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID + S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CDPT(AIEN) + S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CDPT(AIEN) + S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CDPT(AIEN) + S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^C0CDPT(AIEN) + S @AMAP@("ACTORGENDER")=$P($$GENDER^C0CDPT(AIEN),U,2) + S @AMAP@("ACTORGENDERCODE")=$P($$GENDER^C0CDPT(AIEN),U,1) + S @AMAP@("ACTORSSN")="" + S @AMAP@("ACTORSSNTEXT")="" + S @AMAP@("ACTORSSNSOURCEID")="" + S X="MSCDPTID" ; ROUTINE TO TEST FOR MRN ON OPENVISTA + X ^%ZOSF("TEST") ; TEST TO SEE IF THE ROUTINE EXISTS + I $T S MRN=$$^MSCDPTID(DFN) ;TEST FOR MRN ON OPENVISTA ;GPL + I $G(MRN)'="" D ; IF MRN IS PRESENT + . S @AMAP@("ACTORSSN")=MRN + . S @AMAP@("ACTORSSNTEXT")="MRN" + . S @AMAP@("ACTORSSNSOURCEID")=AOID + E D ; NO MRN, USE SSN + . S ZX=$$SSN^C0CDPT(AIEN) + . I ZX'="" D ; IF THERE IS A SSN IN THE RECORD + . . S @AMAP@("ACTORSSN")=ZX + . . S @AMAP@("ACTORSSNTEXT")="SSN" + . . S @AMAP@("ACTORSSNSOURCEID")=AOID + S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^C0CDPT(AIEN) + S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^C0CDPT(AIEN) + S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^C0CDPT(AIEN) + S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CDPT(AIEN) + S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CDPT(AIEN) + S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^C0CDPT(AIEN) + S @AMAP@("ACTORRESTEL")="" + S @AMAP@("ACTORRESTELTEXT")="" + S ZX=$$RESTEL^C0CDPT(AIEN) + I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD + . S @AMAP@("ACTORRESTEL")=ZX + . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone" + S @AMAP@("ACTORWORKTEL")="" + S @AMAP@("ACTORWORKTELTEXT")="" + S ZX=$$WORKTEL^C0CDPT(AIEN) + I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD + . S @AMAP@("ACTORWORKTEL")=ZX + . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone" + S @AMAP@("ACTORCELLTEL")="" + S @AMAP@("ACTORCELLTELTEXT")="" + S ZX=$$CELLTEL^C0CDPT(AIEN) + I ZX'="" D ; IF THERE IS A CELL PHONE IN THE RECORD + . S @AMAP@("ACTORCELLTEL")=ZX + . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone" + S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CDPT(AIEN) + S @AMAP@("ACTORADDRESSSOURCEID")=AOID + S @AMAP@("ACTORIEN")=AIEN + S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX + S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE + Q + ; +MAP(INXML,AMAP,OUTXML) ;MAP ANY ACTOR TO XML + D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE + Q + ; +SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR + ; + ; N AMAP + S AMAP=$NA(^TMP($J,"AMAP")) + K @AMAP + S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID + S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^C0CSYS + S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^C0CSYS + S @AMAP@("ACTORINFOSYSSOURCEID")=AOID + D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE + Q + ; +NOK(INXML,AIEN,AOID,OUTXML) ; PROCESS A NEXT OF KIN TYPE ACTOR + ; + ; N AMAP + S AMAP=$NA(^TMP($J,"AMAP")) + K @AMAP + S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID + S @AMAP@("ACTORDISPLAYNAME")="" + S @AMAP@("ACTORRELATION")="" + S @AMAP@("ACTORRELATIONSOURCEID")="" + S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE + D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE + Q + ; +ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR + ; + N AMAP,ZIEN,ZSITE + S AMAP=$NA(^TMP($J,"AMAP")) + K @AMAP + S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID + S ZSITE=$$SITE^VASITE ; SITE FORMAT IEN^NAME^DATE + S ZIEN=$P(ZSITE,"^",1) + S @AMAP@("ORGANIZATIONNAME")=$P(ZSITE,U,2) + S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" + S @AMAP@("ACTORADDRESSTYPE")="Office" + S @AMAP@("ACTORADDRESSLINE1")=$$GET1^DIQ(4,ZIEN_",",1.01) + S @AMAP@("ACTORADDRESSLINE2")=$$GET1^DIQ(4,ZIEN_",",1.02) + S @AMAP@("ACTORADDRESSCITY")=$$GET1^DIQ(4,ZIEN_",",1.03) + S @AMAP@("ACTORADDRESSSTATE")=$$GET1^DIQ(4,ZIEN_",",.02) + S @AMAP@("ACTORPOSTALCODE")=$$GET1^DIQ(4,ZIEN_",",1.04) + S @AMAP@("ACTORTELEPHONE")="" + S @AMAP@("ACTORTELEPHONETYPE")="" + S ZX=$$GET1^DIQ(4.03,"1,"_ZIEN_",",.03) + I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE + . S @AMAP@("ACTORTELEPHONE")=ZX + . S @AMAP@("ACTORTELEPHONETYPE")="Office" + D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE + K @AMAP + Q + ; +PROVIDER(INXML,AIEN,AOID,OUTXML) ; PROCESS A PROVIDER TYPE ACTOR + ; + ; N AMAP + S AMAP=$NA(^TMP($J,"AMAP")) + K @AMAP + I '$D(^VA(200,AIEN,0)) D Q ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN) + . W "WARNING - MISSING PROVIDER: ",AIEN,! + . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT + S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID + S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CVA200(AIEN) + S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CVA200(AIEN) + S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CVA200(AIEN) + S @AMAP@("ACTORTITLE")=$$TITLE^C0CVA200(AIEN) + S @AMAP@("IDTYPE")=$P($$NPI^C0CVA200(AIEN),U,1) + S @AMAP@("ID")=$P($$NPI^C0CVA200(AIEN),U,2) + S @AMAP@("IDDESC")=$P($$NPI^C0CVA200(AIEN),U,3) + S @AMAP@("ACTORSPECIALITY")=$$SPEC^C0CVA200(AIEN) + S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^C0CVA200(AIEN) + S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^C0CVA200(AIEN) + S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CVA200(AIEN) + S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CVA200(AIEN) + S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^C0CVA200(AIEN) + S @AMAP@("ACTORTELEPHONE")="" + S @AMAP@("ACTORTELEPHONETYPE")="" + S ZX=$$TEL^C0CVA200(AIEN) + I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE + . S @AMAP@("ACTORTELEPHONE")=ZX + . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^C0CVA200(AIEN) + S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CVA200(AIEN) + S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1" + S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE + S @AMAP@("ACTORORGLINK")="ACTORORGANIZATION_1" + D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE + Q + ; Index: ccr/branches/ohum/p/C0CALERT.m =================================================================== --- ccr/branches/ohum/p/C0CALERT.m (revision 1333) +++ ccr/branches/ohum/p/C0CALERT.m (revision 1337) @@ -1,132 +1,132 @@ -C0CALERT ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008,2009 George Lilly, University of Minnesota and others. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(ALTXML,DFN,ALTOUTXML,CALLBK) ; EXTRACT ALERTS INTO XML TEMPLATE - ; CALLBACK IF PROVIDED IS CALLED FOR EACH ALLERGY BEFORE MAPPING - ; ALTXML AND ALTOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED - ; - ; GET ADVERSE REACTIONS AND ALLERGIES - ; N GMRA,GMRAL ; FOR DEBUGGING, DON'T NEW THESE VARIABLES - S GMRA="0^0^111" - D EN1^GMRADPT - I $G(GMRAL)'=1 D Q ; NO ALLERGIES FOUND THUS *QUIT* - . S @ALTOUTXML@(0)=0 - ; DEFINE MAPPING - N ALTTVMAP,ALTVMAP,ALTTARYTMP,ALTARYTMP - S ALTTVMAP=$NA(^TMP("C0CCCR",$J,"ALERTS")) - S ALTTARYTMP=$NA(^TMP("C0CCCR",$J,"ALERTSARYTMP")) - K @ALTTVMAP,@ALTTARYTMP - N ALTTMP,ALTCNT S ALTG=$NA(GMRAL),ALTCNT=1 - S ALTTMP="" ; - F S ALTTMP=$O(@ALTG@(ALTTMP)) Q:ALTTMP="" D ; CHANGED TO $O BY GPL - . W "ALTTMP="_ALTTMP,! - . ; I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q - . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT)) - . K @ALTVMAP - . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT - . N A1 S A1=@ALTG@(ALTTMP) ; ALL THE PIECES - . I $D(CALLBK) D @CALLBK ;CALLBACK FOR EPRESCRIBING - . N A2 S A2=$$GET1^DIQ(120.8,ALTTMP,"MECHANISM","I") ; MECHANISM - . N A3 S A3=$P(A1,U,5) ; ADVERSE FLAG - . N ADT S ADT="Patient has an " ; X $ZINT H 5 - . S ADT=ADT_$S(A2="P":"ADVERSE",A2="A":"ALLERGIC",1:"UNKNOWN") - . S ADT=ADT_" reaction to "_$P(@ALTG@(ALTTMP),U,2)_"." - . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT - . N ADTY S ADTY=$S(A2="P":"Adverse Reaction",A2="A":"Allergy",1:"") ; - . S @ALTVMAP@("ALERTTYPE")=ADTY ; type of allergy - . N ALTCDE ; SNOMED CODE THE THE ALERT - . S ALTCDE=$S(A2="P":"282100009",A2="A":"416098002",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC - . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ; - . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE - . ; AND 282100009 FOR ADVERSE REACTION TO A SUBSTANCE - . I ALTCDE'="" D ; IF THERE IS A CODE - . . S @ALTVMAP@("ALERTCODESYSTEM")="SNOMED CT" - . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="2008" - . E D ; SET TO NULL - . . S @ALTVMAP@("ALERTCODESYSTEM")="" - . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="" - . S @ALTVMAP@("ALERTSTATUSTEXT")="" ; WHERE DO WE GET THIS? - . N ALTPROV S ALTPROV=$P(^GMR(120.8,ALTTMP,0),U,5) ; SOURCE PROVIDER IEN - . I ALTPROV'="" D ; PROVIDER PROVIDEED - . . S @ALTVMAP@("ALERTSOURCEID")="ACTORPROVIDER_"_ALTPROV - . E S @ALTVMAP@("ALERTSOURCEID")="" ; SOURCE NULL - SHOULD NOT HAPPEN - . W "RUNNING ALERTS, PROVIDER: ",@ALTVMAP@("ALERTSOURCEID"),! - . N ACGL1,ACGFI,ACIEN,ACVUID,ACNM,ACTMP - . S ACGL1=$P(@ALTG@(ALTTMP),U,9) ; ADDRESS OF THE REACTANT XX;GLB(YY.Z, - . S ACGFI=$$PRSGLB($P(ACGL1,";",2)) ; FILE NUMBER - . S ACIEN=$P(ACGL1,";",1) ; IEN OF REACTANT - . S ACVUID=$$GET1^DIQ(ACGFI,ACIEN,"VUID") ; VUID OF THE REACTANT - . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="PRODUCT_"_ACIEN ; IE OF REACTANT - . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="" ; WHERE DO WE GET THIS? - . S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT - . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM - . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION - . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE - . I ACVUID'="" D ; IF VUID IS NOT NULL - . . S ZC=$$CODE^C0CUTIL(ACVUID) - . . S ZCD=$P(ZC,"^",1) ; CODE TO USE - . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID - . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION - . E D ; IF REACTANT CODE VALUE IS NULL - . . I $G(DUZ("AG"))="I" D ; IF WE ARE RUNNING ON RPMS - . . . S ACTMP=$O(^C0CCODES(176.112,"C",ACNM,0)) ; - . . . W "RPMS NAME FOUND",ACNM," ",ACTMP,! - . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="" - . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="" - . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ZCD - . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=ZCDS - . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM_" "_ZCDS_": "_ZCD - . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT_" "_ZCDS_": "_ZCD - . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW - . N ARTMP,ARIEN,ARDES,ARVUID - . S (ARTMP,ARDES,ARVUID)="" - . I $D(@ALTG@(ALTTMP,"S",1)) D ; IF REACTION EXISTS - . . S ARTMP=@ALTG@(ALTTMP,"S",1) - . . W "REACTION:",ARTMP,! - . . S ARIEN=$P(ARTMP,";",2) - . . S ARDES=$P(ARTMP,";",1) - . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID") - . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES - . I ARVUID'="" D ; IF REACTION VUID IS NOT NULL - . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID - . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID" - . E D ; IF IT IS NULL DON'T SET CODE SYSTEM - . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")="" - . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="" - . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) - . ; NOW GO TO THE GLOBAL TO GET THE DATE/TIME AND BETTER DESCRIPTION - . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL - . D GETN1^C0CRNF("C0CG1",120.8,ALTTMP,"") ;GET VALUES BY NAME - . S C0CT=$$ZVALUEI^C0CRNF("ORIGINATION DATE/TIME","C0CG1") - . S @ALTVMAP@("ALERTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CT,"DT") - . K @ALTARYTMP - . D MAP^C0CXPATH(ALTXML,ALTVMAP,ALTARYTMP) - . I ALTCNT=1 D CP^C0CXPATH(ALTARYTMP,ALTOUTXML) - . I ALTCNT>1 D INSINNER^C0CXPATH(ALTOUTXML,ALTARYTMP) - . S ALTCNT=ALTCNT+1 - S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS - Q -PRSGLB(INGLB) ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER - ; INGLB IS OF THE FORM: PSNDF(50.6, - ; RETURN 50.6 - Q $P($P(INGLB,"(",2),",",1) ; +C0CALERT ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008,2009 George Lilly, University of Minnesota and others. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(ALTXML,DFN,ALTOUTXML,CALLBK) ; EXTRACT ALERTS INTO XML TEMPLATE + ; CALLBACK IF PROVIDED IS CALLED FOR EACH ALLERGY BEFORE MAPPING + ; ALTXML AND ALTOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; + ; GET ADVERSE REACTIONS AND ALLERGIES + ; N GMRA,GMRAL ; FOR DEBUGGING, DON'T NEW THESE VARIABLES + S GMRA="0^0^111" + D EN1^GMRADPT + I $G(GMRAL)'=1 D Q ; NO ALLERGIES FOUND THUS *QUIT* + . S @ALTOUTXML@(0)=0 + ; DEFINE MAPPING + N ALTTVMAP,ALTVMAP,ALTTARYTMP,ALTARYTMP + S ALTTVMAP=$NA(^TMP("C0CCCR",$J,"ALERTS")) + S ALTTARYTMP=$NA(^TMP("C0CCCR",$J,"ALERTSARYTMP")) + K @ALTTVMAP,@ALTTARYTMP + N ALTTMP,ALTCNT S ALTG=$NA(GMRAL),ALTCNT=1 + S ALTTMP="" ; + F S ALTTMP=$O(@ALTG@(ALTTMP)) Q:ALTTMP="" D ; CHANGED TO $O BY GPL + . W "ALTTMP="_ALTTMP,! + . ; I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q + . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT)) + . K @ALTVMAP + . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT + . N A1 S A1=@ALTG@(ALTTMP) ; ALL THE PIECES + . I $D(CALLBK) D @CALLBK ;CALLBACK FOR EPRESCRIBING + . N A2 S A2=$$GET1^DIQ(120.8,ALTTMP,"MECHANISM","I") ; MECHANISM + . N A3 S A3=$P(A1,U,5) ; ADVERSE FLAG + . N ADT S ADT="Patient has an " ; X $ZINT H 5 + . S ADT=ADT_$S(A2="P":"ADVERSE",A2="A":"ALLERGIC",1:"UNKNOWN") + . S ADT=ADT_" reaction to "_$P(@ALTG@(ALTTMP),U,2)_"." + . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT + . N ADTY S ADTY=$S(A2="P":"Adverse Reaction",A2="A":"Allergy",1:"") ; + . S @ALTVMAP@("ALERTTYPE")=ADTY ; type of allergy + . N ALTCDE ; SNOMED CODE THE THE ALERT + . S ALTCDE=$S(A2="P":"282100009",A2="A":"416098002",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC + . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ; + . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE + . ; AND 282100009 FOR ADVERSE REACTION TO A SUBSTANCE + . I ALTCDE'="" D ; IF THERE IS A CODE + . . S @ALTVMAP@("ALERTCODESYSTEM")="SNOMED CT" + . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="2008" + . E D ; SET TO NULL + . . S @ALTVMAP@("ALERTCODESYSTEM")="" + . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="" + . S @ALTVMAP@("ALERTSTATUSTEXT")="" ; WHERE DO WE GET THIS? + . N ALTPROV S ALTPROV=$P(^GMR(120.8,ALTTMP,0),U,5) ; SOURCE PROVIDER IEN + . I ALTPROV'="" D ; PROVIDER PROVIDEED + . . S @ALTVMAP@("ALERTSOURCEID")="ACTORPROVIDER_"_ALTPROV + . E S @ALTVMAP@("ALERTSOURCEID")="" ; SOURCE NULL - SHOULD NOT HAPPEN + . W "RUNNING ALERTS, PROVIDER: ",@ALTVMAP@("ALERTSOURCEID"),! + . N ACGL1,ACGFI,ACIEN,ACVUID,ACNM,ACTMP + . S ACGL1=$P(@ALTG@(ALTTMP),U,9) ; ADDRESS OF THE REACTANT XX;GLB(YY.Z, + . S ACGFI=$$PRSGLB($P(ACGL1,";",2)) ; FILE NUMBER + . S ACIEN=$P(ACGL1,";",1) ; IEN OF REACTANT + . S ACVUID=$$GET1^DIQ(ACGFI,ACIEN,"VUID") ; VUID OF THE REACTANT + . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="PRODUCT_"_ACIEN ; IE OF REACTANT + . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="" ; WHERE DO WE GET THIS? + . S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT + . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM + . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION + . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE + . I ACVUID'="" D ; IF VUID IS NOT NULL + . . S ZC=$$CODE^C0CUTIL(ACVUID) + . . S ZCD=$P(ZC,"^",1) ; CODE TO USE + . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID + . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION + . E D ; IF REACTANT CODE VALUE IS NULL + . . I $G(DUZ("AG"))="I" D ; IF WE ARE RUNNING ON RPMS + . . . S ACTMP=$O(^C0CCODES(176.112,"C",ACNM,0)) ; + . . . W "RPMS NAME FOUND",ACNM," ",ACTMP,! + . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="" + . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="" + . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ZCD + . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=ZCDS + . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM_" "_ZCDS_": "_ZCD + . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT_" "_ZCDS_": "_ZCD + . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW + . N ARTMP,ARIEN,ARDES,ARVUID + . S (ARTMP,ARDES,ARVUID)="" + . I $D(@ALTG@(ALTTMP,"S",1)) D ; IF REACTION EXISTS + . . S ARTMP=@ALTG@(ALTTMP,"S",1) + . . W "REACTION:",ARTMP,! + . . S ARIEN=$P(ARTMP,";",2) + . . S ARDES=$P(ARTMP,";",1) + . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID") + . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES + . I ARVUID'="" D ; IF REACTION VUID IS NOT NULL + . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID + . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID" + . E D ; IF IT IS NULL DON'T SET CODE SYSTEM + . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")="" + . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="" + . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) + . ; NOW GO TO THE GLOBAL TO GET THE DATE/TIME AND BETTER DESCRIPTION + . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL + . D GETN1^C0CRNF("C0CG1",120.8,ALTTMP,"") ;GET VALUES BY NAME + . S C0CT=$$ZVALUEI^C0CRNF("ORIGINATION DATE/TIME","C0CG1") + . S @ALTVMAP@("ALERTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CT,"DT") + . K @ALTARYTMP + . D MAP^C0CXPATH(ALTXML,ALTVMAP,ALTARYTMP) + . I ALTCNT=1 D CP^C0CXPATH(ALTARYTMP,ALTOUTXML) + . I ALTCNT>1 D INSINNER^C0CXPATH(ALTOUTXML,ALTARYTMP) + . S ALTCNT=ALTCNT+1 + S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS + Q +PRSGLB(INGLB) ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER + ; INGLB IS OF THE FORM: PSNDF(50.6, + ; RETURN 50.6 + Q $P($P(INGLB,"(",2),",",1) ; Index: ccr/branches/ohum/p/C0CBAT.m =================================================================== --- ccr/branches/ohum/p/C0CBAT.m (revision 1333) +++ ccr/branches/ohum/p/C0CBAT.m (revision 1337) @@ -1,234 +1,234 @@ -C0CBAT ; CCDCCR/GPL - CCR Batch utilities; 4/21/09 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is the CCR Batch Utility Library ",! - Q - ; -STOP ; STOP A CURRENTLY RUNNING BATCH JOB - I '$D(^TMP("C0CBAT","RUNNING")) Q ; - W !,!,"HALTING CCR BATCH",! - S ^TMP("C0CBAT","STOP")="" ; SIGNAL JOB TO TERMINATE - H 10 ; WAIT TEN SECONDS FOR SIGNAL TO BE RECEIVED - I '$D(^TMP("C0CBAT","STOP")) D ; SIGNAL RECEIVED - . W "CCR BATCH JOB TERMINATING",! - E D ; - . K ^TMP("C0CBAT","STOP") ; STOP SIGNALING - . W !,"BATCH PROCESSING APPARENTLY NOT RUNNING",! - Q - ; -START ; STARTS A TAKSMAN CCR BATCH JOB - FOR USE IN A MENU OPTION - ; - I $D(^TMP("C0CBAT","RUNNING")) D Q ; ONLY ONE ALLOWED AT A TIME - . W !,"CCR BATCH ALREADY RUNNING",! - . W !,"STOP FIRST WITH STOP^C0CBAT",! - N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTIO - S ZTRTN="EN^C0CBAT",ZTDESC="CCR Batch" - S ZTDTH=$H ; - ;S ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10)) - S ZTSAVE("C0C")="",ZTSAVE("C0C*")="" - S ZTIO="NULL" ; - W !,!,"CCR BATCH JOB STARTED",! - D ^%ZTLOAD - Q - ; -EN ; BATCH ENTRY POINT - ; PROCESSES THE SUBSCRIPTION FILE, EXTRACTING CCR VARIABLES FOR EACH - ; PATIENT WITH AN ACTIVE SUBSCRIPTION, AND IF CHECKSUMS INDICATE A CHANGE, - ; GENERATES A NEW CCR FOR THE PATIENT - ; UPDATES THE E2 CCR ELEMENTS FILE - ; - S C0CQT=1 ; QUIET MODE - I $D(^TMP("C0CBAT","RUNNING")) Q ; ONLY ONE AT A TIME - S ^TMP("C0CBAT","RUNNING")="" ; RUNNING SIGNAL - S C0CBDT=$$NOW^XLFDT ; DATE OF THIS RUN - S C0CBF=177.301 ; FILE NUMBER OF C0C BATCH CONTROL FILE - S C0CBFR=177.3013 ; FILE NUMBER OF UPDATE SUBFILE - S C0CBB=$NA(^TMP("C0CBATCH",C0CBDT)) ; BATCH WORK AREA - I $D(@C0CBB@(0)) D ; ERROR SHOULDN'T EXIST - . W "WORK AREA ERROR",! - . B - S @C0CBB@(0)="V22" ; VERSION USED TO CREATE THIS WORK AREA - S C0CBH=$NA(@C0CBB@("HOTLIST")) ; BASE FOR HOT LIST - S C0CBS=$NA(^C0CS("B")) ; SUBSCRIPTION LIST BASE - ;I $D(^C0CB("B",C0CDT)) D ; BATCH RECORD EXISTS - ;. H 10 ; HANG 10 SECONDS - ;. S C0CBDT=$$NOW^XLFDT ; NEW DATE FOR THIS RUN - ;. I $D(^C0CB("B",C0CDT)) B ;DIDN'T WORK - D BLDHOT(C0CBH) ; BUILD THE HOT LIST - S C0CHN=$$COUNT(C0CBH) ;COUNT NUMBER IN HOT LIST - S C0CSN=$$COUNT(C0CBS) ;COUNT NUMBER OF PATIENTS WITH SUBSCRIPTIONS - S C0CFDA(C0CBF,"+1,",.01)=C0CBDT ; DATE KEY OF BATCH CONTROL - S C0CFDA(C0CBF,"+1,",.02)=C0CBDT ; BATCH ID IS DATE IN STRING FORM - S C0CFDA(C0CBF,"+1,",1)=C0CSN ; TOTAL SUBSCRIPTIONS - S C0CFDA(C0CBF,"+1,",2)=C0CHN ; TOTAL HOT LIST - D UPDIE ; CREATE THE BATCH RECORD - S C0CIEN=$O(^C0CB("B",C0CBDT,"")) - S (C0CN,C0CNH)=0 ; COUNTERS FOR TOTAL AND HOT LIST - S C0CBCUR="" ; CURRENT PATIENT - S C0CSTOP=0 ; STOP FLAG FOR HALTING BATCH SET ^TMP("C0CBAT","STOP")="" - ;F S C0CBCUR=$O(@C0CBH@(C0CBCUR),-1) Q:C0CBCUR="" D ; HOT LIST LATEST FIRST - F S C0CBCUR=$O(@C0CBH@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="") D ; HOT LIST FIRST - . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-900^VITLIMIT:T-900") - . I $G(C0CCHK) D ; - . . D PUTRIM^C0CFM2(C0CBCUR) - . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR - . . K C0CFDA - . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR - . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y" - . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR)) - . . D UPDIE ; CREATE UPDATE SUBFILE - . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL - . S C0CNH=C0CNH+1 ; INCREMENT HOT LIST TOTAL - . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS - . S C0CFDA(C0CBF,C0CIEN_",",2.1)=C0CNH ; UPDATE HOT LIST PROGRESS - . S C0CNOW=$$NOW^XLFDT - . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD - . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS - . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME - . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME - . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME - . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START - . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME - . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; LAST RECORD PROCESSED - . D UPDIE ; - . I $D(^TMP("C0CBAT","STOP")) D ; IF STOP SIGNAL DETECTED - . . S C0CSTOP=1 - . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED - . H 1 ; GIVE OTHERS A CHANCE - F S C0CBCUR=$O(@C0CBS@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="") D ; SUBS LIST - . I $D(@C0CBH@(C0CBCUR)) Q ; SKIP IF IN HOT LIST - ALREADY DONE - . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-760^VITLIMIT:T-760") - . I $G(C0CCHK) D ; IF CHECKSUMS HAVE CHANGED - . . D PUTRIM^C0CFM2(C0CBCUR) - . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR - . . K C0CFDA - . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR - . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y" - . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR)) - . . D UPDIE ; CREATE UPDATE SUBFILE - . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL - . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS - . S C0CNOW=$$NOW^XLFDT - . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD - . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS - . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME - . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME - . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME - . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START - . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME - . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; - . D UPDIE ; - . I $D(^TMP("C0CBAT","STOP")) D ; IF STOP SIGNAL DETECTED - . . S C0CSTOP=1 - . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED - . H 1 ; GIVE IT A BREAK - I (C0CSTOP) S C0CDISP="KILLED" - E S C0CDISP="FINISHED" - S C0CFDA(C0CBF,C0CIEN_",",6)=C0CDISP - D UPDIE ; SET DISPOSITION FIELD - K ^TMP("C0CBAT","RUNNING") - Q - ; -BLDHOT(ZHB) ; BUILD HOT LIST AT GLOBAL ZHB, PASSED BY NAME - ; SEARCHS FOR PATIENTS IN THE "AC" INDEX OF THE ORDER FILE - N ZDFN - S ZDFN="" - F S ZDFN=$O(^OR(100,"AC",ZDFN)) Q:ZDFN="" D ; ALL PATIENTS IN THE AC INDX - . S ZZDFN=$P(ZDFN,";",1) ; FORMAT IS "N;DPT(" - . I '$D(@C0CBS@(ZZDFN)) Q ; SKIP IF NOT IN SUBSCRIPTION LIST - . S @ZHB@(ZZDFN)="" ;ADD PATIENT TO THE HOT LIST - Q - ; -COUNT(ZB) ; EXTRINSIC THAT RETURNS THE NUMBER OF ARRAY ELEMENTS - N ZI,ZN - S ZN=0 - S ZI="" - F S ZI=$O(@ZB@(ZI)) Q:ZI="" D ; - . S ZN=ZN+1 - Q ZN - ; -UPDIEVARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE - ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO - ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO - ; - N ZCCRD,ZVARN,C0CFDA2 - S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY - S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE - I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT - . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE - . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! - . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE - . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE - . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN - . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY - . I $D(ZERR) D ; LAYGO ERROR - . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! - . E D ; - . . D CLEAN^DILF ; CLEAN UP - . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE - . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! - Q ZVARN - ; -UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS - K ZERR - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","","ZERR") - I $D(ZERR) D ; - . W "ERROR",! - . ZWR ZERR - . B - K C0CFDA - Q - ; -SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN - ; TO SET TO VALUE C0CSV. - ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE - ; C0CSN,C0CSV ARE PASSED BY VALUE - ; - N C0CSI,C0CSJ - S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER - S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER - S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV - Q -ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) - E S ZR="" - Q ZR -ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) - E S ZR="" - Q ZR - ; -ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) - E S ZR="" - Q ZR - ; +C0CBAT ; CCDCCR/GPL - CCR Batch utilities; 4/21/09 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is the CCR Batch Utility Library ",! + Q + ; +STOP ; STOP A CURRENTLY RUNNING BATCH JOB + I '$D(^TMP("C0CBAT","RUNNING")) Q ; + W !,!,"HALTING CCR BATCH",! + S ^TMP("C0CBAT","STOP")="" ; SIGNAL JOB TO TERMINATE + H 10 ; WAIT TEN SECONDS FOR SIGNAL TO BE RECEIVED + I '$D(^TMP("C0CBAT","STOP")) D ; SIGNAL RECEIVED + . W "CCR BATCH JOB TERMINATING",! + E D ; + . K ^TMP("C0CBAT","STOP") ; STOP SIGNALING + . W !,"BATCH PROCESSING APPARENTLY NOT RUNNING",! + Q + ; +START ; STARTS A TAKSMAN CCR BATCH JOB - FOR USE IN A MENU OPTION + ; + I $D(^TMP("C0CBAT","RUNNING")) D Q ; ONLY ONE ALLOWED AT A TIME + . W !,"CCR BATCH ALREADY RUNNING",! + . W !,"STOP FIRST WITH STOP^C0CBAT",! + N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTIO + S ZTRTN="EN^C0CBAT",ZTDESC="CCR Batch" + S ZTDTH=$H ; + ;S ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10)) + S ZTSAVE("C0C")="",ZTSAVE("C0C*")="" + S ZTIO="NULL" ; + W !,!,"CCR BATCH JOB STARTED",! + D ^%ZTLOAD + Q + ; +EN ; BATCH ENTRY POINT + ; PROCESSES THE SUBSCRIPTION FILE, EXTRACTING CCR VARIABLES FOR EACH + ; PATIENT WITH AN ACTIVE SUBSCRIPTION, AND IF CHECKSUMS INDICATE A CHANGE, + ; GENERATES A NEW CCR FOR THE PATIENT + ; UPDATES THE E2 CCR ELEMENTS FILE + ; + S C0CQT=1 ; QUIET MODE + I $D(^TMP("C0CBAT","RUNNING")) Q ; ONLY ONE AT A TIME + S ^TMP("C0CBAT","RUNNING")="" ; RUNNING SIGNAL + S C0CBDT=$$NOW^XLFDT ; DATE OF THIS RUN + S C0CBF=177.301 ; FILE NUMBER OF C0C BATCH CONTROL FILE + S C0CBFR=177.3013 ; FILE NUMBER OF UPDATE SUBFILE + S C0CBB=$NA(^TMP("C0CBATCH",C0CBDT)) ; BATCH WORK AREA + I $D(@C0CBB@(0)) D ; ERROR SHOULDN'T EXIST + . W "WORK AREA ERROR",! + . B + S @C0CBB@(0)="V22" ; VERSION USED TO CREATE THIS WORK AREA + S C0CBH=$NA(@C0CBB@("HOTLIST")) ; BASE FOR HOT LIST + S C0CBS=$NA(^C0CS("B")) ; SUBSCRIPTION LIST BASE + ;I $D(^C0CB("B",C0CDT)) D ; BATCH RECORD EXISTS + ;. H 10 ; HANG 10 SECONDS + ;. S C0CBDT=$$NOW^XLFDT ; NEW DATE FOR THIS RUN + ;. I $D(^C0CB("B",C0CDT)) B ;DIDN'T WORK + D BLDHOT(C0CBH) ; BUILD THE HOT LIST + S C0CHN=$$COUNT(C0CBH) ;COUNT NUMBER IN HOT LIST + S C0CSN=$$COUNT(C0CBS) ;COUNT NUMBER OF PATIENTS WITH SUBSCRIPTIONS + S C0CFDA(C0CBF,"+1,",.01)=C0CBDT ; DATE KEY OF BATCH CONTROL + S C0CFDA(C0CBF,"+1,",.02)=C0CBDT ; BATCH ID IS DATE IN STRING FORM + S C0CFDA(C0CBF,"+1,",1)=C0CSN ; TOTAL SUBSCRIPTIONS + S C0CFDA(C0CBF,"+1,",2)=C0CHN ; TOTAL HOT LIST + D UPDIE ; CREATE THE BATCH RECORD + S C0CIEN=$O(^C0CB("B",C0CBDT,"")) + S (C0CN,C0CNH)=0 ; COUNTERS FOR TOTAL AND HOT LIST + S C0CBCUR="" ; CURRENT PATIENT + S C0CSTOP=0 ; STOP FLAG FOR HALTING BATCH SET ^TMP("C0CBAT","STOP")="" + ;F S C0CBCUR=$O(@C0CBH@(C0CBCUR),-1) Q:C0CBCUR="" D ; HOT LIST LATEST FIRST + F S C0CBCUR=$O(@C0CBH@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="") D ; HOT LIST FIRST + . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-900^VITLIMIT:T-900") + . I $G(C0CCHK) D ; + . . D PUTRIM^C0CFM2(C0CBCUR) + . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR + . . K C0CFDA + . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR + . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y" + . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR)) + . . D UPDIE ; CREATE UPDATE SUBFILE + . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL + . S C0CNH=C0CNH+1 ; INCREMENT HOT LIST TOTAL + . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS + . S C0CFDA(C0CBF,C0CIEN_",",2.1)=C0CNH ; UPDATE HOT LIST PROGRESS + . S C0CNOW=$$NOW^XLFDT + . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD + . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS + . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME + . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME + . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME + . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START + . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME + . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; LAST RECORD PROCESSED + . D UPDIE ; + . I $D(^TMP("C0CBAT","STOP")) D ; IF STOP SIGNAL DETECTED + . . S C0CSTOP=1 + . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED + . H 1 ; GIVE OTHERS A CHANCE + F S C0CBCUR=$O(@C0CBS@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="") D ; SUBS LIST + . I $D(@C0CBH@(C0CBCUR)) Q ; SKIP IF IN HOT LIST - ALREADY DONE + . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-760^VITLIMIT:T-760") + . I $G(C0CCHK) D ; IF CHECKSUMS HAVE CHANGED + . . D PUTRIM^C0CFM2(C0CBCUR) + . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR + . . K C0CFDA + . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR + . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y" + . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR)) + . . D UPDIE ; CREATE UPDATE SUBFILE + . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL + . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS + . S C0CNOW=$$NOW^XLFDT + . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD + . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS + . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME + . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME + . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME + . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START + . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME + . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; + . D UPDIE ; + . I $D(^TMP("C0CBAT","STOP")) D ; IF STOP SIGNAL DETECTED + . . S C0CSTOP=1 + . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED + . H 1 ; GIVE IT A BREAK + I (C0CSTOP) S C0CDISP="KILLED" + E S C0CDISP="FINISHED" + S C0CFDA(C0CBF,C0CIEN_",",6)=C0CDISP + D UPDIE ; SET DISPOSITION FIELD + K ^TMP("C0CBAT","RUNNING") + Q + ; +BLDHOT(ZHB) ; BUILD HOT LIST AT GLOBAL ZHB, PASSED BY NAME + ; SEARCHS FOR PATIENTS IN THE "AC" INDEX OF THE ORDER FILE + N ZDFN + S ZDFN="" + F S ZDFN=$O(^OR(100,"AC",ZDFN)) Q:ZDFN="" D ; ALL PATIENTS IN THE AC INDX + . S ZZDFN=$P(ZDFN,";",1) ; FORMAT IS "N;DPT(" + . I '$D(@C0CBS@(ZZDFN)) Q ; SKIP IF NOT IN SUBSCRIPTION LIST + . S @ZHB@(ZZDFN)="" ;ADD PATIENT TO THE HOT LIST + Q + ; +COUNT(ZB) ; EXTRINSIC THAT RETURNS THE NUMBER OF ARRAY ELEMENTS + N ZI,ZN + S ZN=0 + S ZI="" + F S ZI=$O(@ZB@(ZI)) Q:ZI="" D ; + . S ZN=ZN+1 + Q ZN + ; +UPDIEVARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE + ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO + ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO + ; + N ZCCRD,ZVARN,C0CFDA2 + S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY + S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE + I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT + . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE + . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! + . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE + . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE + . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN + . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY + . I $D(ZERR) D ; LAYGO ERROR + . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! + . E D ; + . . D CLEAN^DILF ; CLEAN UP + . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE + . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! + Q ZVARN + ; +UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS + K ZERR + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","","ZERR") + I $D(ZERR) D ; + . W "ERROR",! + . ZWR ZERR + . B + K C0CFDA + Q + ; +SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN + ; TO SET TO VALUE C0CSV. + ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE + ; C0CSN,C0CSV ARE PASSED BY VALUE + ; + N C0CSI,C0CSJ + S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER + S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER + S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV + Q +ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) + E S ZR="" + Q ZR +ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) + E S ZR="" + Q ZR + ; +ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) + E S ZR="" + Q ZR + ; Index: ccr/branches/ohum/p/C0CCCD.m =================================================================== --- ccr/branches/ohum/p/C0CCCD.m (revision 1333) +++ ccr/branches/ohum/p/C0CCCD.m (revision 1337) @@ -1,272 +1,272 @@ -C0CCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008,2009 George Lilly, University of Minnesota. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; EXPORT A CCR - ; -EXPORT ; EXPORT ENTRY POINT FOR CCR - ; Select a patient. - S DIC=2,DIC(0)="AEMQ" D ^DIC - I Y<1 Q ; EXIT - S DFN=$P(Y,U,1) ; SET THE PATIENT - D XPAT(DFN,"","") ; EXPORT TO A FILE - Q - ; -XPAT(DFN,DIR,FN) ; EXPORT ONE PATIENT TO A FILE - ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR") - ; FN IS FILE NAME, DEFAULTS IF NULL - ; N CCDGLO - D CCDRPC(.CCDGLO,DFN,"CCD","","","") - S OARY=$NA(^TMP("C0CCCR",$J,DFN,"CCD",1)) - S ONAM=FN - I FN="" S ONAM="PAT_"_DFN_"_CCD_V1.xml" - S ODIRGLB=$NA(^TMP("C0CCCR","ODIR")) - I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET - . S @ODIRGLB="/home/glilly/CCROUT" - . ;S @ODIRGLB="/home/cedwards/" - . ;S @ODIRGLB="/opt/wv/p/" - S ODIR=DIR - I DIR="" S ODIR=@ODIRGLB - N ZY - S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR) - W $P(ZY,U,2) - Q - ; -CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) ;RPC ENTRY POINT FOR CCR OUTPUT - ; CCRGRTN IS RETURN ARRAY PASSED BY NAME - ; DFN IS PATIENT IEN - ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART - ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC - ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL - ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME - ; - NULL MEANS NOW - ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND - ; "TO" VARIABLES - ; IF NULL WILL DEFAULT TO "FROM" ORGANIZATION AND "TO" DFN - I '$D(DEBUG) S DEBUG=0 - N CCD S CCD=0 ; FLAG FOR PROCESSING A CCD - I CCRPART="CCD" S CCD=1 ; WE ARE PROCESSING A CCD - S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE - I CCD S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCD")) ; GLOBAL FOR THE CCD - E S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR - S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS - ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC - S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL - I CCD D LOAD^C0CCCD1(TGLOBAL) ; LOAD THE CCR TEMPLATE - E D LOAD^C0CCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE - D CP^C0CXPATH(TGLOBAL,CCDGLO) ; COPY THE TEMPLATE TO CCR GLOBAL - N CAPSAVE,CAPSAVE2 ; FOR HOLDING THE CCD ROOT LINES - S CAPSAVE=@TGLOBAL@(3) ; SAVE THE CCD ROOT - S CAPSAVE2=@TGLOBAL@(@TGLOBAL@(0)) ; SAVE LAST LINE OF CCD - S @CCDGLO@(3)="" ; CAP WITH CCR ROOT - S @TGLOBAL@(3)=@CCDGLO@(3) ; CAP THE TEMPLATE TOO - S @CCDGLO@(@CCDGLO@(0))="" ; FINISH CAP - S @TGLOBAL@(@TGLOBAL@(0))="" ; 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)["" D ; REPLACE BODY MARKUP - . . . S @CCDGLO@(I)="" ; WITH CCD EQ - . . I @CCDGLO@(I)["" D ; REPLACE BODY MARKUP - . . . S @CCDGLO@(I)="" - S @CCDGLO@(3)=CAPSAVE ; UNCAP - TURN IT BACK INTO A CCD - S @CCDGLO@(@CCDGLO@(0))=CAPSAVE2 ; UNCAP LAST LINE - Q - ; -INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS - ; TAB IS PASSED BY NAME - W "TAB= ",TAB,! - ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS - D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")") - ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")") - I 'CCD D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") - Q - ; -SHAVE(SHXML) ; REMOVES THE 2-6 AND N-1 AND N-2 LINES FROM A COMPONENT - ; NEEDED TO EXPOSE THE REPEATING PARTS FOR GENERATION - N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST - W SHXML,! - W @SHXML@(1),! - D QUEUE^C0CXPATH("SHBLD",SHXML,1,1) ; THE FIRST LINE IS NEEDED - D QUEUE^C0CXPATH("SHBLD",SHXML,7,@SHXML@(0)-3) ; REPEATING PART - D QUEUE^C0CXPATH("SHBLD",SHXML,@SHXML@(0),@SHXML@(0)) ; LAST LINE - D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST - D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION - D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY - Q - ; -UNSHAVE(ORIGXML,SHXML) ; REPLACES THE 2-6 AND N-1 AND N-2 LINES FROM TEMPLATE - ; NEEDED TO RESTORM FIXED TOP AND BOTTOM OF THE COMPONENT XML - N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST - W SHXML,! - W @SHXML@(1),! - D QUEUE^C0CXPATH("SHBLD",ORIGXML,1,6) ; FIRST 6 LINES OF TEMPLATE - D QUEUE^C0CXPATH("SHBLD",SHXML,2,@SHXML@(0)-1) ; INS ALL BUT FIRST/LAST - D QUEUE^C0CXPATH("SHBLD",ORIGXML,@ORIGXML@(0)-2,@ORIGXML@(0)) ; FROM TEMP - D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST - D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION - D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY - Q - ; -HDRMAP(CXML,DFN,IHDR) ; MAP HEADER VARIABLES: FROM, TO ECT - N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER")) - ; K @VMAP - S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT") - I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS - . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN - . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? - . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM - . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES - . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES - . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES - . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT - I IHDR'="" D ; HEADER VALUES ARE PROVIDED - . D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY - N CTMP - D MAP^C0CXPATH(CXML,VMAP,"CTMP") - D CP^C0CXPATH("CTMP",CXML) - Q - ; -ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML - ; AXML AND ACTRTN ARE PASSED BY NAME - ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 - ; P1= OBJECTID - ACTORPATIENT_2 - ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE - ;OR INSTITUTION - ; OR PERSON(IN PATIENT FILE IE NOK) - ; P3= IEN RECORD NUMBER FOR ACTOR - 2 - N I,J,K,L - K @ACTRTN ; CLEAR RETURN ARRAY - F I=1:1:@AXML@(0) D ; SCAN ALL LINES - . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE - . . S J=$P($P(@AXML@(I),"",2),"",1) - . . W "=>",J,! - . . I J'="" S K(J)="" ; HASHING ACTOR - . . ; TO GET RID OF DUPLICATES - S I="" ; GOING TO $O THROUGH THE HASH - F J=0:0 D Q:$O(K(I))="" ; - . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS - . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID - . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE - . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR - . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY - Q - ; -TEST ; RUN ALL THE TEST CASES - D TESTALL^C0CUNIT("C0CCCR") - Q - ; -ZTEST(WHICH) ; RUN ONE SET OF TESTS - N ZTMP - D ZLOAD^C0CUNIT("ZTMP","C0CCCR") - D ZTEST^C0CUNIT(.ZTMP,WHICH) - Q - ; -TLIST ; LIST THE TESTS - N ZTMP - D ZLOAD^C0CUNIT("ZTMP","C0CCCR") - D TLIST^C0CUNIT(.ZTMP) - Q - ; - ;;> - ;;> - ;;>>>K C0C S C0C="" - ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","","","") - ;;>>?@C0C@(@C0C@(0))["" - ;;> - ;;>>>K C0C S C0C="" - ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","","","") - ;;>>?@C0C@(@C0C@(0))["" - ;;> - ;;>>>K C0C S C0C="" - ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","") - ;;>>?@C0C@(@C0C@(0))["" - ;;> - ;;>>>K C0C S C0C="" - ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","") - ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST") - ;;> - ;;>>>D ZTEST^C0CCCR("ACTLST") - ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") - ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3") - ;;>>?G3(G3(0))["" - ;;> - ;;>>>D ZTEST^C0CCCR("CCR") - ;;>>>W $$TRIM^C0CXPATH(CCDGLO) - ;;> - ;;>>>K C0C S C0C="" - ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCD","","","") - ;;>>?@C0C@(@C0C@(0))["" - ;;> +C0CCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008,2009 George Lilly, University of Minnesota. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; EXPORT A CCR + ; +EXPORT ; EXPORT ENTRY POINT FOR CCR + ; Select a patient. + S DIC=2,DIC(0)="AEMQ" D ^DIC + I Y<1 Q ; EXIT + S DFN=$P(Y,U,1) ; SET THE PATIENT + D XPAT(DFN,"","") ; EXPORT TO A FILE + Q + ; +XPAT(DFN,DIR,FN) ; EXPORT ONE PATIENT TO A FILE + ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR") + ; FN IS FILE NAME, DEFAULTS IF NULL + ; N CCDGLO + D CCDRPC(.CCDGLO,DFN,"CCD","","","") + S OARY=$NA(^TMP("C0CCCR",$J,DFN,"CCD",1)) + S ONAM=FN + I FN="" S ONAM="PAT_"_DFN_"_CCD_V1.xml" + S ODIRGLB=$NA(^TMP("C0CCCR","ODIR")) + I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET + . S @ODIRGLB="/home/glilly/CCROUT" + . ;S @ODIRGLB="/home/cedwards/" + . ;S @ODIRGLB="/opt/wv/p/" + S ODIR=DIR + I DIR="" S ODIR=@ODIRGLB + N ZY + S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR) + W $P(ZY,U,2) + Q + ; +CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) ;RPC ENTRY POINT FOR CCR OUTPUT + ; CCRGRTN IS RETURN ARRAY PASSED BY NAME + ; DFN IS PATIENT IEN + ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART + ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC + ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL + ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME + ; - NULL MEANS NOW + ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND + ; "TO" VARIABLES + ; IF NULL WILL DEFAULT TO "FROM" ORGANIZATION AND "TO" DFN + I '$D(DEBUG) S DEBUG=0 + N CCD S CCD=0 ; FLAG FOR PROCESSING A CCD + I CCRPART="CCD" S CCD=1 ; WE ARE PROCESSING A CCD + S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE + I CCD S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCD")) ; GLOBAL FOR THE CCD + E S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR + S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS + ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC + S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL + I CCD D LOAD^C0CCCD1(TGLOBAL) ; LOAD THE CCR TEMPLATE + E D LOAD^C0CCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE + D CP^C0CXPATH(TGLOBAL,CCDGLO) ; COPY THE TEMPLATE TO CCR GLOBAL + N CAPSAVE,CAPSAVE2 ; FOR HOLDING THE CCD ROOT LINES + S CAPSAVE=@TGLOBAL@(3) ; SAVE THE CCD ROOT + S CAPSAVE2=@TGLOBAL@(@TGLOBAL@(0)) ; SAVE LAST LINE OF CCD + S @CCDGLO@(3)="" ; CAP WITH CCR ROOT + S @TGLOBAL@(3)=@CCDGLO@(3) ; CAP THE TEMPLATE TOO + S @CCDGLO@(@CCDGLO@(0))="" ; FINISH CAP + S @TGLOBAL@(@TGLOBAL@(0))="" ; 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)["" D ; REPLACE BODY MARKUP + . . . S @CCDGLO@(I)="" ; WITH CCD EQ + . . I @CCDGLO@(I)["" D ; REPLACE BODY MARKUP + . . . S @CCDGLO@(I)="" + S @CCDGLO@(3)=CAPSAVE ; UNCAP - TURN IT BACK INTO A CCD + S @CCDGLO@(@CCDGLO@(0))=CAPSAVE2 ; UNCAP LAST LINE + Q + ; +INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS + ; TAB IS PASSED BY NAME + W "TAB= ",TAB,! + ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS + D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")") + ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")") + I 'CCD D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") + Q + ; +SHAVE(SHXML) ; REMOVES THE 2-6 AND N-1 AND N-2 LINES FROM A COMPONENT + ; NEEDED TO EXPOSE THE REPEATING PARTS FOR GENERATION + N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST + W SHXML,! + W @SHXML@(1),! + D QUEUE^C0CXPATH("SHBLD",SHXML,1,1) ; THE FIRST LINE IS NEEDED + D QUEUE^C0CXPATH("SHBLD",SHXML,7,@SHXML@(0)-3) ; REPEATING PART + D QUEUE^C0CXPATH("SHBLD",SHXML,@SHXML@(0),@SHXML@(0)) ; LAST LINE + D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST + D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION + D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY + Q + ; +UNSHAVE(ORIGXML,SHXML) ; REPLACES THE 2-6 AND N-1 AND N-2 LINES FROM TEMPLATE + ; NEEDED TO RESTORM FIXED TOP AND BOTTOM OF THE COMPONENT XML + N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST + W SHXML,! + W @SHXML@(1),! + D QUEUE^C0CXPATH("SHBLD",ORIGXML,1,6) ; FIRST 6 LINES OF TEMPLATE + D QUEUE^C0CXPATH("SHBLD",SHXML,2,@SHXML@(0)-1) ; INS ALL BUT FIRST/LAST + D QUEUE^C0CXPATH("SHBLD",ORIGXML,@ORIGXML@(0)-2,@ORIGXML@(0)) ; FROM TEMP + D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST + D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION + D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY + Q + ; +HDRMAP(CXML,DFN,IHDR) ; MAP HEADER VARIABLES: FROM, TO ECT + N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER")) + ; K @VMAP + S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT") + I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS + . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN + . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? + . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM + . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES + . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES + . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES + . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT + I IHDR'="" D ; HEADER VALUES ARE PROVIDED + . D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY + N CTMP + D MAP^C0CXPATH(CXML,VMAP,"CTMP") + D CP^C0CXPATH("CTMP",CXML) + Q + ; +ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML + ; AXML AND ACTRTN ARE PASSED BY NAME + ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 + ; P1= OBJECTID - ACTORPATIENT_2 + ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE + ;OR INSTITUTION + ; OR PERSON(IN PATIENT FILE IE NOK) + ; P3= IEN RECORD NUMBER FOR ACTOR - 2 + N I,J,K,L + K @ACTRTN ; CLEAR RETURN ARRAY + F I=1:1:@AXML@(0) D ; SCAN ALL LINES + . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE + . . S J=$P($P(@AXML@(I),"",2),"",1) + . . W "=>",J,! + . . I J'="" S K(J)="" ; HASHING ACTOR + . . ; TO GET RID OF DUPLICATES + S I="" ; GOING TO $O THROUGH THE HASH + F J=0:0 D Q:$O(K(I))="" ; + . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS + . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID + . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE + . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR + . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY + Q + ; +TEST ; RUN ALL THE TEST CASES + D TESTALL^C0CUNIT("C0CCCR") + Q + ; +ZTEST(WHICH) ; RUN ONE SET OF TESTS + N ZTMP + D ZLOAD^C0CUNIT("ZTMP","C0CCCR") + D ZTEST^C0CUNIT(.ZTMP,WHICH) + Q + ; +TLIST ; LIST THE TESTS + N ZTMP + D ZLOAD^C0CUNIT("ZTMP","C0CCCR") + D TLIST^C0CUNIT(.ZTMP) + Q + ; + ;;> + ;;> + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","","","") + ;;>>?@C0C@(@C0C@(0))["" + ;;> + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","","","") + ;;>>?@C0C@(@C0C@(0))["" + ;;> + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","") + ;;>>?@C0C@(@C0C@(0))["" + ;;> + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","") + ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST") + ;;> + ;;>>>D ZTEST^C0CCCR("ACTLST") + ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") + ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3") + ;;>>?G3(G3(0))["" + ;;> + ;;>>>D ZTEST^C0CCCR("CCR") + ;;>>>W $$TRIM^C0CXPATH(CCDGLO) + ;;> + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCD","","","") + ;;>>?@C0C@(@C0C@(0))["" + ;;> Index: ccr/branches/ohum/p/C0CCCD1.m =================================================================== --- ccr/branches/ohum/p/C0CCCD1.m (revision 1333) +++ ccr/branches/ohum/p/C0CCCD1.m (revision 1337) @@ -1,268 +1,268 @@ -C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008,2009 George Lilly, University of Minnesota. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is a CCD TEMPLATE with processing routines",! - W ! - Q - ; -ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array - ; ZARY IS PASSED BY NAME - ; BAT is a string identifying the section - ; LINE is a test which will evaluate to true or false - ; I '$G(@ZARY) D ; IF ZARY DOES NOT EXIST ' - ; . S @ZARY@(0)=0 ; initially there are no elements - ; . W "GOT HERE LOADING "_LINE,! - N CNT ; count of array elements - S CNT=@ZARY@(0) ; contains array count - S CNT=CNT+1 ; increment count - S @ZARY@(CNT)=LINE ; put the line in the array - ; S @ZARY@(BAT,CNT)="" ; index the test by battery - S @ZARY@(0)=CNT ; update the array counter - Q - ; -ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference - ; ZARY IS PASSED BY NAME - ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") - ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE - K @ZARY S @ZARY="" - S @ZARY@(0)=0 ; initialize array count - N LINE,LABEL,BODY - N INTEST S INTEST=0 ; switch for in the TEMPLATE section - N SECTION S SECTION="[anonymous]" ; NO section LABEL - ; - N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D - . I LINE?." "1";".E S INTEST=0 ; leaving section - . I INTEST D ; within the section - . . I LINE?." "1";><".E D ; sub-section name found - . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name - . . I LINE?." "1";;".E D ; line found - . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array - Q - ; -LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME - D ZLOAD(ARY,"C0CCCD1") - ; ZWR @ARY - Q - ; -TRMCCD ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD - Q -MARKUP ; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ; - ;; - ;; - Q - ; - ; +C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008,2009 George Lilly, University of Minnesota. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is a CCD TEMPLATE with processing routines",! + W ! + Q + ; +ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array + ; ZARY IS PASSED BY NAME + ; BAT is a string identifying the section + ; LINE is a test which will evaluate to true or false + ; I '$G(@ZARY) D ; IF ZARY DOES NOT EXIST ' + ; . S @ZARY@(0)=0 ; initially there are no elements + ; . W "GOT HERE LOADING "_LINE,! + N CNT ; count of array elements + S CNT=@ZARY@(0) ; contains array count + S CNT=CNT+1 ; increment count + S @ZARY@(CNT)=LINE ; put the line in the array + ; S @ZARY@(BAT,CNT)="" ; index the test by battery + S @ZARY@(0)=CNT ; update the array counter + Q + ; +ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference + ; ZARY IS PASSED BY NAME + ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") + ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE + K @ZARY S @ZARY="" + S @ZARY@(0)=0 ; initialize array count + N LINE,LABEL,BODY + N INTEST S INTEST=0 ; switch for in the TEMPLATE section + N SECTION S SECTION="[anonymous]" ; NO section LABEL + ; + N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D + . I LINE?." "1";".E S INTEST=0 ; leaving section + . I INTEST D ; within the section + . . I LINE?." "1";><".E D ; sub-section name found + . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name + . . I LINE?." "1";;".E D ; line found + . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array + Q + ; +LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME + D ZLOAD(ARY,"C0CCCD1") + ; ZWR @ARY + Q + ; +TRMCCD ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD + Q +MARKUP ; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ; + ;; + ;; + Q + ; + ; Index: ccr/branches/ohum/p/C0CCCR.m =================================================================== --- ccr/branches/ohum/p/C0CCCR.m (revision 1333) +++ ccr/branches/ohum/p/C0CCCR.m (revision 1337) @@ -1,286 +1,280 @@ -C0CCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008,2009 George Lilly, University of Minnesota. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; EXPORT A CCR - ; -EXPORT ; EXPORT ENTRY POINT FOR CCR - ; Select a patient. - S DIC=2,DIC(0)="AEMQ" D ^DIC - I Y<1 Q ; EXIT - S DFN=$P(Y,U,1) ; SET THE PATIENT - ;OHUM/RUT 3120102 To take inputs from user for date limits and notes - D ^C0CVALID - ;OHUM/RUT - D XPAT(DFN) ; EXPORT TO A FILE - Q - ; -XPAT(DFN,XPARMS,DIR,FN) ; EXPORT ONE PATIENT TO A FILE - ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR") - ; FN IS FILE NAME, DEFAULTS IF NULL - N CCRGLO,UDIR,UFN - S C0CNRPC=1 ; FLAG FOR NOT AN RPC CALL - FOR DEBUGGING THE RPC - I '$D(DIR) S UDIR="" - E S UDIR=DIR - I '$D(FN) S UFN="" ; IF FILENAME IS NOT PASSED - E S UFN=FN - I '$D(XPARMS) S XPARMS="" - N C0CRTN ; RETURN ARRAY - D CCRRPC(.C0CRTN,DFN,XPARMS,"CCR") - S OARY=$NA(^TMP("C0CCUR",$J,DFN,"CCR",1)) - S ONAM=UFN - I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_0.xml" - S ODIRGLB=$NA(^TMP("C0CCCR","ODIR")) - S ^TMP("C0CCCR","FNAME",DFN)=ONAM ; FILE NAME FOR BATCH USE - I $D(^TMP("GPLCCR","ODIR")) S @ODIRGLB=^TMP("GPLCCR","ODIR") - I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET - . W "Warning.. please set ^TMP(""C0CCCR"",""ODIR"")=""output path""",! Q - . ;S @ODIRGLB="/home/glilly/CCROUT" - . ;S @ODIRGLB="/home/cedwards/" - . S @ODIRGLB="/opt/wv/p/" - S ODIR=UDIR - I UDIR="" S ODIR=@ODIRGLB - N ZY - S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR) - W !,$P(ZY,U,2),! - Q - ; -DCCR(DFN) ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED - ; - N G1 - S G1=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) - I $D(@G1@(0)) D ; CCR EXISTS - . D PARY^C0CXPATH(G1) - E W "CCR NOT CREATED, RUN D XPAT^C0CCCR(DFN,"""","""") FIRST",! - Q - ; -CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART) ;RPC ENTRY POINT FOR CCR OUTPUT - ; CCRGRTN IS RETURN ARRAY PASSED BY REFERENCE - ; DFN IS PATIENT IEN - ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART - ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC - ; CCRPARMS ARE PARAMETERS THAT AFFECT THE EXTRACTION - ; IN THE FORM "PARM1:VALUE1^PARM2:VALUE2" - ; EXAMPLE: "LABLIMIT:T-60" TO LIMIT LAB EXTRACTION TO THE LAST 60 DAYS - ; SEE C0CPARMS FOR A COMPLETE LIST OF SUPPORTED PARAMETERS - K ^TMP("C0CCCR",$J) ; CLEAN UP THE GLOBAL BEFORE WE USE IT - M ^TMP("C0CSAV",$J)=^TMP($J) ; SAVING CALLER'S TMP SETTINGS - K ^TMP($J) ; START CLEAN - I '$D(DEBUG) S DEBUG=0 - S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD - I '$D(CCRPARMS) S CCRPARMS="" - I '$D(CCRPART) S CCRPART="CCR" - I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"CALL",DFN)="" - D SET^C0CPARMS(CCRPARMS) ;SET PARAMETERS WITH CCRPARMS AS OVERRIDES - I '$D(TESTVIT) S TESTVIT=0 ; FLAG FOR TESTING VITALS - I '$D(TESTLAB) S TESTLAB=0 ; FLAG FOR TESTING RESULTS SECTION - I '$D(TESTALERT) S TESTALERT=1 ; FLAG FOR TESTING ALERTS SECTION - I '$D(TESTMEDS) S TESTMEDS=0 ; FLAG FOR TESTING C0CMED SECTION - S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE - S CCRGLO=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR - S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS - ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC - ;M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART OR ALL - D LOAD^C0CCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE - D CP^C0CXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL - ; - ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL - ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES - D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body") - D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") - D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") - D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Comments") - I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! - ; - D HDRMAP(CCRGLO,DFN) ; MAP HEADER VARIABLES - ; - K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT - S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS - D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS - N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD - F PROCI=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS - . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE - . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL - . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL - . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE - . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS - . S IXML="INXML" - . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES - . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY - . ; W OXML,! - . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL - . W "RUNNING ",CALL,! - . X CALL - . ; NOW INSERT THE RESULTS IN THE CCR BUFFER - . I $G(@OXML@(0))>0 D ; THERE IS A RESULT - . . D INSERT^C0CXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body") - . . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),! - N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING - D ACTLST^C0CCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST - D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") - D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2") - D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors") - K ACTT,ACTT2 - ;D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT") - ;D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2") - ;D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments") - ; gpl - turned off Comments for Certification - K CMTT,CMTT2 - N TRIMI,J,DONE S DONE=0 - F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE - . S J=$$TRIM^C0CXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS - . I DEBUG W "TRIMMED",J,! - . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE - ;S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLOBAL OF PART OR ALL - I CCRPART="CCR" M CCRGRTN=@CCRGLO ; ENTIRE CCR - E M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART - I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"RESULT",CCRGRTN(0))="" - K ^TMP("C0CCCR",$J) ; BEGIN TO CLEAN UP - K ^TMP($J) ; REALLY CLEAN UP - M ^TMP($J)=^TMP("C0CSAV",$J) ; RESTORE CALLER'S $J - Q - ; -INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS - ; TAB IS PASSED BY NAME - I DEBUG W "TAB= ",TAB,! - ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS - D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")") - I TESTALERT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""C0CCCR"",$J,DFN,""ALERTS"")") - D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")") - D PUSH^C0CXPATH(TAB,"MAP;C0CIMMU;//ContinuityOfCareRecord/Body/Immunizations;^TMP(""C0CCCR"",$J,DFN,""IMMUNE"")") - I TESTVIT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVIT2;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") - E D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") - D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")") - D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROC;//ContinuityOfCareRecord/Body/Procedures;^TMP(""C0CCCR"",$J,DFN,""PROCEDURES"")") - ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") - ; gpl - turned off Encounters for Certification - ;OHUM/RUT 3111228 Condition for Notes ; It should be included or not - I ^TMP("C0CCCR","TIULIMIT")'="" D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") - ;OHUM/RUT - Q - ; -HDRMAP(CXML,DFN) ; MAP HEADER VARIABLES: FROM, TO ECT - N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER")) - ; K @VMAP - S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT") - ; I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS - D ; ALWAYS MAP THESE VARIABLES - . S @VMAP@("CCRDOCOBJECTID")=$$UUID^C0CUTIL ; UUID FOR THIS CCR - . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN - . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - FROM PROVIDER - . ;S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? - . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM - . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES - . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES - . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES - . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT - ;I IHDR'="" D ; HEADER VALUES ARE PROVIDED - ;. D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY - N CTMP - D MAP^C0CXPATH(CXML,VMAP,"CTMP") - D CP^C0CXPATH("CTMP",CXML) - N HRIMVARS ; - S HRIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"HEADER")) ; TO PERSIST VARS - M @HRIMVARS@(1)=@VMAP ; PERSIST THE HEADER VARIABLES IN RIM TABLE - S @HRIMVARS@(0)=1 ; ONLY ONE SET OF HEADERS PER PATIENT - Q - ; -ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML - ; AXML AND ACTRTN ARE PASSED BY NAME - ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 - ; P1= OBJECTID - ACTORPATIENT_2 - ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE - ;OR INSTITUTION - ; OR PERSON(IN PATIENT FILE IE NOK) - ; P3= IEN RECORD NUMBER FOR ACTOR - 2 - N I,J,K,L - K @ACTRTN ; CLEAR RETURN ARRAY - F I=1:1:@AXML@(0) D ; FIRST FIX MISSING LINKS - . I @AXML@(I)?.E1"_<".E D ; - . . N ZA,ZB - . . S ZA=$P(@AXML@(I),">",1)_">" - . . S ZB="<"_$P(@AXML@(I),"<",3) - . . S @AXML@(I)=ZA_"ACTORORGANIZATION_1"_ZB - F I=1:1:@AXML@(0) D ; SCAN ALL LINES - . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE - . . S J=$P($P(@AXML@(I),"",2),"",1) - . . I $G(LINKDEBUG) W "=>",J,! - . . I J'="" S K(J)="" ; HASHING ACTOR - . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE - . . S J=$P($P(@AXML@(I),"",2),"",1) - . . I $G(LINKDEBUG) W "=>",J,! - . . I J'="" S K(J)="" ; HASHING ACTOR - . . ; TO GET RID OF DUPLICATES - S I="" ; GOING TO $O THROUGH THE HASH - F J=0:0 D Q:$O(K(I))="" - . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS - . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID - . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE - . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR - . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY - Q - ; -TEST ; RUN ALL THE TEST CASES - D TESTALL^C0CUNIT("C0CCCR") - Q - ; -ZTEST(WHICH) ; RUN ONE SET OF TESTS - N ZTMP - D ZLOAD^C0CUNIT("ZTMP","C0CCCR") - D ZTEST^C0CUNIT(.ZTMP,WHICH) - Q - ; -TLIST ; LIST THE TESTS - N ZTMP - D ZLOAD^C0CUNIT("ZTMP","C0CCCR") - D TLIST^C0CUNIT(.ZTMP) - Q - ; - ;;> - ;;> - ;;>>>K C0C S C0C="" - ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","") - ;;>>?@C0C@(@C0C@(0))["" - ;;> - ;;>>>K C0C S C0C="" - ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","") - ;;>>?@C0C@(@C0C@(0))["" - ;;> - ;;>>>K C0C S C0C="" - ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","") - ;;>>?@C0C@(@C0C@(0))["" - ;;> - ;;>>>K C0C S C0C="" - ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","") - ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST") - ;;> - ;;>>>D ZTEST^C0CCCR("ACTLST") - ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") - ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3") - ;;>>?G3(G3(0))["" - ;;> - ;;>>>D ZTEST^C0CCCR("CCR") - ;;>>>W $$TRIM^C0CXPATH(CCRGLO) - ;;> - ;;>>>S TESTALERT=1 - ;;>>>K C0C S C0C="" - ;;>>>D CCRRPC^C0CCCR(.C0C,"2","ALERTS","") - ;;>>?@C0C@(@C0C@(0))["" - - +C0CCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008,2009 George Lilly, University of Minnesota. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; EXPORT A CCR + ; +EXPORT ; EXPORT ENTRY POINT FOR CCR + ; Select a patient. + S DIC=2,DIC(0)="AEMQ" D ^DIC + I Y<1 Q ; EXIT + S DFN=$P(Y,U,1) ; SET THE PATIENT + D XPAT(DFN) ; EXPORT TO A FILE + Q + ; +XPAT(DFN,XPARMS,DIR,FN) ; EXPORT ONE PATIENT TO A FILE + ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR") + ; FN IS FILE NAME, DEFAULTS IF NULL + N CCRGLO,UDIR,UFN + S C0CNRPC=1 ; FLAG FOR NOT AN RPC CALL - FOR DEBUGGING THE RPC + I '$D(DIR) S UDIR="" + E S UDIR=DIR + I '$D(FN) S UFN="" ; IF FILENAME IS NOT PASSED + E S UFN=FN + I '$D(XPARMS) S XPARMS="" + N C0CRTN ; RETURN ARRAY + D CCRRPC(.C0CRTN,DFN,XPARMS,"CCR") + S OARY=$NA(^TMP("C0CCUR",$J,DFN,"CCR",1)) + S ONAM=UFN + I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_0.xml" + S ODIRGLB=$NA(^TMP("C0CCCR","ODIR")) + S ^TMP("C0CCCR","FNAME",DFN)=ONAM ; FILE NAME FOR BATCH USE + I $D(^TMP("GPLCCR","ODIR")) S @ODIRGLB=^TMP("GPLCCR","ODIR") + I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET + . W "Warning.. please set ^TMP(""C0CCCR"",""ODIR"")=""output path""",! Q + . ;S @ODIRGLB="/home/glilly/CCROUT" + . ;S @ODIRGLB="/home/cedwards/" + . S @ODIRGLB="/opt/wv/p/" + S ODIR=UDIR + I UDIR="" S ODIR=@ODIRGLB + N ZY + S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR) + W !,$P(ZY,U,2),! + Q + ; +DCCR(DFN) ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED + ; + N G1 + S G1=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) + I $D(@G1@(0)) D ; CCR EXISTS + . D PARY^C0CXPATH(G1) + E W "CCR NOT CREATED, RUN D XPAT^C0CCCR(DFN,"""","""") FIRST",! + Q + ; +CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART) ;RPC ENTRY POINT FOR CCR OUTPUT + ; CCRGRTN IS RETURN ARRAY PASSED BY REFERENCE + ; DFN IS PATIENT IEN + ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART + ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC + ; CCRPARMS ARE PARAMETERS THAT AFFECT THE EXTRACTION + ; IN THE FORM "PARM1:VALUE1^PARM2:VALUE2" + ; EXAMPLE: "LABLIMIT:T-60" TO LIMIT LAB EXTRACTION TO THE LAST 60 DAYS + ; SEE C0CPARMS FOR A COMPLETE LIST OF SUPPORTED PARAMETERS + K ^TMP("C0CCCR",$J) ; CLEAN UP THE GLOBAL BEFORE WE USE IT + M ^TMP("C0CSAV",$J)=^TMP($J) ; SAVING CALLER'S TMP SETTINGS + K ^TMP($J) ; START CLEAN + I '$D(DEBUG) S DEBUG=0 + S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD + I '$D(CCRPARMS) S CCRPARMS="" + I '$D(CCRPART) S CCRPART="CCR" + I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"CALL",DFN)="" + D SET^C0CPARMS(CCRPARMS) ;SET PARAMETERS WITH CCRPARMS AS OVERRIDES + I '$D(TESTVIT) S TESTVIT=0 ; FLAG FOR TESTING VITALS + I '$D(TESTLAB) S TESTLAB=0 ; FLAG FOR TESTING RESULTS SECTION + I '$D(TESTALERT) S TESTALERT=1 ; FLAG FOR TESTING ALERTS SECTION + I '$D(TESTMEDS) S TESTMEDS=0 ; FLAG FOR TESTING C0CMED SECTION + S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE + S CCRGLO=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR + S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS + ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC + ;M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART OR ALL + D LOAD^C0CCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE + D CP^C0CXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL + ; + ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL + ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES + D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body") + D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") + D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") + D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Comments") + I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! + ; + D HDRMAP(CCRGLO,DFN) ; MAP HEADER VARIABLES + ; + K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT + S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS + D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS + N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD + F PROCI=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS + . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE + . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL + . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL + . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE + . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS + . S IXML="INXML" + . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES + . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY + . ; W OXML,! + . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL + . W "RUNNING ",CALL,! + . X CALL + . ; NOW INSERT THE RESULTS IN THE CCR BUFFER + . I $G(@OXML@(0))>0 D ; THERE IS A RESULT + . . D INSERT^C0CXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body") + . . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),! + N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING + D ACTLST^C0CCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST + D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") + D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2") + D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors") + K ACTT,ACTT2 + ;D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT") + ;D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2") + ;D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments") + ; gpl - turned off Comments for Certification + K CMTT,CMTT2 + N TRIMI,J,DONE S DONE=0 + F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE + . S J=$$TRIM^C0CXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS + . I DEBUG W "TRIMMED",J,! + . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE + ;S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLOBAL OF PART OR ALL + I CCRPART="CCR" M CCRGRTN=@CCRGLO ; ENTIRE CCR + E M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART + I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"RESULT",CCRGRTN(0))="" + K ^TMP("C0CCCR",$J) ; BEGIN TO CLEAN UP + K ^TMP($J) ; REALLY CLEAN UP + M ^TMP($J)=^TMP("C0CSAV",$J) ; RESTORE CALLER'S $J + Q + ; +INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS + ; TAB IS PASSED BY NAME + I DEBUG W "TAB= ",TAB,! + ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS + D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")") + I TESTALERT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""C0CCCR"",$J,DFN,""ALERTS"")") + D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")") + D PUSH^C0CXPATH(TAB,"MAP;C0CIMMU;//ContinuityOfCareRecord/Body/Immunizations;^TMP(""C0CCCR"",$J,DFN,""IMMUNE"")") + I TESTVIT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVIT2;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") + E D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") + D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")") + D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROC;//ContinuityOfCareRecord/Body/Procedures;^TMP(""C0CCCR"",$J,DFN,""PROCEDURES"")") + ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") + ; gpl - turned off Encounters for Certification + Q + ; +HDRMAP(CXML,DFN) ; MAP HEADER VARIABLES: FROM, TO ECT + N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER")) + ; K @VMAP + S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT") + ; I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS + D ; ALWAYS MAP THESE VARIABLES + . S @VMAP@("CCRDOCOBJECTID")=$$UUID^C0CUTIL ; UUID FOR THIS CCR + . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN + . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - FROM PROVIDER + . ;S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? + . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM + . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES + . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES + . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES + . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT + ;I IHDR'="" D ; HEADER VALUES ARE PROVIDED + ;. D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY + N CTMP + D MAP^C0CXPATH(CXML,VMAP,"CTMP") + D CP^C0CXPATH("CTMP",CXML) + N HRIMVARS ; + S HRIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"HEADER")) ; TO PERSIST VARS + M @HRIMVARS@(1)=@VMAP ; PERSIST THE HEADER VARIABLES IN RIM TABLE + S @HRIMVARS@(0)=1 ; ONLY ONE SET OF HEADERS PER PATIENT + Q + ; +ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML + ; AXML AND ACTRTN ARE PASSED BY NAME + ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 + ; P1= OBJECTID - ACTORPATIENT_2 + ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE + ;OR INSTITUTION + ; OR PERSON(IN PATIENT FILE IE NOK) + ; P3= IEN RECORD NUMBER FOR ACTOR - 2 + N I,J,K,L + K @ACTRTN ; CLEAR RETURN ARRAY + F I=1:1:@AXML@(0) D ; FIRST FIX MISSING LINKS + . I @AXML@(I)?.E1"_<".E D ; + . . N ZA,ZB + . . S ZA=$P(@AXML@(I),">",1)_">" + . . S ZB="<"_$P(@AXML@(I),"<",3) + . . S @AXML@(I)=ZA_"ACTORORGANIZATION_1"_ZB + F I=1:1:@AXML@(0) D ; SCAN ALL LINES + . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE + . . S J=$P($P(@AXML@(I),"",2),"",1) + . . I $G(LINKDEBUG) W "=>",J,! + . . I J'="" S K(J)="" ; HASHING ACTOR + . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE + . . S J=$P($P(@AXML@(I),"",2),"",1) + . . I $G(LINKDEBUG) W "=>",J,! + . . I J'="" S K(J)="" ; HASHING ACTOR + . . ; TO GET RID OF DUPLICATES + S I="" ; GOING TO $O THROUGH THE HASH + F J=0:0 D Q:$O(K(I))="" + . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS + . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID + . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE + . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR + . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY + Q + ; +TEST ; RUN ALL THE TEST CASES + D TESTALL^C0CUNIT("C0CCCR") + Q + ; +ZTEST(WHICH) ; RUN ONE SET OF TESTS + N ZTMP + D ZLOAD^C0CUNIT("ZTMP","C0CCCR") + D ZTEST^C0CUNIT(.ZTMP,WHICH) + Q + ; +TLIST ; LIST THE TESTS + N ZTMP + D ZLOAD^C0CUNIT("ZTMP","C0CCCR") + D TLIST^C0CUNIT(.ZTMP) + Q + ; + ;;> + ;;> + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","") + ;;>>?@C0C@(@C0C@(0))["" + ;;> + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","") + ;;>>?@C0C@(@C0C@(0))["" + ;;> + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","") + ;;>>?@C0C@(@C0C@(0))["" + ;;> + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","") + ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST") + ;;> + ;;>>>D ZTEST^C0CCCR("ACTLST") + ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") + ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3") + ;;>>?G3(G3(0))["" + ;;> + ;;>>>D ZTEST^C0CCCR("CCR") + ;;>>>W $$TRIM^C0CXPATH(CCRGLO) + ;;> + ;;>>>S TESTALERT=1 + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","ALERTS","") + ;;>>?@C0C@(@C0C@(0))["" + + Index: ccr/branches/ohum/p/C0CCCR0.m =================================================================== --- ccr/branches/ohum/p/C0CCCR0.m (revision 1333) +++ ccr/branches/ohum/p/C0CCCR0.m (revision 1337) @@ -1,906 +1,906 @@ -C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008,2009 George Lilly, University of Minnesota. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is a CCR TEMPLATE with processing routines",! - W ! - Q - ; -ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array - ; ZARY IS PASSED BY NAME - ; BAT is a string identifying the section - ; LINE is a test which will evaluate to true or false - ; I '$G(@ZARY) D ; - ; . S @ZARY@(0)=0 ; initially there are no elements - ; . W "GOT HERE LOADING "_LINE,! - N CNT ; count of array elements - S CNT=@ZARY@(0) ; contains array count - S CNT=CNT+1 ; increment count - S @ZARY@(CNT)=LINE ; put the line in the array - ; S @ZARY@(BAT,CNT)="" ; index the test by battery - S @ZARY@(0)=CNT ; update the array counter - Q - ; -ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference - ; ZARY IS PASSED BY NAME - ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") - ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE - K @ZARY S @ZARY="" - S @ZARY@(0)=0 ; initialize array count - N LINE,LABEL,BODY - N INTEST S INTEST=0 ; switch for in the TEMPLATE section - N SECTION S SECTION="[anonymous]" ; NO section LABEL - ; - N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D - . I LINE?." "1";".E S INTEST=0 ; leaving section - . I INTEST D ; within the section - . . I LINE?." "1";><".E D ; sub-section name found - . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name - . . I LINE?." "1";;".E D ; line found - . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array - Q - ; -LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME - D ZLOAD(ARY,"C0CCCR0") - ; ZWR @ARY - Q - ; - ; +C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008,2009 George Lilly, University of Minnesota. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is a CCR TEMPLATE with processing routines",! + W ! + Q + ; +ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array + ; ZARY IS PASSED BY NAME + ; BAT is a string identifying the section + ; LINE is a test which will evaluate to true or false + ; I '$G(@ZARY) D ; + ; . S @ZARY@(0)=0 ; initially there are no elements + ; . W "GOT HERE LOADING "_LINE,! + N CNT ; count of array elements + S CNT=@ZARY@(0) ; contains array count + S CNT=CNT+1 ; increment count + S @ZARY@(CNT)=LINE ; put the line in the array + ; S @ZARY@(BAT,CNT)="" ; index the test by battery + S @ZARY@(0)=CNT ; update the array counter + Q + ; +ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference + ; ZARY IS PASSED BY NAME + ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") + ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE + K @ZARY S @ZARY="" + S @ZARY@(0)=0 ; initialize array count + N LINE,LABEL,BODY + N INTEST S INTEST=0 ; switch for in the TEMPLATE section + N SECTION S SECTION="[anonymous]" ; NO section LABEL + ; + N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D + . I LINE?." "1";".E S INTEST=0 ; leaving section + . I INTEST D ; within the section + . . I LINE?." "1";><".E D ; sub-section name found + . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name + . . I LINE?." "1";;".E D ; line found + . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array + Q + ; +LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME + D ZLOAD(ARY,"C0CCCR0") + ; ZWR @ARY + Q + ; + ; Index: ccr/branches/ohum/p/C0CCMT.m =================================================================== --- ccr/branches/ohum/p/C0CCMT.m (revision 1333) +++ ccr/branches/ohum/p/C0CCMT.m (revision 1337) @@ -1,66 +1,66 @@ -C0CCMT ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10 - ;;1.0;C0C;;May 21, 2010;Build 1 - ;Copyright 2010 George Lilly, University of Minnesota and others. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(NOTEXML,DFN,NOTEOUT) ; EXTRACT NOTES INTO XML TEMPLATE - ; NOTEXML AND NOTEOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED - ; - D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES - ;I '$D(@C0CNTE) Q ; NO NOTES AVAILABLE - D MAP(NOTEXML,C0CNTE,NOTEOUT) ;MAP RESULTS FOR NOTES - Q - ; -MAP(NOTEXML,C0CNTE,NOTEOUT) ; MAP PROCEDURES XML - ; - N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"NOTETEMP")) ;WORK AREA FOR TEMPLATE - K @ZTEMP - N ZBLD - S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"NOTEBLD")) ; BUILD LIST AREA - D QUEUE^C0CXPATH(ZBLD,NOTEXML,1,1) ; FIRST LINE - N ZINNER - D QUERY^C0CXPATH(NOTEXML,"//Comments/Comment","ZINNER") ;ONE NOTE - N ZTMP,ZVAR,ZI - S ZI="" - F S ZI=$O(@C0CNTE@(ZI)) Q:ZI="" D ;FOR EACH NOTE - . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS NOTE XML - . S ZVAR=$NA(@C0CNTE@(ZI)) ;THIS NOTE VARIABLES - . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE - . N ZNOTE,ZN - . D CLEAN($NA(@C0CNTE@(ZI,"TEXT"))) ;REMOVE CONTROL CHARS AND XML RESERVED - . M ZNOTE=@C0CNTE@(ZI,"TEXT") ;THE NOTE TO ADD TO THE BUILD - . S ZNOTE(0)=$O(ZNOTE(""),-1) ;LENGTH OF THE NOTE - . D INSERT^C0CXPATH(ZTMP,"ZNOTE","//Comment/Description/Text") - . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD - D QUEUE^C0CXPATH(ZBLD,NOTEXML,@NOTEXML@(0),@NOTEXML@(0)) - N ZZTMP - D BUILD^C0CXPATH(ZBLD,NOTEOUT) ;BUILD FINAL XML - K @ZTEMP,@ZBLD,@C0CNTE - Q - ; -CLEAN(INARY) ; INARY IS PASSED BY NAME - ; REMOVE CONTROL CHARACTERS AND XML RESERVED SYMBOLS FROM THE ARRAY - N ZI,ZJ S ZI="" - F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; - . S @INARY@(ZI)=$$CLEAN^C0CXPATH(@INARY@(ZI)) ; CONTROL CHARS - . S @INARY@(ZI)=$$SYMENC^MXMLUTL(@INARY@(ZI)) ; XML RESERVED SYMBOLS - Q - ; +C0CCMT ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10 + ;;1.0;C0C;;May 21, 2010;Build 38 + ;Copyright 2010 George Lilly, University of Minnesota and others. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(NOTEXML,DFN,NOTEOUT) ; EXTRACT NOTES INTO XML TEMPLATE + ; NOTEXML AND NOTEOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; + D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES + ;I '$D(@C0CNTE) Q ; NO NOTES AVAILABLE + D MAP(NOTEXML,C0CNTE,NOTEOUT) ;MAP RESULTS FOR NOTES + Q + ; +MAP(NOTEXML,C0CNTE,NOTEOUT) ; MAP PROCEDURES XML + ; + N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"NOTETEMP")) ;WORK AREA FOR TEMPLATE + K @ZTEMP + N ZBLD + S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"NOTEBLD")) ; BUILD LIST AREA + D QUEUE^C0CXPATH(ZBLD,NOTEXML,1,1) ; FIRST LINE + N ZINNER + D QUERY^C0CXPATH(NOTEXML,"//Comments/Comment","ZINNER") ;ONE NOTE + N ZTMP,ZVAR,ZI + S ZI="" + F S ZI=$O(@C0CNTE@(ZI)) Q:ZI="" D ;FOR EACH NOTE + . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS NOTE XML + . S ZVAR=$NA(@C0CNTE@(ZI)) ;THIS NOTE VARIABLES + . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE + . N ZNOTE,ZN + . D CLEAN($NA(@C0CNTE@(ZI,"TEXT"))) ;REMOVE CONTROL CHARS AND XML RESERVED + . M ZNOTE=@C0CNTE@(ZI,"TEXT") ;THE NOTE TO ADD TO THE BUILD + . S ZNOTE(0)=$O(ZNOTE(""),-1) ;LENGTH OF THE NOTE + . D INSERT^C0CXPATH(ZTMP,"ZNOTE","//Comment/Description/Text") + . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD + D QUEUE^C0CXPATH(ZBLD,NOTEXML,@NOTEXML@(0),@NOTEXML@(0)) + N ZZTMP + D BUILD^C0CXPATH(ZBLD,NOTEOUT) ;BUILD FINAL XML + K @ZTEMP,@ZBLD,@C0CNTE + Q + ; +CLEAN(INARY) ; INARY IS PASSED BY NAME + ; REMOVE CONTROL CHARACTERS AND XML RESERVED SYMBOLS FROM THE ARRAY + N ZI,ZJ S ZI="" + F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; + . S @INARY@(ZI)=$$CLEAN^C0CXPATH(@INARY@(ZI)) ; CONTROL CHARS + . S @INARY@(ZI)=$$SYMENC^MXMLUTL(@INARY@(ZI)) ; XML RESERVED SYMBOLS + Q + ; Index: ccr/branches/ohum/p/C0CCPT.m =================================================================== --- ccr/branches/ohum/p/C0CCPT.m (revision 1333) +++ ccr/branches/ohum/p/C0CCPT.m (revision 1337) @@ -1,94 +1,91 @@ -C0CCPT ;;BSL;RETURN CPT DATA; - ;Sequence Managers Software GPL;;;;;Build 1 - ;Copied into C0C namespace from SQMCPT with permission from - ;Brian Lord - and with our thanks. gpl 01/20/2010 -ENTRY(DFN,STDT,ENDDT,TXT) ;BUILD TOTAL ARRAY OF ALL IEN'S FOR TIU NOTES - ;DFN=PATIENT IEN - ;STDT=START DATE IN 3100101 FORMAT (VA YEAR YYYMMDD) - ;ENDDT=END DATE IN 3100101 FORMAT - ;TXT=INCLUDE TEXT FROM ENCOUNTER NOTE - ;THAT FALL INSIDE DATA RANGE. IF NO STDT OR ENDDT ASSUME - ;ALL INCLUSIVE IN THAT DIRECTION - ;LIST OF TIU DOCS IN ^TIU(8925,"ACLPT",3,DFN) - ;BUILD INTO NOTE(Y)="" - S U="^",X="" - F S X=$O(^TIU(8925,"ACLPT",3,DFN,X)) Q:X="" D - . S Y="" - . F S Y=$O(^TIU(8925,"ACLPT",3,DFN,X,Y)) Q:Y="" D - .. S NOTE(Y)="" - ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE - ;GET DATE OF NOTE - ;OHUM/RUT 3111228 Date Range for Notes - S STDT=^TMP("C0CCCR","TIULIMIT") D NOW^%DTC S ENDDT=X - ;OHUM/RUT - S Z="" - F S Z=$O(NOTE(Z)) Q:Z="" D - . S DT=$P(^TIU(8925,Z,0),U,7) - . I $G(STDT)]"" D - .. I STDT>DT S NOTE(Z)="D" ;SET NOTE TO BE DELETED - . I $G(ENDDT)]"" D - .. I ENDDT
0) - . D ENCEVENT^PXKENC(VISIT,1) - . I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q - . S IPRV=0 F S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV D - .. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0) - .. ;Q:$P(X0,U,4)'="P" - .. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U) - .. S PRIM=($P(X0,U,4)="P") - .. S ILST=ILST+1 - .. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM - .. S VISIT(IEN,"PRV",ILST)=CODE_"^^^"_NARR_"^"_PRIM - . S IPOV=0 F S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV D - .. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811)) - .. S CODE=$P(X0,U) - .. S:CODE CODE=$P(^ICD9(CODE,0),U) - .. S CAT=$P(X802,U) - .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) - .. S NARR=$P(X0,U,4) - .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) - .. S PRIM=($P(X0,U,12)="P") - .. S PRV=$P(X12,U,4) - .. S ILST=ILST+1 - .. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV - .. S VISIT(IEN,"POV",ILST)=CODE_U_CAT_U_NARR_U_PRIM_U_PRV - . S ICPT=0 F S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT D - .. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811)) - .. ;S CODE=$P(X0,U) - .. S CODE=$O(^ICPT("B",$P(X0,U),0)) - .. S:CODE CODE=$P(^ICPT(CODE,0),U) - .. S CAT=$P(X802,U) - .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) - .. S NARR=$P(X0,U,4) - .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) - .. S QTY=$P(X0,U,16) - .. S PRV=$P(X12,U,4) - .. S MCNT=0,MIDX=0,MODS="" - .. F S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX D - ... S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0)) - ... I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN - .. I +MCNT S MODS=MCNT_MODS - .. S ILST=ILST+1 - .. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS - .. S VISIT(IEN,"CPT",ILST)=CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS - . S VISIT(IEN,"DATE",0)=$P($P(^TIU(8925,IEN,0),U,7),".") - . S VISIT(IEN,"CLASS")=$$GET1^DIQ(8925,IEN_",",.04) ;GPL 5/21/10 - . I $G(TXT)=1 D GETNOTE(IEN) - Q -GETNOTE(IEN) ;GET THE TEXT THAT GOES WITH VISIT - ;EXTRACT NOTE TEXT FROM ^TIU(8925,IEN,"TEXT" - Q:'$D(VISIT(IEN,"CPT")) - S TXTCNT=0 - F S TXTCNT=TXTCNT+1 Q:'$D(^TIU(8925,IEN,"TEXT",TXTCNT,0)) D - . S VISIT(IEN,"TEXT",TXTCNT)=^TIU(8925,IEN,"TEXT",TXTCNT,0) - Q +C0CCPT ;;BSL;RETURN CPT DATA; + ;Sequence Managers Software GPL;;;;;Build 38 + ;Copied into C0C namespace from SQMCPT with permission from + ;Brian Lord - and with our thanks. gpl 01/20/2010 +ENTRY(DFN,STDT,ENDDT,TXT) ;BUILD TOTAL ARRAY OF ALL IEN'S FOR TIU NOTES + ;DFN=PATIENT IEN + ;STDT=START DATE IN 3100101 FORMAT (VA YEAR YYYMMDD) + ;ENDDT=END DATE IN 3100101 FORMAT + ;TXT=INCLUDE TEXT FROM ENCOUNTER NOTE + ;THAT FALL INSIDE DATA RANGE. IF NO STDT OR ENDDT ASSUME + ;ALL INCLUSIVE IN THAT DIRECTION + ;LIST OF TIU DOCS IN ^TIU(8925,"ACLPT",3,DFN) + ;BUILD INTO NOTE(Y)="" + S U="^",X="" + F S X=$O(^TIU(8925,"ACLPT",3,DFN,X)) Q:X="" D + . S Y="" + . F S Y=$O(^TIU(8925,"ACLPT",3,DFN,X,Y)) Q:Y="" D + .. S NOTE(Y)="" + ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE + ;GET DATE OF NOTE + S Z="" + F S Z=$O(NOTE(Z)) Q:Z="" D + . S DT=$P(^TIU(8925,Z,0),U,7) + . I $G(STDT)]"" D + .. I STDT>DT S NOTE(Z)="D" ;SET NOTE TO BE DELETED + . I $G(ENDDT)]"" D + .. I ENDDT
0) + . D ENCEVENT^PXKENC(VISIT,1) + . I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q + . S IPRV=0 F S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV D + .. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0) + .. ;Q:$P(X0,U,4)'="P" + .. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U) + .. S PRIM=($P(X0,U,4)="P") + .. S ILST=ILST+1 + .. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM + .. S VISIT(IEN,"PRV",ILST)=CODE_"^^^"_NARR_"^"_PRIM + . S IPOV=0 F S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV D + .. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811)) + .. S CODE=$P(X0,U) + .. S:CODE CODE=$P(^ICD9(CODE,0),U) + .. S CAT=$P(X802,U) + .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) + .. S NARR=$P(X0,U,4) + .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) + .. S PRIM=($P(X0,U,12)="P") + .. S PRV=$P(X12,U,4) + .. S ILST=ILST+1 + .. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV + .. S VISIT(IEN,"POV",ILST)=CODE_U_CAT_U_NARR_U_PRIM_U_PRV + . S ICPT=0 F S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT D + .. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811)) + .. ;S CODE=$P(X0,U) + .. S CODE=$O(^ICPT("B",$P(X0,U),0)) + .. S:CODE CODE=$P(^ICPT(CODE,0),U) + .. S CAT=$P(X802,U) + .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) + .. S NARR=$P(X0,U,4) + .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) + .. S QTY=$P(X0,U,16) + .. S PRV=$P(X12,U,4) + .. S MCNT=0,MIDX=0,MODS="" + .. F S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX D + ... S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0)) + ... I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN + .. I +MCNT S MODS=MCNT_MODS + .. S ILST=ILST+1 + .. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS + .. S VISIT(IEN,"CPT",ILST)=CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS + . S VISIT(IEN,"DATE",0)=$P($P(^TIU(8925,IEN,0),U,7),".") + . S VISIT(IEN,"CLASS")=$$GET1^DIQ(8925,IEN_",",.04) ;GPL 5/21/10 + . I $G(TXT)=1 D GETNOTE(IEN) + Q +GETNOTE(IEN) ;GET THE TEXT THAT GOES WITH VISIT + ;EXTRACT NOTE TEXT FROM ^TIU(8925,IEN,"TEXT" + Q:'$D(VISIT(IEN,"CPT")) + S TXTCNT=0 + F S TXTCNT=TXTCNT+1 Q:'$D(^TIU(8925,IEN,"TEXT",TXTCNT,0)) D + . S VISIT(IEN,"TEXT",TXTCNT)=^TIU(8925,IEN,"TEXT",TXTCNT,0) + Q Index: ccr/branches/ohum/p/C0CDIC.m =================================================================== --- ccr/branches/ohum/p/C0CDIC.m (revision 1333) +++ ccr/branches/ohum/p/C0CDIC.m (revision 1337) @@ -1,207 +1,207 @@ -C0CDIC ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08 - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is the CCR Dictionary Utility Library ",! - W ! - Q - ; -DIC2CSV ;OUTPUT THE CCR DICTIONARY TO A CSV FILE - ; - N ZI - S ZI="" - S G1=$NA(^TMP($J,"C0CCSV",1)) - S G1A=$NA(@G1@("V")) - S G2=$NA(^TMP($J,"C0CCSV",2)) - D GETN2^C0CRNF(G1,170) ; GET THE MATRIX - F S ZI=$O(@G1A@(ZI)) Q:ZI="" D ;FOR EACH ROW IN THE MATRIX - . I $G(@G1A@(ZI,"MAPPING METHOD",1))'="" D ; - . . W @G1A@(ZI,"MAPPING METHOD",1),! - . . ;K @G1A@(ZI,"MAPPING METHOD") - . ;W !,ZI,$G(@G1A@(ZI,"MAPPING METHOD",1)) - D RNF2CSV^C0CRNF(G2,G1,"VN") ; PREPARE THE CVS FILE - K @G1 - D FILEOUT^C0CRNF(G2,"FILE_"_170_".csv") - K @G2 - Q - ; -GVARS(C0CVARS,C0CT) ; Get the CCR variables from the CCR template - ; and return them in C0CVARS, which is passed by name - ; FIRST PIECE OF C0CVARS(x) IS THE VARIABLE NAME, SECOND PIECE - ; IS THE LINE NUMBER OF THE VARIABLE IN THE TEMPLATE - ; C0CT IS RETURNED AS THE CCR TEMPLATE - N C0CTVARS ; ARRAY FOR THE TEMPLATE AND ARRAY FOR THE VARS - D LOAD^GPLCCR0(C0CT) ; LOAD THE CCR TEMPLATE - D XVARS^GPLXPATH("C0CTVARS",C0CT) ; PULL OUT THE VARS - N C0CI,C0CX - S @C0CVARS@(0)=C0CTVARS(0) ; SAME COUNT - F C0CI=1:1:C0CTVARS(0) D ; FOR EVERY LINE IN THE ARRAY - . S C0CX=C0CTVARS(C0CI) ; THE VARIABLE - 3 PIECES, FIRST ONE NULL - . S @C0CVARS@(C0CI)=$P(C0CX,"^",2)_"^"_$P(C0CX,"^",3) ; VAR NAME^LINE NUMBER - ;D PARY^GPLXPATH("C0CVARS") - Q - ; -GXPATH(C0CPVARS,C0CPT) ; LOAD THE CCR TEMPLATE INTO C0CPT, PULL OUT VARIABLES - ; AND THE XPATH TO THE VARIABLES INTO C0CPVARS - ; BY INDEXING THE TEMPLATE C0CT AND MATCHING THE XPATH TO THE VARIABLE - ; BOTH ARE PASSED BY NAME - ; C0CPVARS(x) IS VAR^LINENUM^XPATH SORTED BY LINENUM - ; C0CPVARS(0) IS NUMBER OF VARIABLES - ; C0CPT(0) IS NUMBER OF LINES IN THE TEMPLATE - D GVARS(C0CPVARS,C0CPT) ; GET THE VARIABLES AND LINE NUMBERS - ;N C0CTVARS ; HASH TABLE FOR VARIABLE BY LINE NUMBER - D HASHV ; PUT THE VARIABLES IN A LINE NUMBER HASH FOR MATCHING TO XPATHS - ; NOW GO GET THE XPATH INDEXES - D INDEX^GPLXPATH(C0CPT) ; ADD THE XPATH INDEXES TO THE TEMPLATE ARRAY - S C0CI="" ; GOING TO LOOP THROUGH THE WHOLE ARRAY LOOKING AT XPATHS - F S C0CI=$O(@C0CPT@(C0CI)) Q:C0CI="" D ; VISIT EVERY LINE - . I +C0CI'=0 Q ; SKIP EVERYTHING BUT THE XPATH INDEX - . I C0CI=0 Q ; SKIP THE ZERO NODE - . S C0CX=@C0CPT@(C0CI) ; PULL OUT THE LINE NUMBERS X^Y - . S C0CY=$P(C0CX,"^",1) ; STARTING LINE NUMBER - . S C0CZ=$P(C0CX,"^",2) ; ENDING LINE NUMBER - . I C0CY=C0CZ D ; THIS IS AN XPATH END NODE, HAS A VARIABLE (WE HOPE) - . . ; W "FOUND ",C0CI,! - . . I $D(C0CTVARS(C0CY)) D ; IF THERE IS A VARIABLE THERE - . . . S $P(C0CTVARS(C0CY),"^",3)=C0CI ; INSERT THE XPATH FOR THE VAR - D SORTV ; SORT THE ARRAY BY LINE NUMBER - Q - ; -HASHV ; INTERNAL ROUTINE TO PUT VARIABLE NAMES IN A LINE NUMBER HASH - ;N C0CI,C0CTVARS,C0CX,C0CY - F C0CI=1:1:@C0CPVARS@(0) D ; FOR THE ENTIRE ARRAY - . S C0CX=$P(@C0CPVARS@(C0CI),"^",2) ; LINE NUMBER - . S C0CY=$P(@C0CPVARS@(C0CI),"^",1) ; VARIABLE NAME - . S C0CTVARS(C0CX)=C0CY ; BUILD HASH OF VARIABLES BY LINE NUMBER - Q - ; -SORTV ; INTERNAL ROUTINE TO OUTPUT VARIABLES (AND XPATHS) IN LINE NUMBER ORDER - ;N C0CV2 ; SCRACTH SPACE FOR BUILDING SORTED ARRAY - S C0CI="" ; - F S C0CI=$O(C0CTVARS(C0CI)) Q:C0CI="" D ; BY LINE NUMBER - . S C0CX=C0CTVARS(C0CI) ;VARIABLE NAME - . S $P(C0CX,"^",2)=C0CI ; LINE NUMBER IS SECOND PIECE - . D PUSH^GPLXPATH("C0C2",C0CX) ; PUT ONTO ARRAY - K @C0CPVARS - M @C0CPVARS=C0C2 - Q - ; -LOAD ; LOAD VARIABLE NAMES AND XPATH IN ^C0CDIC(170 - ; INITIAL LOAD OF THE CCR DICTIONARY - ; - N C0CDIC,C0CARY,C0CXML,C0CFDA,C0CI - S C0CDIC="^C0CDIC(170," ; ROOT OF THE CCR DICTIONARY - D GXPATH("C0CARY","C0CXML") ; FETCH THE VARIABLES AND XPATH INTO C0CARY - ; C0CXML WILL CONTAIN THE TEMPLATE - NOT NEEDED FOR LOAD - D PARY^GPLXPATH("C0CARY") ;TEST - F C0CI=1:1:C0CARY(0) D ; LOAD EACH VARIABLE - . S C0CFDA(170,"+"_C0CI_",",.01)=$P(C0CARY(C0CI),"^",1) ; VAR NAME - . S C0CFDA(170,"+"_C0CI_",",2)=$P(C0CARY(C0CI),"^",3) ; XPATH - . D UPDATE^DIE("","C0CFDA") - . I $D(^TMP("DIERR",$J)) U $P BREAK - . W "LOADING:",C0CI," ",C0CARY(C0CI),! - Q - ; -INIT ; INITIALIZE CCR DICTIONARY BASED ON VARIABLE NAMES - ; - ; CHEAT SHEET FOR VARIABLE NAMES IN ^C0CDIC(170.xx, - ; THIS IS WHAT WILL BE IN C0CA FOR EACH DICTIONARY ENTRY - ;G1("CODING")="170^8" - ;G1("DATA ELEMENT")="170^7" - ;G1("DESCRIPTION")="170^3" - ;G1("ID")="170^1" - ;G1("M","170^8","CODING")="170.08^.01" - ;G1("MAPPING METHOD")="170.08^1" - ;G1("SECTION")="170^10" - ;G1("SOURCE")="170^4" - ;G1("STATUS")="170^9" - ;G1("TYPE")="170^6" - ;G1("VARIABLE")="170^.01" - ;G1("XPATH")="170^2" - ; - N C0CZA,C0CZX,C0CN,C0CSTAT - S C0CZX=0 - S C0CSTAT=0 ; INIT STATUS SET FLAG - F S C0CZX=$O(^C0CDIC(170,C0CZX)) Q:+C0CZX=0 D ; FOR EACH DICT ENTRY - . ;W C0CZX,! - . K C0CA,C0CN ; CLEAR OUT THE LAST ONE - . D GETN1^C0CRNF("C0CA",170,C0CZX,"","ALL") ; GET VARIABLE HASH - . ;ZWR C0CA B ; - . S C0CN=$$ZVALUE("VARIABLE") ;NAME OF THE VARIABLE - . W "VARIABLE: ",C0CN,! - . I $E(C0CN,1,5)="ACTOR" D SETFDA("SECTION","ACTORS") ; - . I $E(C0CN,1,6)="SOCIAL" D ; - . . D SETFDA("SECTION","SOC") ; - . . D SETFDA("STATUS","X") ;SOCIAL HISTORY NOT IMPLEMENTED - . . S C0CSTAT=1 - . I $E(C0CN,1,6)="FAMILY" D ; - . . D SETFDA("SECTION","FAM") ; - . . D SETFDA("STATUS","X") ;FAMILY HISTORY NOT IMPLEMENTED - . . S C0CSTAT=1 - . ;D SETFDA("TYPE","") ;CORRECT FOR TYPE ERRORS - . I $E(C0CN,1,5)="ALERT" D SETFDA("SECTION","ALERTS") - . I $E(C0CN,1,5)="VITAL" D SETFDA("SECTION","VITALS") - . I $E(C0CN,1,7)="PROBLEM" D SETFDA("SECTION","PROBLEMS") - . I $E(C0CN,1,10)="RESULTTEST" D SETFDA("SECTION","TEST") - . E I $E(C0CN,1,6)="RESULT" D SETFDA("SECTION","LABS") - . I C0CN["CODEVALUE" D SETFDA("TYPE","CD") ;CODES - . I C0CN["CODEVERSION" D SETFDA("TYPE","CV") ; CODE VERSION - . I C0CN["CODINGSYSTEM" D SETFDA("TYPE","CS") ;CODING SYSTEM - . I $$ZVALUE("STATUS")=""!'C0CSTAT D SETFDA("STATUS","N") ;BLANK STATUS TO N - . I $$ZVALUE("XPATH")["/Medication/Directions/" D ; MEDS DIRECTIONS VAR - . . D SETFDA("SECTION","DIR") ; SPECIAL SECTION FOR DIRECTIONS - . E I $$ZVALUE("XPATH")["/Medications/Medication/" D ; ALL OTHER MEDS - . . D SETFDA("SECTION","MEDS") ; A MEDS VAR - . I $E(C0CN,($L(C0CN)-1),$L(C0CN))="ID" D SETFDA("TYPE","ID") ;CATCH THE IDS - . I C0CN["DATETIME" D SETFDA("TYPE","DT") ; DATE/TIME VARIABLE - . W "VARIABLE: ",C0CZX," ",C0CA("VARIABLE"),! - . ;ZWR C0CFDA - . I $D(C0CFDA) D ; WE HAVE CHANGES ON THIS VARIABLE - . . ;ZWR C0CFDA - . . D UPDATE^DIE("","C0CFDA(C0CZX)") - . . I $D(^TMP("DIERR",$J)) U $P BREAK - . . D CLEAN^DILF ; CLEAN UP - . ;ZWR C0CFDA - Q - ; -SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN - ; TO SET TO VALUE C0CSV. - ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE - ; C0CSN,C0CSV ARE PASSED BY VALUE - ; - N C0CSI,C0CSJ - S C0CSI=$$ZFILE(C0CSN,"C0CA") ; FILE NUMBER - S C0CSJ=$$ZFIELD(C0CSN,"C0CA") ; FIELD NUMBER - S C0CFDA(C0CZX,C0CSI,C0CZX_",",C0CSJ)=C0CSV - Q -ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P(@ZTAB@(ZFN),"^",1) -ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P(@ZTAB@(ZFN),"^",2) -ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P(@ZTAB@(ZFN),"^",3) - ; +C0CDIC ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is the CCR Dictionary Utility Library ",! + W ! + Q + ; +DIC2CSV ;OUTPUT THE CCR DICTIONARY TO A CSV FILE + ; + N ZI + S ZI="" + S G1=$NA(^TMP($J,"C0CCSV",1)) + S G1A=$NA(@G1@("V")) + S G2=$NA(^TMP($J,"C0CCSV",2)) + D GETN2^C0CRNF(G1,170) ; GET THE MATRIX + F S ZI=$O(@G1A@(ZI)) Q:ZI="" D ;FOR EACH ROW IN THE MATRIX + . I $G(@G1A@(ZI,"MAPPING METHOD",1))'="" D ; + . . W @G1A@(ZI,"MAPPING METHOD",1),! + . . ;K @G1A@(ZI,"MAPPING METHOD") + . ;W !,ZI,$G(@G1A@(ZI,"MAPPING METHOD",1)) + D RNF2CSV^C0CRNF(G2,G1,"VN") ; PREPARE THE CVS FILE + K @G1 + D FILEOUT^C0CRNF(G2,"FILE_"_170_".csv") + K @G2 + Q + ; +GVARS(C0CVARS,C0CT) ; Get the CCR variables from the CCR template + ; and return them in C0CVARS, which is passed by name + ; FIRST PIECE OF C0CVARS(x) IS THE VARIABLE NAME, SECOND PIECE + ; IS THE LINE NUMBER OF THE VARIABLE IN THE TEMPLATE + ; C0CT IS RETURNED AS THE CCR TEMPLATE + N C0CTVARS ; ARRAY FOR THE TEMPLATE AND ARRAY FOR THE VARS + D LOAD^GPLCCR0(C0CT) ; LOAD THE CCR TEMPLATE + D XVARS^GPLXPATH("C0CTVARS",C0CT) ; PULL OUT THE VARS + N C0CI,C0CX + S @C0CVARS@(0)=C0CTVARS(0) ; SAME COUNT + F C0CI=1:1:C0CTVARS(0) D ; FOR EVERY LINE IN THE ARRAY + . S C0CX=C0CTVARS(C0CI) ; THE VARIABLE - 3 PIECES, FIRST ONE NULL + . S @C0CVARS@(C0CI)=$P(C0CX,"^",2)_"^"_$P(C0CX,"^",3) ; VAR NAME^LINE NUMBER + ;D PARY^GPLXPATH("C0CVARS") + Q + ; +GXPATH(C0CPVARS,C0CPT) ; LOAD THE CCR TEMPLATE INTO C0CPT, PULL OUT VARIABLES + ; AND THE XPATH TO THE VARIABLES INTO C0CPVARS + ; BY INDEXING THE TEMPLATE C0CT AND MATCHING THE XPATH TO THE VARIABLE + ; BOTH ARE PASSED BY NAME + ; C0CPVARS(x) IS VAR^LINENUM^XPATH SORTED BY LINENUM + ; C0CPVARS(0) IS NUMBER OF VARIABLES + ; C0CPT(0) IS NUMBER OF LINES IN THE TEMPLATE + D GVARS(C0CPVARS,C0CPT) ; GET THE VARIABLES AND LINE NUMBERS + ;N C0CTVARS ; HASH TABLE FOR VARIABLE BY LINE NUMBER + D HASHV ; PUT THE VARIABLES IN A LINE NUMBER HASH FOR MATCHING TO XPATHS + ; NOW GO GET THE XPATH INDEXES + D INDEX^GPLXPATH(C0CPT) ; ADD THE XPATH INDEXES TO THE TEMPLATE ARRAY + S C0CI="" ; GOING TO LOOP THROUGH THE WHOLE ARRAY LOOKING AT XPATHS + F S C0CI=$O(@C0CPT@(C0CI)) Q:C0CI="" D ; VISIT EVERY LINE + . I +C0CI'=0 Q ; SKIP EVERYTHING BUT THE XPATH INDEX + . I C0CI=0 Q ; SKIP THE ZERO NODE + . S C0CX=@C0CPT@(C0CI) ; PULL OUT THE LINE NUMBERS X^Y + . S C0CY=$P(C0CX,"^",1) ; STARTING LINE NUMBER + . S C0CZ=$P(C0CX,"^",2) ; ENDING LINE NUMBER + . I C0CY=C0CZ D ; THIS IS AN XPATH END NODE, HAS A VARIABLE (WE HOPE) + . . ; W "FOUND ",C0CI,! + . . I $D(C0CTVARS(C0CY)) D ; IF THERE IS A VARIABLE THERE + . . . S $P(C0CTVARS(C0CY),"^",3)=C0CI ; INSERT THE XPATH FOR THE VAR + D SORTV ; SORT THE ARRAY BY LINE NUMBER + Q + ; +HASHV ; INTERNAL ROUTINE TO PUT VARIABLE NAMES IN A LINE NUMBER HASH + ;N C0CI,C0CTVARS,C0CX,C0CY + F C0CI=1:1:@C0CPVARS@(0) D ; FOR THE ENTIRE ARRAY + . S C0CX=$P(@C0CPVARS@(C0CI),"^",2) ; LINE NUMBER + . S C0CY=$P(@C0CPVARS@(C0CI),"^",1) ; VARIABLE NAME + . S C0CTVARS(C0CX)=C0CY ; BUILD HASH OF VARIABLES BY LINE NUMBER + Q + ; +SORTV ; INTERNAL ROUTINE TO OUTPUT VARIABLES (AND XPATHS) IN LINE NUMBER ORDER + ;N C0CV2 ; SCRACTH SPACE FOR BUILDING SORTED ARRAY + S C0CI="" ; + F S C0CI=$O(C0CTVARS(C0CI)) Q:C0CI="" D ; BY LINE NUMBER + . S C0CX=C0CTVARS(C0CI) ;VARIABLE NAME + . S $P(C0CX,"^",2)=C0CI ; LINE NUMBER IS SECOND PIECE + . D PUSH^GPLXPATH("C0C2",C0CX) ; PUT ONTO ARRAY + K @C0CPVARS + M @C0CPVARS=C0C2 + Q + ; +LOAD ; LOAD VARIABLE NAMES AND XPATH IN ^C0CDIC(170 + ; INITIAL LOAD OF THE CCR DICTIONARY + ; + N C0CDIC,C0CARY,C0CXML,C0CFDA,C0CI + S C0CDIC="^C0CDIC(170," ; ROOT OF THE CCR DICTIONARY + D GXPATH("C0CARY","C0CXML") ; FETCH THE VARIABLES AND XPATH INTO C0CARY + ; C0CXML WILL CONTAIN THE TEMPLATE - NOT NEEDED FOR LOAD + D PARY^GPLXPATH("C0CARY") ;TEST + F C0CI=1:1:C0CARY(0) D ; LOAD EACH VARIABLE + . S C0CFDA(170,"+"_C0CI_",",.01)=$P(C0CARY(C0CI),"^",1) ; VAR NAME + . S C0CFDA(170,"+"_C0CI_",",2)=$P(C0CARY(C0CI),"^",3) ; XPATH + . D UPDATE^DIE("","C0CFDA") + . I $D(^TMP("DIERR",$J)) U $P BREAK + . W "LOADING:",C0CI," ",C0CARY(C0CI),! + Q + ; +INIT ; INITIALIZE CCR DICTIONARY BASED ON VARIABLE NAMES + ; + ; CHEAT SHEET FOR VARIABLE NAMES IN ^C0CDIC(170.xx, + ; THIS IS WHAT WILL BE IN C0CA FOR EACH DICTIONARY ENTRY + ;G1("CODING")="170^8" + ;G1("DATA ELEMENT")="170^7" + ;G1("DESCRIPTION")="170^3" + ;G1("ID")="170^1" + ;G1("M","170^8","CODING")="170.08^.01" + ;G1("MAPPING METHOD")="170.08^1" + ;G1("SECTION")="170^10" + ;G1("SOURCE")="170^4" + ;G1("STATUS")="170^9" + ;G1("TYPE")="170^6" + ;G1("VARIABLE")="170^.01" + ;G1("XPATH")="170^2" + ; + N C0CZA,C0CZX,C0CN,C0CSTAT + S C0CZX=0 + S C0CSTAT=0 ; INIT STATUS SET FLAG + F S C0CZX=$O(^C0CDIC(170,C0CZX)) Q:+C0CZX=0 D ; FOR EACH DICT ENTRY + . ;W C0CZX,! + . K C0CA,C0CN ; CLEAR OUT THE LAST ONE + . D GETN1^C0CRNF("C0CA",170,C0CZX,"","ALL") ; GET VARIABLE HASH + . ;ZWR C0CA B ; + . S C0CN=$$ZVALUE("VARIABLE") ;NAME OF THE VARIABLE + . W "VARIABLE: ",C0CN,! + . I $E(C0CN,1,5)="ACTOR" D SETFDA("SECTION","ACTORS") ; + . I $E(C0CN,1,6)="SOCIAL" D ; + . . D SETFDA("SECTION","SOC") ; + . . D SETFDA("STATUS","X") ;SOCIAL HISTORY NOT IMPLEMENTED + . . S C0CSTAT=1 + . I $E(C0CN,1,6)="FAMILY" D ; + . . D SETFDA("SECTION","FAM") ; + . . D SETFDA("STATUS","X") ;FAMILY HISTORY NOT IMPLEMENTED + . . S C0CSTAT=1 + . ;D SETFDA("TYPE","") ;CORRECT FOR TYPE ERRORS + . I $E(C0CN,1,5)="ALERT" D SETFDA("SECTION","ALERTS") + . I $E(C0CN,1,5)="VITAL" D SETFDA("SECTION","VITALS") + . I $E(C0CN,1,7)="PROBLEM" D SETFDA("SECTION","PROBLEMS") + . I $E(C0CN,1,10)="RESULTTEST" D SETFDA("SECTION","TEST") + . E I $E(C0CN,1,6)="RESULT" D SETFDA("SECTION","LABS") + . I C0CN["CODEVALUE" D SETFDA("TYPE","CD") ;CODES + . I C0CN["CODEVERSION" D SETFDA("TYPE","CV") ; CODE VERSION + . I C0CN["CODINGSYSTEM" D SETFDA("TYPE","CS") ;CODING SYSTEM + . I $$ZVALUE("STATUS")=""!'C0CSTAT D SETFDA("STATUS","N") ;BLANK STATUS TO N + . I $$ZVALUE("XPATH")["/Medication/Directions/" D ; MEDS DIRECTIONS VAR + . . D SETFDA("SECTION","DIR") ; SPECIAL SECTION FOR DIRECTIONS + . E I $$ZVALUE("XPATH")["/Medications/Medication/" D ; ALL OTHER MEDS + . . D SETFDA("SECTION","MEDS") ; A MEDS VAR + . I $E(C0CN,($L(C0CN)-1),$L(C0CN))="ID" D SETFDA("TYPE","ID") ;CATCH THE IDS + . I C0CN["DATETIME" D SETFDA("TYPE","DT") ; DATE/TIME VARIABLE + . W "VARIABLE: ",C0CZX," ",C0CA("VARIABLE"),! + . ;ZWR C0CFDA + . I $D(C0CFDA) D ; WE HAVE CHANGES ON THIS VARIABLE + . . ;ZWR C0CFDA + . . D UPDATE^DIE("","C0CFDA(C0CZX)") + . . I $D(^TMP("DIERR",$J)) U $P BREAK + . . D CLEAN^DILF ; CLEAN UP + . ;ZWR C0CFDA + Q + ; +SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN + ; TO SET TO VALUE C0CSV. + ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE + ; C0CSN,C0CSV ARE PASSED BY VALUE + ; + N C0CSI,C0CSJ + S C0CSI=$$ZFILE(C0CSN,"C0CA") ; FILE NUMBER + S C0CSJ=$$ZFIELD(C0CSN,"C0CA") ; FIELD NUMBER + S C0CFDA(C0CZX,C0CSI,C0CZX_",",C0CSJ)=C0CSV + Q +ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P(@ZTAB@(ZFN),"^",1) +ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P(@ZTAB@(ZFN),"^",2) +ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P(@ZTAB@(ZFN),"^",3) + ; Index: ccr/branches/ohum/p/C0CDOM.m =================================================================== --- ccr/branches/ohum/p/C0CDOM.m (revision 1333) +++ ccr/branches/ohum/p/C0CDOM.m (revision 1337) @@ -1,319 +1,319 @@ -C0CDOM ; GPL - DOM PROCESSING ROUTINES ;6/6/11 17:05 - ;;0.1;C0C;nopatch;noreleasedate;Build 1 - ;Copyright 2011 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q - ; -DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE - ; THE XPATH INDEX ZXIDX, PASSED BY NAME - ; THE XPATH ARRAY XPARY, PASSED BY NAME - ; ZOID IS THE STARTING OID - ; ZPATH IS THE STARTING XPATH, USUALLY "/" - ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE - ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT - I $G(ZREDUX)="" S ZREDUX="" - N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY - N NEWNUM S NEWNUM="" - I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" - S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE - I $G(ZREDUX)'="" D ; REDUX PROVIDED? - . N GT S GT=$P(NEWPATH,ZREDUX,2) - . I GT'="" S NEWPATH=GT - S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX - N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE - I $D(GA) D ; PROCESS THE ATTRIBUTES - . N ZI S ZI="" - . F S ZI=$O(GA(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE - . . N ZP S ZP=NEWPATH_"@"_ZI ; PATH FOR ATTRIBUTE - . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY - . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE - N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE - I $D(GD(2)) D ; - . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY - E I $D(GD(1)) D ; - . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY - . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY - N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD - I ZFRST'=0 D ; THERE IS A CHILD - . N ZNUM - . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE - . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD - N GNXT S GNXT=$$NXTSIB(ZOID) - I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES - I GNXT'=0 D ; - . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? - . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES - . . N ZNUM S ZNUM=1 ; - . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB - . E D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB - Q - ; -ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY - ; - ; IF ZATT=1 THE ARRAY IS ADDED AS ATTRIBUTES - ; - N ZZI,ZZJ,ZZN - S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY - I ZZI="" Q ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE - S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY - S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH . - I ZZI'["]" D ; A SINGLETON - . S ZZN=1 - E D ; THERE IS AN [x] OCCURANCE - . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE - . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X] - I ZZJ'="" D ; TIME TO ADD THE VALUE - . S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE - Q - ; -PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME - ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW - ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML - ;Q $$EN^MXMLDOM(INXML) - Q $$EN^MXMLDOM(INXML,"W") - ; -ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE - N ZN - ;I $$TAG(ZOID)["entry" B - S ZN=$$NXTSIB(ZOID) - I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG - Q 0 - ; -FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID - Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) - ; -PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID - Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) - ; -ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID - S HANDLE=C0CDOCID - K @RTN - D GETTXT^MXMLDOM("A") - Q - ; -TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE - ;I ZOID=149 B ;GPLTEST - N X,Y - S Y="" - S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE - I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y - I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) - Q Y - ; -NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING - Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) - ; -DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE - ;N ZT,ZN S ZT="" - ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) - ;Q $G(@C0CDOM@(ZOID,"T",1)) - S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) - Q - ; -OUTXML(ZRTN,INID,NO1ST) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM - ; - S C0CDOCID=INID - I '$D(NO1ST) S NO1ST=0 ; DO NOT SURPRESS THE 0 S ZPARNODE=PARENT ; WE HAVE BEEN PASSED A PARENT NODE ID - E I $L($G(PARENT))>0 D ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL - . D STARTELE^MXMLDOM(PARENT) ; INSERT THE PARENT NODE - . S ZPARNODE=1 ; - ; WE NOW HAVE A HANDLE AND A PARENT NODE AND LEVEL HAS BEEN SET - N ZEXARY - D EXPAND("ZEXARY",INARY) ; EXPAND THE NHIN ARRAY - D MAJOR("ZEXARY") ; PROCESS ALL THE NODES TO BE ADDED - I $L($G(PARENT))>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE - Q HANDLE ; SUCCESS - ; -MAJOR(ZARY) ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES - N ZI S ZI="" - N ZTAG - F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH SECTION - . N ZELEADD S ZELEADD=0 - . I ZI["@" D ; END NODE HAS NO VALUE, ONLY ATTRIBUTES - . . S ZTAG=$P(ZI,"@",1) ; PULL OUT THE TAG - . . K ZATT ; CLEAR OUT LAST ONE - . . M ZATT=@ZARY@(ZI,1) ; GET ATTRIBUTE ARRAY - . . D STARTELE^MXMLDOM(ZTAG,.ZATT) ; ADD THE NODE - . . S ZELEADD=1 ; FLAG TO NOT ADD THE ELEMENT TWICE - . I $O(@ZARY@(ZI,""))="" D ;END NODE - . . S ZTAG=ZI ; USE ZI FOR THE TAG - . . I 'ZELEADD D STARTELE^MXMLDOM(ZTAG) ; ADD ELEMENT IF NOT THERE - . . S ZELEADD=1 ; ADDED AN ELEMENT - . . D CHAR^MXMLDOM($G(@ZARY@(ZI))) ; INSERT THE VALUE - . I ZELEADD D Q ; NO MORE TO DO ON THIS LEVEL - . . D ENDELE^MXMLDOM(ZTAG) ; CLOSE THE ELEMENT BEFORE LEAVING - . N NEWARY ; INDENTED ARRAY - . N ZN S ZN=0 - . F S ZN=$O(@ZARY@(ZI,ZN)) Q:ZN="" D ; FOR EACH MULTIPLE - . . D STARTELE^MXMLDOM(ZI) ; ADD THE INTERMEDIATE TAG - . . S NEWARY=$NA(@ZARY@(ZI,ZN)) ; INDENT THE ARRAY - . . D MAJOR(NEWARY) ; RECURSE FOR INDENTED ARRAY - . . D ENDELE^MXMLDOM(ZI) ; END THE INTERMEDIATE TAG - Q - ; -EXPAND(ZZOUT,ZZIN) ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED - ; CONSISTENT FORMAT - ; GNARY("patient",1,"facilities[2].facility@code")="050" - ; becomes G2ARY("patient",1,"facilities",2,"facility@",1,"code")="050" - ; for easier processing (this is fileman format genius) - ; basically removes the dot notation from the strings - ; - N ZZI - S ZZI="" - F S ZZI=$O(@ZZIN@(ZZI)) Q:ZZI="" D ; - . N ZZN S ZZN=0 - . F S ZZN=$O(@ZZIN@(ZZI,ZZN)) Q:ZZN="" D ; - . . N ZZS S ZZS="" - . . N GA ;PUSH STACK - . . F S ZZS=$O(@ZZIN@(ZZI,ZZN,ZZS)) Q:ZZS="" D ; - . . . K GA ; NEW STACK - . . . D PUSH^C0CXPATH("GA",ZZI_"^"_ZZN) ; PUSH PARENT - . . . N ZZV ; PLACE TO STASH THE VALUE - . . . S ZZV=@ZZIN@(ZZI,ZZN,ZZS) ; VALUE - . . . W !,"VALUE:",ZZV - . . . N GK ; COUNTER - . . . F GK=1:1:$L(ZZS,".") D ; FOR EACH INTERMEDIATE NODE - . . . . N ZZN2 S ZZN2=1 ; DEFAULT IF NO [X] - . . . . N GM S GM=$P(ZZS,".",GK) ; TAG - . . . . I GM["[" D ; IT'S A MULTIPLE - . . . . . S ZZN2=$P($P(GM,"[",2),"]",1) ; PULL OUT THE NUMBER - . . . . . S GM=$P(GM,"[",1) ; PULL OUT THE TAG - . . . . I GM["@" D ; IT'S GOT ATTRIBUTES - . . . . . N GM2 S GM2=$P(GM,"@",2) ; PULLOUT THE ATTRIBUTE NAME - . . . . . D PUSH^C0CXPATH("GA",$P(GM,"@",1)_"@"_"^"_ZZN2) ; PUSH THE TAG - . . . . . D PUSH^C0CXPATH("GA",GM2_"^"_ZZN2) - . . . . E D PUSH^C0CXPATH("GA",GM_"^"_ZZN2) ; - . . . S GA(GA(0))=$P(GA(GA(0)),"^",1)_"^" ; GET RID OF THE LAST "1" - . . . N GZI S GZI="" ; STRING FOR THE INDEX - . . . F GK=1:1:GA(0) D ; TIME TO REVERSE POP THE TAGS - . . . . S GM=$P(GA(GK),"^",1) ; THE TAG - . . . . S ZZN2=$P(GA(GK),"^",2) ; THE NUMBER IF ANY - . . . . I ZZN2="" S GZI=GZI_""""_GM_"""" ; FOR THE LAST ONE - . . . . E S GZI=GZI_""""_GM_""""_","_ZZN2_"," ; FOR THE REST - . . . S GZI2=ZZOUT_"("_GZI_")" ; INCLUDE THE ARRAY NAME - . . . W !,GZI - . . . S @GZI2=ZZV ; REMEMBER THE VALUE? - Q - ; -NEWDOM() ; extrinsic which creates a new DOM and returns the HANDLE - N CBK,SUCCESS,LEVEL,NODE,HANDLE - K ^TMP("MXMLERR",$J) - L +^TMP("MXMLDOM",$J):5 - E Q 0 - S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)="" - L -^TMP("MXMLDOM",$J) - Q HANDLE - ; +C0CDOM ; GPL - DOM PROCESSING ROUTINES ;6/6/11 17:05 + ;;0.1;C0C;nopatch;noreleasedate;Build 38 + ;Copyright 2011 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q + ; +DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE + ; THE XPATH INDEX ZXIDX, PASSED BY NAME + ; THE XPATH ARRAY XPARY, PASSED BY NAME + ; ZOID IS THE STARTING OID + ; ZPATH IS THE STARTING XPATH, USUALLY "/" + ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE + ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT + I $G(ZREDUX)="" S ZREDUX="" + N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY + N NEWNUM S NEWNUM="" + I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" + S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE + I $G(ZREDUX)'="" D ; REDUX PROVIDED? + . N GT S GT=$P(NEWPATH,ZREDUX,2) + . I GT'="" S NEWPATH=GT + S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX + N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE + I $D(GA) D ; PROCESS THE ATTRIBUTES + . N ZI S ZI="" + . F S ZI=$O(GA(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE + . . N ZP S ZP=NEWPATH_"@"_ZI ; PATH FOR ATTRIBUTE + . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY + . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE + N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE + I $D(GD(2)) D ; + . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY + E I $D(GD(1)) D ; + . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY + . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY + N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD + I ZFRST'=0 D ; THERE IS A CHILD + . N ZNUM + . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE + . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD + N GNXT S GNXT=$$NXTSIB(ZOID) + I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES + I GNXT'=0 D ; + . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? + . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES + . . N ZNUM S ZNUM=1 ; + . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB + . E D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB + Q + ; +ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY + ; + ; IF ZATT=1 THE ARRAY IS ADDED AS ATTRIBUTES + ; + N ZZI,ZZJ,ZZN + S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY + I ZZI="" Q ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE + S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY + S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH . + I ZZI'["]" D ; A SINGLETON + . S ZZN=1 + E D ; THERE IS AN [x] OCCURANCE + . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE + . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X] + I ZZJ'="" D ; TIME TO ADD THE VALUE + . S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE + Q + ; +PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME + ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW + ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML + ;Q $$EN^MXMLDOM(INXML) + Q $$EN^MXMLDOM(INXML,"W") + ; +ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE + N ZN + ;I $$TAG(ZOID)["entry" B + S ZN=$$NXTSIB(ZOID) + I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG + Q 0 + ; +FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID + Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) + ; +PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID + Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) + ; +ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID + S HANDLE=C0CDOCID + K @RTN + D GETTXT^MXMLDOM("A") + Q + ; +TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE + ;I ZOID=149 B ;GPLTEST + N X,Y + S Y="" + S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE + I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y + I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) + Q Y + ; +NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING + Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) + ; +DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE + ;N ZT,ZN S ZT="" + ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) + ;Q $G(@C0CDOM@(ZOID,"T",1)) + S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) + Q + ; +OUTXML(ZRTN,INID,NO1ST) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM + ; + S C0CDOCID=INID + I '$D(NO1ST) S NO1ST=0 ; DO NOT SURPRESS THE 0 S ZPARNODE=PARENT ; WE HAVE BEEN PASSED A PARENT NODE ID + E I $L($G(PARENT))>0 D ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL + . D STARTELE^MXMLDOM(PARENT) ; INSERT THE PARENT NODE + . S ZPARNODE=1 ; + ; WE NOW HAVE A HANDLE AND A PARENT NODE AND LEVEL HAS BEEN SET + N ZEXARY + D EXPAND("ZEXARY",INARY) ; EXPAND THE NHIN ARRAY + D MAJOR("ZEXARY") ; PROCESS ALL THE NODES TO BE ADDED + I $L($G(PARENT))>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE + Q HANDLE ; SUCCESS + ; +MAJOR(ZARY) ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES + N ZI S ZI="" + N ZTAG + F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH SECTION + . N ZELEADD S ZELEADD=0 + . I ZI["@" D ; END NODE HAS NO VALUE, ONLY ATTRIBUTES + . . S ZTAG=$P(ZI,"@",1) ; PULL OUT THE TAG + . . K ZATT ; CLEAR OUT LAST ONE + . . M ZATT=@ZARY@(ZI,1) ; GET ATTRIBUTE ARRAY + . . D STARTELE^MXMLDOM(ZTAG,.ZATT) ; ADD THE NODE + . . S ZELEADD=1 ; FLAG TO NOT ADD THE ELEMENT TWICE + . I $O(@ZARY@(ZI,""))="" D ;END NODE + . . S ZTAG=ZI ; USE ZI FOR THE TAG + . . I 'ZELEADD D STARTELE^MXMLDOM(ZTAG) ; ADD ELEMENT IF NOT THERE + . . S ZELEADD=1 ; ADDED AN ELEMENT + . . D CHAR^MXMLDOM($G(@ZARY@(ZI))) ; INSERT THE VALUE + . I ZELEADD D Q ; NO MORE TO DO ON THIS LEVEL + . . D ENDELE^MXMLDOM(ZTAG) ; CLOSE THE ELEMENT BEFORE LEAVING + . N NEWARY ; INDENTED ARRAY + . N ZN S ZN=0 + . F S ZN=$O(@ZARY@(ZI,ZN)) Q:ZN="" D ; FOR EACH MULTIPLE + . . D STARTELE^MXMLDOM(ZI) ; ADD THE INTERMEDIATE TAG + . . S NEWARY=$NA(@ZARY@(ZI,ZN)) ; INDENT THE ARRAY + . . D MAJOR(NEWARY) ; RECURSE FOR INDENTED ARRAY + . . D ENDELE^MXMLDOM(ZI) ; END THE INTERMEDIATE TAG + Q + ; +EXPAND(ZZOUT,ZZIN) ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED + ; CONSISTENT FORMAT + ; GNARY("patient",1,"facilities[2].facility@code")="050" + ; becomes G2ARY("patient",1,"facilities",2,"facility@",1,"code")="050" + ; for easier processing (this is fileman format genius) + ; basically removes the dot notation from the strings + ; + N ZZI + S ZZI="" + F S ZZI=$O(@ZZIN@(ZZI)) Q:ZZI="" D ; + . N ZZN S ZZN=0 + . F S ZZN=$O(@ZZIN@(ZZI,ZZN)) Q:ZZN="" D ; + . . N ZZS S ZZS="" + . . N GA ;PUSH STACK + . . F S ZZS=$O(@ZZIN@(ZZI,ZZN,ZZS)) Q:ZZS="" D ; + . . . K GA ; NEW STACK + . . . D PUSH^C0CXPATH("GA",ZZI_"^"_ZZN) ; PUSH PARENT + . . . N ZZV ; PLACE TO STASH THE VALUE + . . . S ZZV=@ZZIN@(ZZI,ZZN,ZZS) ; VALUE + . . . W !,"VALUE:",ZZV + . . . N GK ; COUNTER + . . . F GK=1:1:$L(ZZS,".") D ; FOR EACH INTERMEDIATE NODE + . . . . N ZZN2 S ZZN2=1 ; DEFAULT IF NO [X] + . . . . N GM S GM=$P(ZZS,".",GK) ; TAG + . . . . I GM["[" D ; IT'S A MULTIPLE + . . . . . S ZZN2=$P($P(GM,"[",2),"]",1) ; PULL OUT THE NUMBER + . . . . . S GM=$P(GM,"[",1) ; PULL OUT THE TAG + . . . . I GM["@" D ; IT'S GOT ATTRIBUTES + . . . . . N GM2 S GM2=$P(GM,"@",2) ; PULLOUT THE ATTRIBUTE NAME + . . . . . D PUSH^C0CXPATH("GA",$P(GM,"@",1)_"@"_"^"_ZZN2) ; PUSH THE TAG + . . . . . D PUSH^C0CXPATH("GA",GM2_"^"_ZZN2) + . . . . E D PUSH^C0CXPATH("GA",GM_"^"_ZZN2) ; + . . . S GA(GA(0))=$P(GA(GA(0)),"^",1)_"^" ; GET RID OF THE LAST "1" + . . . N GZI S GZI="" ; STRING FOR THE INDEX + . . . F GK=1:1:GA(0) D ; TIME TO REVERSE POP THE TAGS + . . . . S GM=$P(GA(GK),"^",1) ; THE TAG + . . . . S ZZN2=$P(GA(GK),"^",2) ; THE NUMBER IF ANY + . . . . I ZZN2="" S GZI=GZI_""""_GM_"""" ; FOR THE LAST ONE + . . . . E S GZI=GZI_""""_GM_""""_","_ZZN2_"," ; FOR THE REST + . . . S GZI2=ZZOUT_"("_GZI_")" ; INCLUDE THE ARRAY NAME + . . . W !,GZI + . . . S @GZI2=ZZV ; REMEMBER THE VALUE? + Q + ; +NEWDOM() ; extrinsic which creates a new DOM and returns the HANDLE + N CBK,SUCCESS,LEVEL,NODE,HANDLE + K ^TMP("MXMLERR",$J) + L +^TMP("MXMLDOM",$J):5 + E Q 0 + S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)="" + L -^TMP("MXMLDOM",$J) + Q HANDLE + ; Index: ccr/branches/ohum/p/C0CDPT.m =================================================================== --- ccr/branches/ohum/p/C0CDPT.m (revision 1333) +++ ccr/branches/ohum/p/C0CDPT.m (revision 1337) @@ -1,269 +1,269 @@ -C0CDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ; - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ; General Public License. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; FAMILY Family Name - ; GIVEN Given Name - ; MIDDLE Middle Name - ; SUFFIX Suffix Name - ; DISPNAME Display Name - ; DOB Date of Birth - ; GENDER Get Gender - ; SSN Get SSN for ID - ; ADDRTYPE Get Home Address - ; ADDR1 Get Home Address line 1 - ; ADDR2 Get Home Address line 2 - ; CITY Get City for Home Address - ; STATE Get State for Home Address - ; ZIP Get Zip code for Home Address - ; COUNTY Get County for our Address - ; COUNTRY Get Country for our Address - ; RESTEL Residential Telephone - ; WORKTEL Work Telephone - ; EMAIL Email Adddress - ; CELLTEL Cell Phone - ; NOK1FAM Next of Kin 1 (NOK1) Family Name - ; NOK1GIV NOK1 Given Name - ; NOK1MID NOK1 Middle Name - ; NOK1SUF NOK1 Suffi Name - ; NOK1DISP NOK1 Display Name - ; NOK1REL NOK1 Relationship to the patient - ; NOK1ADD1 NOK1 Address 1 - ; NOK1ADD2 NOK1 Address 2 - ; NOK1CITY NOK1 City - ; NOK1STAT NOK1 State - ; NOK1ZIP NOK1 Zip Code - ; NOK1HTEL NOK1 Home Telephone - ; NOK1WTEL NOK1 Work Telephone - ; NOK1SAME Is NOK1's Address the same the patient? - ; NOK2FAM NOK2 Family Name - ; NOK2GIV NOK2 Given Name - ; NOK2MID NOK2 Middle Name - ; NOK2SUF NOK2 Suffi Name - ; NOK2DISP NOK2 Display Name - ; NOK2REL NOK2 Relationship to the patient - ; NOK2ADD1 NOK2 Address 1 - ; NOK2ADD2 NOK2 Address 2 - ; NOK2CITY NOK2 City - ; NOK2STAT NOK2 State - ; NOK2ZIP NOK2 Zip Code - ; NOK2HTEL NOK2 Home Telephone - ; NOK2WTEL NOK2 Work Telephone - ; NOK2SAME Is NOK2's Address the same the patient? - ; EMERFAM Emergency Contact (EMER) Family Name - ; EMERGIV EMER Given Name - ; EMERMID EMER Middle Name - ; EMERSUF EMER Suffi Name - ; EMERDISP EMER Display Name - ; EMERREL EMER Relationship to the patient - ; EMERADD1 EMER Address 1 - ; EMERADD2 EMER Address 2 - ; EMERCITY EMER City - ; EMERSTAT EMER State - ; EMERZIP EMER Zip Code - ; EMERHTEL EMER Home Telephone - ; EMERWTEL EMER Work Telephone - ; EMERSAME Is EMER's Address the same the NOK? - ; - W "No Entry at top!" Q - ; - ;**Revision History** - ; - June 15, 08: v0.1 using merged global - ; - Oct 3, 08: v0.2 using fileman calls, many formatting changes. - ; - ; All methods are Public and Extrinsic - ; All calls use Fileman file 2 (Patient). - ; You can obtain field numbers using the data dictionary - ; -FAMILY(DFN) ; Family Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.01) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("FAMILY") -GIVEN(DFN) ; Given Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.01) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("GIVEN") -MIDDLE(DFN) ; Middle Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.01) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("MIDDLE") -SUFFIX(DFN) ; Suffi Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.01) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("SUFFIX") -DISPNAME(DFN) ; Display Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.01) - ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma - Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") -DOB(DFN) ; Date of Birth - N DOB S DOB=$$GET1^DIQ(2,DFN,.03,"I") - ; Date in FM Date Format. Convert to UTC/ISO 8601. - Q $$FMDTOUTC^C0CUTIL(DOB,"D") -GENDER(DFN) ; Gender/Sex - Q $$GET1^DIQ(2,DFN,.02,"I")_"^"_$$GET1^DIQ(2,DFN,.02,"E") ; -SSN(DFN) ; SSN - Q $$GET1^DIQ(2,DFN,.09) -ADDRTYPE(DFN) ; Address Type - ; Vista only stores a home address for the patient. - Q "Home" -ADDR1(DFN) ; Get Home Address line 1 - Q $$GET1^DIQ(2,DFN,.111) -ADDR2(DFN) ; Get Home Address line 2 - ; Vista has Lines 2,3; CCR has only line 1,2; so compromise - N ADDLN2,ADDLN3 - S ADDLN2=$$GET1^DIQ(2,DFN,.112),ADDLN3=$$GET1^DIQ(2,DFN,.113) - Q:ADDLN3="" ADDLN2 - Q ADDLN2_", "_ADDLN3 -CITY(DFN) ; Get City for Home Address - Q $$GET1^DIQ(2,DFN,.114) -STATE(DFN) ; Get State for Home Address - Q $$GET1^DIQ(2,DFN,.115) -ZIP(DFN) ; Get Zip code for Home Address - Q $$GET1^DIQ(2,DFN,.116) -COUNTY(DFN) ; Get County for our Address - Q $$GET1^DIQ(2,DFN,.117) -COUNTRY(DFN) ; Get Country for our Address - ; Unfortunately, it's not stored anywhere in Vista, so the inevitable... - Q "USA" -RESTEL(DFN) ; Residential Telephone - Q $$GET1^DIQ(2,DFN,.131) -WORKTEL(DFN) ; Work Telephone - Q $$GET1^DIQ(2,DFN,.132) -EMAIL(DFN) ; Email Adddress - Q $$GET1^DIQ(2,DFN,.133) -CELLTEL(DFN) ; Cell Phone - Q $$GET1^DIQ(2,DFN,.134) -NOK1FAM(DFN) ; Next of Kin 1 (NOK1) Family Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.211) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("FAMILY") -NOK1GIV(DFN) ; NOK1 Given Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.211) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("GIVEN") -NOK1MID(DFN) ; NOK1 Middle Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.211) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("MIDDLE") -NOK1SUF(DFN) ; NOK1 Suffi Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.211) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("SUFFIX") -NOK1DISP(DFN) ; NOK1 Display Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.211) - ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma - Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") -NOK1REL(DFN) ; NOK1 Relationship to the patient - Q $$GET1^DIQ(2,DFN,.212) -NOK1ADD1(DFN) ; NOK1 Address 1 - Q $$GET1^DIQ(2,DFN,.213) -NOK1ADD2(DFN) ; NOK1 Address 2 - N ADDLN2,ADDLN3 - S ADDLN2=$$GET1^DIQ(2,DFN,.214),ADDLN3=$$GET1^DIQ(2,DFN,.215) - Q:ADDLN3="" ADDLN2 - Q ADDLN2_", "_ADDLN3 -NOK1CITY(DFN) ; NOK1 City - Q $$GET1^DIQ(2,DFN,.216) -NOK1STAT(DFN) ; NOK1 State - Q $$GET1^DIQ(2,DFN,.217) -NOK1ZIP(DFN) ; NOK1 Zip Code - Q $$GET1^DIQ(2,DFN,.218) -NOK1HTEL(DFN) ; NOK1 Home Telephone - Q $$GET1^DIQ(2,DFN,.219) -NOK1WTEL(DFN) ; NOK1 Work Telephone - Q $$GET1^DIQ(2,DFN,.21011) -NOK1SAME(DFN) ; Is NOK1's Address the same the patient? - Q $$GET1^DIQ(2,DFN,.2125) -NOK2FAM(DFN) ; NOK2 Family Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("FAMILY") -NOK2GIV(DFN) ; NOK2 Given Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("GIVEN") -NOK2MID(DFN) ; NOK2 Middle Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("MIDDLE") -NOK2SUF(DFN) ; NOK2 Suffi Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("SUFFIX") -NOK2DISP(DFN) ; NOK2 Display Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) - ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma - Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") -NOK2REL(DFN) ; NOK2 Relationship to the patient - Q $$GET1^DIQ(2,DFN,.2192) -NOK2ADD1(DFN) ; NOK2 Address 1 - Q $$GET1^DIQ(2,DFN,.2193) -NOK2ADD2(DFN) ; NOK2 Address 2 - N ADDLN2,ADDLN3 - S ADDLN2=$$GET1^DIQ(2,DFN,.2194),ADDLN3=$$GET1^DIQ(2,DFN,.2195) - Q:ADDLN3="" ADDLN2 - Q ADDLN2_", "_ADDLN3 -NOK2CITY(DFN) ; NOK2 City - Q $$GET1^DIQ(2,DFN,.2196) -NOK2STAT(DFN) ; NOK2 State - Q $$GET1^DIQ(2,DFN,.2197) -NOK2ZIP(DFN) ; NOK2 Zip Code - Q $$GET1^DIQ(2,DFN,.2198) -NOK2HTEL(DFN) ; NOK2 Home Telephone - Q $$GET1^DIQ(2,DFN,.2199) -NOK2WTEL(DFN) ; NOK2 Work Telephone - Q $$GET1^DIQ(2,DFN,.211011) -NOK2SAME(DFN) ; Is NOK2's Address the same the patient? - Q $$GET1^DIQ(2,DFN,.21925) -EMERFAM(DFN) ; Emergency Contact (EMER) Family Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.331) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("FAMILY") -EMERGIV(DFN) ; EMER Given Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.331) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("GIVEN") -EMERMID(DFN) ; EMER Middle Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.331) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("MIDDLE") -EMERSUF(DFN) ; EMER Suffi Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.331) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("SUFFIX") -EMERDISP(DFN) ; EMER Display Name - N NAME S NAME=$$GET1^DIQ(2,DFN,.331) - ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma - Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") -EMERREL(DFN) ; EMER Relationship to the patient - Q $$GET1^DIQ(2,DFN,.331) -EMERADD1(DFN) ; EMER Address 1 - Q $$GET1^DIQ(2,DFN,.333) -EMERADD2(DFN) ; EMER Address 2 - N ADDLN2,ADDLN3 - S ADDLN2=$$GET1^DIQ(2,DFN,.334),ADDLN3=$$GET1^DIQ(2,DFN,.335) - Q:ADDLN3="" ADDLN2 - Q ADDLN2_", "_ADDLN3 -EMERCITY(DFN) ; EMER City - Q $$GET1^DIQ(2,DFN,.336) -EMERSTAT(DFN) ; EMER State - Q $$GET1^DIQ(2,DFN,.337) -EMERZIP(DFN) ; EMER Zip Code - Q $$GET1^DIQ(2,DFN,.338) -EMERHTEL(DFN) ; EMER Home Telephone - Q $$GET1^DIQ(2,DFN,.339) -EMERWTEL(DFN) ; EMER Work Telephone - Q $$GET1^DIQ(2,DFN,.33011) -EMERSAME(DFN) ; Is EMER's Address the same the NOK? - Q $$GET1^DIQ(2,DFN,.3305) +C0CDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ; + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; FAMILY Family Name + ; GIVEN Given Name + ; MIDDLE Middle Name + ; SUFFIX Suffix Name + ; DISPNAME Display Name + ; DOB Date of Birth + ; GENDER Get Gender + ; SSN Get SSN for ID + ; ADDRTYPE Get Home Address + ; ADDR1 Get Home Address line 1 + ; ADDR2 Get Home Address line 2 + ; CITY Get City for Home Address + ; STATE Get State for Home Address + ; ZIP Get Zip code for Home Address + ; COUNTY Get County for our Address + ; COUNTRY Get Country for our Address + ; RESTEL Residential Telephone + ; WORKTEL Work Telephone + ; EMAIL Email Adddress + ; CELLTEL Cell Phone + ; NOK1FAM Next of Kin 1 (NOK1) Family Name + ; NOK1GIV NOK1 Given Name + ; NOK1MID NOK1 Middle Name + ; NOK1SUF NOK1 Suffi Name + ; NOK1DISP NOK1 Display Name + ; NOK1REL NOK1 Relationship to the patient + ; NOK1ADD1 NOK1 Address 1 + ; NOK1ADD2 NOK1 Address 2 + ; NOK1CITY NOK1 City + ; NOK1STAT NOK1 State + ; NOK1ZIP NOK1 Zip Code + ; NOK1HTEL NOK1 Home Telephone + ; NOK1WTEL NOK1 Work Telephone + ; NOK1SAME Is NOK1's Address the same the patient? + ; NOK2FAM NOK2 Family Name + ; NOK2GIV NOK2 Given Name + ; NOK2MID NOK2 Middle Name + ; NOK2SUF NOK2 Suffi Name + ; NOK2DISP NOK2 Display Name + ; NOK2REL NOK2 Relationship to the patient + ; NOK2ADD1 NOK2 Address 1 + ; NOK2ADD2 NOK2 Address 2 + ; NOK2CITY NOK2 City + ; NOK2STAT NOK2 State + ; NOK2ZIP NOK2 Zip Code + ; NOK2HTEL NOK2 Home Telephone + ; NOK2WTEL NOK2 Work Telephone + ; NOK2SAME Is NOK2's Address the same the patient? + ; EMERFAM Emergency Contact (EMER) Family Name + ; EMERGIV EMER Given Name + ; EMERMID EMER Middle Name + ; EMERSUF EMER Suffi Name + ; EMERDISP EMER Display Name + ; EMERREL EMER Relationship to the patient + ; EMERADD1 EMER Address 1 + ; EMERADD2 EMER Address 2 + ; EMERCITY EMER City + ; EMERSTAT EMER State + ; EMERZIP EMER Zip Code + ; EMERHTEL EMER Home Telephone + ; EMERWTEL EMER Work Telephone + ; EMERSAME Is EMER's Address the same the NOK? + ; + W "No Entry at top!" Q + ; + ;**Revision History** + ; - June 15, 08: v0.1 using merged global + ; - Oct 3, 08: v0.2 using fileman calls, many formatting changes. + ; + ; All methods are Public and Extrinsic + ; All calls use Fileman file 2 (Patient). + ; You can obtain field numbers using the data dictionary + ; +FAMILY(DFN) ; Family Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.01) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("FAMILY") +GIVEN(DFN) ; Given Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.01) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("GIVEN") +MIDDLE(DFN) ; Middle Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.01) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("MIDDLE") +SUFFIX(DFN) ; Suffi Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.01) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("SUFFIX") +DISPNAME(DFN) ; Display Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.01) + ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma + Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") +DOB(DFN) ; Date of Birth + N DOB S DOB=$$GET1^DIQ(2,DFN,.03,"I") + ; Date in FM Date Format. Convert to UTC/ISO 8601. + Q $$FMDTOUTC^C0CUTIL(DOB,"D") +GENDER(DFN) ; Gender/Sex + Q $$GET1^DIQ(2,DFN,.02,"I")_"^"_$$GET1^DIQ(2,DFN,.02,"E") ; +SSN(DFN) ; SSN + Q $$GET1^DIQ(2,DFN,.09) +ADDRTYPE(DFN) ; Address Type + ; Vista only stores a home address for the patient. + Q "Home" +ADDR1(DFN) ; Get Home Address line 1 + Q $$GET1^DIQ(2,DFN,.111) +ADDR2(DFN) ; Get Home Address line 2 + ; Vista has Lines 2,3; CCR has only line 1,2; so compromise + N ADDLN2,ADDLN3 + S ADDLN2=$$GET1^DIQ(2,DFN,.112),ADDLN3=$$GET1^DIQ(2,DFN,.113) + Q:ADDLN3="" ADDLN2 + Q ADDLN2_", "_ADDLN3 +CITY(DFN) ; Get City for Home Address + Q $$GET1^DIQ(2,DFN,.114) +STATE(DFN) ; Get State for Home Address + Q $$GET1^DIQ(2,DFN,.115) +ZIP(DFN) ; Get Zip code for Home Address + Q $$GET1^DIQ(2,DFN,.116) +COUNTY(DFN) ; Get County for our Address + Q $$GET1^DIQ(2,DFN,.117) +COUNTRY(DFN) ; Get Country for our Address + ; Unfortunately, it's not stored anywhere in Vista, so the inevitable... + Q "USA" +RESTEL(DFN) ; Residential Telephone + Q $$GET1^DIQ(2,DFN,.131) +WORKTEL(DFN) ; Work Telephone + Q $$GET1^DIQ(2,DFN,.132) +EMAIL(DFN) ; Email Adddress + Q $$GET1^DIQ(2,DFN,.133) +CELLTEL(DFN) ; Cell Phone + Q $$GET1^DIQ(2,DFN,.134) +NOK1FAM(DFN) ; Next of Kin 1 (NOK1) Family Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.211) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("FAMILY") +NOK1GIV(DFN) ; NOK1 Given Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.211) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("GIVEN") +NOK1MID(DFN) ; NOK1 Middle Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.211) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("MIDDLE") +NOK1SUF(DFN) ; NOK1 Suffi Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.211) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("SUFFIX") +NOK1DISP(DFN) ; NOK1 Display Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.211) + ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma + Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") +NOK1REL(DFN) ; NOK1 Relationship to the patient + Q $$GET1^DIQ(2,DFN,.212) +NOK1ADD1(DFN) ; NOK1 Address 1 + Q $$GET1^DIQ(2,DFN,.213) +NOK1ADD2(DFN) ; NOK1 Address 2 + N ADDLN2,ADDLN3 + S ADDLN2=$$GET1^DIQ(2,DFN,.214),ADDLN3=$$GET1^DIQ(2,DFN,.215) + Q:ADDLN3="" ADDLN2 + Q ADDLN2_", "_ADDLN3 +NOK1CITY(DFN) ; NOK1 City + Q $$GET1^DIQ(2,DFN,.216) +NOK1STAT(DFN) ; NOK1 State + Q $$GET1^DIQ(2,DFN,.217) +NOK1ZIP(DFN) ; NOK1 Zip Code + Q $$GET1^DIQ(2,DFN,.218) +NOK1HTEL(DFN) ; NOK1 Home Telephone + Q $$GET1^DIQ(2,DFN,.219) +NOK1WTEL(DFN) ; NOK1 Work Telephone + Q $$GET1^DIQ(2,DFN,.21011) +NOK1SAME(DFN) ; Is NOK1's Address the same the patient? + Q $$GET1^DIQ(2,DFN,.2125) +NOK2FAM(DFN) ; NOK2 Family Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("FAMILY") +NOK2GIV(DFN) ; NOK2 Given Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("GIVEN") +NOK2MID(DFN) ; NOK2 Middle Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("MIDDLE") +NOK2SUF(DFN) ; NOK2 Suffi Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("SUFFIX") +NOK2DISP(DFN) ; NOK2 Display Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) + ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma + Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") +NOK2REL(DFN) ; NOK2 Relationship to the patient + Q $$GET1^DIQ(2,DFN,.2192) +NOK2ADD1(DFN) ; NOK2 Address 1 + Q $$GET1^DIQ(2,DFN,.2193) +NOK2ADD2(DFN) ; NOK2 Address 2 + N ADDLN2,ADDLN3 + S ADDLN2=$$GET1^DIQ(2,DFN,.2194),ADDLN3=$$GET1^DIQ(2,DFN,.2195) + Q:ADDLN3="" ADDLN2 + Q ADDLN2_", "_ADDLN3 +NOK2CITY(DFN) ; NOK2 City + Q $$GET1^DIQ(2,DFN,.2196) +NOK2STAT(DFN) ; NOK2 State + Q $$GET1^DIQ(2,DFN,.2197) +NOK2ZIP(DFN) ; NOK2 Zip Code + Q $$GET1^DIQ(2,DFN,.2198) +NOK2HTEL(DFN) ; NOK2 Home Telephone + Q $$GET1^DIQ(2,DFN,.2199) +NOK2WTEL(DFN) ; NOK2 Work Telephone + Q $$GET1^DIQ(2,DFN,.211011) +NOK2SAME(DFN) ; Is NOK2's Address the same the patient? + Q $$GET1^DIQ(2,DFN,.21925) +EMERFAM(DFN) ; Emergency Contact (EMER) Family Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.331) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("FAMILY") +EMERGIV(DFN) ; EMER Given Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.331) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("GIVEN") +EMERMID(DFN) ; EMER Middle Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.331) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("MIDDLE") +EMERSUF(DFN) ; EMER Suffi Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.331) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("SUFFIX") +EMERDISP(DFN) ; EMER Display Name + N NAME S NAME=$$GET1^DIQ(2,DFN,.331) + ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma + Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") +EMERREL(DFN) ; EMER Relationship to the patient + Q $$GET1^DIQ(2,DFN,.331) +EMERADD1(DFN) ; EMER Address 1 + Q $$GET1^DIQ(2,DFN,.333) +EMERADD2(DFN) ; EMER Address 2 + N ADDLN2,ADDLN3 + S ADDLN2=$$GET1^DIQ(2,DFN,.334),ADDLN3=$$GET1^DIQ(2,DFN,.335) + Q:ADDLN3="" ADDLN2 + Q ADDLN2_", "_ADDLN3 +EMERCITY(DFN) ; EMER City + Q $$GET1^DIQ(2,DFN,.336) +EMERSTAT(DFN) ; EMER State + Q $$GET1^DIQ(2,DFN,.337) +EMERZIP(DFN) ; EMER Zip Code + Q $$GET1^DIQ(2,DFN,.338) +EMERHTEL(DFN) ; EMER Home Telephone + Q $$GET1^DIQ(2,DFN,.339) +EMERWTEL(DFN) ; EMER Work Telephone + Q $$GET1^DIQ(2,DFN,.33011) +EMERSAME(DFN) ; Is EMER's Address the same the NOK? + Q $$GET1^DIQ(2,DFN,.3305) Index: ccr/branches/ohum/p/C0CENC.m =================================================================== --- ccr/branches/ohum/p/C0CENC.m (revision 1333) +++ ccr/branches/ohum/p/C0CENC.m (revision 1337) @@ -1,189 +1,189 @@ -C0CENC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10 - ;;1.0;C0C;;May 21, 2010;Build 1 - ;Copyright 2010 George Lilly, University of Minnesota and others. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(ENCXML,DFN,ENCOUT) ; EXTRACT ENCOUNTERS INTO XML TEMPLATE - ; ENCXML AND ENCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED - ; - D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES - ;I '$D(@C0CENC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE - K @C0CENC - D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET ENCOUNTERS - D MAP(ENCXML,C0CENC,ENCOUT) ;MAP RESULTS FOR ENCOUNTERS - Q - ; -TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, - ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME - ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES - ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT - ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY - ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM - ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS - ; - ;K VISIT,LST,NOTE - I '$D(C0CPRC) D SETVARS^C0CPROC ; INITIALIZE WORK AREAS IF NOT ALREADY THERE - I '$D(VISIT) D ENTRY^C0CCPT(DFN,,,1) ; RETURNS VISIT LOCAL VARIABLE - ; NEED TO ADD START AND END DATES FROM PARAMETERS - N ZI S ZI="" - N PREVCPT,PREVDT S (PREVCPT,PREVDT)="" - F S ZI=$O(VISIT(ZI),-1) Q:ZI="" D ; REVERSE TIME ORDER - MOST RECENT FIRST - . N ZDATE - . S ZDATE=$$DATE(VISIT(ZI,"DATE",0)) - . S ZPRVARY=$NA(VISIT(ZI,"PRV")) - . N ZPRV - . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM - . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON - . ; ENCOBJECTID - ENCOUNTER OBJECT ID - . ; ENCDATETIME - ENCOUNTER DATE TIME - . ; ENCTYPETXT - ENCOUNTER TYPE (PLANNING TO USE ADMINISTRATIVE CPT IF AVAIL) - . ; ENCTYPECODE - CODE OF TYPE - PLANNING CPT CODE - . ; ENCTYPECODESYS - CODING SYSTEM OF TYPE - CPT-4 - . ; ENCDESCTXT - ENCOUNTER DESCRIPTION TEXT - . ; ENCDESCCODE - ENCOUNTER DESCRIPTION CODE - . ; ENCDESCCODESYS - ENCOUNTER DESCRIPTION CODE SYSTEM - . ; ENCLOCACTORID - ENCOUNTER LOCATION ACTOR ID - . ; ENCPRVACTORID - ENCOUNTER PRACTIONER ACTOR ID - . ; ENCINDTXT - ENCOUNTER INDICATION TEXT - . ; ENCINDCODE - ENCOUNTER INDICATION CODE - . ; ENCINDCODESYS - ENCOUNTER INDICATION CODE SYSTEM - . ; ENCACTORID - ENCOUNTER SOURCE ACTOR ID - . ; ENCCOMMENTID - ENCOUNTER COMMENT ID - POINTER TO NOTE IN COMMENT SECTION - . S ZRNF("ENCOBJECTID")="ENCOUNTER_"_ZI - . S ZRNF("ENCDATETIME")=ZDATE ; ENCOUNTER DATE TIME - . S ZRNF("ENCTYPETXT")="" - . S ZRNF("ENCTYPECODE")="" - . S ZRNF("ENCTYPECODESYS")="" - . S ZRNF("ENCDESCTXT")="" - . S ZRNF("ENCDESCCODE")="" - . S ZRNF("ENCDESCCODESYS")="" - . N TYPTXT,TYPCDE,TYPSYS ; WILL BE UPDATED BY GETTYPE CALL - . I $$GETTYPE("VISIT(ZI)",.TYPTXT,.TYPCDE,.TYPSYS) D ; RETURNS FALSE IF NO TYPE - . . S ZRNF("ENCTYPETXT")=TYPTXT - . . S ZRNF("ENCTYPECODE")=TYPCDE - . . S ZRNF("ENCTYPECODESYS")=TYPSYS - . . S ZRNF("ENCDESCTXT")=TYPTXT ; FOR NOW, DESCRIPTION IS SAME AS TYPE - . . S ZRNF("ENCDESCCODE")=TYPCDE ; DESCRIPTION IS REQUIRED (TYPE IS NOT) - . . S ZRNF("ENCDESCCODESYS")=TYPSYS ; NEED TO CLARIFY FOR VISTA - . S ZRNF("ENCLOCACTORID")="ACTORORGANIZATION_1" - . S ZRNF("ENCPRVACTORID")=ZPRV ; PRIMARY PROVIDER LISTED FOR THE ENCOUNTER - . S ZRNF("ENCINDTXT")="" ; WE WILL PUT POINTERS TO PROBLEMS HERE - . S ZRNF("ENCINDCODE")="" - . S ZRNF("ENCINDCODESYS")="" - . S ZRNF("ENCACTORID")=ZPRV ; SOURCE WILL BE PRIMARY PROVIDER - . S ZRNF("ENCCOMMENTID")="" - . I $G(VISIT(ZI,"TEXT",1))'="" D ; THERE IS A NOTE - . . M @C0CNTE@(ZI,"TEXT")=VISIT(ZI,"TEXT") ; COPY THE TEXT OF THE NOTE - . . S @C0CNTE@(ZI,"COMMENTOBJECTID")="NOTE_"_ZI - . . S @C0CNTE@(ZI,"CMTDATETIME")=ZDATE ; DATE OF THE NOTE - . . S @C0CNTE@(ZI,"ACTORSOURCEID")=ZPRV ; SOURCE OF THE NOTE - . . S ZRNF("ENCCOMMENTID")="NOTE_"_ZI ; POINT TO THE NOTE FROM THE ENCOUNTER - . D RNF1TO2^C0CRNF(C0CENC,"ZRNF") ; ADD THIS ROW TO THE ARRAY - . ;S PREVCPT=ZCPT - . ;S PREVDT=ZDATE - N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"ENCOUNTERS")) - M @ZRIM=@C0CENC@("V") - K VISIT,LST,NOTE - Q - ; -GETTYPE(ZARY,ZTXT,ZCDE,ZSYS) ; EXTRINSIC WHICH RETURNS FALSE IF NO ENCOUNTER TYPE - ; UPDATES ZTXT WITH ENCOUNTER TYPE TEXT, ZCDE WITH ENCOUNTER TYPE CODE - ; AND ZSYS WITH ENCOUNTER TYPE CODING SYSTEM - ; THIS ROUTINE SHOULD BE UPDATED TO SEARCH FOR AN ADMINISTRATIVE CPT CODE - ; INSTEAD OF JUST THE FIRST ONE IN THE LIST - GPL 1/23/10 - N ZS,ZC - S ZC="" S ZS="" - S (ZTXT,ZCDE,ZSYS)="" - F S ZC=$O(@ZARY@("CPT",ZC)) Q:ZC="" D ; TRY AND FIND A "99" CPT CODE - . N ZT - . S ZT=$$CPT^C0CPROC(@ZARY@("CPT",ZC)) ; VALUES IN A CPT MULTIPLE - . I $E($P(ZT,U,1),1,2)="99" S ZS=ZT ; IS IT AN ADMIN CPT CODE? - I ZS'="" D ; CODED ENCOUNTER TYPE FOUND - . S ZTXT=$P(ZS,U,2)_" "_$P(ZS,U,3) ; USE BOTH PIECES FOR THE TYPE - . S ZCDE=$P($$CPT^C0CPROC(ZS),U,1) ; CPT CODE FOR ENCOUTER - . S ZSYS="" - . I ZCDE'="" S ZSYS="CPT-4" ; ONLY HAVE A CODING SYSTEM IF THERE IS A CODE - I ZS="" S ZTXT=$$ANYTXT(ZARY) ; TRY AND GET FREE FORM TEXT FROM CPT MULTIPLES - I ZTXT="" Q 0 ; FAILED - W !,ZTXT - Q 1 ; SUCCESS - ; -ANYTXT(ZVST) ; EXTRINSIC WHICH RETURNS TEXT FROM THE CPT MULTIPLE - ; OF A VISIT ARRAY WITHOUT CHECKING THE CPT CODE (THAT HAVING FAILED) - ; ZVST IS THE VISIT ARRAY AND IS PASSED BY NAME - ; RETURNS TEXT TO USE AS ENCOUNTER TYPE IF ANY - N ZK,ZL - S ZK="" S ZL="" - F S ZK=$O(@ZVST@("CPT",ZK)) Q:ZK="" D ; LOOK FOR SOME TEXT TO USE - . N ZT - . S ZT=$G(@ZVST@("CPT",ZK)) ; LOOK AT THIS CPT MULTIPLE - . I $P(ZT,U,2)_" "_$P(ZT,U,3)'=" " S ZL=$P(ZT,U,2)_" "_$P(ZT,U,3) - . ; CONCATENATE PIECE 2 AND 3 OF THE CPT MULTIPLE FOR A TYPE - I ZL="" S ZL=$G(@ZVST@("CLASS")) ; USE THE NOTE DOCUMENT CLASS FOR ENCOUTNER TYPE - Q ZL - ; -PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME - N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN="" - F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH PRV SEG - . I ZR'="" Q ;ONLY WANT THE FIRST PRIMARY PROVIDER - . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1) - I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR - Q ZRTN - ; -DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT - Q $$FMDTOUTC^C0CUTIL(ISTR,"DT") - ; -CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS - ; CPT^CATEGORY^TEXT - N Z1,Z2,Z3,ZRTN - S Z1=$P(ISTR,U,1) - I Z1="" D ; - . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1) - I Z1'="" D ; IF THERE IS A CPT CODE IN THERE - . ;S Z1=$P(ISTR,U,1) - . S Z2=$P(ISTR,U,2) - . S Z3=$P(ISTR,U,3) - . S ZRTN=Z1_U_Z2_U_Z3 - E S ZRTN="" - Q ZRTN - ; -MAP(ENCXML,C0CENC,ENCOUT) ; MAP PROCEDURES XML - ; - N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"ENCTEMP")) ;WORK AREA FOR TEMPLATE - K @ZTEMP - N ZBLD - S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"ENCBLD")) ; BUILD LIST AREA - D QUEUE^C0CXPATH(ZBLD,ENCXML,1,1) ; FIRST LINE - N ZINNER - D QUERY^C0CXPATH(ENCXML,"//Encounters/Encounter","ZINNER") ;ONE ENCOUNTER - N ZTMP,ZVAR,ZI - S ZI="" - F S ZI=$O(@C0CENC@("V",ZI)) Q:ZI="" D ;FOR EACH ENCOUNTER - . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS ENCOUNTER XML - . S ZVAR=$NA(@C0CENC@("V",ZI)) ;THIS ENCOUNTER VARIABLES - . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE - . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD - D QUEUE^C0CXPATH(ZBLD,ENCXML,@ENCXML@(0),@ENCXML@(0)) - N ZZTMP - D BUILD^C0CXPATH(ZBLD,ENCOUT) ;BUILD FINAL XML - K @ZTEMP,@ZBLD,@C0CENC - Q - ; +C0CENC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10 + ;;1.0;C0C;;May 21, 2010;Build 38 + ;Copyright 2010 George Lilly, University of Minnesota and others. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(ENCXML,DFN,ENCOUT) ; EXTRACT ENCOUNTERS INTO XML TEMPLATE + ; ENCXML AND ENCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; + D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES + ;I '$D(@C0CENC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE + K @C0CENC + D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET ENCOUNTERS + D MAP(ENCXML,C0CENC,ENCOUT) ;MAP RESULTS FOR ENCOUNTERS + Q + ; +TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, + ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME + ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES + ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT + ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY + ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM + ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS + ; + ;K VISIT,LST,NOTE + I '$D(C0CPRC) D SETVARS^C0CPROC ; INITIALIZE WORK AREAS IF NOT ALREADY THERE + I '$D(VISIT) D ENTRY^C0CCPT(DFN,,,1) ; RETURNS VISIT LOCAL VARIABLE + ; NEED TO ADD START AND END DATES FROM PARAMETERS + N ZI S ZI="" + N PREVCPT,PREVDT S (PREVCPT,PREVDT)="" + F S ZI=$O(VISIT(ZI),-1) Q:ZI="" D ; REVERSE TIME ORDER - MOST RECENT FIRST + . N ZDATE + . S ZDATE=$$DATE(VISIT(ZI,"DATE",0)) + . S ZPRVARY=$NA(VISIT(ZI,"PRV")) + . N ZPRV + . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM + . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON + . ; ENCOBJECTID - ENCOUNTER OBJECT ID + . ; ENCDATETIME - ENCOUNTER DATE TIME + . ; ENCTYPETXT - ENCOUNTER TYPE (PLANNING TO USE ADMINISTRATIVE CPT IF AVAIL) + . ; ENCTYPECODE - CODE OF TYPE - PLANNING CPT CODE + . ; ENCTYPECODESYS - CODING SYSTEM OF TYPE - CPT-4 + . ; ENCDESCTXT - ENCOUNTER DESCRIPTION TEXT + . ; ENCDESCCODE - ENCOUNTER DESCRIPTION CODE + . ; ENCDESCCODESYS - ENCOUNTER DESCRIPTION CODE SYSTEM + . ; ENCLOCACTORID - ENCOUNTER LOCATION ACTOR ID + . ; ENCPRVACTORID - ENCOUNTER PRACTIONER ACTOR ID + . ; ENCINDTXT - ENCOUNTER INDICATION TEXT + . ; ENCINDCODE - ENCOUNTER INDICATION CODE + . ; ENCINDCODESYS - ENCOUNTER INDICATION CODE SYSTEM + . ; ENCACTORID - ENCOUNTER SOURCE ACTOR ID + . ; ENCCOMMENTID - ENCOUNTER COMMENT ID - POINTER TO NOTE IN COMMENT SECTION + . S ZRNF("ENCOBJECTID")="ENCOUNTER_"_ZI + . S ZRNF("ENCDATETIME")=ZDATE ; ENCOUNTER DATE TIME + . S ZRNF("ENCTYPETXT")="" + . S ZRNF("ENCTYPECODE")="" + . S ZRNF("ENCTYPECODESYS")="" + . S ZRNF("ENCDESCTXT")="" + . S ZRNF("ENCDESCCODE")="" + . S ZRNF("ENCDESCCODESYS")="" + . N TYPTXT,TYPCDE,TYPSYS ; WILL BE UPDATED BY GETTYPE CALL + . I $$GETTYPE("VISIT(ZI)",.TYPTXT,.TYPCDE,.TYPSYS) D ; RETURNS FALSE IF NO TYPE + . . S ZRNF("ENCTYPETXT")=TYPTXT + . . S ZRNF("ENCTYPECODE")=TYPCDE + . . S ZRNF("ENCTYPECODESYS")=TYPSYS + . . S ZRNF("ENCDESCTXT")=TYPTXT ; FOR NOW, DESCRIPTION IS SAME AS TYPE + . . S ZRNF("ENCDESCCODE")=TYPCDE ; DESCRIPTION IS REQUIRED (TYPE IS NOT) + . . S ZRNF("ENCDESCCODESYS")=TYPSYS ; NEED TO CLARIFY FOR VISTA + . S ZRNF("ENCLOCACTORID")="ACTORORGANIZATION_1" + . S ZRNF("ENCPRVACTORID")=ZPRV ; PRIMARY PROVIDER LISTED FOR THE ENCOUNTER + . S ZRNF("ENCINDTXT")="" ; WE WILL PUT POINTERS TO PROBLEMS HERE + . S ZRNF("ENCINDCODE")="" + . S ZRNF("ENCINDCODESYS")="" + . S ZRNF("ENCACTORID")=ZPRV ; SOURCE WILL BE PRIMARY PROVIDER + . S ZRNF("ENCCOMMENTID")="" + . I $G(VISIT(ZI,"TEXT",1))'="" D ; THERE IS A NOTE + . . M @C0CNTE@(ZI,"TEXT")=VISIT(ZI,"TEXT") ; COPY THE TEXT OF THE NOTE + . . S @C0CNTE@(ZI,"COMMENTOBJECTID")="NOTE_"_ZI + . . S @C0CNTE@(ZI,"CMTDATETIME")=ZDATE ; DATE OF THE NOTE + . . S @C0CNTE@(ZI,"ACTORSOURCEID")=ZPRV ; SOURCE OF THE NOTE + . . S ZRNF("ENCCOMMENTID")="NOTE_"_ZI ; POINT TO THE NOTE FROM THE ENCOUNTER + . D RNF1TO2^C0CRNF(C0CENC,"ZRNF") ; ADD THIS ROW TO THE ARRAY + . ;S PREVCPT=ZCPT + . ;S PREVDT=ZDATE + N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"ENCOUNTERS")) + M @ZRIM=@C0CENC@("V") + K VISIT,LST,NOTE + Q + ; +GETTYPE(ZARY,ZTXT,ZCDE,ZSYS) ; EXTRINSIC WHICH RETURNS FALSE IF NO ENCOUNTER TYPE + ; UPDATES ZTXT WITH ENCOUNTER TYPE TEXT, ZCDE WITH ENCOUNTER TYPE CODE + ; AND ZSYS WITH ENCOUNTER TYPE CODING SYSTEM + ; THIS ROUTINE SHOULD BE UPDATED TO SEARCH FOR AN ADMINISTRATIVE CPT CODE + ; INSTEAD OF JUST THE FIRST ONE IN THE LIST - GPL 1/23/10 + N ZS,ZC + S ZC="" S ZS="" + S (ZTXT,ZCDE,ZSYS)="" + F S ZC=$O(@ZARY@("CPT",ZC)) Q:ZC="" D ; TRY AND FIND A "99" CPT CODE + . N ZT + . S ZT=$$CPT^C0CPROC(@ZARY@("CPT",ZC)) ; VALUES IN A CPT MULTIPLE + . I $E($P(ZT,U,1),1,2)="99" S ZS=ZT ; IS IT AN ADMIN CPT CODE? + I ZS'="" D ; CODED ENCOUNTER TYPE FOUND + . S ZTXT=$P(ZS,U,2)_" "_$P(ZS,U,3) ; USE BOTH PIECES FOR THE TYPE + . S ZCDE=$P($$CPT^C0CPROC(ZS),U,1) ; CPT CODE FOR ENCOUTER + . S ZSYS="" + . I ZCDE'="" S ZSYS="CPT-4" ; ONLY HAVE A CODING SYSTEM IF THERE IS A CODE + I ZS="" S ZTXT=$$ANYTXT(ZARY) ; TRY AND GET FREE FORM TEXT FROM CPT MULTIPLES + I ZTXT="" Q 0 ; FAILED + W !,ZTXT + Q 1 ; SUCCESS + ; +ANYTXT(ZVST) ; EXTRINSIC WHICH RETURNS TEXT FROM THE CPT MULTIPLE + ; OF A VISIT ARRAY WITHOUT CHECKING THE CPT CODE (THAT HAVING FAILED) + ; ZVST IS THE VISIT ARRAY AND IS PASSED BY NAME + ; RETURNS TEXT TO USE AS ENCOUNTER TYPE IF ANY + N ZK,ZL + S ZK="" S ZL="" + F S ZK=$O(@ZVST@("CPT",ZK)) Q:ZK="" D ; LOOK FOR SOME TEXT TO USE + . N ZT + . S ZT=$G(@ZVST@("CPT",ZK)) ; LOOK AT THIS CPT MULTIPLE + . I $P(ZT,U,2)_" "_$P(ZT,U,3)'=" " S ZL=$P(ZT,U,2)_" "_$P(ZT,U,3) + . ; CONCATENATE PIECE 2 AND 3 OF THE CPT MULTIPLE FOR A TYPE + I ZL="" S ZL=$G(@ZVST@("CLASS")) ; USE THE NOTE DOCUMENT CLASS FOR ENCOUTNER TYPE + Q ZL + ; +PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME + N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN="" + F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH PRV SEG + . I ZR'="" Q ;ONLY WANT THE FIRST PRIMARY PROVIDER + . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1) + I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR + Q ZRTN + ; +DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT + Q $$FMDTOUTC^C0CUTIL(ISTR,"DT") + ; +CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS + ; CPT^CATEGORY^TEXT + N Z1,Z2,Z3,ZRTN + S Z1=$P(ISTR,U,1) + I Z1="" D ; + . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1) + I Z1'="" D ; IF THERE IS A CPT CODE IN THERE + . ;S Z1=$P(ISTR,U,1) + . S Z2=$P(ISTR,U,2) + . S Z3=$P(ISTR,U,3) + . S ZRTN=Z1_U_Z2_U_Z3 + E S ZRTN="" + Q ZRTN + ; +MAP(ENCXML,C0CENC,ENCOUT) ; MAP PROCEDURES XML + ; + N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"ENCTEMP")) ;WORK AREA FOR TEMPLATE + K @ZTEMP + N ZBLD + S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"ENCBLD")) ; BUILD LIST AREA + D QUEUE^C0CXPATH(ZBLD,ENCXML,1,1) ; FIRST LINE + N ZINNER + D QUERY^C0CXPATH(ENCXML,"//Encounters/Encounter","ZINNER") ;ONE ENCOUNTER + N ZTMP,ZVAR,ZI + S ZI="" + F S ZI=$O(@C0CENC@("V",ZI)) Q:ZI="" D ;FOR EACH ENCOUNTER + . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS ENCOUNTER XML + . S ZVAR=$NA(@C0CENC@("V",ZI)) ;THIS ENCOUNTER VARIABLES + . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE + . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD + D QUEUE^C0CXPATH(ZBLD,ENCXML,@ENCXML@(0),@ENCXML@(0)) + N ZZTMP + D BUILD^C0CXPATH(ZBLD,ENCOUT) ;BUILD FINAL XML + K @ZTEMP,@ZBLD,@C0CENC + Q + ; Index: ccr/branches/ohum/p/C0CENV.m =================================================================== --- ccr/branches/ohum/p/C0CENV.m (revision 1333) +++ ccr/branches/ohum/p/C0CENV.m (revision 1337) @@ -1,195 +1,195 @@ -C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009 - ;;1.0;C0C;;May 19, 2009;Build 1 - ; - ; -ENV ; Does not prevent loading of the transport global. - ; Environment check is done only during the install. - ; - N XQA,XQAMSG - ; - ; - ; Make sure the patch name exist - ; - I '$D(XPDNM) D Q - . D BMES("No valid patch name exist") - . S XPDQUIT=2 - . D EXIT - ; - D CHECK - D EXIT - Q - ; - ; -CHECK ; Perform environment check - ; - I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D - . D BMES("Terminal Device is not defined") - . S XPDQUIT=2 - ; - I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D - . D BMES("Please log in to set local DUZ... variables") - . S XPDQUIT=2 - ; - I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D - . D BMES("You are not a valid user on this system") - . S XPDQUIT=2 - Q - ; - ; -EXIT ; - ; - ; - I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q - D BMES("--- Environment Check is Ok ---") - ; - Q - ; - ; -PRE ;Pre-install entry point - ; - ; No action needed in pre-install - D BMES("No action need for pre-install") - ; - Q - ; - ; -POST ;Post install - ; - ; Check for RPMS system with V LAB file. - ; - I $$VFILE^DILFD(9000010.09)'=1 Q - ; - S %=$$NEWCP^XPDUTL("RPMS1","POST1^C0CENV") - S %=$$NEWCP^XPDUTL("RPMS2","POST2^C0CENV") - S %=$$NEWCP^XPDUTL("RPMS3","POST3^C0CENV") - S %=$$NEWCP^XPDUTL("RPMS4","POST4^C0CENV") - S %=$$NEWCP^XPDUTL("RPMS5","POST5^C0CENV") - S %=$$NEWCP^XPDUTL("RPMS6","POST6^C0CENV") - S %=$$NEWCP^XPDUTL("RPMS7","POST7^C0CENV") - ; - Q - ; - ; -POST1 ; Checkpoint call back entry point. - ; Add new style ALR1 cross-reference to V LAB file. - ; - N MSG - S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR1^C0CLA7DD - S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - Q - ; - ; -POST2 ; Checkpoint call back entry point. - ; Add new style ALR2 cross-reference to V LAB file. - ; - N MSG - S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR2^C0CLA7DD - S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - Q - ; - ; -POST3 ; Checkpoint call back entry point. - ; Add new style ALR3 cross-reference to V LAB file. - ; - N MSG - S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR3^C0CLA7DD - S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - Q - ; - ; -POST4 ; Checkpoint call back entry point. - ; Add new style ALR4 cross-reference to V LAB file. - ; - N MSG - S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR4^C0CLA7DD - S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - Q - ; - ; -POST5 ; Checkpoint call back entry point. - ; Add new style ALR5 cross-reference to V LAB file. - ; - N MSG - S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR5^C0CLA7DD - S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - Q - ; - ; -POST6 ; Checkpoint call back entry point. - ; Check for RPMS system and determine LAB patch level - ; and need to load in C0C version of LA7 routines. - ; - N MSG - ; - ; Load and rename C0CQRY2 to LA7QRY2 if LA*5.2*69 not installed - I '$$PATCH^XPDUTL("LA*5.2*69") D - . S MSG="This system missing LAB patch LA*5.2*69" - . D BMES(MSG) - . S MSG="Renaming routine C0CQRY2 to LA7QRY2" - . D BMES(MSG) - . D LOAD("C0CQRY2") - . D SAVE("C0CQRY2","LA7QRY2") - ; - ; Load and rename C0CVOBX1 to LA7VOBX1 if LA*5.2*64 not installed. - I '$$PATCH^XPDUTL("LA*5.2*64") D - . S MSG="This system missing LAB patch LA*5.2*64" - . D BMES(MSG) - . S MSG="Renaming routine C0CVOBX1 to LA7VOBX1" - . D BMES(MSG) - . D LOAD("C0CVOBX1") - . D SAVE("C0CVOBX1","LA7VOBX1") - ; - ; Load and rename C0CQRY1 to LA7QRY1 if LA*5.2*68 not installed. - I '$$PATCH^XPDUTL("LA*5.2*68") D - . S MSG="This system missing LAB patch LA*5.2*68" - . D BMES(MSG) - . S MSG="Renaming routine C0CQRY1 to LA7QRY1" - . D BMES(MSG) - . D LOAD("C0CQRY1") - . D SAVE("C0CQRY1","LA7QRY1") - ; - Q - ; - ; -POST7 ; Checkpoint call back entry point. - ; - D REINDEX^C0CLA7DD - ; - Q - ; - ; -BMES(STR) ; Write BMES^XPDUTL statements - ; - D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM)) - ; - Q - ; - ; -LOAD(X) ; load routine X - N %N,DIF,XCNP - K ^TMP($J,X) - S DIF="^TMP($J,X,",XCNP=0 - X ^%ZOSF("LOAD") - Q - ; - ; -SAVE(OLD,NEW) ; restore routine X - N %,DIE,X,XCM,XCN,XCS - S DIE="^TMP($J,"""_OLD_""",",XCN=0,X=NEW - X ^%ZOSF("SAVE") - Q +C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009 + ;;1.0;C0C;;May 19, 2009; + ; + ; +ENV ; Does not prevent loading of the transport global. + ; Environment check is done only during the install. + ; + N XQA,XQAMSG + ; + ; + ; Make sure the patch name exist + ; + I '$D(XPDNM) D Q + . D BMES("No valid patch name exist") + . S XPDQUIT=2 + . D EXIT + ; + D CHECK + D EXIT + Q + ; + ; +CHECK ; Perform environment check + ; + I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D + . D BMES("Terminal Device is not defined") + . S XPDQUIT=2 + ; + I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D + . D BMES("Please log in to set local DUZ... variables") + . S XPDQUIT=2 + ; + I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D + . D BMES("You are not a valid user on this system") + . S XPDQUIT=2 + Q + ; + ; +EXIT ; + ; + ; + I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q + D BMES("--- Environment Check is Ok ---") + ; + Q + ; + ; +PRE ;Pre-install entry point + ; + ; No action needed in pre-install + D BMES("No action need for pre-install") + ; + Q + ; + ; +POST ;Post install + ; + ; Check for RPMS system with V LAB file. + ; + I $$VFILE^DILFD(9000010.09)'=1 Q + ; + S %=$$NEWCP^XPDUTL("RPMS1","POST1^C0CENV") + S %=$$NEWCP^XPDUTL("RPMS2","POST2^C0CENV") + S %=$$NEWCP^XPDUTL("RPMS3","POST3^C0CENV") + S %=$$NEWCP^XPDUTL("RPMS4","POST4^C0CENV") + S %=$$NEWCP^XPDUTL("RPMS5","POST5^C0CENV") + S %=$$NEWCP^XPDUTL("RPMS6","POST6^C0CENV") + S %=$$NEWCP^XPDUTL("RPMS7","POST7^C0CENV") + ; + Q + ; + ; +POST1 ; Checkpoint call back entry point. + ; Add new style ALR1 cross-reference to V LAB file. + ; + N MSG + S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR1^C0CLA7DD + S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + Q + ; + ; +POST2 ; Checkpoint call back entry point. + ; Add new style ALR2 cross-reference to V LAB file. + ; + N MSG + S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR2^C0CLA7DD + S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + Q + ; + ; +POST3 ; Checkpoint call back entry point. + ; Add new style ALR3 cross-reference to V LAB file. + ; + N MSG + S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR3^C0CLA7DD + S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + Q + ; + ; +POST4 ; Checkpoint call back entry point. + ; Add new style ALR4 cross-reference to V LAB file. + ; + N MSG + S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR4^C0CLA7DD + S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + Q + ; + ; +POST5 ; Checkpoint call back entry point. + ; Add new style ALR5 cross-reference to V LAB file. + ; + N MSG + S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR5^C0CLA7DD + S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + Q + ; + ; +POST6 ; Checkpoint call back entry point. + ; Check for RPMS system and determine LAB patch level + ; and need to load in C0C version of LA7 routines. + ; + N MSG + ; + ; Load and rename C0CQRY2 to LA7QRY2 if LA*5.2*69 not installed + I '$$PATCH^XPDUTL("LA*5.2*69") D + . S MSG="This system missing LAB patch LA*5.2*69" + . D BMES(MSG) + . S MSG="Renaming routine C0CQRY2 to LA7QRY2" + . D BMES(MSG) + . D LOAD("C0CQRY2") + . D SAVE("C0CQRY2","LA7QRY2") + ; + ; Load and rename C0CVOBX1 to LA7VOBX1 if LA*5.2*64 not installed. + I '$$PATCH^XPDUTL("LA*5.2*64") D + . S MSG="This system missing LAB patch LA*5.2*64" + . D BMES(MSG) + . S MSG="Renaming routine C0CVOBX1 to LA7VOBX1" + . D BMES(MSG) + . D LOAD("C0CVOBX1") + . D SAVE("C0CVOBX1","LA7VOBX1") + ; + ; Load and rename C0CQRY1 to LA7QRY1 if LA*5.2*68 not installed. + I '$$PATCH^XPDUTL("LA*5.2*68") D + . S MSG="This system missing LAB patch LA*5.2*68" + . D BMES(MSG) + . S MSG="Renaming routine C0CQRY1 to LA7QRY1" + . D BMES(MSG) + . D LOAD("C0CQRY1") + . D SAVE("C0CQRY1","LA7QRY1") + ; + Q + ; + ; +POST7 ; Checkpoint call back entry point. + ; + D REINDEX^C0CLA7DD + ; + Q + ; + ; +BMES(STR) ; Write BMES^XPDUTL statements + ; + D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM)) + ; + Q + ; + ; +LOAD(X) ; load routine X + N %N,DIF,XCNP + K ^TMP($J,X) + S DIF="^TMP($J,X,",XCNP=0 + X ^%ZOSF("LOAD") + Q + ; + ; +SAVE(OLD,NEW) ; restore routine X + N %,DIE,X,XCM,XCN,XCS + S DIE="^TMP($J,"""_OLD_""",",XCN=0,X=NEW + X ^%ZOSF("SAVE") + Q Index: ccr/branches/ohum/p/C0CEVC.m =================================================================== --- ccr/branches/ohum/p/C0CEVC.m (revision 1333) +++ ccr/branches/ohum/p/C0CEVC.m (revision 1337) @@ -1,177 +1,177 @@ -C0CEVC ; CCDCCR/GPL - SUPPORT FOR EWD VISTCOM PAGES ; 3/1/2010 - ;;1.0;C0C;;Mar 1, 2010;Build 1 -gpltest2 ; experiment with sending a CCR to an ewd page - N ZI - S ZI="" - D PSEUDO - N ZIO - S ZIO=IO - S IO="/dev/null" - OPEN IO - U IO - N G - S G=$$URLTOKEN^C0CEWD - D CCRRPC^C0CCCR(.GPL,2) - S IO=ZIO - OPEN IO - U IO - K GPL(0) - F S ZI=$O(GPL(ZI)) Q:ZI="" W GPL(ZI),! - Q - ; -gpltest ; experiment with sending a CCR to an ewd page - N ZI - S ZI="" - K ^GPL(0) - S ^GPL(2)="" - 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)="" - C DEV U ZIO - ;M ^CacheTempEWD($j)=GPL - S DOCNAME="CCR" - ;ZWR GPL - ;S ZR=$$parseDocument^%zewdHTMLParser(DOCNAME) - ;d setSessionValues^%zewdAPI(DOCNAME,GPL,sessid) - d mergeArrayToSession^%zewdAPI(.GPL,DOCNAME,sessid) - Q "" - ; -INITSES(sessid) ;initialize an EWD/CPRS session - K ^TMP("GPL") - ;M ^TMP("GPL")=^%zewdSession("session",sessid) - N ZT,ZDFN - S ZT=$$URLTOKEN^C0CEWD(sessid) - ;S ^TMP("GPL")=ZT - d trace^%zewdAPI("*********************ZT="_ZT) - S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN - S ^TMP("GPL","DFN")=ZDFN - I ZDFN=0 S DFN=2 ; DEFAULT TEST PATIENT - D setSessionValue^%zewdAPI("vista.dfn",ZDFN,sessid) - ;M ^TMP("GPL","request")=requestArray - ;D PSEUDO - ;D ^%ZTER - q "" - ; -PRSEORTK(ZTOKEN) ;PARSES THE TOKEN SENT BY CPRS AND RETURNS THE DFN - ; OF THE PATIENT ; HERE'S WHAT THE TOKEN LOOKS LIKE: - ; ^TMP('ORWCHART',6547,'192.168.169.8',002E0FE6) - N ZX,ZN1,ZIP,ZN2,ZDFN,ZG - S ZDFN=0 ; DEFAULT RETURN - S ZN1=$P(ZTOKEN,",",2) ; FIRST NUMBER - S ZIP=$P(ZTOKEN,",",3) ; IP NUMBER - S ZIP=$P(ZIP,"'",2) ; GET RID OF ' - S ZN2=$P(ZTOKEN,",",4) ; SECOND NUMBER - S ZN2=$P(ZN2,")",1) ; GET RID OF ) - S ZG=$NA(^TMP("ORWCHART",ZN1,ZIP,ZN2)) ; BUILD THE GLOBAL NAME - I $G(@ZG)'="" S ZDFN=@ZG ; ACCESS THE GLOBAL - S ^TMP("GPL","FIRSTDFN")=ZDFN - S ^TMP("GPL","FIRSTGLB")=ZG - Q ZDFN - ; -GETPATIENTLIST(sessid) ; - D PSEUDO - D LISTALL^ORWPT(.RTN,"NAME","1") - N ZI - S ZI="" - F S ZI=$O(RTN(ZI)) Q:ZI="" D ; - . S data(ZI,"DFN")=$P(RTN(ZI),"^",1) - . S data(ZI,"Name")=$P(RTN(ZI),"^",2) - ; ZWR data - ;S data(1,"DFN")=$P(RTN(1),"^",1) - ;S data(1,"Name")=$P(RTN(1),"^",2) - d deleteFromSession^%zewdAPI("patients",sessid) - d createDataTableStore^%zewdYUIRuntime(.data,"patients",sessid) - ;d mergeArrayToSession^%zewdAPI(.data,"patients",sessid) - Q "" - ; -PSEUDO - S U="^" - S DILOCKTM=3 - S DISYS=19 - S DT=3100219 - S DTIME=999 - S DUZ=10 - S DUZ(0)="@" - S DUZ(1)="" - S DUZ(2)=1 - S DUZ("AG")="V" - S DUZ("BUF")=1 - S DUZ("LANG")="" - ;S IO="/dev/pts/2" - ;S IO(0)="/dev/pts/2" - ;S IO(1,"/dev/pts/2")="" - ;S IO("ERROR")="" - ;S IO("HOME")="41^/dev/pts/2" - ;S IO("ZIO")="/dev/pts/2" - ;S IOBS="$C(8)" - ;S IOF="#,$C(27,91,50,74,27,91,72)" - ;S SIOM=80 - Q - ; -PSEUDO2 ; FAKE LOGIN SETS SOME LOCAL VARIABLE TO FOOL FILEMAN - S DILOCKTM=3 - S DISYS=19 - S DT=3100112 - S DTIME=9999 - S DUZ=10000000020 - S DUZ(0)="@" - S DUZ(1)="" - S DUZ(2)=67 - S DUZ("AG")="E" - S DUZ("BUF")=1 - S DUZ("LANG")=1 - S IO="/dev/pts/0" - ;S IO(0)="/dev/pts/0" - ;S IO(1,"/dev/pts/0")="" - ;S IO("ERROR")="" - ;S IO("HOME")="50^/dev/pts/0" - ;S IO("ZIO")="/dev/pts/0" - ;S IOBS="$C(8)" - ;S IOF="!!!!!!!!!!!!!!!!!!!!!!!!,#,$C(27,91,50,74,27,91,72)" - ;S IOM=80 - ;S ION="GTM/UNIX TELNET" - ;S IOS=50 - ;S IOSL=24 - ;S IOST="C-VT100" - ;S IOST(0)=9 - ;S IOT="VTRM" - ;S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)" - S U="^" - S X="1;DIC(4.2," - S XPARSYS="1;DIC(4.2," - S XQXFLG="^^XUP" - S Y="DEV^VISTA^hollywood^VISTA:hollywood" - Q - ; +C0CEVC ; CCDCCR/GPL - SUPPORT FOR EWD VISTCOM PAGES ; 3/1/2010 + ;;1.0;C0C;;Mar 1, 2010; +gpltest2 ; experiment with sending a CCR to an ewd page + N ZI + S ZI="" + D PSEUDO + N ZIO + S ZIO=IO + S IO="/dev/null" + OPEN IO + U IO + N G + S G=$$URLTOKEN^C0CEWD + D CCRRPC^C0CCCR(.GPL,2) + S IO=ZIO + OPEN IO + U IO + K GPL(0) + F S ZI=$O(GPL(ZI)) Q:ZI="" W GPL(ZI),! + Q + ; +gpltest ; experiment with sending a CCR to an ewd page + N ZI + S ZI="" + K ^GPL(0) + S ^GPL(2)="" + 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)="" + 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 + ; Index: ccr/branches/ohum/p/C0CEWD.m =================================================================== --- ccr/branches/ohum/p/C0CEWD.m (revision 1333) +++ ccr/branches/ohum/p/C0CEWD.m (revision 1337) @@ -1,71 +1,71 @@ -C0CEWD ; CCDCCR/GPL - CCR EWD utilities; 1/6/11 - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 - ;Copyright 2011 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q - ; -TOKEN() ; EXTRINSIC WHICH RETURNS A NEW RANDOM TOKEN - Q $$UUID^C0CUTIL ; USE THE UUID FUNCTION IN THE CCR PACKAGE - ; -STORE(ZARY) ; STORE AN ARRAY OF VALUES INDEXED BY A NEW TOKEN - ; IN ^TMP("C0E","TOKEN") FOR LATER RETRIEVAL FROM INSIDE AN EWD SESSION - ; RETURNS THE TOKEN. ZARY IS PASSED BY NAME - N ZT - S ZT=$$TOKEN ; GET A NEW TOKEN - M ^TMP("C0E","TOKEN",ZT)=@ZARY ; - Q ZT - ; -GET(C0ERTN,C0ETOKEN,NOKILL) ; RETRIEVE A STORED ARRAY INDEXED BY ZTOKEN - ; KILL THE ARRAY AFTER RETRIEVAL UNLESS NOKILL=1 - ; C0ERTN IS PASSED BY NAME - I '$D(^TMP("C0E","TOKEN",C0ETOKEN)) D Q ; DOESN'T EXIST - . S @C0ERTN="" ; PASS BACK NULL - M @C0ERTN=^TMP("C0E","TOKEN",C0ETOKEN) ; RETRIEVE - I $G(NOKILL)'=1 K ^TMP("C0E","TOKEN",C0ETOKEN) ; DELETE - Q - ; -URLTOKEN(sessid) ; EXTRINSIC WHICH RETRIEVES THE TOKEN PASSED ON THE URL - ; IN EWD EXAMPLE: https://example.com/ewd/myApp/index.ewd?token="12345" - N token - S token="" - s token=$$getRequestValue^%zewdAPI("token",sessid) - s token=$tr(token,"""") ; strip out quotes - Q token - ; -cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options) - ; - n maxNo,noFound - ; - s maxNo=50 - s noFound=0 - f s seedValue=$o(^DPT("B",seedValue)) q:seedValue="" q:noFound=maxNo d - . s lastSeedValue=seedValue - . i prefix'="",$e(seedValue,1,$l(prefix))'=prefix q - . s optionNo=optionNo+1 - . s noFound=noFound+1 - . s options(optionNo)=seedValue - QUIT - ; -set1 ; - s ^zewd("comboPlus","methodMap","test")="cbTestMethod^C0PEREW" - q - ; -test1(sessid) ; - d setSessionValue^%zewdAPI("testing","ZZ",sessid) - q 0 - ; +C0CEWD ; CCDCCR/GPL - CCR EWD utilities; 1/6/11 + ;;0.1;CCDCCR;nopatch;noreleasedate;Build 77 + ;Copyright 2011 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q + ; +TOKEN() ; EXTRINSIC WHICH RETURNS A NEW RANDOM TOKEN + Q $$UUID^C0CUTIL ; USE THE UUID FUNCTION IN THE CCR PACKAGE + ; +STORE(ZARY) ; STORE AN ARRAY OF VALUES INDEXED BY A NEW TOKEN + ; IN ^TMP("C0E","TOKEN") FOR LATER RETRIEVAL FROM INSIDE AN EWD SESSION + ; RETURNS THE TOKEN. ZARY IS PASSED BY NAME + N ZT + S ZT=$$TOKEN ; GET A NEW TOKEN + M ^TMP("C0E","TOKEN",ZT)=@ZARY ; + Q ZT + ; +GET(C0ERTN,C0ETOKEN,NOKILL) ; RETRIEVE A STORED ARRAY INDEXED BY ZTOKEN + ; KILL THE ARRAY AFTER RETRIEVAL UNLESS NOKILL=1 + ; C0ERTN IS PASSED BY NAME + I '$D(^TMP("C0E","TOKEN",C0ETOKEN)) D Q ; DOESN'T EXIST + . S @C0ERTN="" ; PASS BACK NULL + M @C0ERTN=^TMP("C0E","TOKEN",C0ETOKEN) ; RETRIEVE + I $G(NOKILL)'=1 K ^TMP("C0E","TOKEN",C0ETOKEN) ; DELETE + Q + ; +URLTOKEN(sessid) ; EXTRINSIC WHICH RETRIEVES THE TOKEN PASSED ON THE URL + ; IN EWD EXAMPLE: https://example.com/ewd/myApp/index.ewd?token="12345" + N token + S token="" + s token=$$getRequestValue^%zewdAPI("token",sessid) + s token=$tr(token,"""") ; strip out quotes + Q token + ; +cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options) + ; + n maxNo,noFound + ; + s maxNo=50 + s noFound=0 + f s seedValue=$o(^DPT("B",seedValue)) q:seedValue="" q:noFound=maxNo d + . s lastSeedValue=seedValue + . i prefix'="",$e(seedValue,1,$l(prefix))'=prefix q + . s optionNo=optionNo+1 + . s noFound=noFound+1 + . s options(optionNo)=seedValue + QUIT + ; +set1 ; + s ^zewd("comboPlus","methodMap","test")="cbTestMethod^C0PEREW" + q + ; +test1(sessid) ; + d setSessionValue^%zewdAPI("testing","ZZ",sessid) + q 0 + ; Index: ccr/branches/ohum/p/C0CEWD1.m =================================================================== --- ccr/branches/ohum/p/C0CEWD1.m (revision 1333) +++ ccr/branches/ohum/p/C0CEWD1.m (revision 1337) @@ -1,67 +1,67 @@ -C0CEWD1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q - ; -TEST(filepath) ; filepath IS THE PATH/FILE TO BE READ IN - i $g(^%ZISH)["" d ; if the VistA Kernal routine %ZISH exists - . n zfile,zpath,ztmp s (zfile,zpath,ztmp)="" - . s zfile=$re($p($re(filepath),"/",1)) ;file name - . s zpath=$p(filepath,zfile,1) ; file path - . s ztmp=$na(^CacheTempEWD($j,0)) - . s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2 - q - ; -TEST2 ; - s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml" - ;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath) - s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global - s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0) - ;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM") - w ok,! - q - ; -LOAD(filepath) ; load an xml file into the EWD global for DOM processing - ; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML) - ; after to process it to the DOM - isHTML=0 for XML files - n i - i $g(^%ZISH)["" d QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09 - . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)="" - . s zfile=$re($p($re(filepath),"/",1)) ;file name - . s zpath=$p(filepath,zfile,1) ; file path - . s ztmp=$na(^CacheTempEWD($j,0)) - . s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2 - . s i=$o(^CacheTempEWD($j,""),-1) ; highest line number - q i - ; -Q(ZQ,ZD) ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED - I '$D(ZD) S ZD="DerekDOM" - s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ; - d displayNodes^%zewdXPath(.nodes) - q - ; -GET1URL0(URL) ; - s ok=$$httpGET^%zewdGTM(URL,.gpl) - D INDEX^C0CXPATH("gpl","gpl2") - W !,"S URL=""",URL,"""",! - S G="" - F S G=$O(gpl2(G)) Q:G="" D ; - . W " S VDX(""",G,""")=""",gpl2(G),"""",! - W ! - Q +C0CEWD1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q + ; +TEST(filepath) ; filepath IS THE PATH/FILE TO BE READ IN + i $g(^%ZISH)["" d ; if the VistA Kernal routine %ZISH exists + . n zfile,zpath,ztmp s (zfile,zpath,ztmp)="" + . s zfile=$re($p($re(filepath),"/",1)) ;file name + . s zpath=$p(filepath,zfile,1) ; file path + . s ztmp=$na(^CacheTempEWD($j,0)) + . s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2 + q + ; +TEST2 ; + s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml" + ;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath) + s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global + s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0) + ;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM") + w ok,! + q + ; +LOAD(filepath) ; load an xml file into the EWD global for DOM processing + ; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML) + ; after to process it to the DOM - isHTML=0 for XML files + n i + i $g(^%ZISH)["" d QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09 + . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)="" + . s zfile=$re($p($re(filepath),"/",1)) ;file name + . s zpath=$p(filepath,zfile,1) ; file path + . s ztmp=$na(^CacheTempEWD($j,0)) + . s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2 + . s i=$o(^CacheTempEWD($j,""),-1) ; highest line number + q i + ; +Q(ZQ,ZD) ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED + I '$D(ZD) S ZD="DerekDOM" + s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ; + d displayNodes^%zewdXPath(.nodes) + q + ; +GET1URL0(URL) ; + s ok=$$httpGET^%zewdGTM(URL,.gpl) + D INDEX^C0CXPATH("gpl","gpl2") + W !,"S URL=""",URL,"""",! + S G="" + F S G=$O(gpl2(G)) Q:G="" D ; + . W " S VDX(""",G,""")=""",gpl2(G),"""",! + W ! + Q Index: ccr/branches/ohum/p/C0CFM1.m =================================================================== --- ccr/branches/ohum/p/C0CFM1.m (revision 1333) +++ ccr/branches/ohum/p/C0CFM1.m (revision 1337) @@ -1,177 +1,177 @@ -C0CFM1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is the CCR FILEMAN Utility Library ",! - W ! - Q - ; -PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE - ; - S C0CGLB=$NA(^TMP("GPLRIM","VARS",DFN)) - I '$D(ZWHICH) S ZWHICH="ALL" - I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED - . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) - . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION - E D ; MULTIPLE SECTIONS - . S C0CVARS=$NA(@C0CGLB) - . S C0CI="" - . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION - . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION - . . D PUTRIM1(DFN,C0CI,C0CVARSN) - Q - ; -PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS - ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" - S C0CX=0 - F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE - . W "ZOCC=",C0CX,! - . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE - . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE - Q - ; -PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE - ; ^C0C(171.201, DFN IS THE PATIENT IEN PASSED BY VALUE - ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE - ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC - ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM - ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT - ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES - ; - S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 - ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE - N ZF,ZFV S ZF=171.201 S ZFV=171.2012 - S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS - N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER - N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) - W "ZTYPE: ",ZTYPE," ",ZTYPN,! - N ZVARN ; IEN OF VARIABLE BEING PROCESSED - ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE - S C0CFDA(ZF,"?+1,",.01)=DFN - S C0CFDA(ZF,"?+1,",.02)=ZSRC - S C0CFDA(ZF,"?+1,",.03)=ZTYPN - S C0CFDA(ZF,"?+1,",.04)=ZOCC ;CREATE OCCURANCE - K ZERR - D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER - I $D(ZERR) B ;OOPS - K C0CFDA - S ZD0=$O(^C0C(ZF,"C",DFN,ZSRC,ZTYPN,ZOCC,"")) - W "RECORD NUMBER: ",ZD0,! - ;B - S ZCNT=0 - S ZC0CI="" ; - F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; - . I ZC0CI'="M" D ; NOT A SUBVARIABLE - . . S ZCNT=ZCNT+1 ;INCREMENT COUNT - . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT - . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND - . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN - . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) - . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN - . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) - ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" - ;S GT1(170,"?+1,",12)="DIR" - ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" - ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","","ZERR") - Q - ; -VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE - ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO - ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO - ; - N ZCCRD,ZVARN,C0CFDA2 - S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY - S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE - I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT - . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE - . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! - . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE - . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE - . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN - . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY - . I $D(ZERR) D ; LAYGO ERROR - . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! - . E D ; - . . D CLEAN^DILF ; CLEAN UP - . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE - . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! - Q ZVARN - ; -BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) - ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED - ; - N C0CDIC,C0CNODE ; - S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY - S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE - Q - ; -FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED - ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET - ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS - ; CONVERSION - ;N C0CC,C0CI,C0CJ,C0CN,C0CZX - D FIELDS^C0CRNF("C0CC",170) - S C0CI="" - F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION - . S C0CZX="" - . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE - . . W "SECTION ",C0CI," VAR ",C0CZX - . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) - . . W " TYPE: ",C0CV,! - . . D SETFDA("SECTION",C0CV) - . . ;ZWR C0CFDA - Q - ; -SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN - ; TO SET TO VALUE C0CSV. - ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE - ; C0CSN,C0CSV ARE PASSED BY VALUE - ; - N C0CSI,C0CSJ - S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER - S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER - S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV - Q -ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) - E S ZR="" - Q ZR -ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) - E S ZR="" - Q ZR - ; -ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) - E S ZR="" - Q ZR - ; +C0CFM1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is the CCR FILEMAN Utility Library ",! + W ! + Q + ; +PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE + ; + S C0CGLB=$NA(^TMP("GPLRIM","VARS",DFN)) + I '$D(ZWHICH) S ZWHICH="ALL" + I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED + . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) + . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION + E D ; MULTIPLE SECTIONS + . S C0CVARS=$NA(@C0CGLB) + . S C0CI="" + . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION + . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION + . . D PUTRIM1(DFN,C0CI,C0CVARSN) + Q + ; +PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS + ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" + S C0CX=0 + F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE + . W "ZOCC=",C0CX,! + . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE + . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE + Q + ; +PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE + ; ^C0C(171.201, DFN IS THE PATIENT IEN PASSED BY VALUE + ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE + ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC + ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM + ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT + ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES + ; + S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 + ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE + N ZF,ZFV S ZF=171.201 S ZFV=171.2012 + S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS + N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER + N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) + W "ZTYPE: ",ZTYPE," ",ZTYPN,! + N ZVARN ; IEN OF VARIABLE BEING PROCESSED + ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE + S C0CFDA(ZF,"?+1,",.01)=DFN + S C0CFDA(ZF,"?+1,",.02)=ZSRC + S C0CFDA(ZF,"?+1,",.03)=ZTYPN + S C0CFDA(ZF,"?+1,",.04)=ZOCC ;CREATE OCCURANCE + K ZERR + D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER + I $D(ZERR) B ;OOPS + K C0CFDA + S ZD0=$O(^C0C(ZF,"C",DFN,ZSRC,ZTYPN,ZOCC,"")) + W "RECORD NUMBER: ",ZD0,! + ;B + S ZCNT=0 + S ZC0CI="" ; + F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; + . I ZC0CI'="M" D ; NOT A SUBVARIABLE + . . S ZCNT=ZCNT+1 ;INCREMENT COUNT + . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT + . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND + . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN + . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) + . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN + . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) + ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" + ;S GT1(170,"?+1,",12)="DIR" + ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" + ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","","ZERR") + Q + ; +VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE + ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO + ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO + ; + N ZCCRD,ZVARN,C0CFDA2 + S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY + S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE + I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT + . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE + . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! + . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE + . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE + . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN + . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY + . I $D(ZERR) D ; LAYGO ERROR + . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! + . E D ; + . . D CLEAN^DILF ; CLEAN UP + . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE + . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! + Q ZVARN + ; +BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) + ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED + ; + N C0CDIC,C0CNODE ; + S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY + S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE + Q + ; +FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED + ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET + ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS + ; CONVERSION + ;N C0CC,C0CI,C0CJ,C0CN,C0CZX + D FIELDS^C0CRNF("C0CC",170) + S C0CI="" + F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION + . S C0CZX="" + . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE + . . W "SECTION ",C0CI," VAR ",C0CZX + . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) + . . W " TYPE: ",C0CV,! + . . D SETFDA("SECTION",C0CV) + . . ;ZWR C0CFDA + Q + ; +SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN + ; TO SET TO VALUE C0CSV. + ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE + ; C0CSN,C0CSV ARE PASSED BY VALUE + ; + N C0CSI,C0CSJ + S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER + S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER + S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV + Q +ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) + E S ZR="" + Q ZR +ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) + E S ZR="" + Q ZR + ; +ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) + E S ZR="" + Q ZR + ; Index: ccr/branches/ohum/p/C0CFM2.m =================================================================== --- ccr/branches/ohum/p/C0CFM2.m (revision 1333) +++ ccr/branches/ohum/p/C0CFM2.m (revision 1337) @@ -1,362 +1,362 @@ -C0CFM2 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is the CCR FILEMAN Utility Library ",! - ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF - ; CCR ELEMENTS (^C0C(179.201, - ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE - ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT - ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS - ; ALL SUB-VARIABLES HAVE BEEN REMOVED - W ! - Q - ; -RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE - ; - I '$D(RIMBASE) D ASETUP^C0CRIMA ; FOR COMMAND LINE CALLS - N ZI,ZJ,ZC,ZPATBASE - S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH)) - S ZI="" - F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END - . S ZI=$O(@ZPATBASE@(ZI)) - . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE - Q - ; -PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE - ; - S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN)) - I '$D(ZWHICH) S ZWHICH="ALL" - I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED - . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) - . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION - E D ; MULTIPLE SECTIONS - . S C0CVARS=$NA(@C0CGLB) - . S C0CI="" - . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION - . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION - . . D PUTRIM1(DFN,C0CI,C0CVARSN) - Q - ; -PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS - ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" - S C0CX=0 - F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE - . W "ZOCC=",C0CX,! - . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME - . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE - . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE - . I $D(C0CMDO) D ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :() - . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV - . . S ZZCNT=0 - . . S ZZC0CI=0 - . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE - . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE - . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR - . . W "MULTIPLE:",ZZVALS,! - . . ;B - . . F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE - . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT - . . . W "COUNT:",ZZCNT,! - . . . S ZV=$NA(@ZZVALS@(ZZC0CI)) - . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV) - Q - ; -PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE - ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE - ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE - ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC - ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM - ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT - ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES - ; - N PATN,ZTYPN,XD0,ZTYP - I '$D(ZSRC) S ZSRC=1 ; CCR SOURCE IS ASSUMED, 1 IF NOT SET - ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE - N C0CFPAT S C0CFPAT=171.101 ; FILE AT PATIENT LEVEL - N C0CFSRC S C0CFSRC=171.111 ; FILE AT CCR SOURCE LVL - N C0CFTYP S C0CFTYP=171.121 ; FILE AT ELEMENT TYPE LVL - N C0CFOCC S C0CFOCC=171.131 ; FILE AT OCCURANCE LVL - N C0CFVAR S C0CFVAR=171.1311 ; FILE AT VARIABLE LVL - ;FILE IS ^C0CE(PAT,1,SCR,1,TYP,1,OCC,1,VAR,1, ... - ; AND WE HAVE TO ADD THEM LEVEL AT A TIME I THINK - N C0CFDA - S C0CFDA(C0CFPAT,"?+1,",.01)=DFN - D UPDIE ; ADD THE PATIENT - S PATN=$O(^C0CE("B",DFN,"")) ; IEN FOR THE PATIENT - S C0CFDA(C0CFSRC,"?+1,"_PATN_",",.01)=ZSRC - D UPDIE ; ADD THE CCR SOURCE - N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) ; FIND THE ELE TYPE - S C0CFDA(C0CFTYP,"?+1,"_ZSRC_","_PATN_",",.01)=ZTYPN - D UPDIE ; ADD THE ELEMENT TYPE - S ZTYP=$O(^C0CE(PATN,1,ZSRC,1,"B",ZTYPN,"")) ; IEN OF ELEMENT TYPE - S C0CFDA(C0CFOCC,"?+1,"_ZTYP_","_ZSRC_","_PATN_",",.01)=ZOCC ; STRING OCC - ; OCC IS PRECEDED BY " " TO FORCE STRING STORAGE AND PRESERVE - ; STRING COLLATION ON THE INDEX - D UPDIE ; ADD THE OCCURANCE - S ZD0=$O(^C0CE(PATN,1,ZSRC,1,ZTYP,1,"B",ZOCC,"")) - W "RECORD NUMBER: ",ZD0,! - ;I ZD0=32 B - ;I ZD0=31 B - N ZCNT,ZC0CI,ZVARN,C0CZ1 - S ZCNT=0 - S ZC0CI="" ; - F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; - . I ZC0CI'="M" D ; NOT A SUBVARIABLE - . . S ZCNT=ZCNT+1 ;INCREMENT COUNT - . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT - . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND - . . S C0CZ1=ZTYP_","_ZSRC_","_PATN_"," - . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,.01)=ZVARN - . . S ZZVAL=$TR(@ZVALS@(ZC0CI),"^","|") - . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,1)=ZZVAL - . E D ; THIS IS A SUBELEMENT - . . ;PUT THE FOLLOWING BACK TO USE RECURSION - . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV - . . ;S ZZCNT=0 - . . ;S ZZC0CI=0 - . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE - . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE - . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR - . . ;W "MULTIPLE:",ZZVALS,! - . . ;B - . . ;F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE - . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT - . . ;. W "COUNT:",ZZCNT,! - . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI)) - . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION - . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION) - D UPDIE ; UPDATE - Q - ; -UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS - K ZERR - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","","ZERR") - I $D(ZERR) D ; - . W "ERROR",! - . ZWR ZERR - . B - K C0CFDA - Q - ; -CHECK ; CHECKSUM EXPERIMENTS - ; - ;B - S ZG=$NA(^C0CE(DA(2),1,DA(1),1,DA)) - ;S G2=$NA(^C0CE(8,1,1,1,2,1,6)) - S X=$$CHKSUM^XUSESIG1(ZG) - W G1,! - Q - ; -CHKELS(DFN) ; CHECKSUM ALL ELEMENTS FOR A PATIENT - ; - S ZGLB=$NA(^TMP("C0CCHK")) - S ZPAT=$O(^C0CE("B",DFN,"")) - K @ZGLB@(ZPAT) ; CLEAR PREVIOUS CHECKSUMS - S ZSRC="" - F S ZSRC=$O(^C0CE(ZPAT,1,"B",ZSRC)) Q:ZSRC="" D ; - . W "PAT:",ZPAT," SRC:",ZSRC,! - . S ZEL="" - . F S ZEL=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL)) Q:ZEL="" D ;ELEMENTS - . . W "ELEMENT:",ZEL," " - . . S ZELE=$$GET1^DIQ(170.101,ZEL,.01,"E") ;ELEMENT NAME - . . W ZELE," " - . . S ZELI=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL,"")) - . . S ZG=$NA(^C0CE(ZPAT,1,ZSRC,1,ZELI)) - . . S ZCHK=$$CHKSUM^XUSESIG1(ZG) ; CHECKSUM FOR THE ELEMENT - . . W ZCHK,! - . . S @ZGLB@(ZPAT,ZELE,ZSRC)=ZCHK - ZWR ^TMP("C0CCHK",ZPAT,*) - Q - ; -DOIT(DFN) ; EXPERIMENT FOR TIMING CALLS USING mumps -dir DOIT^C0CFM2(DFN) - D SETXUP - D CHKELS(DFN) - Q - ; -SETXUP ; SET UP ENVIRONMENT - S DISYS=19 - S DT=3090325 - S DTIME=300 - S DUZ=1 - S DUZ(0)="@" - S DUZ(1)="" - S DUZ(2)=7247 - S DUZ("AG")="I" - S DUZ("BUF")=1 - S DUZ("LANG")="" - S IO="/dev/pts/20" - S IO(0)="/dev/pts/20" - S IO(1,"/dev/pts/20")="" - S IO("ERROR")="" - S IO("HOME")="344^/dev/pts/20" - S IO("ZIO")="/dev/pts/20" - S IOBS="$C(8)" - S IOF="#,$C(27,91,50,74,27,91,72)" - S IOM=80 - S ION="TELNET" - S IOS=344 - S IOSL=24 - S IOST="C-VT100" - S IOST(0)=9 - S IOT="VTRM" - S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)" - S U="^" - S X="216;DIC(4.2," - S XPARSYS="216;DIC(4.2," - S XQXFLG="^^XUP" - Q - ; -PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE - ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE - ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE - ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC - ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM - ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT - ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES - ; - S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 - ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE - N ZF,ZFV S ZF=171.101 S ZFV=171.1011 - ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS - ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER - N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) - W "ZTYPE: ",ZTYPE," ",ZTYPN,! - N ZVARN ; IEN OF VARIABLE BEING PROCESSED - ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE - K C0CFDA - S C0CFDA(ZF,"?+1,",.01)=DFN - S C0CFDA(ZF,"?+1,",.02)=ZSRC - S C0CFDA(ZF,"?+1,",.03)=ZTYPN - S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE - K ZERR - ;B - D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER - I $D(ZERR) B ;OOPS - K C0CFDA - S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,"")) - W "RECORD NUMBER: ",ZD0,! - ;B - S ZCNT=0 - S ZC0CI="" ; - F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; - . I ZC0CI'="M" D ; NOT A SUBVARIABLE - . . S ZCNT=ZCNT+1 ;INCREMENT COUNT - . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT - . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND - . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN - . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) - . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN - . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) - ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" - ;S GT1(170,"?+1,",12)="DIR" - ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" - ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","","ZERR") - I $D(ZERR) D ; - . W "ERROR",! - . ZWR ZERR - . B - K C0CFDA - Q - ; -VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE - ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO - ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO - ; - N ZCCRD,ZVARN,C0CFDA2 - S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY - S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE - I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT - . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE - . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! - . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE - . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE - . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN - . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY - . I $D(ZERR) D ; LAYGO ERROR - . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! - . E D ; - . . D CLEAN^DILF ; CLEAN UP - . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE - . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! - Q ZVARN - ; -BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) - ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED - ; - N C0CDIC,C0CNODE ; - S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY - S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE - Q - ; -FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED - ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET - ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS - ; CONVERSION - ;N C0CC,C0CI,C0CJ,C0CN,C0CZX - D FIELDS^C0CRNF("C0CC",170) - S C0CI="" - F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION - . S C0CZX="" - . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE - . . W "SECTION ",C0CI," VAR ",C0CZX - . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) - . . W " TYPE: ",C0CV,! - . . D SETFDA("SECTION",C0CV) - . . ;ZWR C0CFDA - Q - ; -SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN - ; TO SET TO VALUE C0CSV. - ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE - ; C0CSN,C0CSV ARE PASSED BY VALUE - ; - N C0CSI,C0CSJ - S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER - S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER - S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV - Q -ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) - E S ZR="" - Q ZR -ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) - E S ZR="" - Q ZR - ; -ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) - E S ZR="" - Q ZR - ; +C0CFM2 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is the CCR FILEMAN Utility Library ",! + ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF + ; CCR ELEMENTS (^C0C(179.201, + ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE + ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT + ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS + ; ALL SUB-VARIABLES HAVE BEEN REMOVED + W ! + Q + ; +RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE + ; + I '$D(RIMBASE) D ASETUP^C0CRIMA ; FOR COMMAND LINE CALLS + N ZI,ZJ,ZC,ZPATBASE + S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH)) + S ZI="" + F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END + . S ZI=$O(@ZPATBASE@(ZI)) + . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE + Q + ; +PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE + ; + S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN)) + I '$D(ZWHICH) S ZWHICH="ALL" + I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED + . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) + . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION + E D ; MULTIPLE SECTIONS + . S C0CVARS=$NA(@C0CGLB) + . S C0CI="" + . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION + . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION + . . D PUTRIM1(DFN,C0CI,C0CVARSN) + Q + ; +PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS + ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" + S C0CX=0 + F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE + . W "ZOCC=",C0CX,! + . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME + . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE + . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE + . I $D(C0CMDO) D ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :() + . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV + . . S ZZCNT=0 + . . S ZZC0CI=0 + . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE + . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE + . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR + . . W "MULTIPLE:",ZZVALS,! + . . ;B + . . F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE + . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT + . . . W "COUNT:",ZZCNT,! + . . . S ZV=$NA(@ZZVALS@(ZZC0CI)) + . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV) + Q + ; +PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE + ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE + ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE + ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC + ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM + ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT + ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES + ; + N PATN,ZTYPN,XD0,ZTYP + I '$D(ZSRC) S ZSRC=1 ; CCR SOURCE IS ASSUMED, 1 IF NOT SET + ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE + N C0CFPAT S C0CFPAT=171.101 ; FILE AT PATIENT LEVEL + N C0CFSRC S C0CFSRC=171.111 ; FILE AT CCR SOURCE LVL + N C0CFTYP S C0CFTYP=171.121 ; FILE AT ELEMENT TYPE LVL + N C0CFOCC S C0CFOCC=171.131 ; FILE AT OCCURANCE LVL + N C0CFVAR S C0CFVAR=171.1311 ; FILE AT VARIABLE LVL + ;FILE IS ^C0CE(PAT,1,SCR,1,TYP,1,OCC,1,VAR,1, ... + ; AND WE HAVE TO ADD THEM LEVEL AT A TIME I THINK + N C0CFDA + S C0CFDA(C0CFPAT,"?+1,",.01)=DFN + D UPDIE ; ADD THE PATIENT + S PATN=$O(^C0CE("B",DFN,"")) ; IEN FOR THE PATIENT + S C0CFDA(C0CFSRC,"?+1,"_PATN_",",.01)=ZSRC + D UPDIE ; ADD THE CCR SOURCE + N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) ; FIND THE ELE TYPE + S C0CFDA(C0CFTYP,"?+1,"_ZSRC_","_PATN_",",.01)=ZTYPN + D UPDIE ; ADD THE ELEMENT TYPE + S ZTYP=$O(^C0CE(PATN,1,ZSRC,1,"B",ZTYPN,"")) ; IEN OF ELEMENT TYPE + S C0CFDA(C0CFOCC,"?+1,"_ZTYP_","_ZSRC_","_PATN_",",.01)=ZOCC ; STRING OCC + ; OCC IS PRECEDED BY " " TO FORCE STRING STORAGE AND PRESERVE + ; STRING COLLATION ON THE INDEX + D UPDIE ; ADD THE OCCURANCE + S ZD0=$O(^C0CE(PATN,1,ZSRC,1,ZTYP,1,"B",ZOCC,"")) + W "RECORD NUMBER: ",ZD0,! + ;I ZD0=32 B + ;I ZD0=31 B + N ZCNT,ZC0CI,ZVARN,C0CZ1 + S ZCNT=0 + S ZC0CI="" ; + F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; + . I ZC0CI'="M" D ; NOT A SUBVARIABLE + . . S ZCNT=ZCNT+1 ;INCREMENT COUNT + . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT + . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND + . . S C0CZ1=ZTYP_","_ZSRC_","_PATN_"," + . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,.01)=ZVARN + . . S ZZVAL=$TR(@ZVALS@(ZC0CI),"^","|") + . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,1)=ZZVAL + . E D ; THIS IS A SUBELEMENT + . . ;PUT THE FOLLOWING BACK TO USE RECURSION + . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV + . . ;S ZZCNT=0 + . . ;S ZZC0CI=0 + . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE + . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE + . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR + . . ;W "MULTIPLE:",ZZVALS,! + . . ;B + . . ;F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE + . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT + . . ;. W "COUNT:",ZZCNT,! + . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI)) + . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION + . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION) + D UPDIE ; UPDATE + Q + ; +UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS + K ZERR + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","","ZERR") + I $D(ZERR) D ; + . W "ERROR",! + . ZWR ZERR + . B + K C0CFDA + Q + ; +CHECK ; CHECKSUM EXPERIMENTS + ; + ;B + S ZG=$NA(^C0CE(DA(2),1,DA(1),1,DA)) + ;S G2=$NA(^C0CE(8,1,1,1,2,1,6)) + S X=$$CHKSUM^XUSESIG1(ZG) + W G1,! + Q + ; +CHKELS(DFN) ; CHECKSUM ALL ELEMENTS FOR A PATIENT + ; + S ZGLB=$NA(^TMP("C0CCHK")) + S ZPAT=$O(^C0CE("B",DFN,"")) + K @ZGLB@(ZPAT) ; CLEAR PREVIOUS CHECKSUMS + S ZSRC="" + F S ZSRC=$O(^C0CE(ZPAT,1,"B",ZSRC)) Q:ZSRC="" D ; + . W "PAT:",ZPAT," SRC:",ZSRC,! + . S ZEL="" + . F S ZEL=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL)) Q:ZEL="" D ;ELEMENTS + . . W "ELEMENT:",ZEL," " + . . S ZELE=$$GET1^DIQ(170.101,ZEL,.01,"E") ;ELEMENT NAME + . . W ZELE," " + . . S ZELI=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL,"")) + . . S ZG=$NA(^C0CE(ZPAT,1,ZSRC,1,ZELI)) + . . S ZCHK=$$CHKSUM^XUSESIG1(ZG) ; CHECKSUM FOR THE ELEMENT + . . W ZCHK,! + . . S @ZGLB@(ZPAT,ZELE,ZSRC)=ZCHK + ZWR ^TMP("C0CCHK",ZPAT,*) + Q + ; +DOIT(DFN) ; EXPERIMENT FOR TIMING CALLS USING mumps -dir DOIT^C0CFM2(DFN) + D SETXUP + D CHKELS(DFN) + Q + ; +SETXUP ; SET UP ENVIRONMENT + S DISYS=19 + S DT=3090325 + S DTIME=300 + S DUZ=1 + S DUZ(0)="@" + S DUZ(1)="" + S DUZ(2)=7247 + S DUZ("AG")="I" + S DUZ("BUF")=1 + S DUZ("LANG")="" + S IO="/dev/pts/20" + S IO(0)="/dev/pts/20" + S IO(1,"/dev/pts/20")="" + S IO("ERROR")="" + S IO("HOME")="344^/dev/pts/20" + S IO("ZIO")="/dev/pts/20" + S IOBS="$C(8)" + S IOF="#,$C(27,91,50,74,27,91,72)" + S IOM=80 + S ION="TELNET" + S IOS=344 + S IOSL=24 + S IOST="C-VT100" + S IOST(0)=9 + S IOT="VTRM" + S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)" + S U="^" + S X="216;DIC(4.2," + S XPARSYS="216;DIC(4.2," + S XQXFLG="^^XUP" + Q + ; +PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE + ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE + ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE + ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC + ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM + ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT + ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES + ; + S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 + ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE + N ZF,ZFV S ZF=171.101 S ZFV=171.1011 + ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS + ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER + N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) + W "ZTYPE: ",ZTYPE," ",ZTYPN,! + N ZVARN ; IEN OF VARIABLE BEING PROCESSED + ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE + K C0CFDA + S C0CFDA(ZF,"?+1,",.01)=DFN + S C0CFDA(ZF,"?+1,",.02)=ZSRC + S C0CFDA(ZF,"?+1,",.03)=ZTYPN + S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE + K ZERR + ;B + D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER + I $D(ZERR) B ;OOPS + K C0CFDA + S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,"")) + W "RECORD NUMBER: ",ZD0,! + ;B + S ZCNT=0 + S ZC0CI="" ; + F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; + . I ZC0CI'="M" D ; NOT A SUBVARIABLE + . . S ZCNT=ZCNT+1 ;INCREMENT COUNT + . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT + . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND + . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN + . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) + . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN + . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) + ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" + ;S GT1(170,"?+1,",12)="DIR" + ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" + ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","","ZERR") + I $D(ZERR) D ; + . W "ERROR",! + . ZWR ZERR + . B + K C0CFDA + Q + ; +VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE + ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO + ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO + ; + N ZCCRD,ZVARN,C0CFDA2 + S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY + S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE + I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT + . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE + . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! + . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE + . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE + . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN + . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY + . I $D(ZERR) D ; LAYGO ERROR + . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! + . E D ; + . . D CLEAN^DILF ; CLEAN UP + . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE + . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! + Q ZVARN + ; +BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) + ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED + ; + N C0CDIC,C0CNODE ; + S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY + S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE + Q + ; +FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED + ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET + ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS + ; CONVERSION + ;N C0CC,C0CI,C0CJ,C0CN,C0CZX + D FIELDS^C0CRNF("C0CC",170) + S C0CI="" + F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION + . S C0CZX="" + . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE + . . W "SECTION ",C0CI," VAR ",C0CZX + . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) + . . W " TYPE: ",C0CV,! + . . D SETFDA("SECTION",C0CV) + . . ;ZWR C0CFDA + Q + ; +SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN + ; TO SET TO VALUE C0CSV. + ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE + ; C0CSN,C0CSV ARE PASSED BY VALUE + ; + N C0CSI,C0CSJ + S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER + S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER + S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV + Q +ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) + E S ZR="" + Q ZR +ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) + E S ZR="" + Q ZR + ; +ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) + E S ZR="" + Q ZR + ; Index: ccr/branches/ohum/p/C0CFM3.m =================================================================== --- ccr/branches/ohum/p/C0CFM3.m (revision 1333) +++ ccr/branches/ohum/p/C0CFM3.m (revision 1337) @@ -1,287 +1,287 @@ -C0CFM3 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is the CCR FILEMAN Utility Library ",! - ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF - ; CCR ELEMENTS (^C0C(179.201, - ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE - ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT - ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS - ; ALL SUB-VARIABLES HAVE BEEN REMOVED - W ! - Q - ; -RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE - ; ' - I '$D(RIMBASE) D ASETUP^GPLRIMA ; FOR COMMAND LINE CALLS - N ZI,ZJ,ZC,ZPATBASE - S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH)) - S ZI="" - F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END - . S ZI=$O(@ZPATBASE@(ZI)) - . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE - Q - ; -PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE - ; - S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN)) - I '$D(ZWHICH) S ZWHICH="ALL" - I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED - . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) - . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION - E D ; MULTIPLE SECTIONS - . S C0CVARS=$NA(@C0CGLB) - . S C0CI="" - . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION - . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION - . . D PUTRIM1(DFN,C0CI,C0CVARSN) - Q - ; -PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS - ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" - S C0CX=0 - F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE - . W "ZOCC=",C0CX,! - . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME - . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE - . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE - . I $D(C0CMDO) D ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :() - . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV - . . S ZZCNT=0 - . . S ZZC0CI=0 - . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE - . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE - . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR - . . W "MULTIPLE:",ZZVALS,! - . . ;B - . . F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE - . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT - . . . W "COUNT:",ZZCNT,! - . . . S ZV=$NA(@ZZVALS@(ZZC0CI)) - . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV) - Q - ; -PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE - ; 171.601, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE - ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE - ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC - ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM - ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT - ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES - ; - N ZSRC,PATN,ZTYPN,XD0,ZTYP - S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 - ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE - N C0CF S C0CF=171.601 ; FILE AT ELEMENT LEVEL - N C0CFV S C0CFV=171.6011 ; FILE AT VARIABLE LVL - N C0CFDA - N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) - W "ZTYPE: ",ZTYPE," ",ZTYPN,! - N ZVARN ; IEN OF VARIABLE BEING PROCESSED - ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE - S C0CFDA(C0CF,"+1,",.01)=ZTYPN - S C0CFDA(C0CF,"+1,",.02)=DFN - S C0CFDA(C0CF,"+1,",.03)=ZSRC - S C0CFDA(C0CF,"+1,",.04)=" "_ZOCC ;CREATE OCCURANCE with leading space - D UPDIE ; CREATE THE RECORD - S C0CIEN=$O(^C0CE4("C",DFN,ZSRC,ZTYPN," "_ZOCC,"")) - N ZCNT,ZC0CI,ZVARN,C0CZ1 - S ZCNT=0 - S ZC0CI="" ; - F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; - . I ZC0CI'="M" D ; NOT A SUBVARIABLE - . . S ZCNT=ZCNT+1 ;INCREMENT COUNT - . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT - . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND - . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",.01)=ZVARN - . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",1)=@ZVALS@(ZC0CI) - . E D ; THIS IS A SUBELEMENT - . . ;PUT THE FOLLOWING BACK TO USE RECURSION - . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV - . . ;S ZZCNT=0 - . . ;S ZZC0CI=0 - . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE - . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE - . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR - . . ;W "MULTIPLE:",ZZVALS,! - . . ;B - . . ;F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE - . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT - . . ;. W "COUNT:",ZZCNT,! - . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI)) - . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION - . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION) - D UPDIE ; UPDATE - Q - ; -UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS - K ZERR - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","","ZERR") - I $D(ZERR) D ; - . W "ERROR",! - . ZWR ZERR - . B - K C0CFDA - Q - ; -PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE - ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE - ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE - ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC - ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM - ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT - ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES - ; - S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 - ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE - N ZF,ZFV S ZF=171.101 S ZFV=171.1011 - ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS - ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER - N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) - W "ZTYPE: ",ZTYPE," ",ZTYPN,! - N ZVARN ; IEN OF VARIABLE BEING PROCESSED - ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE - K C0CFDA - S C0CFDA(ZF,"?+1,",.01)=DFN - S C0CFDA(ZF,"?+1,",.02)=ZSRC - S C0CFDA(ZF,"?+1,",.03)=ZTYPN - S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE - K ZERR - ;B - D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER - I $D(ZERR) B ;OOPS - K C0CFDA - S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,"")) - W "RECORD NUMBER: ",ZD0,! - ;B - S ZCNT=0 - S ZC0CI="" ; - F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; - . I ZC0CI'="M" D ; NOT A SUBVARIABLE - . . S ZCNT=ZCNT+1 ;INCREMENT COUNT - . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT - . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND - . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN - . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) - . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN - . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) - ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" - ;S GT1(170,"?+1,",12)="DIR" - ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" - ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","","ZERR") - I $D(ZERR) D ; - . W "ERROR",! - . ZWR ZERR - . B - K C0CFDA - Q - ; -VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE - ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO - ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO - ; - N ZCCRD,ZVARN,C0CFDA2 - S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY - S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE - I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT - . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE - . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! - . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE - . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE - . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN - . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY - . I $D(ZERR) D ; LAYGO ERROR - . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! - . E D ; - . . D CLEAN^DILF ; CLEAN UP - . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE - . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! - Q ZVARN - ; -BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) - ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED - ; - N C0CDIC,C0CNODE ; - S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY - S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE - Q - ; -FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED - ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET - ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS - ; CONVERSION - ;N C0CC,C0CI,C0CJ,C0CN,C0CZX - D FIELDS^C0CRNF("C0CC",170) - S C0CI="" - F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION - . S C0CZX="" - . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE - . . W "SECTION ",C0CI," VAR ",C0CZX - . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) - . . W " TYPE: ",C0CV,! - . . D SETFDA("SECTION",C0CV) - . . ;ZWR C0CFDA - Q - ; -SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN - ; TO SET TO VALUE C0CSV. - ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE - ; C0CSN,C0CSV ARE PASSED BY VALUE - ; - N C0CSI,C0CSJ - S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER - S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER - S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV - Q -ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) - E S ZR="" - Q ZR -ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) - E S ZR="" - Q ZR - ; -ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) - E S ZR="" - Q ZR - ; -SHOWE4(DFN) ; - ; - N ZG - S ZG="" - F S ZG=$O(^C0CE4("P",DFN,ZG)) Q:ZG="" D ZWR ^C0CE4(ZG,*) - Q - ; +C0CFM3 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is the CCR FILEMAN Utility Library ",! + ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF + ; CCR ELEMENTS (^C0C(179.201, + ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE + ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT + ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS + ; ALL SUB-VARIABLES HAVE BEEN REMOVED + W ! + Q + ; +RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE + ; ' + I '$D(RIMBASE) D ASETUP^GPLRIMA ; FOR COMMAND LINE CALLS + N ZI,ZJ,ZC,ZPATBASE + S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH)) + S ZI="" + F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END + . S ZI=$O(@ZPATBASE@(ZI)) + . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE + Q + ; +PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE + ; + S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN)) + I '$D(ZWHICH) S ZWHICH="ALL" + I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED + . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) + . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION + E D ; MULTIPLE SECTIONS + . S C0CVARS=$NA(@C0CGLB) + . S C0CI="" + . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION + . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION + . . D PUTRIM1(DFN,C0CI,C0CVARSN) + Q + ; +PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS + ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" + S C0CX=0 + F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE + . W "ZOCC=",C0CX,! + . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME + . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE + . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE + . I $D(C0CMDO) D ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :() + . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV + . . S ZZCNT=0 + . . S ZZC0CI=0 + . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE + . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE + . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR + . . W "MULTIPLE:",ZZVALS,! + . . ;B + . . F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE + . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT + . . . W "COUNT:",ZZCNT,! + . . . S ZV=$NA(@ZZVALS@(ZZC0CI)) + . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV) + Q + ; +PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE + ; 171.601, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE + ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE + ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC + ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM + ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT + ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES + ; + N ZSRC,PATN,ZTYPN,XD0,ZTYP + S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 + ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE + N C0CF S C0CF=171.601 ; FILE AT ELEMENT LEVEL + N C0CFV S C0CFV=171.6011 ; FILE AT VARIABLE LVL + N C0CFDA + N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) + W "ZTYPE: ",ZTYPE," ",ZTYPN,! + N ZVARN ; IEN OF VARIABLE BEING PROCESSED + ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE + S C0CFDA(C0CF,"+1,",.01)=ZTYPN + S C0CFDA(C0CF,"+1,",.02)=DFN + S C0CFDA(C0CF,"+1,",.03)=ZSRC + S C0CFDA(C0CF,"+1,",.04)=" "_ZOCC ;CREATE OCCURANCE with leading space + D UPDIE ; CREATE THE RECORD + S C0CIEN=$O(^C0CE4("C",DFN,ZSRC,ZTYPN," "_ZOCC,"")) + N ZCNT,ZC0CI,ZVARN,C0CZ1 + S ZCNT=0 + S ZC0CI="" ; + F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; + . I ZC0CI'="M" D ; NOT A SUBVARIABLE + . . S ZCNT=ZCNT+1 ;INCREMENT COUNT + . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT + . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND + . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",.01)=ZVARN + . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",1)=@ZVALS@(ZC0CI) + . E D ; THIS IS A SUBELEMENT + . . ;PUT THE FOLLOWING BACK TO USE RECURSION + . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV + . . ;S ZZCNT=0 + . . ;S ZZC0CI=0 + . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE + . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE + . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR + . . ;W "MULTIPLE:",ZZVALS,! + . . ;B + . . ;F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE + . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT + . . ;. W "COUNT:",ZZCNT,! + . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI)) + . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION + . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION) + D UPDIE ; UPDATE + Q + ; +UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS + K ZERR + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","","ZERR") + I $D(ZERR) D ; + . W "ERROR",! + . ZWR ZERR + . B + K C0CFDA + Q + ; +PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE + ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE + ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE + ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC + ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM + ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT + ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES + ; + S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 + ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE + N ZF,ZFV S ZF=171.101 S ZFV=171.1011 + ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS + ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER + N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) + W "ZTYPE: ",ZTYPE," ",ZTYPN,! + N ZVARN ; IEN OF VARIABLE BEING PROCESSED + ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE + K C0CFDA + S C0CFDA(ZF,"?+1,",.01)=DFN + S C0CFDA(ZF,"?+1,",.02)=ZSRC + S C0CFDA(ZF,"?+1,",.03)=ZTYPN + S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE + K ZERR + ;B + D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER + I $D(ZERR) B ;OOPS + K C0CFDA + S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,"")) + W "RECORD NUMBER: ",ZD0,! + ;B + S ZCNT=0 + S ZC0CI="" ; + F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; + . I ZC0CI'="M" D ; NOT A SUBVARIABLE + . . S ZCNT=ZCNT+1 ;INCREMENT COUNT + . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT + . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND + . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN + . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) + . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN + . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) + ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" + ;S GT1(170,"?+1,",12)="DIR" + ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" + ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","","ZERR") + I $D(ZERR) D ; + . W "ERROR",! + . ZWR ZERR + . B + K C0CFDA + Q + ; +VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE + ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO + ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO + ; + N ZCCRD,ZVARN,C0CFDA2 + S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY + S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE + I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT + . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE + . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! + . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE + . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE + . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN + . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY + . I $D(ZERR) D ; LAYGO ERROR + . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! + . E D ; + . . D CLEAN^DILF ; CLEAN UP + . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE + . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! + Q ZVARN + ; +BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) + ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED + ; + N C0CDIC,C0CNODE ; + S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY + S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE + Q + ; +FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED + ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET + ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS + ; CONVERSION + ;N C0CC,C0CI,C0CJ,C0CN,C0CZX + D FIELDS^C0CRNF("C0CC",170) + S C0CI="" + F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION + . S C0CZX="" + . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE + . . W "SECTION ",C0CI," VAR ",C0CZX + . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) + . . W " TYPE: ",C0CV,! + . . D SETFDA("SECTION",C0CV) + . . ;ZWR C0CFDA + Q + ; +SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN + ; TO SET TO VALUE C0CSV. + ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE + ; C0CSN,C0CSV ARE PASSED BY VALUE + ; + N C0CSI,C0CSJ + S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER + S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER + S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV + Q +ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) + E S ZR="" + Q ZR +ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) + E S ZR="" + Q ZR + ; +ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) + E S ZR="" + Q ZR + ; +SHOWE4(DFN) ; + ; + N ZG + S ZG="" + F S ZG=$O(^C0CE4("P",DFN,ZG)) Q:ZG="" D ZWR ^C0CE4(ZG,*) + Q + ; Index: ccr/branches/ohum/p/C0CIM2.m =================================================================== --- ccr/branches/ohum/p/C0CIM2.m (revision 1333) +++ ccr/branches/ohum/p/C0CIM2.m (revision 1337) @@ -1,133 +1,133 @@ -C0CIM2 ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10 - ;;1.0;C0C;;Feb 16, 2010;Build 1 - ;Copyright 2010 George Lilly, University of Minnesota and others. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(IMMXML,DFN,IMMOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE - ; IMMXML AND IMMOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED - ; - ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS - ; THAT GET PASSED TO *GET ROUTINES - ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME)) - N C0CIMM - S C0CIMM=$NA(^TMP("C0CCCR",$J,DFN,"C0CIMM")) - ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS - ; THAT GET INSERTED INTO THE XML TEMPLATE - ; I '$D(@C0CIMM) D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS IF NOT THERE - D GETRPMS(DFN,C0CIMM) ; GET VARS IF NOT THERE - ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE - ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES - D MAP(IMMXML,C0CIMM,IMMOUT) ;MAP RESULTS FOR PROCEDURES - Q - ; -GETRPMS(DFN,C0CIMM) ; CALLS GET^BGOVIMM TO GET IMMUNIZATIONS. - ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME - ; C0CIMM: IMMUNIZATIONS - ; READY TO BE MAPPED TO XML BY MAP^C0CIMM - ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY - ; EXIST. - ; - ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J)) - ; - ; SETUP RPC/API CALL HERE - ; USE START AND END DATES FROM PARAMETERS IF REQUIRED - N IMMA - D GET^BGOVIMM(.IMMA,DFN) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE - ; PREFORM SORT HERE IF NEEDED - ; - ; NO SORT REQUIRED FOR IMMUNIZATIONS - ; - ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY - ; RNF1 ARRAY FORMAT: - ; VAR("NAME_OF_RIM_VARIABLE")=VALUE - ; - ; IMMUNIZATIONS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF IMMUNIZATION RESULTS - ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD - ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS - N C0CIM,C0CC,ZRNF - S C0CIM="" ; INITIALIZE FOR $O - F C0CC=1:1 S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM="" D ; FOR EACH IMMUNE TYPE IN THE LIST - . I DEBUG W @IMMA@(C0CIM),! - . ; FIGURE OUT WHICH TYPE OF IMMUNIZATION IT IS (IMMUNIZATION, FORECAST, CONTRAINDICATIONS, REFUSALS) - . D:$P(@IMMA@(C0CIM),U,1)="I" IMMUN - . D:$P(@IMMA@(C0CIM),U,1)="F" FORECAST - . D:$P(@IMMA@(C0CIM),U,1)="C" CONTRA - . D:$P(@IMMA@(C0CIM),U,1)="R" REFUSE - . D RNF1TO2^C0CRNF(C0CIMM,"ZRNF") ;ADD THIS ROW TO THE ARRAY - . K ZRNF - ; SAVE RIM VARIABLES SEE C0CRIMA - N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE")) - M @ZRIM=@C0CIMM@("V") - Q - ; -IMMUN ; PARSES IMMUNIZATION TYPE ROWS FOR RPMS - ; RPC FORMAT - ; I ^ Imm Name [2] ^ Visit Date [3] ^ V File IEN [4] ^ Other Location [5] ^ Group [6] ^ Imm IEN [7] ^ Lot [8] ^ - ; Reaction [9] ^ VIS Date [10] ^ Age [11] ^ Visit Date [12] ^ Provider IEN~Name [13] ^ Inj Site [14] ^ - ; Volume [15] ^ Visit IEN [16] ^ Visit Category [17] ^ Full Name [18] ^ Location IEN~Name [19] ^ Visit Locked [20] - ; RETRIEVE IMMUNIZATION RECORD FROM IMMUNIZATION FILE (9999999.14) FOR THIS IMMUNIZATION - D GETN^C0CRNF("C0CZIM",9999999.14,$P(@IMMA@(C0CIM),U,7)) ; GET IMMUNIZATION RECORD - ; RETIREVE IMMUNIZATION RECORD FROM V IMMUNIZATION FILE (9000010.11) FOR THIS IMMUNIZATION - D GETN^C0CRNF("C0CZVI",9000010.11,$P(@IMMA@(C0CIM),U,4)) ; GET V IMMUNIZATION RECORD - S ZRNF("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID - S ZRNF("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME - S ZRNF("IMMUNEDATETIME")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("EVENT DATE AND TIME","C0CZVI"),"DT") - S ZRNF("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_$P($P(@IMMA@(C0CIM),U,13),"~",1) - S ZRNF("IMMUNEPRODUCTNAMETEXT")=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD - S ZRNF("IMMUNEPRODUCTCODE")=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE - I $$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM")'="" S ZRNF("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code" - E S ZRNF("IMMUNEPRODUCTCODESYSTEM")="" ;NULL - ;CLEANUP FROM C0CRNF CALLS - K C0CZIM,C0CZVI - Q -FORECAST ; PARSES FORECAST TYPE ROWS FOR RPMS - ; CURRENTLY DISABLED - Q -CONTRA ; PARSES FORECAST TYPE ROWS FOR RPMS - ; CURRENTLY DISABLED - Q -REFUSE ; PARSES FORECAST TYPE ROWS FOR RPMS - ; CURRENTLY DISABLED - Q - ; -MAP(IMMXML,C0CIMM,IMMOUT) ; MAP IMMUNIZATION XML - ; - N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"IMMTEMP")) ;WORK AREA FOR TEMPLATE - K @ZTEMP - N ZBLD - S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"IMMBLD")) ; BUILD LIST AREA - D QUEUE^C0CXPATH(ZBLD,IMMXML,1,1) ; FIRST LINE - N ZINNER - ; XPATH NEEDS TO MATCH YOUR SECTION - D QUERY^C0CXPATH(IMMXML,"//Immunizations/Immunization","ZINNER") ;ONE PROC - N ZTMP,ZVAR,ZI - S ZI="" - F S ZI=$O(@C0CIMM@("V",ZI)) Q:ZI="" D ;FOR EACH IMMUNIZATION - . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS IMMUNIZATION XML - . S ZVAR=$NA(@C0CIMM@("V",ZI)) ;THIS IMMUNIZATION VARIABLES - . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE IMMUNIZATION - . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD - D QUEUE^C0CXPATH(ZBLD,IMMXML,@IMMXML@(0),@IMMXML@(0)) - N ZZTMP ; IS THIS NEEDED? - D BUILD^C0CXPATH(ZBLD,IMMOUT) ;BUILD FINAL XML - K @ZTEMP,@ZBLD - Q - ; +C0CIM2 ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10 + ;;1.0;C0C;;Feb 16, 2010;Build 38 + ;Copyright 2010 George Lilly, University of Minnesota and others. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(IMMXML,DFN,IMMOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE + ; IMMXML AND IMMOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; + ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS + ; THAT GET PASSED TO *GET ROUTINES + ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME)) + N C0CIMM + S C0CIMM=$NA(^TMP("C0CCCR",$J,DFN,"C0CIMM")) + ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS + ; THAT GET INSERTED INTO THE XML TEMPLATE + ; I '$D(@C0CIMM) D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS IF NOT THERE + D GETRPMS(DFN,C0CIMM) ; GET VARS IF NOT THERE + ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE + ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES + D MAP(IMMXML,C0CIMM,IMMOUT) ;MAP RESULTS FOR PROCEDURES + Q + ; +GETRPMS(DFN,C0CIMM) ; CALLS GET^BGOVIMM TO GET IMMUNIZATIONS. + ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME + ; C0CIMM: IMMUNIZATIONS + ; READY TO BE MAPPED TO XML BY MAP^C0CIMM + ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY + ; EXIST. + ; + ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J)) + ; + ; SETUP RPC/API CALL HERE + ; USE START AND END DATES FROM PARAMETERS IF REQUIRED + N IMMA + D GET^BGOVIMM(.IMMA,DFN) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE + ; PREFORM SORT HERE IF NEEDED + ; + ; NO SORT REQUIRED FOR IMMUNIZATIONS + ; + ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY + ; RNF1 ARRAY FORMAT: + ; VAR("NAME_OF_RIM_VARIABLE")=VALUE + ; + ; IMMUNIZATIONS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF IMMUNIZATION RESULTS + ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD + ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS + N C0CIM,C0CC,ZRNF + S C0CIM="" ; INITIALIZE FOR $O + F C0CC=1:1 S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM="" D ; FOR EACH IMMUNE TYPE IN THE LIST + . I DEBUG W @IMMA@(C0CIM),! + . ; FIGURE OUT WHICH TYPE OF IMMUNIZATION IT IS (IMMUNIZATION, FORECAST, CONTRAINDICATIONS, REFUSALS) + . D:$P(@IMMA@(C0CIM),U,1)="I" IMMUN + . D:$P(@IMMA@(C0CIM),U,1)="F" FORECAST + . D:$P(@IMMA@(C0CIM),U,1)="C" CONTRA + . D:$P(@IMMA@(C0CIM),U,1)="R" REFUSE + . D RNF1TO2^C0CRNF(C0CIMM,"ZRNF") ;ADD THIS ROW TO THE ARRAY + . K ZRNF + ; SAVE RIM VARIABLES SEE C0CRIMA + N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE")) + M @ZRIM=@C0CIMM@("V") + Q + ; +IMMUN ; PARSES IMMUNIZATION TYPE ROWS FOR RPMS + ; RPC FORMAT + ; I ^ Imm Name [2] ^ Visit Date [3] ^ V File IEN [4] ^ Other Location [5] ^ Group [6] ^ Imm IEN [7] ^ Lot [8] ^ + ; Reaction [9] ^ VIS Date [10] ^ Age [11] ^ Visit Date [12] ^ Provider IEN~Name [13] ^ Inj Site [14] ^ + ; Volume [15] ^ Visit IEN [16] ^ Visit Category [17] ^ Full Name [18] ^ Location IEN~Name [19] ^ Visit Locked [20] + ; RETRIEVE IMMUNIZATION RECORD FROM IMMUNIZATION FILE (9999999.14) FOR THIS IMMUNIZATION + D GETN^C0CRNF("C0CZIM",9999999.14,$P(@IMMA@(C0CIM),U,7)) ; GET IMMUNIZATION RECORD + ; RETIREVE IMMUNIZATION RECORD FROM V IMMUNIZATION FILE (9000010.11) FOR THIS IMMUNIZATION + D GETN^C0CRNF("C0CZVI",9000010.11,$P(@IMMA@(C0CIM),U,4)) ; GET V IMMUNIZATION RECORD + S ZRNF("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID + S ZRNF("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME + S ZRNF("IMMUNEDATETIME")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("EVENT DATE AND TIME","C0CZVI"),"DT") + S ZRNF("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_$P($P(@IMMA@(C0CIM),U,13),"~",1) + S ZRNF("IMMUNEPRODUCTNAMETEXT")=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD + S ZRNF("IMMUNEPRODUCTCODE")=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE + I $$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM")'="" S ZRNF("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code" + E S ZRNF("IMMUNEPRODUCTCODESYSTEM")="" ;NULL + ;CLEANUP FROM C0CRNF CALLS + K C0CZIM,C0CZVI + Q +FORECAST ; PARSES FORECAST TYPE ROWS FOR RPMS + ; CURRENTLY DISABLED + Q +CONTRA ; PARSES FORECAST TYPE ROWS FOR RPMS + ; CURRENTLY DISABLED + Q +REFUSE ; PARSES FORECAST TYPE ROWS FOR RPMS + ; CURRENTLY DISABLED + Q + ; +MAP(IMMXML,C0CIMM,IMMOUT) ; MAP IMMUNIZATION XML + ; + N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"IMMTEMP")) ;WORK AREA FOR TEMPLATE + K @ZTEMP + N ZBLD + S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"IMMBLD")) ; BUILD LIST AREA + D QUEUE^C0CXPATH(ZBLD,IMMXML,1,1) ; FIRST LINE + N ZINNER + ; XPATH NEEDS TO MATCH YOUR SECTION + D QUERY^C0CXPATH(IMMXML,"//Immunizations/Immunization","ZINNER") ;ONE PROC + N ZTMP,ZVAR,ZI + S ZI="" + F S ZI=$O(@C0CIMM@("V",ZI)) Q:ZI="" D ;FOR EACH IMMUNIZATION + . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS IMMUNIZATION XML + . S ZVAR=$NA(@C0CIMM@("V",ZI)) ;THIS IMMUNIZATION VARIABLES + . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE IMMUNIZATION + . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD + D QUEUE^C0CXPATH(ZBLD,IMMXML,@IMMXML@(0),@IMMXML@(0)) + N ZZTMP ; IS THIS NEEDED? + D BUILD^C0CXPATH(ZBLD,IMMOUT) ;BUILD FINAL XML + K @ZTEMP,@ZBLD + Q + ; Index: ccr/branches/ohum/p/C0CIMMU.m =================================================================== --- ccr/branches/ohum/p/C0CIMMU.m (revision 1333) +++ ccr/branches/ohum/p/C0CIMMU.m (revision 1337) @@ -1,107 +1,107 @@ -C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008,2009 George Lilly, University of Minnesota. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; - ; PROCESS THE IMMUNIZATIONS SECTION OF THE CCR - ; -MAP(IPXML,DFN,OUTXML) ; MAP IMMUNIZATIONS - ; - N C0CZV,C0CZVI ; TO STORE MAPPED VARIABLES - N C0CZT ; TMP ARRAY OF MAPPED XML - S C0CZV=$NA(^TMP("C0CCCR",$J,"IMMUNE")) ; TEMP STORAGE FOR VARIABLES - D EXTRACT(IPXML,DFN,OUTXML) ;EXTRACT THE VARIABLES - N C0CZI,C0CZIC ; COUNT OF IMMUNIZATIONS - S C0CZIC=$G(@C0CZV@(0)) ; TOTAL FROM VARIABLE ARRAY - I C0CZIC>0 D ;IMMUNIZATIONS FOUND - . F C0CZI=1:1:C0CZIC D ;FOR EACH IMMUNIZATION - . . S C0CZVI=$NA(@C0CZV@(C0CZI)) ;THIS IMMUNIZATION - . . D MAP^C0CXPATH(IPXML,C0CZVI,"C0CZT") ;MAP THE VARIABLES TO XML - . . I C0CZI=1 D ; FIRST ONE - . . . D CP^C0CXPATH("C0CZT",OUTXML) ;JUST COPY RESULTS - . . E D ;NOT THE FIRST - . . . D INSINNER^C0CXPATH(OUTXML,"C0CZT") - E S @OUTXML@(0)=0 ; SIGNAL NO IMMUNIZATIONS - N IMMUTMP,I - D MISSING^C0CXPATH(OUTXML,"IMMUTMP") ; SEARCH XML FOR MISSING VARS - I IMMUTMP(0)>0 D ; IF THERE ARE MISSING VARS - - . ; STRINGS MARKED AS @@X@@ - . W !,"IMMUNE Missing list: ",! - . F I=1:1:IMMUTMP(0) W IMMUTMP(I),! - Q - ; -EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT IMMUNIZATIONS INTO VARIABLES - ; - ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED - ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE - ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE - ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS - ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT - ; - N RPCRSLT,J,K,PTMP,X,VMAP,TBU - S TVMAP=$NA(^TMP("C0CCCR",$J,"IMMUNE")) - S TARYTMP=$NA(^TMP("C0CCCR",$J,"IMMUARYTMP")) - S IMMA=$NA(^TMP("PXI",$J)) ; - K @IMMA ; CLEAR OUT PREVIOUS RESULTS - K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES - D IMMUN^PXRHS03(DFN) ; - I $O(@IMMA@(""))="" D Q ; RPC RETURNS NULL - . W "NULL RESULT FROM IMMUN^PXRHS03 ",! - . S @TVMAP@(0)=0 - N C0CIM,C0CC,C0CIMD,C0CIEN,C0CT ; - S C0CIM="" - S C0CC=0 ; COUNT - F S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM="" D ; FOR EACH IMMUNE TYPE IN THE LIST - . S C0CC=C0CC+1 ;INCREMENT COUNT - . S @TVMAP@(0)=C0CC ; SAVE NEW COUNT TO ARRAY - . S VMAP=$NA(@TVMAP@(C0CC)) ; THIS IMMUNE ELEMENT - . K @VMAP ; MAKE SURE IT IS CLEARED OUT - . W C0CIM,! - . S C0CIMD="" ; IMMUNE DATE - . F S C0CIMD=$O(@IMMA@(C0CIM,C0CIMD)) Q:C0CIMD="" D ; FOR EACH DATE - . . S C0CIEN=$O(@IMMA@(C0CIM,C0CIMD,"")) ;IEN OF IMMUNE RECORD - . . D GETN^C0CRNF("C0CI",9000010.11,C0CIEN) ; GET THE FILEMAN RECORD FOR IENS - . . W C0CIEN,"_",C0CIMD - . . S C0CT=$$FMDTOUTC^C0CUTIL(9999999-C0CIMD,"DT") ; FORMAT DATE/TIME - . . W C0CT,! - . . S @VMAP@("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID - . . S @VMAP@("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME - . . S @VMAP@("IMMUNEDATETIME")=C0CT ;FORMATTED DATE/TIME - . . S C0CIP=$$ZVALUEI^C0CRNF("ENCOUNTER PROVIDER","C0CI") ;IEN OF PROVIDER - . . S @VMAP@("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_C0CIP - . . S C0CIIEN=$$ZVALUEI^C0CRNF("IMMUNIZATION","C0CI") ;IEN OF IMMUNIZATION - . . I $G(DUZ("AG"))="I" D ; RUNNING IN RPMS - . . . D GETN^C0CRNF("C0CZIM",9999999.14,C0CIIEN) ;GET IMMUNE RECORD - . . . S C0CIN=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD - . . . ; FOR LOOKING UP THE CODE - . . . ; GET IT FROM THE CODE FILE - . . . S C0CICD=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE - . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME - . . . S @VMAP@("IMMUNEPRODUCTCODE")=C0CICD ; CVX CODE - . . . I C0CICD'="" S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code" ; - . . . E S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NULL - . . E D ; NOT IN RPMS - . . . S C0CIN=$$ZVALUE^C0CRNF("IMMUNIZATION","C0CI") ;NAME OF IMMUNIZATION - . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME - . . . S @VMAP@("IMMUNEPRODUCTCODE")="" ; CVX CODE - . . . S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NO CODE - N C0CIRIM S C0CIRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE")) - M @C0CIRIM=@TVMAP ; PERSIST RIM VARIABLES - Q - ; +C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008,2009 George Lilly, University of Minnesota. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; + ; PROCESS THE IMMUNIZATIONS SECTION OF THE CCR + ; +MAP(IPXML,DFN,OUTXML) ; MAP IMMUNIZATIONS + ; + N C0CZV,C0CZVI ; TO STORE MAPPED VARIABLES + N C0CZT ; TMP ARRAY OF MAPPED XML + S C0CZV=$NA(^TMP("C0CCCR",$J,"IMMUNE")) ; TEMP STORAGE FOR VARIABLES + D EXTRACT(IPXML,DFN,OUTXML) ;EXTRACT THE VARIABLES + N C0CZI,C0CZIC ; COUNT OF IMMUNIZATIONS + S C0CZIC=$G(@C0CZV@(0)) ; TOTAL FROM VARIABLE ARRAY + I C0CZIC>0 D ;IMMUNIZATIONS FOUND + . F C0CZI=1:1:C0CZIC D ;FOR EACH IMMUNIZATION + . . S C0CZVI=$NA(@C0CZV@(C0CZI)) ;THIS IMMUNIZATION + . . D MAP^C0CXPATH(IPXML,C0CZVI,"C0CZT") ;MAP THE VARIABLES TO XML + . . I C0CZI=1 D ; FIRST ONE + . . . D CP^C0CXPATH("C0CZT",OUTXML) ;JUST COPY RESULTS + . . E D ;NOT THE FIRST + . . . D INSINNER^C0CXPATH(OUTXML,"C0CZT") + E S @OUTXML@(0)=0 ; SIGNAL NO IMMUNIZATIONS + N IMMUTMP,I + D MISSING^C0CXPATH(OUTXML,"IMMUTMP") ; SEARCH XML FOR MISSING VARS + I IMMUTMP(0)>0 D ; IF THERE ARE MISSING VARS - + . ; STRINGS MARKED AS @@X@@ + . W !,"IMMUNE Missing list: ",! + . F I=1:1:IMMUTMP(0) W IMMUTMP(I),! + Q + ; +EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT IMMUNIZATIONS INTO VARIABLES + ; + ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE + ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE + ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS + ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT + ; + N RPCRSLT,J,K,PTMP,X,VMAP,TBU + S TVMAP=$NA(^TMP("C0CCCR",$J,"IMMUNE")) + S TARYTMP=$NA(^TMP("C0CCCR",$J,"IMMUARYTMP")) + S IMMA=$NA(^TMP("PXI",$J)) ; + K @IMMA ; CLEAR OUT PREVIOUS RESULTS + K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES + D IMMUN^PXRHS03(DFN) ; + I $O(@IMMA@(""))="" D Q ; RPC RETURNS NULL + . W "NULL RESULT FROM IMMUN^PXRHS03 ",! + . S @TVMAP@(0)=0 + N C0CIM,C0CC,C0CIMD,C0CIEN,C0CT ; + S C0CIM="" + S C0CC=0 ; COUNT + F S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM="" D ; FOR EACH IMMUNE TYPE IN THE LIST + . S C0CC=C0CC+1 ;INCREMENT COUNT + . S @TVMAP@(0)=C0CC ; SAVE NEW COUNT TO ARRAY + . S VMAP=$NA(@TVMAP@(C0CC)) ; THIS IMMUNE ELEMENT + . K @VMAP ; MAKE SURE IT IS CLEARED OUT + . W C0CIM,! + . S C0CIMD="" ; IMMUNE DATE + . F S C0CIMD=$O(@IMMA@(C0CIM,C0CIMD)) Q:C0CIMD="" D ; FOR EACH DATE + . . S C0CIEN=$O(@IMMA@(C0CIM,C0CIMD,"")) ;IEN OF IMMUNE RECORD + . . D GETN^C0CRNF("C0CI",9000010.11,C0CIEN) ; GET THE FILEMAN RECORD FOR IENS + . . W C0CIEN,"_",C0CIMD + . . S C0CT=$$FMDTOUTC^C0CUTIL(9999999-C0CIMD,"DT") ; FORMAT DATE/TIME + . . W C0CT,! + . . S @VMAP@("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID + . . S @VMAP@("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME + . . S @VMAP@("IMMUNEDATETIME")=C0CT ;FORMATTED DATE/TIME + . . S C0CIP=$$ZVALUEI^C0CRNF("ENCOUNTER PROVIDER","C0CI") ;IEN OF PROVIDER + . . S @VMAP@("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_C0CIP + . . S C0CIIEN=$$ZVALUEI^C0CRNF("IMMUNIZATION","C0CI") ;IEN OF IMMUNIZATION + . . I $G(DUZ("AG"))="I" D ; RUNNING IN RPMS + . . . D GETN^C0CRNF("C0CZIM",9999999.14,C0CIIEN) ;GET IMMUNE RECORD + . . . S C0CIN=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD + . . . ; FOR LOOKING UP THE CODE + . . . ; GET IT FROM THE CODE FILE + . . . S C0CICD=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE + . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME + . . . S @VMAP@("IMMUNEPRODUCTCODE")=C0CICD ; CVX CODE + . . . I C0CICD'="" S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code" ; + . . . E S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NULL + . . E D ; NOT IN RPMS + . . . S C0CIN=$$ZVALUE^C0CRNF("IMMUNIZATION","C0CI") ;NAME OF IMMUNIZATION + . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME + . . . S @VMAP@("IMMUNEPRODUCTCODE")="" ; CVX CODE + . . . S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NO CODE + N C0CIRIM S C0CIRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE")) + M @C0CIRIM=@TVMAP ; PERSIST RIM VARIABLES + Q + ; Index: ccr/branches/ohum/p/C0CIN.m =================================================================== --- ccr/branches/ohum/p/C0CIN.m (revision 1333) +++ ccr/branches/ohum/p/C0CIN.m (revision 1337) @@ -1,193 +1,193 @@ -C0CIN ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08 - ;;1.0;C0C;;Sep 20, 2009;Build 1 - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is the CCR Import Utility Library ",! - Q - ; -TEST ; TESTS BOTH ROUTINES AT ONCE - N ZI,ZJ - S ZI="/home/vademo2/CCR" ;directory purposely leaving off the trailing / - S ZJ="PAT_358_CCR_V1_0_21.xml" ; random test patient - D RPCFIN(.GPL,358,135,"GPLTEST","CCR",ZJ,ZI) - Q - ; -RPCAIN(RTN,DFN,DUZ,SOURCE,TYPE,ARY) ; ARRAY IN RPC - ACCEPT AN XML DOCUMENT - ; AND STORE IT IN THE INCOMING XML FILE - ; RETURNS THE IEN OF THE RECORD OR TEXT IF THERE IS AN ERROR - I $G(DFN)="" S RTN="DFN NOT DEFINED" Q ; - N C0CXF S C0CXF=175 ; FILE NUMBER FOR INCOMING XML FILE - N C0CFDA,ZX - S C0CFDA(C0CXF,"+1,",.01)=DFN ; PATIENT - S C0CFDA(C0CXF,"+1,",.02)=DUZ ; PROVIDER CREATING THE RECORD - S C0CFDA(C0CXF,"+1,",1)=$$NOW^XLFDT ;DATE - S C0CFDA(C0CXF,"+1,",2)=TYPE ;TYPE - S C0CFDA(C0CXF,"+1,",3)=$$ADDSRC(SOURCE) ;SOURCE - S C0CFDA(C0CXF,"+1,",7)="NEW" ; STATUS OF NEW FOR NOT PROCESSED - D UPDIE ; CREATE THE RECORD - S ZX=C0CIEN(1) ; CAPTURE THE RECORD NUMBER - D WP^DIE(C0CXF,ZX_",",4,,ARY,"ZERR") - ;W "RECORD:",ZX,! - S RTN=ZX ; RETURN IEN OF THE XML FILE - Q - ; -ADDSRC(ZSRC) ;EXTRISIC TO ADD A SOURCE TO THE CCR SOURCE FILE - ; RETURNS RECORD NUMBER. IF SOURCE EXISTS, JUST RETURNS IT'S RECORD NUMBER - ; - N ZX,ZF,C0CFDA - S ZF=171.401 ; FILE NUMBER FOR CCR SOURCE FILE - S C0CFDA(ZF,"?+1,",.01)=ZSRC - D UPDIE - Q $O(^C0C(171.401,"B",ZSRC,"")) - ; -RPCFIN(RTN,DFN,DUZ,SOURCE,TYPE,FN,FP) ; FILE IN RPC - READ AN XML DOCUMENT - ; FROM A HOST FILE AND STORE IT IN THE INCOMING XML FILE - N ZX,ZTMP - I $E($RE(FP))'="/" S ZX=FP_"/" - E S ZX=FP - S ZX=ZX_FN - D LOAD("ZTMP",ZX) - I '$D(ZTMP) D Q ; NO LUCK - . W "FILE NOT LOADED",! - D RPCAIN(.RTN,DFN,DUZ,SOURCE,TYPE,"ZTMP") - N C0CFDA - S C0CFDA(175,RTN_",",5)=FN ; FILE NAME - S C0CFDA(175,RTN_",",6)=FP ; FILE PATH - D UPDIE ; UPDATE WITH FILE NAME AND PATH - Q - ; -RPCLIST(RTN,DFN) ; CCR LIST - LIST XML DOCUMENTS FOR PATIENT DFN - ; THAT ARE STORED IN THE INCOMING XML FILE - ; RETURNS AN ARRAY OF THE FORM - ; RTN(x)="IEN^DATE^TYPE^SOURCE^STATUS^CREATEDBY" WHERE - ; IEN IS THE RECORD NUMBER OF THE XML DOCUMENT - ; DATE IS THE DATE THE DOCUMENT WAS STORED IN THE FILE - ; TYPE IS "CCD" OR "CCR" OR "OTHER" - ; SOURCE IS THE NAME OF THE DOCUMENT SOURCE FROM THE CCR SOURCE FILE - ; STATUS IS THE STATUS OF THE DOCUMENT (VALUES TO BE DEFINED) - ; CREATEDBY IS THE NAME OF THE PROVIDER WHO UPLOADED THE XML - N ZF S ZF=175 ; FILE NUMBER OF INCOMING XML FILE - N ZI S ZI="" - N ZN S ZN=0 - F S ZI=$O(^C0CIN("B",DFN,ZI),-1) Q:ZI="" D ; FOR EACH RECORD FOR THIS PATIENT - . S ZN=ZN+1 ;INCREMENT COUNT OF RETURN ARRAY - . S $P(RTN(ZN),"^",1)=ZI ; IEN OF RECORD - . S $P(RTN(ZN),"^",2)=$$GET1^DIQ(ZF,ZI_",",1,"E") ;DATE - . S $P(RTN(ZN),"^",3)=$$GET1^DIQ(ZF,ZI_",",2,"E") ;TYPE - . S $P(RTN(ZN),"^",4)=$$GET1^DIQ(ZF,ZI_",",3,"E") ;SOURCE - . S $P(RTN(ZN),"^",5)=$$GET1^DIQ(ZF,ZI_",",7,"I") ; STATUS - . S $P(RTN(ZN),"^",6)=$$GET1^DIQ(ZF,ZI_",",.02,"E") ; CREATED BY - Q - ; -RPCDOC(RTN,IEN) ; RETRIEVE DOCUMENT NUMBER IEN FROM THE INCOMING XML FILE - ; RETURNED IN ARRAY RTN - N ZI - S ZI=$$GET1^DIQ(175,IEN_",",4,,"RTN") - Q - ; -EN(INXML,SOURCE,C0CDFN) ; IMPORT A CCR, PASSED BY NAME INXML - ; FILE UNDER SOURCE, WHICH IS A POINTER TO THE CCR SOURCE FILE - ; FOR PATIENT C0CDFN - ;N C0CXP - S C0CINB=$NA(^TMP("C0CIN",$J,"VARS",C0CDFN)) - S C0CDOCID=$$PARSE^C0CMXML(INXML) ;W !,"DocID: ",C0CDOCID - ;S REDUX="//ContinuityOfCareRecord/Body" - S REDUX="" - D XPATH^C0CMXML(1,"/","C0CIDX","C0CXP",,REDUX) - ;D INDEX^C0CXPATH(INXML,"C0CXP",-1) ; GENERATE XPATHS FROM THE CCR - ;N ZI,ZJ,ZK - S ZI="" - F S ZI=$O(C0CXP(ZI)) Q:ZI="" D ; FOR EACH XPATH - . D DEMUX^C0CMXP("ZJ",ZI) ; - . W ZJ,! - . S ZK=$P(ZJ,"^",3) ; PULL OUT THE XPATH - . S ZM=$P(ZJ,"^",1) ; PULL OUT THE MULTIPLE - . S ZS=$P(ZJ,"^",2) ; PULL OUT THE SUBMULTIPLE - . S C0CDICN=$O(^C0CDIC(170,"XPATH",ZK,"")) - . I C0CDICN="" D Q ; - . . W "MISSING XPATH:",!,ZK,! ; OOPS, XPATH NOT IN C0CDIC - . . S MISSING(ZK)="" - . ;D GETS^DIQ(170,C0CDICN_",","*",,"C0CFDA") - . S C0CVAR=$$GET1^DIQ(170,C0CDICN_",",.01) ; VARIABLE NAME - . S C0CSEC=$$GET1^DIQ(170,C0CDICN_",",12) ;ELEMENT TYPE - . W C0CSEC,":",C0CVAR,! - Q - ; -GETACCR(AOUT,C0CDFN) ; EXTRACT A CCR FOR PATIENT ADFN AND PUT IT IN ARRAY AOUT - ;PASSED BY NAME - N ZT - D CCRRPC^C0CCCR(.ZT,C0CDFN,"LABLIMIT:T-1000") - M @AOUT=ZT - Q - ; -TEST64 ;TEST BASE64 DECODING FOR IMPORTING CCR FROM THE NHIN - W $$FTG^%ZISH("/tmp/","base64_encoded_ccr.txt","G64(1)",1) - S G=G64(1) - S ZI="" - F S ZI=$O(G64(1,"OVF",ZI)) Q:ZI="" D ; FOR EVERY OVERFLOW RECORD - . S G=G_G64(1,"OVF",ZI) ;HOPE IT'S NOT TOO BIG - S G2=$$DECODE^RGUTUU(G) - Q - ; -NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML - ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME - ; - N ZI,ZN,ZTMP - S ZN=1 - S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">" - S ZN=ZN+1 - F S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)="" D ; - . S @OUTXML@(ZN)=@OUTXML@(ZN)_">" - . S ZN=ZN+1 - Q - ; -CLEANCR(OUTXML,INXML) ; USE $C(10) TO SEPARATE THE STRING INXML INTO - ;AN ARRAY OUTXML(n) OUTXML AND INXML PASSED BY NAME - N ZX,ZY,ZN - S ZX=1,ZN=1 - F S ZY=$F(@INXML,$C(10),ZX) Q:ZY=0 D ; - . S @OUTXML@(ZN)=$E(G2,ZX,ZY-2) - . I @OUTXML@(ZN)'="" S ZN=ZN+1 - . S ZX=ZY - Q - ; -LOAD(ZRTN,filepath) ; load an xml file into the ZRTN array, passed by name - n i - D ; - . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)="" - . s ztmp=$na(^TMP("C0CLOAD",$J)) - . k @ztmp - . s zfile=$re($p($re(filepath),"/",1)) ;file name - . s zpath=$p(filepath,zfile,1) ; file path - . s zok=$$FTG^%ZISH(zpath,zfile,$NA(@ztmp@(1)),3) ; import the file incr sub 3 - . m @ZRTN=@ztmp - . k @ztmp - . s i=$o(@ZRTN@(""),-1) ; highest line number - q - ; -UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS - K ZERR,C0CIEN - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","C0CIEN","ZERR") - I $D(ZERR) D ; - . W "ERROR",! - . ZWR ZERR - . B - K C0CFDA - Q - ; +C0CIN ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08 + ;;1.0;C0C;;Sep 20, 2009;Build 38 + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is the CCR Import Utility Library ",! + Q + ; +TEST ; TESTS BOTH ROUTINES AT ONCE + N ZI,ZJ + S ZI="/home/vademo2/CCR" ;directory purposely leaving off the trailing / + S ZJ="PAT_358_CCR_V1_0_21.xml" ; random test patient + D RPCFIN(.GPL,358,135,"GPLTEST","CCR",ZJ,ZI) + Q + ; +RPCAIN(RTN,DFN,DUZ,SOURCE,TYPE,ARY) ; ARRAY IN RPC - ACCEPT AN XML DOCUMENT + ; AND STORE IT IN THE INCOMING XML FILE + ; RETURNS THE IEN OF THE RECORD OR TEXT IF THERE IS AN ERROR + I $G(DFN)="" S RTN="DFN NOT DEFINED" Q ; + N C0CXF S C0CXF=175 ; FILE NUMBER FOR INCOMING XML FILE + N C0CFDA,ZX + S C0CFDA(C0CXF,"+1,",.01)=DFN ; PATIENT + S C0CFDA(C0CXF,"+1,",.02)=DUZ ; PROVIDER CREATING THE RECORD + S C0CFDA(C0CXF,"+1,",1)=$$NOW^XLFDT ;DATE + S C0CFDA(C0CXF,"+1,",2)=TYPE ;TYPE + S C0CFDA(C0CXF,"+1,",3)=$$ADDSRC(SOURCE) ;SOURCE + S C0CFDA(C0CXF,"+1,",7)="NEW" ; STATUS OF NEW FOR NOT PROCESSED + D UPDIE ; CREATE THE RECORD + S ZX=C0CIEN(1) ; CAPTURE THE RECORD NUMBER + D WP^DIE(C0CXF,ZX_",",4,,ARY,"ZERR") + ;W "RECORD:",ZX,! + S RTN=ZX ; RETURN IEN OF THE XML FILE + Q + ; +ADDSRC(ZSRC) ;EXTRISIC TO ADD A SOURCE TO THE CCR SOURCE FILE + ; RETURNS RECORD NUMBER. IF SOURCE EXISTS, JUST RETURNS IT'S RECORD NUMBER + ; + N ZX,ZF,C0CFDA + S ZF=171.401 ; FILE NUMBER FOR CCR SOURCE FILE + S C0CFDA(ZF,"?+1,",.01)=ZSRC + D UPDIE + Q $O(^C0C(171.401,"B",ZSRC,"")) + ; +RPCFIN(RTN,DFN,DUZ,SOURCE,TYPE,FN,FP) ; FILE IN RPC - READ AN XML DOCUMENT + ; FROM A HOST FILE AND STORE IT IN THE INCOMING XML FILE + N ZX,ZTMP + I $E($RE(FP))'="/" S ZX=FP_"/" + E S ZX=FP + S ZX=ZX_FN + D LOAD("ZTMP",ZX) + I '$D(ZTMP) D Q ; NO LUCK + . W "FILE NOT LOADED",! + D RPCAIN(.RTN,DFN,DUZ,SOURCE,TYPE,"ZTMP") + N C0CFDA + S C0CFDA(175,RTN_",",5)=FN ; FILE NAME + S C0CFDA(175,RTN_",",6)=FP ; FILE PATH + D UPDIE ; UPDATE WITH FILE NAME AND PATH + Q + ; +RPCLIST(RTN,DFN) ; CCR LIST - LIST XML DOCUMENTS FOR PATIENT DFN + ; THAT ARE STORED IN THE INCOMING XML FILE + ; RETURNS AN ARRAY OF THE FORM + ; RTN(x)="IEN^DATE^TYPE^SOURCE^STATUS^CREATEDBY" WHERE + ; IEN IS THE RECORD NUMBER OF THE XML DOCUMENT + ; DATE IS THE DATE THE DOCUMENT WAS STORED IN THE FILE + ; TYPE IS "CCD" OR "CCR" OR "OTHER" + ; SOURCE IS THE NAME OF THE DOCUMENT SOURCE FROM THE CCR SOURCE FILE + ; STATUS IS THE STATUS OF THE DOCUMENT (VALUES TO BE DEFINED) + ; CREATEDBY IS THE NAME OF THE PROVIDER WHO UPLOADED THE XML + N ZF S ZF=175 ; FILE NUMBER OF INCOMING XML FILE + N ZI S ZI="" + N ZN S ZN=0 + F S ZI=$O(^C0CIN("B",DFN,ZI),-1) Q:ZI="" D ; FOR EACH RECORD FOR THIS PATIENT + . S ZN=ZN+1 ;INCREMENT COUNT OF RETURN ARRAY + . S $P(RTN(ZN),"^",1)=ZI ; IEN OF RECORD + . S $P(RTN(ZN),"^",2)=$$GET1^DIQ(ZF,ZI_",",1,"E") ;DATE + . S $P(RTN(ZN),"^",3)=$$GET1^DIQ(ZF,ZI_",",2,"E") ;TYPE + . S $P(RTN(ZN),"^",4)=$$GET1^DIQ(ZF,ZI_",",3,"E") ;SOURCE + . S $P(RTN(ZN),"^",5)=$$GET1^DIQ(ZF,ZI_",",7,"I") ; STATUS + . S $P(RTN(ZN),"^",6)=$$GET1^DIQ(ZF,ZI_",",.02,"E") ; CREATED BY + Q + ; +RPCDOC(RTN,IEN) ; RETRIEVE DOCUMENT NUMBER IEN FROM THE INCOMING XML FILE + ; RETURNED IN ARRAY RTN + N ZI + S ZI=$$GET1^DIQ(175,IEN_",",4,,"RTN") + Q + ; +EN(INXML,SOURCE,C0CDFN) ; IMPORT A CCR, PASSED BY NAME INXML + ; FILE UNDER SOURCE, WHICH IS A POINTER TO THE CCR SOURCE FILE + ; FOR PATIENT C0CDFN + ;N C0CXP + S C0CINB=$NA(^TMP("C0CIN",$J,"VARS",C0CDFN)) + S C0CDOCID=$$PARSE^C0CMXML(INXML) ;W !,"DocID: ",C0CDOCID + ;S REDUX="//ContinuityOfCareRecord/Body" + S REDUX="" + D XPATH^C0CMXML(1,"/","C0CIDX","C0CXP",,REDUX) + ;D INDEX^C0CXPATH(INXML,"C0CXP",-1) ; GENERATE XPATHS FROM THE CCR + ;N ZI,ZJ,ZK + S ZI="" + F S ZI=$O(C0CXP(ZI)) Q:ZI="" D ; FOR EACH XPATH + . D DEMUX^C0CMXP("ZJ",ZI) ; + . W ZJ,! + . S ZK=$P(ZJ,"^",3) ; PULL OUT THE XPATH + . S ZM=$P(ZJ,"^",1) ; PULL OUT THE MULTIPLE + . S ZS=$P(ZJ,"^",2) ; PULL OUT THE SUBMULTIPLE + . S C0CDICN=$O(^C0CDIC(170,"XPATH",ZK,"")) + . I C0CDICN="" D Q ; + . . W "MISSING XPATH:",!,ZK,! ; OOPS, XPATH NOT IN C0CDIC + . . S MISSING(ZK)="" + . ;D GETS^DIQ(170,C0CDICN_",","*",,"C0CFDA") + . S C0CVAR=$$GET1^DIQ(170,C0CDICN_",",.01) ; VARIABLE NAME + . S C0CSEC=$$GET1^DIQ(170,C0CDICN_",",12) ;ELEMENT TYPE + . W C0CSEC,":",C0CVAR,! + Q + ; +GETACCR(AOUT,C0CDFN) ; EXTRACT A CCR FOR PATIENT ADFN AND PUT IT IN ARRAY AOUT + ;PASSED BY NAME + N ZT + D CCRRPC^C0CCCR(.ZT,C0CDFN,"LABLIMIT:T-1000") + M @AOUT=ZT + Q + ; +TEST64 ;TEST BASE64 DECODING FOR IMPORTING CCR FROM THE NHIN + W $$FTG^%ZISH("/tmp/","base64_encoded_ccr.txt","G64(1)",1) + S G=G64(1) + S ZI="" + F S ZI=$O(G64(1,"OVF",ZI)) Q:ZI="" D ; FOR EVERY OVERFLOW RECORD + . S G=G_G64(1,"OVF",ZI) ;HOPE IT'S NOT TOO BIG + S G2=$$DECODE^RGUTUU(G) + Q + ; +NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML + ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME + ; + N ZI,ZN,ZTMP + S ZN=1 + S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">" + S ZN=ZN+1 + F S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)="" D ; + . S @OUTXML@(ZN)=@OUTXML@(ZN)_">" + . S ZN=ZN+1 + Q + ; +CLEANCR(OUTXML,INXML) ; USE $C(10) TO SEPARATE THE STRING INXML INTO + ;AN ARRAY OUTXML(n) OUTXML AND INXML PASSED BY NAME + N ZX,ZY,ZN + S ZX=1,ZN=1 + F S ZY=$F(@INXML,$C(10),ZX) Q:ZY=0 D ; + . S @OUTXML@(ZN)=$E(G2,ZX,ZY-2) + . I @OUTXML@(ZN)'="" S ZN=ZN+1 + . S ZX=ZY + Q + ; +LOAD(ZRTN,filepath) ; load an xml file into the ZRTN array, passed by name + n i + D ; + . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)="" + . s ztmp=$na(^TMP("C0CLOAD",$J)) + . k @ztmp + . s zfile=$re($p($re(filepath),"/",1)) ;file name + . s zpath=$p(filepath,zfile,1) ; file path + . s zok=$$FTG^%ZISH(zpath,zfile,$NA(@ztmp@(1)),3) ; import the file incr sub 3 + . m @ZRTN=@ztmp + . k @ztmp + . s i=$o(@ZRTN@(""),-1) ; highest line number + q + ; +UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS + K ZERR,C0CIEN + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","C0CIEN","ZERR") + I $D(ZERR) D ; + . W "ERROR",! + . ZWR ZERR + . B + K C0CFDA + Q + ; Index: ccr/branches/ohum/p/C0CLA7DD.m =================================================================== --- ccr/branches/ohum/p/C0CLA7DD.m (revision 1333) +++ ccr/branches/ohum/p/C0CLA7DD.m (revision 1337) @@ -1,259 +1,259 @@ -C0CLA7DD ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009 - ;;1.0;C0C;;May 19, 2009;Build 1 - ; - ; Tasked by C0C post-install routine C0CENV to create C0C cross-references on V LAB file. - ; - Q - ; - ; -EN ; Add new style cross-references to V LAB file if it exists. - ; OLD entry point - see new KIDS check points in C0CENV. - ; - ; - ; Quit if AUPNVLAB global does not exist. - I $$VFILE^DILFD(9000010.09)'=1 Q - ; - N MSG - ; - S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR1 - S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - ; - S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR2 - S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - ; - S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR3 - S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - ; - S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR4 - S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - ; - S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR5 - S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - ; - Q - ; - ; -ALR1 ; Installation of ALR1 cross-reference - ; - N C0CFLAG,C0CXR,C0CRES,C0COUT - ; - S C0CFLAG="" - ; - S C0CXR("FILE")=9000010.09 - S C0CXR("NAME")="ALR1" - S C0CXR("TYPE")="R" - S C0CXR("USE")="S" - S C0CXR("EXECUTION")="R" - S C0CXR("ACTIVITY")="IR" - S C0CXR("SHORT DESCR")="X-ref to link entry with parent in LAB DATA file (#63)" - S C0CXR("VAL",1)=.02 - S C0CXR("VAL",1,"SUBSCRIPT")=1 - S C0CXR("VAL",1,"COLLATION")="F" - S C0CXR("VAL",2)=.06 - S C0CXR("VAL",2,"SUBSCRIPT")=2 - S C0CXR("VAL",2,"LENGTH")=30 - S C0CXR("VAL",2,"COLLATION")="F" - S C0CXR("VAL",3)=.01 - S C0CXR("VAL",3,"SUBSCRIPT")=3 - S C0CXR("VAL",3,"COLLATION")="F" - S C0CXR("VAL",4)=1201 - S C0CXR("VAL",4,"SUBSCRIPT")=4 - S C0CXR("VAL",4,"COLLATION")="F" - D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") - ; - Q - ; - ; -ALR2 ; Installation of ALR2 cross-reference - ; - N C0CFLAG,C0CXR,C0CRES,C0COUT - ; - S C0CFLAG="" - ; - S C0CXR("FILE")=9000010.09 - S C0CXR("NAME")="ALR2" - S C0CXR("TYPE")="MU" - S C0CXR("USE")="S" - S C0CXR("EXECUTION")="R" - S C0CXR("ACTIVITY")="IR" - S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result." - S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes" - S C0CXR("DESCR",2)="that has been assigned to a lab result. Allows queries to" - S C0CXR("DESCR",3)="retrieve the LOINC code associated with a specific test" - S C0CXR("DESCR",4)="result." - S C0CXR("SET")="S ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)=""""" - S C0CXR("KILL")="K ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)" - S C0CXR("WHOLE KILL")="K ^AUPNVLAB(""ALR2"")" - S C0CXR("VAL",1)=.02 - S C0CXR("VAL",1,"SUBSCRIPT")=1 - S C0CXR("VAL",1,"COLLATION")="F" - S C0CXR("VAL",2)=1201 - S C0CXR("VAL",2,"SUBSCRIPT")=2 - S C0CXR("VAL",2,"COLLATION")="F" - S C0CXR("VAL",3)=.06 - S C0CXR("VAL",3,"SUBSCRIPT")=3 - S C0CXR("VAL",3,"COLLATION")="F" - S C0CXR("VAL",4)=.01 - S C0CXR("VAL",4,"SUBSCRIPT")=4 - S C0CXR("VAL",4,"COLLATION")="F" - S C0CXR("VAL",5)=1113 - S C0CXR("VAL",5,"SUBSCRIPT")=5 - S C0CXR("VAL",5,"COLLATION")="F" - D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") - ; - Q - ; - ; -ALR3 ; Installation of ALR3 cross-reference - ; - N C0CFLAG,C0CXR,C0CRES,C0COUT - ; - S C0CFLAG="" - ; - S C0CXR("FILE")=9000010.09 - S C0CXR("NAME")="ALR3" - S C0CXR("TYPE")="R" - S C0CXR("USE")="S" - S C0CXR("EXECUTION")="F" - S C0CXR("ACTIVITY")="IR" - S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result - any patient" - S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes that has been assigned to a lab result. Allows queries" - S C0CXR("DESCR",2)="to retrieve the LOINC code associated with a specific test result. It allows any patient" - S C0CXR("DESCR",3)="lab results to be identified by LOINC" - S C0CXR("VAL",1)=1113 - S C0CXR("VAL",1,"SUBSCRIPT")=1 - S C0CXR("VAL",1,"COLLATION")="F" - ; - D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") - ; - Q - ; - ; -ALR4 ; Installation of ALR4 cross-reference - ; - N C0CFLAG,C0CXR,C0CRES,C0COUT - ; - S C0CFLAG="" - ; - S C0CXR("FILE")=9000010.09 - S C0CXR("NAME")="ALR4" - S C0CXR("TYPE")="R" - S C0CXR("USE")="S" - S C0CXR("EXECUTION")="R" - S C0CXR("ACTIVITY")="IR" - S C0CXR("SHORT DESCR")="X-ref by patient and collection date/time" - S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a" - S C0CXR("DESCR",2)="patient by collection date/time. This includes results that are only in" - S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA" - S C0CXR("DESCR",4)="file (#63)." - S C0CXR("VAL",1)=.02 - S C0CXR("VAL",1,"SUBSCRIPT")=1 - S C0CXR("VAL",1,"COLLATION")="F" - S C0CXR("VAL",2)=1201 - S C0CXR("VAL",2,"SUBSCRIPT")=2 - S C0CXR("VAL",2,"COLLATION")="F" - ; - D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") - ; - Q - ; - ; -ALR5 ; Installation of ALR5 cross-reference - ; - N C0CFLAG,C0CXR,C0CRES,C0COUT - ; - S C0CFLAG="" - ; - S C0CXR("FILE")=9000010.09 - S C0CXR("NAME")="ALR5" - S C0CXR("TYPE")="R" - S C0CXR("USE")="S" - S C0CXR("EXECUTION")="R" - S C0CXR("ACTIVITY")="IR" - S C0CXR("SHORT DESCR")="X-ref by patient and results availble date/time" - S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a" - S C0CXR("DESCR",2)="patient by results available date/time. This includes results that are only in" - S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA" - S C0CXR("DESCR",4)="file (#63)." - S C0CXR("VAL",1)=.02 - S C0CXR("VAL",1,"SUBSCRIPT")=1 - S C0CXR("VAL",1,"COLLATION")="F" - S C0CXR("VAL",2)=1212 - S C0CXR("VAL",2,"SUBSCRIPT")=2 - S C0CXR("VAL",2,"COLLATION")="F" - ; - D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") - ; - Q - ; - ; -REINDEX ; Set data into indexes for current entries. - ; - ; - N C0CHLOG,DA,DIK,MSG - ; - S C0CHLOG("START")=$H - S MSG="Starting indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") - D BMES(MSG),SENDXQA(MSG) - ; - S DIK="^AUPNVLAB(" - S DIK(1)=".02^ALR1^ALR2^ALR4^ALR5" - D ENALL^DIK - ; - S C0CHLOG("END")=$H - S MSG="Finished indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z") - D BMES(MSG),SENDXQA(MSG) - ; - S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3) - D BMES(MSG) - ; - S C0CHLOG("START")=$H - S MSG="Starting indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") - D BMES(MSG),SENDXQA(MSG) - ; - K DA,DIK - S DIK="^AUPNVLAB(" - S DIK(1)="1113^ALR3" - D ENALL^DIK - ; - S C0CHLOG("END")=$H - S MSG="Finished indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z") - D BMES(MSG),SENDXQA(MSG) - ; - S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3) - D BMES(MSG) - ; - Q - ; - ; -BMES(STR) ; Write BMES^XPDUTL statements - ; - D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM)) - ; - Q - ; - ; -SENDXQA(MSG) ; Send alert for reindex status - ; - N XQA,XQAMSG - ; - S XQA(DUZ)="" - S XQAMSG=MSG - D SETUP^XQALERT - ; - Q +C0CLA7DD ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009 + ;;1.0;C0C;;May 19, 2009; + ; + ; Tasked by C0C post-install routine C0CENV to create C0C cross-references on V LAB file. + ; + Q + ; + ; +EN ; Add new style cross-references to V LAB file if it exists. + ; OLD entry point - see new KIDS check points in C0CENV. + ; + ; + ; Quit if AUPNVLAB global does not exist. + I $$VFILE^DILFD(9000010.09)'=1 Q + ; + N MSG + ; + S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR1 + S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + ; + S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR2 + S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + ; + S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR3 + S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + ; + S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR4 + S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + ; + S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR5 + S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + ; + Q + ; + ; +ALR1 ; Installation of ALR1 cross-reference + ; + N C0CFLAG,C0CXR,C0CRES,C0COUT + ; + S C0CFLAG="" + ; + S C0CXR("FILE")=9000010.09 + S C0CXR("NAME")="ALR1" + S C0CXR("TYPE")="R" + S C0CXR("USE")="S" + S C0CXR("EXECUTION")="R" + S C0CXR("ACTIVITY")="IR" + S C0CXR("SHORT DESCR")="X-ref to link entry with parent in LAB DATA file (#63)" + S C0CXR("VAL",1)=.02 + S C0CXR("VAL",1,"SUBSCRIPT")=1 + S C0CXR("VAL",1,"COLLATION")="F" + S C0CXR("VAL",2)=.06 + S C0CXR("VAL",2,"SUBSCRIPT")=2 + S C0CXR("VAL",2,"LENGTH")=30 + S C0CXR("VAL",2,"COLLATION")="F" + S C0CXR("VAL",3)=.01 + S C0CXR("VAL",3,"SUBSCRIPT")=3 + S C0CXR("VAL",3,"COLLATION")="F" + S C0CXR("VAL",4)=1201 + S C0CXR("VAL",4,"SUBSCRIPT")=4 + S C0CXR("VAL",4,"COLLATION")="F" + D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") + ; + Q + ; + ; +ALR2 ; Installation of ALR2 cross-reference + ; + N C0CFLAG,C0CXR,C0CRES,C0COUT + ; + S C0CFLAG="" + ; + S C0CXR("FILE")=9000010.09 + S C0CXR("NAME")="ALR2" + S C0CXR("TYPE")="MU" + S C0CXR("USE")="S" + S C0CXR("EXECUTION")="R" + S C0CXR("ACTIVITY")="IR" + S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result." + S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes" + S C0CXR("DESCR",2)="that has been assigned to a lab result. Allows queries to" + S C0CXR("DESCR",3)="retrieve the LOINC code associated with a specific test" + S C0CXR("DESCR",4)="result." + S C0CXR("SET")="S ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)=""""" + S C0CXR("KILL")="K ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)" + S C0CXR("WHOLE KILL")="K ^AUPNVLAB(""ALR2"")" + S C0CXR("VAL",1)=.02 + S C0CXR("VAL",1,"SUBSCRIPT")=1 + S C0CXR("VAL",1,"COLLATION")="F" + S C0CXR("VAL",2)=1201 + S C0CXR("VAL",2,"SUBSCRIPT")=2 + S C0CXR("VAL",2,"COLLATION")="F" + S C0CXR("VAL",3)=.06 + S C0CXR("VAL",3,"SUBSCRIPT")=3 + S C0CXR("VAL",3,"COLLATION")="F" + S C0CXR("VAL",4)=.01 + S C0CXR("VAL",4,"SUBSCRIPT")=4 + S C0CXR("VAL",4,"COLLATION")="F" + S C0CXR("VAL",5)=1113 + S C0CXR("VAL",5,"SUBSCRIPT")=5 + S C0CXR("VAL",5,"COLLATION")="F" + D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") + ; + Q + ; + ; +ALR3 ; Installation of ALR3 cross-reference + ; + N C0CFLAG,C0CXR,C0CRES,C0COUT + ; + S C0CFLAG="" + ; + S C0CXR("FILE")=9000010.09 + S C0CXR("NAME")="ALR3" + S C0CXR("TYPE")="R" + S C0CXR("USE")="S" + S C0CXR("EXECUTION")="F" + S C0CXR("ACTIVITY")="IR" + S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result - any patient" + S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes that has been assigned to a lab result. Allows queries" + S C0CXR("DESCR",2)="to retrieve the LOINC code associated with a specific test result. It allows any patient" + S C0CXR("DESCR",3)="lab results to be identified by LOINC" + S C0CXR("VAL",1)=1113 + S C0CXR("VAL",1,"SUBSCRIPT")=1 + S C0CXR("VAL",1,"COLLATION")="F" + ; + D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") + ; + Q + ; + ; +ALR4 ; Installation of ALR4 cross-reference + ; + N C0CFLAG,C0CXR,C0CRES,C0COUT + ; + S C0CFLAG="" + ; + S C0CXR("FILE")=9000010.09 + S C0CXR("NAME")="ALR4" + S C0CXR("TYPE")="R" + S C0CXR("USE")="S" + S C0CXR("EXECUTION")="R" + S C0CXR("ACTIVITY")="IR" + S C0CXR("SHORT DESCR")="X-ref by patient and collection date/time" + S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a" + S C0CXR("DESCR",2)="patient by collection date/time. This includes results that are only in" + S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA" + S C0CXR("DESCR",4)="file (#63)." + S C0CXR("VAL",1)=.02 + S C0CXR("VAL",1,"SUBSCRIPT")=1 + S C0CXR("VAL",1,"COLLATION")="F" + S C0CXR("VAL",2)=1201 + S C0CXR("VAL",2,"SUBSCRIPT")=2 + S C0CXR("VAL",2,"COLLATION")="F" + ; + D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") + ; + Q + ; + ; +ALR5 ; Installation of ALR5 cross-reference + ; + N C0CFLAG,C0CXR,C0CRES,C0COUT + ; + S C0CFLAG="" + ; + S C0CXR("FILE")=9000010.09 + S C0CXR("NAME")="ALR5" + S C0CXR("TYPE")="R" + S C0CXR("USE")="S" + S C0CXR("EXECUTION")="R" + S C0CXR("ACTIVITY")="IR" + S C0CXR("SHORT DESCR")="X-ref by patient and results availble date/time" + S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a" + S C0CXR("DESCR",2)="patient by results available date/time. This includes results that are only in" + S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA" + S C0CXR("DESCR",4)="file (#63)." + S C0CXR("VAL",1)=.02 + S C0CXR("VAL",1,"SUBSCRIPT")=1 + S C0CXR("VAL",1,"COLLATION")="F" + S C0CXR("VAL",2)=1212 + S C0CXR("VAL",2,"SUBSCRIPT")=2 + S C0CXR("VAL",2,"COLLATION")="F" + ; + D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") + ; + Q + ; + ; +REINDEX ; Set data into indexes for current entries. + ; + ; + N C0CHLOG,DA,DIK,MSG + ; + S C0CHLOG("START")=$H + S MSG="Starting indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") + D BMES(MSG),SENDXQA(MSG) + ; + S DIK="^AUPNVLAB(" + S DIK(1)=".02^ALR1^ALR2^ALR4^ALR5" + D ENALL^DIK + ; + S C0CHLOG("END")=$H + S MSG="Finished indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z") + D BMES(MSG),SENDXQA(MSG) + ; + S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3) + D BMES(MSG) + ; + S C0CHLOG("START")=$H + S MSG="Starting indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") + D BMES(MSG),SENDXQA(MSG) + ; + K DA,DIK + S DIK="^AUPNVLAB(" + S DIK(1)="1113^ALR3" + D ENALL^DIK + ; + S C0CHLOG("END")=$H + S MSG="Finished indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z") + D BMES(MSG),SENDXQA(MSG) + ; + S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3) + D BMES(MSG) + ; + Q + ; + ; +BMES(STR) ; Write BMES^XPDUTL statements + ; + D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM)) + ; + Q + ; + ; +SENDXQA(MSG) ; Send alert for reindex status + ; + N XQA,XQAMSG + ; + S XQA(DUZ)="" + S XQAMSG=MSG + D SETUP^XQALERT + ; + Q Index: ccr/branches/ohum/p/C0CLA7Q.m =================================================================== --- ccr/branches/ohum/p/C0CLA7Q.m (revision 1333) +++ ccr/branches/ohum/p/C0CLA7Q.m (revision 1337) @@ -1,169 +1,169 @@ -C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009 - ;;1.0;C0C;;May 19, 2009;Build 1 - ; - ; - Q - ; - ; -LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for Lab Result Query - ; - ; - K ^TMP("C0C-VLAB",$J) - ; - ; Check and retrieve lab results from LAB DATA file (#63) - S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7)) - ; - ; If V LAB file present then check for lab results that are only in this file - ; If results found in V Lab file then build results and add to above results. - I $D(^AUPNVLAB) D - . D VCHECK - . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD - ; - ;K ^TMP("C0C-VLAB",$J) - ; - Q C0CDEST - ; - ; -VCHECK ; If V LAB file present then check for lab results that are only in this file. - ; - N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC - ; - S LA7PTID=C0CPTID - D PATID^LA7QRY2 - I $D(LA7ERR) Q - ; - ; Resolve search codes to lab datanames - S LA7SC=$G(C0CSC) - I $T(SCLIST^LA7QRY2)'="" D - . N TMP - . S LA7SCRC=$G(C0CSC) - . S TMP=$$SCLIST^LA7QRY2(LA7SCRC) - . S LA7SC=TMP - ; - I LA7SC'="*" D CHKSC^LA7QRY1 - ; - ; Convert specimen codes to file #61 Topography entries - S LA7SPEC=$G(C0CSPEC) - I LA7SPEC'="*" D SPEC^LA7QRY1 - ; - S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0 - ; - F S C0CROOT=$Q(@C0CROOT) Q:C0CROOT="" D Q:C0CEND - . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q ; Left x-ref or patient - . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q ; Exceeded end date/time - . S C0CDA=$QS(C0CROOT,4) - . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q ; Already checked during scan of file #63 - . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q ; Source is LAB DATA file - skip - . D VCHK1 - ; - ; - Q - ; - ; -VBUILD ; Build results found only in V LAB file into HL7 structure. - ; - ; - Q - ; - ; -LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63. - ; Call from LA7QRY2 - ; - N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X - ; - S DFN=$P(^LR(LRDFN,0),"^",3) - S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0) - S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5) - S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)="" - ; - ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)="" - ; - S C0C60="" - F S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60 D Q:C0CLN'="" - . D FINDDT - . I C0CDA<1 Q - . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q ; Source is not LAB DATA file - skip - . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13) - . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8) - . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer - . I C0CPDA="" S C0CPDA=C0CDA - . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2) - . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2) - . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^") - . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2) - . S ^TMP("C0C-VLAB",$J,1,C0CDA)="" - . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)="" - . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST - ; - S X=$P(LA7X,"^",3) - ; If order NLT then update if no order NLT - I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64) - ; - ; If result NLT then update if no result NLT - I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64) - ; - ; If LOINC found then update variable with LN code - I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN - ; - S $P(LA7X,"^",3)=X - ; - Q - ; - ; -TMPCHK ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments - ; Called from LA7VOBX1 - ; - N I,X - ; - S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)) - I X="" Q - F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I) - S $P(LA7VAL,"^",3)=LA7X - ; - Q - ; - ; -VCHK1 ; Check the entry in V Lab to determine if it meets criteria - ; - N C0CVLAB,I - ; - F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I)) - ; - ; JMC 04/13/09 - Store anything for now that meets date criteria. - D VSTORE - ; - Q - ; - ; -VSTORE ; Store entry for building in HL7 message when parent is from V LAB file. - ; - N C0CPDA,C0CPTEST - ; - ; Determine parent test to use for OBR segment - S C0CPDA=$P(C0CVLAB(12),"^",8) - I C0CPDA="" S C0CPDA=C0CDA - ; - ; Determine parent test - S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^") - ; - S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA - ; - Q - ; - ; -FINDDT ; Find entry in V LAB for the date/time or one close to it. - ; RPMS stores related specimen entries under the same date/time. - ; Lab file #63 creates unique entries with slightly different times. - ; - S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0)) - I C0CDA>0 Q - ; - ; If entry found then confirm that specimen type matches. - N C0CDTY - S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0)) - I C0CDTY D - . I $P(C0CDT,".")'=$P(C0CDTY,".") Q - . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0)) - . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA="" - ; - Q +C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009 + ;;1.0;C0C;;May 19, 2009;Build 38 + ; + ; + Q + ; + ; +LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for Lab Result Query + ; + ; + K ^TMP("C0C-VLAB",$J) + ; + ; Check and retrieve lab results from LAB DATA file (#63) + S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7)) + ; + ; If V LAB file present then check for lab results that are only in this file + ; If results found in V Lab file then build results and add to above results. + I $D(^AUPNVLAB) D + . D VCHECK + . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD + ; + ;K ^TMP("C0C-VLAB",$J) + ; + Q C0CDEST + ; + ; +VCHECK ; If V LAB file present then check for lab results that are only in this file. + ; + N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC + ; + S LA7PTID=C0CPTID + D PATID^LA7QRY2 + I $D(LA7ERR) Q + ; + ; Resolve search codes to lab datanames + S LA7SC=$G(C0CSC) + I $T(SCLIST^LA7QRY2)'="" D + . N TMP + . S LA7SCRC=$G(C0CSC) + . S TMP=$$SCLIST^LA7QRY2(LA7SCRC) + . S LA7SC=TMP + ; + I LA7SC'="*" D CHKSC^LA7QRY1 + ; + ; Convert specimen codes to file #61 Topography entries + S LA7SPEC=$G(C0CSPEC) + I LA7SPEC'="*" D SPEC^LA7QRY1 + ; + S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0 + ; + F S C0CROOT=$Q(@C0CROOT) Q:C0CROOT="" D Q:C0CEND + . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q ; Left x-ref or patient + . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q ; Exceeded end date/time + . S C0CDA=$QS(C0CROOT,4) + . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q ; Already checked during scan of file #63 + . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q ; Source is LAB DATA file - skip + . D VCHK1 + ; + ; + Q + ; + ; +VBUILD ; Build results found only in V LAB file into HL7 structure. + ; + ; + Q + ; + ; +LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63. + ; Call from LA7QRY2 + ; + N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X + ; + S DFN=$P(^LR(LRDFN,0),"^",3) + S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0) + S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5) + S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)="" + ; + ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)="" + ; + S C0C60="" + F S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60 D Q:C0CLN'="" + . D FINDDT + . I C0CDA<1 Q + . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q ; Source is not LAB DATA file - skip + . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13) + . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8) + . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer + . I C0CPDA="" S C0CPDA=C0CDA + . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2) + . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2) + . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^") + . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2) + . S ^TMP("C0C-VLAB",$J,1,C0CDA)="" + . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)="" + . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST + ; + S X=$P(LA7X,"^",3) + ; If order NLT then update if no order NLT + I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64) + ; + ; If result NLT then update if no result NLT + I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64) + ; + ; If LOINC found then update variable with LN code + I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN + ; + S $P(LA7X,"^",3)=X + ; + Q + ; + ; +TMPCHK ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments + ; Called from LA7VOBX1 + ; + N I,X + ; + S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)) + I X="" Q + F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I) + S $P(LA7VAL,"^",3)=LA7X + ; + Q + ; + ; +VCHK1 ; Check the entry in V Lab to determine if it meets criteria + ; + N C0CVLAB,I + ; + F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I)) + ; + ; JMC 04/13/09 - Store anything for now that meets date criteria. + D VSTORE + ; + Q + ; + ; +VSTORE ; Store entry for building in HL7 message when parent is from V LAB file. + ; + N C0CPDA,C0CPTEST + ; + ; Determine parent test to use for OBR segment + S C0CPDA=$P(C0CVLAB(12),"^",8) + I C0CPDA="" S C0CPDA=C0CDA + ; + ; Determine parent test + S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^") + ; + S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA + ; + Q + ; + ; +FINDDT ; Find entry in V LAB for the date/time or one close to it. + ; RPMS stores related specimen entries under the same date/time. + ; Lab file #63 creates unique entries with slightly different times. + ; + S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0)) + I C0CDA>0 Q + ; + ; If entry found then confirm that specimen type matches. + N C0CDTY + S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0)) + I C0CDTY D + . I $P(C0CDT,".")'=$P(C0CDTY,".") Q + . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0)) + . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA="" + ; + Q Index: ccr/branches/ohum/p/C0CLABS.m =================================================================== --- ccr/branches/ohum/p/C0CLABS.m (revision 1333) +++ ccr/branches/ohum/p/C0CLABS.m (revision 1337) @@ -1,399 +1,399 @@ -C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008,2009 George Lilly, University of Minnesota. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; -MAP(MIXML,DFN,MOXML) ;TO MAKE THIS COMPATIBLE WITH OLD CALLING FOR EXTRACT - ; ASSUMES THAT EXTRACT HAS BEEN RUN AND THE VARIABLES STORED IN MIVAR - ; MIXML,MIVAR, AND MOXML ARE PASSED BY NAME - ; MIXML IS THE TEMPLATE TO USE - ; MOXML IS THE OUTPUT XML ARRAY - ; DFN IS THE PATIENT RECORD NUMBER - N C0COXML,C0CO,C0CV,C0CIXML - I '$D(MIVAR) S C0CV="" ;DEFAULT - E S C0CV=MIVAR ;PASSED VARIABLE ARRAY - I '$D(MIXML) S C0CIXML="" ;DEFAULT - E S C0CIXML=MIXML ;PASSED INPUT XML - D RPCMAP(.C0COXML,DFN,C0CV,C0CIXML) ; CALL RPC TO DO THE WORK - I '$D(MOXML) S C0CO=$NA(^TMP("C0CCCR",$J,DFN,"RESULTS")) ;DEFAULT FOR OUTPUT - E S C0CO=MOXML - ; ZWR C0COXML - M @C0CO=C0COXML ; COPY RESULTS TO OUTPUT - Q - ; -RPCMAP(RTN,DFN,RMIVAR,RMIXML) ; RPC ENTRY POINT FOR MAPPING RESULTS - ; RTN IS PASSED BY REFERENCE - ;N C0CT0,C0CT,C0CV ; CCR TEMPLATE, RESULTS SUBTEMPLATE, VARIABLES - ;N C0CRT,C0CTT ; TEST REQUEST TEMPLATE, TEST RESULT TEMPLATE - I '$D(DEBUG) S DEBUG=0 ; DEFAULT NO DEBUGGING - I RMIXML="" D ; INPUT XML NOT PASSED - . D LOAD^C0CCCR0("C0CT0") ; LOAD ENTIRE CCR TEMPLATE - . D QUERY^C0CXPATH("C0CT0","//ContinuityOfCareRecord/Body/Results","C0CT0R") - . S C0CT="C0CT0R" ; NAME OF EXTRACTED RESULTS TEMPLATE - E S C0CT=RMIXML ; WE ARE PASSED THE RESULTS PART OF THE TEMPLATE - I RMIVAR="" D ; LOCATION OF VARIABLES NOT PASSED - . S C0CV=$NA(^TMP("C0CCCR",$J,"RESULTS")) ;DEFAULT VARIABLE LOCATION - E S C0CV=RMIVAR ; PASSED LOCATIONS OF VARS - D CP^C0CXPATH(C0CT,"C0CRT") ; START MAKING TEST REQUEST TEMPLATE - D REPLACE^C0CXPATH("C0CRT","","//Results/Result/Test") ; DELETE TEST FROM REQ - D QUERY^C0CXPATH(C0CT,"//Results/Result/Test","C0CTT") ; MAKE TEST TEMPLATE - I '$D(C0CQT) S C0CQT=0 ; DEFAULT NOT SILENT - I 'C0CQT D ; WE ARE DEBUGGING - . W "I MAPPED",! - . W "VARS:",C0CV,! - . W "DFN:",DFN,! - . ;D PARY^C0CXPATH("C0CT") ; SECTION TEMPLATE - . ;D PARY^C0CXPATH("C0CRT") ;REQUEST TEMPLATE (OCR) - . ;D PARY^C0CXPATH("C0CTT") ;TEST TEMPLATE (OCX) - D EXTRACT("C0CT",DFN,) ; FIRST CALL EXTRACT - I '$D(@C0CV@(0)) D Q ; NO VARS THERE - . S RTN(0)=0 ; PASS BACK NO RESULTS INDICATOR - I @C0CV@(0)=0 S RTN(0)=0 Q ; NO RESULTS - S RIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"RESULTS")) - K @RIMVARS - M @RIMVARS=@C0CV ; UPDATE RIMVARS SO THEY STAY IN SYNCH - N C0CI,C0CJ,C0CMAP,C0CTMAP,C0CTMP - S C0CIN=@C0CV@(0) ; COUNT OF RESULTS (OBR) - N C0CRTMP ; AREA TO BUILD ONE RESULT REQUEST AND ALL TESTS FOR IT - N C0CRBASE S C0CRBASE=$NA(^TMP($J,"TESTTMP")) ;WORK AREA - N C0CRBLD ; BUILD LIST FOR XML - THE BUILD IS DELAYED UNTIL THE END - ; TO IMPROVE PERFORMANCE - D QUEUE^C0CXPATH("C0CRBLD","C0CRT",1,1) ; - 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 - . 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 - . . . I C0CJ=C0CJN S C0CJE=@C0CTMP@(0)-1 E S C0CJE=@C0CTMP@(0) ; - . . . 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) ; - . ;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)) ; - D BUILD^C0CXPATH("C0CRBLD","RTN") ;RENDER THE XML - K @C0CRBASE ; CLEAR OUT TEMPORARY STURCTURE - Q - ; -EXTRACT(ILXML,DFN,OLXML) ; EXTRACT LABS INTO THE C0CLVAR GLOBAL - ; - ; LABXML AND LABOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED - ; - ; - ; - N C0CNSSN ; IS THERE AN SSN FLAG - S C0CNSSN=0 - S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS - D GHL7 ; GET HL7 MESSAGE FOR THIS PATIENT - I C0CNSSN=1 D Q ; NO SSN, CAN'T GET HL7 FOR THIS PATIENT - . S @C0CLB@(0)=0 - K @C0CLB ; CLEAR OUT OLD VARS IF ANY - N QTSAV S QTSAV=C0CQT ;SAVE QUIET FLAG - S C0CQT=1 ; SURPRESS LISTING - D LIST ; EXTRACT THE VARIABLES - ; FOR CERTIFICATION, SEE IF THERE ARE OTHER RESULTS TO ADD - D EN^C0CORSLT(C0CLB,DFN) ; LOOKS FOR ECG TESTS - S C0CQT=QTSAV ; RESET SILENT FLAG - K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT - I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^C0CLABS - Q - ; -GHL7 ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT - ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR - ; SET UP FOR LAB API CALL - S C0CPTID=$$SSN^C0CDPT(DFN) ; GET THE SSN FOR THIS PATIENT - I C0CPTID="" D Q ; NO SSN, COMPLAIN AND QUIT - . W "LAB LOOKUP FAILED, NO SSN",! - . S C0CNSSN=1 ; SET NO SSN FLAG - S C0CSPC="*" ; LOOKING FOR ALL LABS - ;I $D(^TMP("C0CCCR","RPMS")) D ; RUNNING RPMS - ;. D DT^DILF(,"T-365",.C0CSDT) ; START DATE ONE YEAR AGO TO LIMIT VOLUME - ;E D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING - ;D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY - S C0CLLMT=$$GET^C0CPARMS("LABLIMIT") ; GET THE LIMIT PARM - S C0CLSTRT=$$GET^C0CPARMS("LABSTART") ; GET START PARM - D DT^DILF(,C0CLLMT,.C0CSDT) ; - W "LAB LIMIT: ",C0CLLMT,! - D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM - S C0CEDT=$$NOW^XLFDT ; PULL LABS STARTING NOW - S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP - Q - ; -LIST ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB - ; - ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR - I '$D(C0CLB) S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS - I '$D(C0CQT) S C0CQT=0 - I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT - I '$D(^TMP("C0CCCR","LABTBL",0)) D SETTBL ;INITIALIZE LAB TABLE - I ^TMP("C0CCCR","LABTBL",0)'="V3" D SETTBL ;NEED NEWEST VERSION - I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE - S C0CTAB=$NA(^TMP("C0CCCR","LABTBL")) ; BASE OF OBX TABLE - S C0CHB=$NA(^TMP("HLS",$J)) - S C0CI="" - S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT - F S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI="" D ; FOR ALL RECORDS IN HL7 MSG - . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES - . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) - . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT) - . I $G(C0CVAR("RESULTCODINGSYSTEM"))="LN" D ; gpl - for certification - . . S C0CVAR("RESULTCODINGSYSTEM")="LOINC" ; NEED TO SPELL IT OUT - . . N C0CRDT S C0CRDT=C0CVAR("RESULTDESCRIPTIONTEXT") ; THE DESCRIPTION - . . N C0CRCD S C0CRCD=C0CVAR("RESULTCODE") ; THE LOINC CODE - . . S C0CVAR("RESULTDESCRIPTIONTEXT")=C0CRDT_" LOINC: "_C0CRCD - . M XV=C0CVAR ; - . I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION - . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT - . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT - . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS - . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI - . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR - . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1) - . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT - . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL - . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME - . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS - . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION - . I C0CTYP="OBX" D ; SPECIAL CASE FOR OBX3 - . . ; RESULTTESTCODEVALUE - . . ; RESULTTESTDESCRIPTIONTEXT - . . I C0CVAR("C3")="LN" D ; PRIMARY CODE IS LOINC - . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE - . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC - . . . ;S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESC TXT - . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2")_" LOINC: "_C0CVAR("C1") - . . E I C0CVAR("C6")="LN" D ; SECONDARY CODE IS LOINC - . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE - . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC - . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT - . . E I C0CVAR("C6")'="" D ; NO LOINC CODES, USE SECONDARY IF PRESENT - . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE - . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME - . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT - . . E D ; NO SECONDARY, USE PRIMARY - . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE - . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME - . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT - . . N C0CZG S C0CZG=XV("RESULTTESTNORMALDESCTEXT") ; - . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH - . . ;S XV("RESULTTESTNORMALDESCTEXT")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE - . . S XV("RESULTTESTNORMALDESCTEXT")=C0CZG - . . S C0CZG=XV("RESULTTESTVALUE") - . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH - . . ;S XV("RESULTTESTVALUE")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE - . . S XV("RESULTTESTVALUE")=C0CZG - . I C0CTYP="OBX" D ; PROCESS TEST RESULTS - . . I C0CLOBX=0 D ; FIRST TEST RESULT FOR THIS SECTION - . . . S C0CLB2=$NA(@C0CLB@(C0CLI,"M","TEST")) ; INDENT FOR TEST RESULTS - . . S C0CLOBX=C0CLOBX+1 ; INCREMENT TEST COUNT - . . S @C0CLB2@(0)=C0CLOBX ; STORE THE TEST COUNT - . . S XV("RESULTTESTOBJECTID")="RESULTTEST_"_C0CLI_"_"_C0CLOBX - . . S C0CX1=XV("RESULTTESTSOURCEACTORID") ; TEST SOURCE - . . S C0CX2=$P($P(C0CX1,"^",1),"-",1) ; PULL OUT STATION NUMBER - . . S XV("RESULTTESTSOURCEACTORID")="ACTORORGANIZATION_"_C0CX2 - . . S XV("RESULTTESTNORMALSOURCEACTORID")=XV("RESULTTESTSOURCEACTORID") - . . S C0CX1=XV("RESULTTESTDATETIME") ;DATE TIME IN HL7 FORMAT - . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL - . . S XV("RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME - . . ; I 'C0CQT ZWR XV - . . M @C0CLB2@(C0CLOBX)=XV ; PERSIST THE TEST RESULT VARIABLES - . I 'C0CQT D ; - . . W C0CI," ",C0CTYP,! - . ; S C0CI=$O(@C0CHB@(C0CI)) - ;K ^TMP("C0CRIM","VARS",DFN,"RESULTS") - ;M ^TMP("C0CRIM","VARS",DFN,"RESULTS")=@C0CLB - Q -LTYP(OSEG,OTYP,OVARA,OC0CQT) ; - S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE - I '$D(OC0CQT) S C0CQT=0 ; NOT C0CQT IS DEFAULT - E S C0CQT=OC0CQT ; ACCEPT C0CQT FLAG - I 1 D ; FOR HL7 SEGMENT TYPE - . S OI="" ; INDEX INTO FIELDS IN SEG - . F S OI=$O(@OTAB@(OI)) Q:OI="" D ; FOR EACH FIELD OF THE SEGMENT - . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX - . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED - . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE - . . I $P(OI,";",2)'="" D ; THIS IS DEFINING A SUB-VALUE - . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX - . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE - . . I OVAR'="" S OVARA(OVAR)=OV ; PASS BACK VARIABLE AND VALUE - . . I 'C0CQT D ; PRINT OUTPUT IF C0CQT IS FALSE - . . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,! - Q -LOBX ; - Q - ; -OUT(DFN) ; WRITE OUT A CCR THAT HAS JUST BEEN PROCESSED (FOR TESTING) - N GA,GF,GD - S GA=$NA(^TMP("C0CCCR",$J,DFN,"CCR",1)) - S GF="RPMS_CCR_"_DFN_"_"_DT_".xml" - S GD=^TMP("C0CCCR","ODIR") - W $$OUTPUT^C0CXPATH(GA,GF,GD) - Q - ; -SETTBL ; - K X ; CLEAR X - S X("PID","PID1")="1^00104^Set ID - Patient ID" - S X("PID","PID2")="2^00105^Patient ID (External ID)" - S X("PID","PID3")="3^00106^Patient ID (Internal ID)" - S X("PID","PID4")="4^00107^Alternate Patient ID" - S X("PID","PID5")="5^00108^Patient's Name" - S X("PID","PID6")="6^00109^Mother's Maiden Name" - S X("PID","PID7")="7^00110^Date of Birth" - S X("PID","PID8")="8^00111^Sex" - S X("PID","PID9")="9^00112^Patient Alias" - S X("PID","PID10")="10^00113^Race" - S X("PID","PID11")="11^00114^Patient Address" - S X("PID","PID12")="12^00115^County Code" - S X("PID","PID13")="13^00116^Phone Number - Home" - S X("PID","PID14")="14^00117^Phone Number - Business" - S X("PID","PID15")="15^00118^Language - Patient" - S X("PID","PID16")="16^00119^Marital Status" - S X("PID","PID17")="17^00120^Religion" - S X("PID","PID18")="18^00121^Patient Account Number" - S X("PID","PID19")="19^00122^SSN Number - Patient" - S X("PID","PID20")="20^00123^Drivers License - Patient" - S X("PID","PID21")="21^00124^Mother's Identifier" - S X("PID","PID22")="22^00125^Ethnic Group" - S X("PID","PID23")="23^00126^Birth Place" - S X("PID","PID24")="24^00127^Multiple Birth Indicator" - S X("PID","PID25")="25^00128^Birth Order" - S X("PID","PID26")="26^00129^Citizenship" - S X("PID","PID27")="27^00130^Veteran.s Military Status" - S X("PID","PID28")="28^00739^Nationality" - S X("PID","PID29")="29^00740^Patient Death Date/Time" - S X("PID","PID30")="30^00741^Patient Death Indicator" - S X("NTE","NTE1")="1^00573^Set ID - NTE" - S X("NTE","NTE2")="2^00574^Source of Comment" - S X("NTE","NTE3")="3^00575^Comment" - S X("ORC","ORC1")="1^00215^Order Control" - S X("ORC","ORC2")="2^00216^Placer Order Number" - S X("ORC","ORC3")="3^00217^Filler Order Number" - S X("ORC","ORC4")="4^00218^Placer Order Number" - S X("ORC","ORC5")="5^00219^Order Status" - S X("ORC","ORC6")="6^00220^Response Flag" - S X("ORC","ORC7")="7^00221^Quantity/Timing" - S X("ORC","ORC8")="8^00222^Parent" - S X("ORC","ORC9")="9^00223^Date/Time of Transaction" - S X("ORC","ORC10")="10^00224^Entered By" - S X("ORC","ORC11")="11^00225^Verified By" - S X("ORC","ORC12")="12^00226^Ordering Provider" - S X("ORC","ORC13")="13^00227^Enterer's Location" - S X("ORC","ORC14")="14^00228^Call Back Phone Number" - S X("ORC","ORC15")="15^00229^Order Effective Date/Time" - S X("ORC","ORC16")="16^00230^Order Control Code Reason" - S X("ORC","ORC17")="17^00231^Entering Organization" - S X("ORC","ORC18")="18^00232^Entering Device" - S X("ORC","ORC19")="19^00233^Action By" - S X("OBR","OBR1")="1^00237^Set ID - Observation Request" - S X("OBR","OBR2")="2^00216^Placer Order Number" - S X("OBR","OBR3")="3^00217^Filler Order Number" - S X("OBR","OBR4")="4^00238^Universal Service ID" - S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE" - S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT" - S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE^RESULTCODINGSYSTEM" - S X("OBR","OBR5")="5^00239^Priority" - S X("OBR","OBR6")="6^00240^Requested Date/Time" - S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME" - S X("OBR","OBR8")="8^00242^Observation End Date/Time" - S X("OBR","OBR9")="9^00243^Collection Volume" - S X("OBR","OBR10")="10^00244^Collector Identifier" - S X("OBR","OBR11")="11^00245^Specimen Action Code" - S X("OBR","OBR12")="12^00246^Danger Code" - S X("OBR","OBR13")="13^00247^Relevant Clinical Info." - S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time" - S X("OBR","OBR15")="15^00249^Specimen Source" - S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID" - S X("OBR","OBR17")="17^00250^Order Callback Phone Number" - S X("OBR","OBR18")="18^00251^Placers Field 1" - S X("OBR","OBR19")="19^00252^Placers Field 2" - S X("OBR","OBR20")="20^00253^Filler Field 1" - S X("OBR","OBR21")="21^00254^Filler Field 2" - S X("OBR","OBR22")="22^00255^Results Rpt./Status Change" - S X("OBR","OBR23")="23^00256^Charge to Practice" - S X("OBR","OBR24")="24^00257^Diagnostic Service Sect" - S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS" - S X("OBR","OBR26")="26^00259^Parent Result" - S X("OBR","OBR27")="27^00221^Quantity/Timing" - S X("OBR","OBR28")="28^00260^Result Copies to" - S X("OBR","OBR29")="29^00261^Parent Number" - S X("OBR","OBR30")="30^00262^Transportation Mode" - S X("OBR","OBR31")="31^00263^Reason for Study" - S X("OBR","OBR32")="32^00264^Principal Result Interpreter" - S X("OBR","OBR33")="33^00265^Assistant Result Interpreter" - S X("OBR","OBR34")="34^00266^Technician" - S X("OBR","OBR35")="35^00267^Transcriptionist" - S X("OBR","OBR36")="36^00268^Scheduled Date/Time" - S X("OBR","OBR37")="37^01028^Number of Sample Containers" - S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample" - S X("OBR","OBR39")="39^01030^Collector.s Comment" - S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility" - S X("OBR","OBR41")="41^01032^Transport Arranged" - S X("OBR","OBR42")="42^01033^Escort Required" - S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment" - S X("OBX","OBX1")="1^00559^Set ID - OBX" - S X("OBX","OBX2")="2^00676^Value Type" - S X("OBX","OBX3")="3^00560^Observation Identifier" - S X("OBX","OBX3;C1")="3;1^00560^Observation Identifier^C1" - S X("OBX","OBX3;C2")="3;2^00560^Observation Identifier^C2" - S X("OBX","OBX3;C3")="3;3^00560^Observation Identifier^C3" - S X("OBX","OBX3;C4")="3;4^00560^Observation Identifier^C4" - S X("OBX","OBX3;C5")="3;5^00560^Observation Identifier^C5" - S X("OBX","OBX3;C6")="3;6^00560^Observation Identifier^C6" - S X("OBX","OBX4")="4^00769^Observation Sub-Id" - S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE" - S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS" - S X("OBX","OBX7")="7^00563^Reference Range^RESULTTESTNORMALDESCTEXT" - S X("OBX","OBX8")="8^00564^Abnormal Flags^RESULTTESTFLAG" - S X("OBX","OBX9")="9^00639^Probability" - S X("OBX","OBX10")="10^00565^Nature of Abnormal Test" - S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT" - S X("OBX","OBX12")="12^00567^Date Last Normal Value" - S X("OBX","OBX13")="13^00581^User Defined Access Checks" - S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME" - S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID" - S X("OBX","OBX16")="16^00584^Responsible Observer" - S X("OBX","OBX17")="17^00936^Observation Method" - K ^TMP("C0CCCR","LABTBL") - M ^TMP("C0CCCR","LABTBL")=X ; SET VALUES IN LAB TBL - S ^TMP("C0CCCR","LABTBL",0)="V3" - Q - ; +C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008,2009 George Lilly, University of Minnesota. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; +MAP(MIXML,DFN,MOXML) ;TO MAKE THIS COMPATIBLE WITH OLD CALLING FOR EXTRACT + ; ASSUMES THAT EXTRACT HAS BEEN RUN AND THE VARIABLES STORED IN MIVAR + ; MIXML,MIVAR, AND MOXML ARE PASSED BY NAME + ; MIXML IS THE TEMPLATE TO USE + ; MOXML IS THE OUTPUT XML ARRAY + ; DFN IS THE PATIENT RECORD NUMBER + N C0COXML,C0CO,C0CV,C0CIXML + I '$D(MIVAR) S C0CV="" ;DEFAULT + E S C0CV=MIVAR ;PASSED VARIABLE ARRAY + I '$D(MIXML) S C0CIXML="" ;DEFAULT + E S C0CIXML=MIXML ;PASSED INPUT XML + D RPCMAP(.C0COXML,DFN,C0CV,C0CIXML) ; CALL RPC TO DO THE WORK + I '$D(MOXML) S C0CO=$NA(^TMP("C0CCCR",$J,DFN,"RESULTS")) ;DEFAULT FOR OUTPUT + E S C0CO=MOXML + ; ZWR C0COXML + M @C0CO=C0COXML ; COPY RESULTS TO OUTPUT + Q + ; +RPCMAP(RTN,DFN,RMIVAR,RMIXML) ; RPC ENTRY POINT FOR MAPPING RESULTS + ; RTN IS PASSED BY REFERENCE + ;N C0CT0,C0CT,C0CV ; CCR TEMPLATE, RESULTS SUBTEMPLATE, VARIABLES + ;N C0CRT,C0CTT ; TEST REQUEST TEMPLATE, TEST RESULT TEMPLATE + I '$D(DEBUG) S DEBUG=0 ; DEFAULT NO DEBUGGING + I RMIXML="" D ; INPUT XML NOT PASSED + . D LOAD^C0CCCR0("C0CT0") ; LOAD ENTIRE CCR TEMPLATE + . D QUERY^C0CXPATH("C0CT0","//ContinuityOfCareRecord/Body/Results","C0CT0R") + . S C0CT="C0CT0R" ; NAME OF EXTRACTED RESULTS TEMPLATE + E S C0CT=RMIXML ; WE ARE PASSED THE RESULTS PART OF THE TEMPLATE + I RMIVAR="" D ; LOCATION OF VARIABLES NOT PASSED + . S C0CV=$NA(^TMP("C0CCCR",$J,"RESULTS")) ;DEFAULT VARIABLE LOCATION + E S C0CV=RMIVAR ; PASSED LOCATIONS OF VARS + D CP^C0CXPATH(C0CT,"C0CRT") ; START MAKING TEST REQUEST TEMPLATE + D REPLACE^C0CXPATH("C0CRT","","//Results/Result/Test") ; DELETE TEST FROM REQ + D QUERY^C0CXPATH(C0CT,"//Results/Result/Test","C0CTT") ; MAKE TEST TEMPLATE + I '$D(C0CQT) S C0CQT=0 ; DEFAULT NOT SILENT + I 'C0CQT D ; WE ARE DEBUGGING + . W "I MAPPED",! + . W "VARS:",C0CV,! + . W "DFN:",DFN,! + . ;D PARY^C0CXPATH("C0CT") ; SECTION TEMPLATE + . ;D PARY^C0CXPATH("C0CRT") ;REQUEST TEMPLATE (OCR) + . ;D PARY^C0CXPATH("C0CTT") ;TEST TEMPLATE (OCX) + D EXTRACT("C0CT",DFN,) ; FIRST CALL EXTRACT + I '$D(@C0CV@(0)) D Q ; NO VARS THERE + . S RTN(0)=0 ; PASS BACK NO RESULTS INDICATOR + I @C0CV@(0)=0 S RTN(0)=0 Q ; NO RESULTS + S RIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"RESULTS")) + K @RIMVARS + M @RIMVARS=@C0CV ; UPDATE RIMVARS SO THEY STAY IN SYNCH + N C0CI,C0CJ,C0CMAP,C0CTMAP,C0CTMP + S C0CIN=@C0CV@(0) ; COUNT OF RESULTS (OBR) + N C0CRTMP ; AREA TO BUILD ONE RESULT REQUEST AND ALL TESTS FOR IT + N C0CRBASE S C0CRBASE=$NA(^TMP($J,"TESTTMP")) ;WORK AREA + N C0CRBLD ; BUILD LIST FOR XML - THE BUILD IS DELAYED UNTIL THE END + ; TO IMPROVE PERFORMANCE + D QUEUE^C0CXPATH("C0CRBLD","C0CRT",1,1) ; + 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 + . 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 + . . . I C0CJ=C0CJN S C0CJE=@C0CTMP@(0)-1 E S C0CJE=@C0CTMP@(0) ; + . . . 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) ; + . ;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)) ; + D BUILD^C0CXPATH("C0CRBLD","RTN") ;RENDER THE XML + K @C0CRBASE ; CLEAR OUT TEMPORARY STURCTURE + Q + ; +EXTRACT(ILXML,DFN,OLXML) ; EXTRACT LABS INTO THE C0CLVAR GLOBAL + ; + ; LABXML AND LABOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; + ; + ; + N C0CNSSN ; IS THERE AN SSN FLAG + S C0CNSSN=0 + S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS + D GHL7 ; GET HL7 MESSAGE FOR THIS PATIENT + I C0CNSSN=1 D Q ; NO SSN, CAN'T GET HL7 FOR THIS PATIENT + . S @C0CLB@(0)=0 + K @C0CLB ; CLEAR OUT OLD VARS IF ANY + N QTSAV S QTSAV=C0CQT ;SAVE QUIET FLAG + S C0CQT=1 ; SURPRESS LISTING + D LIST ; EXTRACT THE VARIABLES + ; FOR CERTIFICATION, SEE IF THERE ARE OTHER RESULTS TO ADD + D EN^C0CORSLT(C0CLB,DFN) ; LOOKS FOR ECG TESTS + S C0CQT=QTSAV ; RESET SILENT FLAG + K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT + I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^C0CLABS + Q + ; +GHL7 ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT + ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR + ; SET UP FOR LAB API CALL + S C0CPTID=$$SSN^C0CDPT(DFN) ; GET THE SSN FOR THIS PATIENT + I C0CPTID="" D Q ; NO SSN, COMPLAIN AND QUIT + . W "LAB LOOKUP FAILED, NO SSN",! + . S C0CNSSN=1 ; SET NO SSN FLAG + S C0CSPC="*" ; LOOKING FOR ALL LABS + ;I $D(^TMP("C0CCCR","RPMS")) D ; RUNNING RPMS + ;. D DT^DILF(,"T-365",.C0CSDT) ; START DATE ONE YEAR AGO TO LIMIT VOLUME + ;E D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING + ;D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY + S C0CLLMT=$$GET^C0CPARMS("LABLIMIT") ; GET THE LIMIT PARM + S C0CLSTRT=$$GET^C0CPARMS("LABSTART") ; GET START PARM + D DT^DILF(,C0CLLMT,.C0CSDT) ; + W "LAB LIMIT: ",C0CLLMT,! + D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM + S C0CEDT=$$NOW^XLFDT ; PULL LABS STARTING NOW + S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP + Q + ; +LIST ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB + ; + ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR + I '$D(C0CLB) S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS + I '$D(C0CQT) S C0CQT=0 + I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT + I '$D(^TMP("C0CCCR","LABTBL",0)) D SETTBL ;INITIALIZE LAB TABLE + I ^TMP("C0CCCR","LABTBL",0)'="V3" D SETTBL ;NEED NEWEST VERSION + I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE + S C0CTAB=$NA(^TMP("C0CCCR","LABTBL")) ; BASE OF OBX TABLE + S C0CHB=$NA(^TMP("HLS",$J)) + S C0CI="" + S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT + F S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI="" D ; FOR ALL RECORDS IN HL7 MSG + . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES + . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) + . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT) + . I $G(C0CVAR("RESULTCODINGSYSTEM"))="LN" D ; gpl - for certification + . . S C0CVAR("RESULTCODINGSYSTEM")="LOINC" ; NEED TO SPELL IT OUT + . . N C0CRDT S C0CRDT=C0CVAR("RESULTDESCRIPTIONTEXT") ; THE DESCRIPTION + . . N C0CRCD S C0CRCD=C0CVAR("RESULTCODE") ; THE LOINC CODE + . . S C0CVAR("RESULTDESCRIPTIONTEXT")=C0CRDT_" LOINC: "_C0CRCD + . M XV=C0CVAR ; + . I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION + . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT + . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT + . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS + . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI + . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR + . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1) + . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT + . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL + . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME + . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS + . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION + . I C0CTYP="OBX" D ; SPECIAL CASE FOR OBX3 + . . ; RESULTTESTCODEVALUE + . . ; RESULTTESTDESCRIPTIONTEXT + . . I C0CVAR("C3")="LN" D ; PRIMARY CODE IS LOINC + . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE + . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC + . . . ;S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESC TXT + . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2")_" LOINC: "_C0CVAR("C1") + . . E I C0CVAR("C6")="LN" D ; SECONDARY CODE IS LOINC + . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE + . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC + . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT + . . E I C0CVAR("C6")'="" D ; NO LOINC CODES, USE SECONDARY IF PRESENT + . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE + . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME + . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT + . . E D ; NO SECONDARY, USE PRIMARY + . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE + . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME + . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT + . . N C0CZG S C0CZG=XV("RESULTTESTNORMALDESCTEXT") ; + . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH + . . ;S XV("RESULTTESTNORMALDESCTEXT")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE + . . S XV("RESULTTESTNORMALDESCTEXT")=C0CZG + . . S C0CZG=XV("RESULTTESTVALUE") + . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH + . . ;S XV("RESULTTESTVALUE")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE + . . S XV("RESULTTESTVALUE")=C0CZG + . I C0CTYP="OBX" D ; PROCESS TEST RESULTS + . . I C0CLOBX=0 D ; FIRST TEST RESULT FOR THIS SECTION + . . . S C0CLB2=$NA(@C0CLB@(C0CLI,"M","TEST")) ; INDENT FOR TEST RESULTS + . . S C0CLOBX=C0CLOBX+1 ; INCREMENT TEST COUNT + . . S @C0CLB2@(0)=C0CLOBX ; STORE THE TEST COUNT + . . S XV("RESULTTESTOBJECTID")="RESULTTEST_"_C0CLI_"_"_C0CLOBX + . . S C0CX1=XV("RESULTTESTSOURCEACTORID") ; TEST SOURCE + . . S C0CX2=$P($P(C0CX1,"^",1),"-",1) ; PULL OUT STATION NUMBER + . . S XV("RESULTTESTSOURCEACTORID")="ACTORORGANIZATION_"_C0CX2 + . . S XV("RESULTTESTNORMALSOURCEACTORID")=XV("RESULTTESTSOURCEACTORID") + . . S C0CX1=XV("RESULTTESTDATETIME") ;DATE TIME IN HL7 FORMAT + . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL + . . S XV("RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME + . . ; I 'C0CQT ZWR XV + . . M @C0CLB2@(C0CLOBX)=XV ; PERSIST THE TEST RESULT VARIABLES + . I 'C0CQT D ; + . . W C0CI," ",C0CTYP,! + . ; S C0CI=$O(@C0CHB@(C0CI)) + ;K ^TMP("C0CRIM","VARS",DFN,"RESULTS") + ;M ^TMP("C0CRIM","VARS",DFN,"RESULTS")=@C0CLB + Q +LTYP(OSEG,OTYP,OVARA,OC0CQT) ; + S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE + I '$D(OC0CQT) S C0CQT=0 ; NOT C0CQT IS DEFAULT + E S C0CQT=OC0CQT ; ACCEPT C0CQT FLAG + I 1 D ; FOR HL7 SEGMENT TYPE + . S OI="" ; INDEX INTO FIELDS IN SEG + . F S OI=$O(@OTAB@(OI)) Q:OI="" D ; FOR EACH FIELD OF THE SEGMENT + . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX + . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED + . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE + . . I $P(OI,";",2)'="" D ; THIS IS DEFINING A SUB-VALUE + . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX + . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE + . . I OVAR'="" S OVARA(OVAR)=OV ; PASS BACK VARIABLE AND VALUE + . . I 'C0CQT D ; PRINT OUTPUT IF C0CQT IS FALSE + . . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,! + Q +LOBX ; + Q + ; +OUT(DFN) ; WRITE OUT A CCR THAT HAS JUST BEEN PROCESSED (FOR TESTING) + N GA,GF,GD + S GA=$NA(^TMP("C0CCCR",$J,DFN,"CCR",1)) + S GF="RPMS_CCR_"_DFN_"_"_DT_".xml" + S GD=^TMP("C0CCCR","ODIR") + W $$OUTPUT^C0CXPATH(GA,GF,GD) + Q + ; +SETTBL ; + K X ; CLEAR X + S X("PID","PID1")="1^00104^Set ID - Patient ID" + S X("PID","PID2")="2^00105^Patient ID (External ID)" + S X("PID","PID3")="3^00106^Patient ID (Internal ID)" + S X("PID","PID4")="4^00107^Alternate Patient ID" + S X("PID","PID5")="5^00108^Patient's Name" + S X("PID","PID6")="6^00109^Mother's Maiden Name" + S X("PID","PID7")="7^00110^Date of Birth" + S X("PID","PID8")="8^00111^Sex" + S X("PID","PID9")="9^00112^Patient Alias" + S X("PID","PID10")="10^00113^Race" + S X("PID","PID11")="11^00114^Patient Address" + S X("PID","PID12")="12^00115^County Code" + S X("PID","PID13")="13^00116^Phone Number - Home" + S X("PID","PID14")="14^00117^Phone Number - Business" + S X("PID","PID15")="15^00118^Language - Patient" + S X("PID","PID16")="16^00119^Marital Status" + S X("PID","PID17")="17^00120^Religion" + S X("PID","PID18")="18^00121^Patient Account Number" + S X("PID","PID19")="19^00122^SSN Number - Patient" + S X("PID","PID20")="20^00123^Drivers License - Patient" + S X("PID","PID21")="21^00124^Mother's Identifier" + S X("PID","PID22")="22^00125^Ethnic Group" + S X("PID","PID23")="23^00126^Birth Place" + S X("PID","PID24")="24^00127^Multiple Birth Indicator" + S X("PID","PID25")="25^00128^Birth Order" + S X("PID","PID26")="26^00129^Citizenship" + S X("PID","PID27")="27^00130^Veteran.s Military Status" + S X("PID","PID28")="28^00739^Nationality" + S X("PID","PID29")="29^00740^Patient Death Date/Time" + S X("PID","PID30")="30^00741^Patient Death Indicator" + S X("NTE","NTE1")="1^00573^Set ID - NTE" + S X("NTE","NTE2")="2^00574^Source of Comment" + S X("NTE","NTE3")="3^00575^Comment" + S X("ORC","ORC1")="1^00215^Order Control" + S X("ORC","ORC2")="2^00216^Placer Order Number" + S X("ORC","ORC3")="3^00217^Filler Order Number" + S X("ORC","ORC4")="4^00218^Placer Order Number" + S X("ORC","ORC5")="5^00219^Order Status" + S X("ORC","ORC6")="6^00220^Response Flag" + S X("ORC","ORC7")="7^00221^Quantity/Timing" + S X("ORC","ORC8")="8^00222^Parent" + S X("ORC","ORC9")="9^00223^Date/Time of Transaction" + S X("ORC","ORC10")="10^00224^Entered By" + S X("ORC","ORC11")="11^00225^Verified By" + S X("ORC","ORC12")="12^00226^Ordering Provider" + S X("ORC","ORC13")="13^00227^Enterer's Location" + S X("ORC","ORC14")="14^00228^Call Back Phone Number" + S X("ORC","ORC15")="15^00229^Order Effective Date/Time" + S X("ORC","ORC16")="16^00230^Order Control Code Reason" + S X("ORC","ORC17")="17^00231^Entering Organization" + S X("ORC","ORC18")="18^00232^Entering Device" + S X("ORC","ORC19")="19^00233^Action By" + S X("OBR","OBR1")="1^00237^Set ID - Observation Request" + S X("OBR","OBR2")="2^00216^Placer Order Number" + S X("OBR","OBR3")="3^00217^Filler Order Number" + S X("OBR","OBR4")="4^00238^Universal Service ID" + S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE" + S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT" + S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE^RESULTCODINGSYSTEM" + S X("OBR","OBR5")="5^00239^Priority" + S X("OBR","OBR6")="6^00240^Requested Date/Time" + S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME" + S X("OBR","OBR8")="8^00242^Observation End Date/Time" + S X("OBR","OBR9")="9^00243^Collection Volume" + S X("OBR","OBR10")="10^00244^Collector Identifier" + S X("OBR","OBR11")="11^00245^Specimen Action Code" + S X("OBR","OBR12")="12^00246^Danger Code" + S X("OBR","OBR13")="13^00247^Relevant Clinical Info." + S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time" + S X("OBR","OBR15")="15^00249^Specimen Source" + S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID" + S X("OBR","OBR17")="17^00250^Order Callback Phone Number" + S X("OBR","OBR18")="18^00251^Placers Field 1" + S X("OBR","OBR19")="19^00252^Placers Field 2" + S X("OBR","OBR20")="20^00253^Filler Field 1" + S X("OBR","OBR21")="21^00254^Filler Field 2" + S X("OBR","OBR22")="22^00255^Results Rpt./Status Change" + S X("OBR","OBR23")="23^00256^Charge to Practice" + S X("OBR","OBR24")="24^00257^Diagnostic Service Sect" + S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS" + S X("OBR","OBR26")="26^00259^Parent Result" + S X("OBR","OBR27")="27^00221^Quantity/Timing" + S X("OBR","OBR28")="28^00260^Result Copies to" + S X("OBR","OBR29")="29^00261^Parent Number" + S X("OBR","OBR30")="30^00262^Transportation Mode" + S X("OBR","OBR31")="31^00263^Reason for Study" + S X("OBR","OBR32")="32^00264^Principal Result Interpreter" + S X("OBR","OBR33")="33^00265^Assistant Result Interpreter" + S X("OBR","OBR34")="34^00266^Technician" + S X("OBR","OBR35")="35^00267^Transcriptionist" + S X("OBR","OBR36")="36^00268^Scheduled Date/Time" + S X("OBR","OBR37")="37^01028^Number of Sample Containers" + S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample" + S X("OBR","OBR39")="39^01030^Collector.s Comment" + S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility" + S X("OBR","OBR41")="41^01032^Transport Arranged" + S X("OBR","OBR42")="42^01033^Escort Required" + S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment" + S X("OBX","OBX1")="1^00559^Set ID - OBX" + S X("OBX","OBX2")="2^00676^Value Type" + S X("OBX","OBX3")="3^00560^Observation Identifier" + S X("OBX","OBX3;C1")="3;1^00560^Observation Identifier^C1" + S X("OBX","OBX3;C2")="3;2^00560^Observation Identifier^C2" + S X("OBX","OBX3;C3")="3;3^00560^Observation Identifier^C3" + S X("OBX","OBX3;C4")="3;4^00560^Observation Identifier^C4" + S X("OBX","OBX3;C5")="3;5^00560^Observation Identifier^C5" + S X("OBX","OBX3;C6")="3;6^00560^Observation Identifier^C6" + S X("OBX","OBX4")="4^00769^Observation Sub-Id" + S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE" + S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS" + S X("OBX","OBX7")="7^00563^Reference Range^RESULTTESTNORMALDESCTEXT" + S X("OBX","OBX8")="8^00564^Abnormal Flags^RESULTTESTFLAG" + S X("OBX","OBX9")="9^00639^Probability" + S X("OBX","OBX10")="10^00565^Nature of Abnormal Test" + S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT" + S X("OBX","OBX12")="12^00567^Date Last Normal Value" + S X("OBX","OBX13")="13^00581^User Defined Access Checks" + S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME" + S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID" + S X("OBX","OBX16")="16^00584^Responsible Observer" + S X("OBX","OBX17")="17^00936^Observation Method" + K ^TMP("C0CCCR","LABTBL") + M ^TMP("C0CCCR","LABTBL")=X ; SET VALUES IN LAB TBL + S ^TMP("C0CCCR","LABTBL",0)="V3" + Q + ; Index: ccr/branches/ohum/p/C0CMAIL.m =================================================================== --- ccr/branches/ohum/p/C0CMAIL.m (revision 1333) +++ ccr/branches/ohum/p/C0CMAIL.m (revision 1337) @@ -1,372 +1,372 @@ -C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr -V ;;0.1;C0C;nopatch;noreleasedate;Build 1 - ;Copyright 2011 Chris Richardson, Richardson Computer Research - ; Modified 3110516@1818 - ; rcr@rcresearch.us - ; Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; ------------------ - ;Entry Points - ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) - ; Input: - ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL - ; or "*" for all boxes, default is "IN" if missing]" - ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", - ; "*" for All or 9,999 maximum - ; MALL?1.n = that number of the n most recent - ; Internally: - ; BNAM = Box Name - ; Output: - ; C0CDATA - ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket - ; (BNAM,"MSG",C0CIEN,"FROM")=Name - ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address - ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address - ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title - ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments - ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text - ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text - ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes - ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) - ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line - ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details - ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data - ; - ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments - ; Input; - ; D0 - The IEN for the message in file 3.9, MESSAGE global - ; Output - ; OUTBF - The array of your choice to save the expanded and decoded message. - ; -GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data - K:'$G(C0CDATA("KEEP")) C0CDATA - N U - S U="^" - D:$G(C0CINPUT) - . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL - . S INPUT=C0CINPUT - . S DUZ=+INPUT - . D:$D(^XMB(3.7,DUZ,0))#2 - . . S MBLST=$P(INPUT,";",2) - . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag - . . S:MALL["*" MALL=99999 - . . ; Only one of these can be correct - . . D - . . . ; If nul, make it "IN" only - . . . I MBLST="" D QUIT - . . . . S MBLST("IN")=0,I=0 - . . . . D GATHER(DUZ,"IN",.LST) - . . . .QUIT - . . . ; - . . . ; If "*", Get all Mailboxes and look for New Messages - . . . I MBLST["*" D QUIT - . . . . N NAM,NUM - . . . . S NUM=0 - . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D - . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) - . . . . . D GATHER(DUZ,NAM,.LST) - . . . . .QUIT - . . . .QUIT - . . . ; - . . . ; If comma separated, look for mailboxes with new messages - . . . I $L(MBLST,",")>1 D QUIT - . . . . S NAM="" - . . . . N T,V - . . . . F T=1:1:$L(MBLST,",") S V=$P(MBLST,",",T) I $L(V) D - . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) - . . . . . S:NAM="" NAM=V - . . . . . D GATHER(DUZ,NAM,.LST) - . . . . .QUIT - . . . .QUIT - . . . ; - . . . ; If only 1 mailbox named, go get it - . . . I $L(MBLST) D GATHER(DUZ,MBLST,.LST) QUIT - . . .QUIT - . . MERGE C0CDATA=LST - . .QUIT - .QUIT - QUIT - ; =================== -GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail - N I,J,K,L - S (I,K)=0 - S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) - F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D - . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) - . D ; :L - . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails - . . S LST(NAM,"MSG",I)=L - . . D GETTYP(I) - . .QUIT - .QUIT - S LST(NAM,"NUMBER")=K - QUIT - ; =================== - ; D0 is the IEN into the Message Global ^XMB(3.9,D0) - ; The products of these emails are scanned to identify - ; the number of documents stored in the MIME package. - ; The protocol runs like this; - ; Line 1 is the --separator - ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD - ; Line n+2 thru t-1 where t does NOT have "Content-" - ; Line t is Next Section Terminator, or Message Terminator, --separator - ; Line t+1 should not exist in the data set if Message Terminator - ; CON = "Content-" - ; FLG = "--" - ; SEP = FLG+7 or more characters ; Separator - ; END = SEP+FLG - ; SGC = Segment Count - ; Note: separator is a string of specific characters of - ; indeterminate length - ; LST() the transfer array - ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line - ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data - ; -GETTYP(D0) ; Look for the goodies in the Mail - N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM - S CON="Content-" - S FLG="--" - S SEP="" ; Start SEP as null, so we can use this to help identify the type - S (BCN,CNT,D1,END,SGC)=0 - S XX=$G(^XMB(3.9,D0,0)) - S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) - S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) - F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) - S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) - S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) - ; Get the folks the email is sent to. - S D1=0 - F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D - . N T - . S T=+$G(^XMB(3.9,D0,1,D1,0)) - . S:T T=$P($G(^VA(200,+T,0)),"^") - . S LST("TO",D1)=T - . S T=$G(^XMB(3.9,D0,6,D1,0)) - . S:T T=$P($G(^VA(200,+T,0)),"^") - . S:T="" T="" - . S LST("TO NAME",D1)=T - .QUIT - ; Preload first Segment (0) with beginning on Line 1 - ; if not a 64bit - S LST(NAM,"MSG",D0,"SEG",0)=1 - S D1=.9999,SEP="--" - F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D - . ; Clear any control characters (cr/lf/ff) off - . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) - . ; Enter once to set the SEP to capture the separator - . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q - . . S SEP=X,END=X_FLG - . . S (CNT,SGC)=1,BCN=0 - . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 - . .QUIT - . ; - . ; A new separator is set, process original - . I X=SEP D QUIT - . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN - . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) - . . S SGC=SGC+1,BCN=0 - . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 - . .QUIT - . ; - . S BCN=BCN+$L(X) - . I X[CON D Q - . . S J=$P($P(X,";"),CON,2) - . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) - . .QUIT - . ; - . ; S LST(NAM,"MSG",D0,"SEG",D1)=X - .QUIT - QUIT - ; =================== -NAME(NM) ; Return the name of the Sender - N NAME - S NAME="" - D - . ; Look first for a value to use with the NEW PERSON file - . ; - . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q - . ; - . I $L(NM) S NAME=NM Q - . ; - . ; Else, pull the data from the message and display the foreign source - . ; of the message. - . N T - . S VAL=$G(^XMB(3.9,D0,.7)) - . S:VAL T=$P(^VA(200,VAL,0),U) - . I $L($G(T)) S NAME=T Q - . ; - .QUIT - QUIT NAME - ; =================== -TIME(Y) ; The time and date of the sending - X ^DD("DD") - QUIT Y - ; =================== - ; Segments in Message need to be identified and decoded properly - ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message - ; ARRAY will have the details of this one call - ; - ; Inputs; - ; C0CINPUT - The IEN of the message to expand - ; Outputs; - ; C0CDATA - Carrier for the returned structure of the Message - ; C0CDATA(D0,"SEG")=number of SEGMENTS - ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details - ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details - ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details - ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details - ; -DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery - N LST,D0,D1,U - S U="^" - S D0=+$G(C0CINPUT) - I D0 D QUIT - . D GETTYP2(D0) - . I $D(LST) M C0CDATA(D0)=LST - .QUIT - QUIT - ; =================== - ; End note if needed - ; MSK - Set of characters that do not exist in 64 bit encoding -GETTYP2(D0) ; Try to get the types and MSK for the - N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM - S CON="Content-",U="^" - S FLG="--" - S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" - S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type - S (BCN,CNT,D1,END,SGC)=0 - S XX=$G(^XMB(3.9,D0,0)) - ; S K=$P(^XMB(3.9,D0,2,0),U,3) - S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) - S LST("CREATED")=$$TIME($P(XX,U,3)) - F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) - S LST("FROM")=$$NAME(XXNM) - ; Get the folks the email is sent to. - S D1=0 - F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" - . N I,T - . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) - . S:T T=$P($G(^VA(200,T,0)),"^") - . S LST("TO",+D1)=T - . S T=$G(^XMB(3.9,D0,6,+D1,0)) - . S:T="" T=$P($G(^VA(200,+T,0)),"^") - . S:T="" T="" - . S LST("TO NAME",D1)=T - .QUIT - ; Get the Header for the message - S D1=0 - F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D - . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) - .QUIT - ; Start walking the different sections - S D1=.99999,SEP="--" - F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D - . ; Clear any control characters (cr/lf/ff) off - . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) - . ; Enter once to set the SEP to capture the separator - . I (SEP="--")&($E(X,1,2)=FLG)&($L(X,FLG)=2) D Q - . . S SEP=X,END=X_FLG - . . S (CNT,SGC)=1,BCN=0 - . . S LST("SEG",SGC)=D1 - . .QUIT - . ; - . ; A new SEGMENT separator is set, process original - . I X=SEP D QUIT - . . ; Save Current Values - . . S LST("SEG",SGC,"SIZE")=BCN - . . ; Close this Segment and prepare to start a New Segment - . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) - . . ; Put the result in LST("SEG",SGC,"XML") - . . I $L(BF) D - . . . S ZN=1 - . . . N I,T,TBF - . . . S TBF=BF - . . . F I=1:1:($L(TBF,"=")) D - . . . . S BF=$P(TBF,"=",I)_"=" - . . . . I BF'="=" D DECODER - . . . .QUIT - . . . S BF="" - . . .QUIT - . . S SGC=SGC+1,BCN=0 - . . ; Incriment SGC to start a new Segment - . . S LST("SEG",SGC)=D1 - . .QUIT - . ; - . ; Accumulate the 64 bit encoding - . I X=$TR(X,MSK)&$L(X) D Q - . . S BF=BF_X - . . S BCN=BCN+$L(X) - . .QUIT - . ; - . ; Ending Condition, close out the Segment - . I X=END D QUIT - . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) - . . I $L(BF) S ZN=1 D DECODER S BF="" Q - . .QUIT - . ; - . S BCN=BCN+$L(X) - . ; Split out the Content Info - . I X[CON D Q - . . S J=$P(X,CON,2) - . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9) - . .QUIT - . ; - . ; Everything else is Text - . S LST("SEG",SGC,"TXT",D1)=X - .QUIT - QUIT - ; =================== - ; Break down the Buffer Array so it can be saved. - ; BF is passed in. -DECODER ; - N RCNT,TBF,ZBF,ZI,ZJ,ZK,ZSIZE - S ZBF=BF - ; Full Buffer, BF, now check for Encryption and Unpack - F RCNT=1:1:$L(ZBF,"=") D - . N BF - . S BF=$P(ZBF,"=",RCNT) - . ; Unpacking the 64 bit encoding - . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) - . D:$L(TBF) - . . N XBF - . . S BF=BF_"=" - . . D NORMAL(.XBF,.TBF) - . . M LST("SEG",SGC,"XML",RCNT)=XBF - . .QUIT - .QUIT - QUIT - ; =================== - ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT - ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT - ; >D NORMAL^C0CMAIL(.OUT,BF) -NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML - ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME - ; - N ZN,OUTBF - S ZN=1 - S OUTBF(ZN)=$P(INXML,"><",ZN)_">" - F ZN=ZN+1:1 S OUTBF(ZN)="<"_$P(INXML,"><",ZN) Q:$P(INXML,"><",ZN+1)="" D ; - . S OUTBF(ZN)=OUTBF(ZN)_">" - .QUIT - M OUTXML=OUTBF - QUIT - ; =================== - ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv - ; End note if needed - QUIT - ; =================== +C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr +V ;;0.1;C0C;nopatch;noreleasedate + ;Copyright 2011 Chris Richardson, Richardson Computer Research + ; Modified 3110516@1818 + ; rcr@rcresearch.us + ; Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; ------------------ + ;Entry Points + ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) + ; Input: + ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL + ; or "*" for all boxes, default is "IN" if missing]" + ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", + ; "*" for All or 9,999 maximum + ; MALL?1.n = that number of the n most recent + ; Internally: + ; BNAM = Box Name + ; Output: + ; C0CDATA + ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket + ; (BNAM,"MSG",C0CIEN,"FROM")=Name + ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title + ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments + ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text + ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text + ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes + ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) + ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data + ; + ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments + ; Input; + ; D0 - The IEN for the message in file 3.9, MESSAGE global + ; Output + ; OUTBF - The array of your choice to save the expanded and decoded message. + ; +GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data + K:'$G(C0CDATA("KEEP")) C0CDATA + N U + S U="^" + D:$G(C0CINPUT) + . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL + . S INPUT=C0CINPUT + . S DUZ=+INPUT + . D:$D(^XMB(3.7,DUZ,0))#2 + . . S MBLST=$P(INPUT,";",2) + . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag + . . S:MALL["*" MALL=99999 + . . ; Only one of these can be correct + . . D + . . . ; If nul, make it "IN" only + . . . I MBLST="" D QUIT + . . . . S MBLST("IN")=0,I=0 + . . . . D GATHER(DUZ,"IN",.LST) + . . . .QUIT + . . . ; + . . . ; If "*", Get all Mailboxes and look for New Messages + . . . I MBLST["*" D QUIT + . . . . N NAM,NUM + . . . . S NUM=0 + . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D + . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) + . . . . . D GATHER(DUZ,NAM,.LST) + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If comma separated, look for mailboxes with new messages + . . . I $L(MBLST,",")>1 D QUIT + . . . . S NAM="" + . . . . N T,V + . . . . F T=1:1:$L(MBLST,",") S V=$P(MBLST,",",T) I $L(V) D + . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) + . . . . . S:NAM="" NAM=V + . . . . . D GATHER(DUZ,NAM,.LST) + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If only 1 mailbox named, go get it + . . . I $L(MBLST) D GATHER(DUZ,MBLST,.LST) QUIT + . . .QUIT + . . MERGE C0CDATA=LST + . .QUIT + .QUIT + QUIT + ; =================== +GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail + N I,J,K,L + S (I,K)=0 + S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) + F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D + . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) + . D ; :L + . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails + . . S LST(NAM,"MSG",I)=L + . . D GETTYP(I) + . .QUIT + .QUIT + S LST(NAM,"NUMBER")=K + QUIT + ; =================== + ; D0 is the IEN into the Message Global ^XMB(3.9,D0) + ; The products of these emails are scanned to identify + ; the number of documents stored in the MIME package. + ; The protocol runs like this; + ; Line 1 is the --separator + ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD + ; Line n+2 thru t-1 where t does NOT have "Content-" + ; Line t is Next Section Terminator, or Message Terminator, --separator + ; Line t+1 should not exist in the data set if Message Terminator + ; CON = "Content-" + ; FLG = "--" + ; SEP = FLG+7 or more characters ; Separator + ; END = SEP+FLG + ; SGC = Segment Count + ; Note: separator is a string of specific characters of + ; indeterminate length + ; LST() the transfer array + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data + ; +GETTYP(D0) ; Look for the goodies in the Mail + N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM + S CON="Content-" + S FLG="--" + S SEP="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) + S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D + . N T + . S T=+$G(^XMB(3.9,D0,1,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S LST("TO",D1)=T + . S T=$G(^XMB(3.9,D0,6,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . S LST("TO NAME",D1)=T + .QUIT + ; Preload first Segment (0) with beginning on Line 1 + ; if not a 64bit + S LST(NAM,"MSG",D0,"SEG",0)=1 + S D1=.9999,SEP="--" + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; Enter once to set the SEP to capture the separator + . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q + . . S SEP=X,END=X_FLG + . . S (CNT,SGC)=1,BCN=0 + . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 + . .QUIT + . ; + . ; A new separator is set, process original + . I X=SEP D QUIT + . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN + . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) + . . S SGC=SGC+1,BCN=0 + . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 + . .QUIT + . ; + . S BCN=BCN+$L(X) + . I X[CON D Q + . . S J=$P($P(X,";"),CON,2) + . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) + . .QUIT + . ; + . ; S LST(NAM,"MSG",D0,"SEG",D1)=X + .QUIT + QUIT + ; =================== +NAME(NM) ; Return the name of the Sender + N NAME + S NAME="" + D + . ; Look first for a value to use with the NEW PERSON file + . ; + . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q + . ; + . I $L(NM) S NAME=NM Q + . ; + . ; Else, pull the data from the message and display the foreign source + . ; of the message. + . N T + . S VAL=$G(^XMB(3.9,D0,.7)) + . S:VAL T=$P(^VA(200,VAL,0),U) + . I $L($G(T)) S NAME=T Q + . ; + .QUIT + QUIT NAME + ; =================== +TIME(Y) ; The time and date of the sending + X ^DD("DD") + QUIT Y + ; =================== + ; Segments in Message need to be identified and decoded properly + ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message + ; ARRAY will have the details of this one call + ; + ; Inputs; + ; C0CINPUT - The IEN of the message to expand + ; Outputs; + ; C0CDATA - Carrier for the returned structure of the Message + ; C0CDATA(D0,"SEG")=number of SEGMENTS + ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details + ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details + ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details + ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details + ; +DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery + N LST,D0,D1,U + S U="^" + S D0=+$G(C0CINPUT) + I D0 D QUIT + . D GETTYP2(D0) + . I $D(LST) M C0CDATA(D0)=LST + .QUIT + QUIT + ; =================== + ; End note if needed + ; MSK - Set of characters that do not exist in 64 bit encoding +GETTYP2(D0) ; Try to get the types and MSK for the + N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM + S CON="Content-",U="^" + S FLG="--" + S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" + S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + ; S K=$P(^XMB(3.9,D0,2,0),U,3) + S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST("CREATED")=$$TIME($P(XX,U,3)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST("FROM")=$$NAME(XXNM) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" + . N I,T + . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) + . S:T T=$P($G(^VA(200,T,0)),"^") + . S LST("TO",+D1)=T + . S T=$G(^XMB(3.9,D0,6,+D1,0)) + . S:T="" T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . S LST("TO NAME",D1)=T + .QUIT + ; Get the Header for the message + S D1=0 + F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D + . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) + .QUIT + ; Start walking the different sections + S D1=.99999,SEP="--" + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; Enter once to set the SEP to capture the separator + . I (SEP="--")&($E(X,1,2)=FLG)&($L(X,FLG)=2) D Q + . . S SEP=X,END=X_FLG + . . S (CNT,SGC)=1,BCN=0 + . . S LST("SEG",SGC)=D1 + . .QUIT + . ; + . ; A new SEGMENT separator is set, process original + . I X=SEP D QUIT + . . ; Save Current Values + . . S LST("SEG",SGC,"SIZE")=BCN + . . ; Close this Segment and prepare to start a New Segment + . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) + . . ; Put the result in LST("SEG",SGC,"XML") + . . I $L(BF) D + . . . S ZN=1 + . . . N I,T,TBF + . . . S TBF=BF + . . . F I=1:1:($L(TBF,"=")) D + . . . . S BF=$P(TBF,"=",I)_"=" + . . . . I BF'="=" D DECODER + . . . .QUIT + . . . S BF="" + . . .QUIT + . . S SGC=SGC+1,BCN=0 + . . ; Incriment SGC to start a new Segment + . . S LST("SEG",SGC)=D1 + . .QUIT + . ; + . ; Accumulate the 64 bit encoding + . I X=$TR(X,MSK)&$L(X) D Q + . . S BF=BF_X + . . S BCN=BCN+$L(X) + . .QUIT + . ; + . ; Ending Condition, close out the Segment + . I X=END D QUIT + . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) + . . I $L(BF) S ZN=1 D DECODER S BF="" Q + . .QUIT + . ; + . S BCN=BCN+$L(X) + . ; Split out the Content Info + . I X[CON D Q + . . S J=$P(X,CON,2) + . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9) + . .QUIT + . ; + . ; Everything else is Text + . S LST("SEG",SGC,"TXT",D1)=X + .QUIT + QUIT + ; =================== + ; Break down the Buffer Array so it can be saved. + ; BF is passed in. +DECODER ; + N RCNT,TBF,ZBF,ZI,ZJ,ZK,ZSIZE + S ZBF=BF + ; Full Buffer, BF, now check for Encryption and Unpack + F RCNT=1:1:$L(ZBF,"=") D + . N BF + . S BF=$P(ZBF,"=",RCNT) + . ; Unpacking the 64 bit encoding + . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) + . D:$L(TBF) + . . N XBF + . . S BF=BF_"=" + . . D NORMAL(.XBF,.TBF) + . . M LST("SEG",SGC,"XML",RCNT)=XBF + . .QUIT + .QUIT + QUIT + ; =================== + ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT + ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT + ; >D NORMAL^C0CMAIL(.OUT,BF) +NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML + ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME + ; + N ZN,OUTBF + S ZN=1 + S OUTBF(ZN)=$P(INXML,"><",ZN)_">" + F ZN=ZN+1:1 S OUTBF(ZN)="<"_$P(INXML,"><",ZN) Q:$P(INXML,"><",ZN+1)="" D ; + . S OUTBF(ZN)=OUTBF(ZN)_">" + .QUIT + M OUTXML=OUTBF + QUIT + ; =================== + ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv + ; End note if needed + QUIT + ; =================== Index: ccr/branches/ohum/p/C0CMAIL2.m =================================================================== --- ccr/branches/ohum/p/C0CMAIL2.m (revision 1333) +++ ccr/branches/ohum/p/C0CMAIL2.m (revision 1337) @@ -1,464 +1,464 @@ -C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr - ;;0.1;C0C;nopatch;noreleasedate;Build 1 - ;Copyright 2011 Chris Richardson, Richardson Computer Research - ; Modified 3110615@1040 - ; rcr@rcresearch.us - ; Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; ------------------ - ;Entry Points - ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments - ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) - ; Input: - ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL - ; or "*" for all boxes, default is "IN" if missing]" - ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", - ; "*" for All or 9,999 maximum - ; MALL?1.n = that number of the n most recent - ; Internally: - ; BNAM = Box Name - ; Output: - ; C0CDATA - ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket - ; (BNAM,"MSG",C0CIEN,"FROM")=Name - ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address - ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address - ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title - ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments - ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text - ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text - ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes - ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) - ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line - ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details - ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data - ; - ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments - ; Input; - ; D0 - The IEN for the message in file 3.9, MESSAGE global - ; Output - ; OUTBF - The array of your choice to save the expanded and decoded message. - ; -GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data - K:'$G(C0CDATA("KEEP")) C0CDATA - N U - S U="^" - D:$G(C0CINPUT) - . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL - . S INPUT=C0CINPUT - . S DUZ=+INPUT - . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q - . ; - . D:$D(^XMB(3.7,DUZ,0))#2 - . . S MBLST=$P(INPUT,";",2) - . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag - . . S:MALL["*" MALL=99999 - . . ; Only one of these can be correct - . . D - . . . ; If nul, make it "IN" only - . . . I MBLST="" D QUIT - . . . . S MBLST("IN")=0,I=0 - . . . . D GATHER(DUZ,"IN",.LST) - . . . .QUIT - . . . ; - . . . ; If "*", Get all Mailboxes and look for New Messages - . . . I MBLST["*" D QUIT - . . . . N NAM,NUM - . . . . S NUM=0 - . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D - . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) - . . . . . D GATHER(DUZ,NAM,.LST) - . . . . .QUIT - . . . .QUIT - . . . ; - . . . ; If comma separated, look for mailboxes with new messages - . . . I $L(MBLST,",")>1 D QUIT - . . . . S NAM="" - . . . . N TN,V - . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D - . . . . . I $L(V) D QUIT - . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) - . . . . . . S:NAM="" NAM=V - . . . . . . D GATHER(DUZ,NAM,.LST) - . . . . . .QUIT - . . . . . ; - . . . . . D ERROR("ER08") - . . . . .QUIT - . . . .QUIT - . . . ; - . . . ; If only 1 mailbox named, go get it - . . . I $L(MBLST) D QUIT - . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT - . . . . ; - . . . . D ERROR("ER07") - . . .QUIT - . . MERGE C0CDATA=LST - . .QUIT - .QUIT - QUIT - ; =================== -GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail - N I,J,K,L - S (I,K)=0 - S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) - F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D - . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) - . D ; :L - . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails - . . S LST(NAM,"MSG",I)=L - . . D GETTYP(I) - . .QUIT - .QUIT - S LST(NAM,"NUMBER")=K - QUIT - ; =================== - ; D0 is the IEN into the Message Global ^XMB(3.9,D0) - ; The products of these emails are scanned to identify - ; the number of documents stored in the MIME package. - ; The protocol runs like this; - ; Line 1 is the --separator - ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD - ; Line n+2 thru t-1 where t does NOT have "Content-" - ; Line t is Next Section Terminator, or Message Terminator, --separator - ; Line t+1 should not exist in the data set if Message Terminator - ; CON = "Content-" - ; FLG = "--" - ; SEP = FLG+7 or more characters ; Separator - ; END = SEP+FLG - ; SGC = Segment Count - ; Note: separator is a string of specific characters of - ; indeterminate length - ; LST() the transfer array - ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line - ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data - ; -GETTYP(D0) ; Look for the goodies in the Mail - N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM - S CON="Content-" - S FLG="--" - S SEP="" ; Start SEP as null, so we can use this to help identify the type - S (BCN,CNT,D1,END,SGC)=0 - S XX=$G(^XMB(3.9,D0,0)) - S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) - S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) - F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) - S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) - S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) - ; Get the folks the email is sent to. - S D1=0 - F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D - . N T - . S T=+$G(^XMB(3.9,D0,1,D1,0)) - . S:T T=$P($G(^VA(200,+T,0)),"^") - . S LST("TO",D1)=T - . S T=$G(^XMB(3.9,D0,6,D1,0)) - . S:T T=$P($G(^VA(200,+T,0)),"^") - . S:T="" T="" - . 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="" - 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="" - . 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["126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q - . . ; - . . D - . . . I 'OK S (BF,UBF,TBF,XBF)="" Q - . . . ; - . . . S BF=BF_"=" - . . . D NORMAL(.XBF,.TBF) - . . .QUIT - . . M LST("SEG",SGC,"XML",RCNT)=XBF - . .QUIT - .QUIT - QUIT - ; =================== - ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT - ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT - ; >D NORMAL^C0CMAIL(.OUT,BF) -NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML - ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME - ; - N ZN,OUTBF,XX,ZSEP - S INXML=$TR(INXML,$C(10,12,13)) - S ZN=1,ZSEP=">" - S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 - F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" - . S XX=$P(INXML,"><",ZN) - . S:$E($RE(XX))=">" ZSEP="" - . Q:XX="" - . ; - . S XX="<"_XX_ZSEP - . D - . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q - . . ; - . . D ERROR("ER05") - . . F ZL=ZL+1:1 D Q:XX="" - . . . N XL - . . . S XL=$E(XX,1,4000) - . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters - . . . S OUTBF(ZL)=XL - . . .QUIT - . .QUIT - .QUIT - M OUTXML=OUTBF - QUIT - ; =================== -UPPER(X) ; Convert any lowercase letters to Uppercase letters - QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ; =================== - ; EN is a counter that remains between error events -ERROR(ER) ; Error Handler - N TXXQ,XXXQ - S XXXQ="Unknown Error Encountered = "_ER - S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) - I TXXQ'="" D - . I TXXQ["_" X "S TXXQ="_TXXQ - . S XXXQ=TXXQ - .QUIT - S EN(ER)=$G(EN(ER))+1 - S LST("ERR",ER,EN(ER))=XXXQ - QUIT - ; =================== -ER01 ;;Message Missing -ER02 ;;Message Text Missing -ER03 ;;Message Not Identifiable -ER04 ;;Segment is too large -ER05 ;;Mailbox Missing -ER06 ;;"User Missing = "_$G(DUZ) -ER07 ;;"Bad DUZ = "_DUZ -ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) -ER10 ;;"Bad Separator found = "_X -ER11 ;;"Non-Standard Separator Found:>"_$G(J) -ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) - ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv - ; End note if needed - QUIT - ; =================== +C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr +V ;;0.1;C0C;nopatch;noreleasedate + ;Copyright 2011 Chris Richardson, Richardson Computer Research + ; Modified 3110615@1040 + ; rcr@rcresearch.us + ; Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; ------------------ + ;Entry Points + ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments + ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) + ; Input: + ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL + ; or "*" for all boxes, default is "IN" if missing]" + ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", + ; "*" for All or 9,999 maximum + ; MALL?1.n = that number of the n most recent + ; Internally: + ; BNAM = Box Name + ; Output: + ; C0CDATA + ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket + ; (BNAM,"MSG",C0CIEN,"FROM")=Name + ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title + ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments + ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text + ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text + ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes + ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) + ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data + ; + ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments + ; Input; + ; D0 - The IEN for the message in file 3.9, MESSAGE global + ; Output + ; OUTBF - The array of your choice to save the expanded and decoded message. + ; +GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data + K:'$G(C0CDATA("KEEP")) C0CDATA + N U + S U="^" + D:$G(C0CINPUT) + . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL + . S INPUT=C0CINPUT + . S DUZ=+INPUT + . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q + . ; + . D:$D(^XMB(3.7,DUZ,0))#2 + . . S MBLST=$P(INPUT,";",2) + . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag + . . S:MALL["*" MALL=99999 + . . ; Only one of these can be correct + . . D + . . . ; If nul, make it "IN" only + . . . I MBLST="" D QUIT + . . . . S MBLST("IN")=0,I=0 + . . . . D GATHER(DUZ,"IN",.LST) + . . . .QUIT + . . . ; + . . . ; If "*", Get all Mailboxes and look for New Messages + . . . I MBLST["*" D QUIT + . . . . N NAM,NUM + . . . . S NUM=0 + . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D + . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) + . . . . . D GATHER(DUZ,NAM,.LST) + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If comma separated, look for mailboxes with new messages + . . . I $L(MBLST,",")>1 D QUIT + . . . . S NAM="" + . . . . N TN,V + . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D + . . . . . I $L(V) D QUIT + . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) + . . . . . . S:NAM="" NAM=V + . . . . . . D GATHER(DUZ,NAM,.LST) + . . . . . .QUIT + . . . . . ; + . . . . . D ERROR("ER08") + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If only 1 mailbox named, go get it + . . . I $L(MBLST) D QUIT + . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT + . . . . ; + . . . . D ERROR("ER07") + . . .QUIT + . . MERGE C0CDATA=LST + . .QUIT + .QUIT + QUIT + ; =================== +GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail + N I,J,K,L + S (I,K)=0 + S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) + F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D + . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) + . D ; :L + . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails + . . S LST(NAM,"MSG",I)=L + . . D GETTYP(I) + . .QUIT + .QUIT + S LST(NAM,"NUMBER")=K + QUIT + ; =================== + ; D0 is the IEN into the Message Global ^XMB(3.9,D0) + ; The products of these emails are scanned to identify + ; the number of documents stored in the MIME package. + ; The protocol runs like this; + ; Line 1 is the --separator + ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD + ; Line n+2 thru t-1 where t does NOT have "Content-" + ; Line t is Next Section Terminator, or Message Terminator, --separator + ; Line t+1 should not exist in the data set if Message Terminator + ; CON = "Content-" + ; FLG = "--" + ; SEP = FLG+7 or more characters ; Separator + ; END = SEP+FLG + ; SGC = Segment Count + ; Note: separator is a string of specific characters of + ; indeterminate length + ; LST() the transfer array + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data + ; +GETTYP(D0) ; Look for the goodies in the Mail + N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM + S CON="Content-" + S FLG="--" + S SEP="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) + S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D + . N T + . S T=+$G(^XMB(3.9,D0,1,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S LST("TO",D1)=T + . S T=$G(^XMB(3.9,D0,6,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . 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="" + 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="" + . 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["126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q + . . ; + . . D + . . . I 'OK S (BF,UBF,TBF,XBF)="" 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 + ; =================== Index: ccr/branches/ohum/p/C0CMAIL3.m =================================================================== --- ccr/branches/ohum/p/C0CMAIL3.m (revision 1333) +++ ccr/branches/ohum/p/C0CMAIL3.m (revision 1337) @@ -1,534 +1,534 @@ -C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr - ;;0.1;C0C;nopatch;noreleasedate;Build 1 - ;Copyright 2011 Chris Richardson, Richardson Computer Research - ; Modified 3110619@2038 - ; rcr@rcresearch.us - ; Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; ------------------ - ;Entry Points - ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments - ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) - ; Input: - ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL - ; or "*" for all boxes, default is "IN" if missing]" - ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", - ; "*" for All or 9,999 maximum - ; MALL?1.n = that number of the n most recent - ; Internally: - ; BNAM = Box Name - ; Output: - ; C0CDATA - ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket - ; (BNAM,"MSG",C0CIEN,"FROM")=Name - ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address - ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address - ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title - ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments - ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text - ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text - ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes - ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) - ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line - ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details - ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data - ; - ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments - ; Input; - ; D0 - The IEN for the message in file 3.9, MESSAGE global - ; Output - ; OUTBF - The array of your choice to save the expanded and decoded message. - ; -GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data - K:'$G(C0CDATA("KEEP")) C0CDATA - N U - S U="^" - D:$G(C0CINPUT) - . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL - . S INPUT=C0CINPUT - . S DUZ=+INPUT - . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q - . ; - . D:$D(^XMB(3.7,DUZ,0))#2 - . . S MBLST=$P(INPUT,";",2) - . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag - . . S:MALL["*" MALL=99999 - . . ; Only one of these can be correct - . . D - . . . ; If nul, make it "IN" only - . . . I MBLST="" D QUIT - . . . . S MBLST("IN")=0,I=0 - . . . . D GATHER(DUZ,"IN",.LST) - . . . .QUIT - . . . ; - . . . ; If "*", Get all Mailboxes and look for New Messages - . . . I MBLST["*" D QUIT - . . . . N NAM,NUM - . . . . S NUM=0 - . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D - . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) - . . . . . D GATHER(DUZ,NAM,.LST) - . . . . .QUIT - . . . .QUIT - . . . ; - . . . ; If comma separated, look for mailboxes with new messages - . . . I $L(MBLST,",")>1 D QUIT - . . . . S NAM="" - . . . . N TN,V - . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D - . . . . . I $L(V) D QUIT - . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) - . . . . . . S:NAM="" NAM=V - . . . . . . D GATHER(DUZ,NAM,.LST) - . . . . . .QUIT - . . . . . ; - . . . . . D ERROR("ER08") - . . . . .QUIT - . . . .QUIT - . . . ; - . . . ; If only 1 mailbox named, go get it - . . . I $L(MBLST) D QUIT - . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT - . . . . ; - . . . . D ERROR("ER07") - . . .QUIT - . . MERGE C0CDATA=LST - . .QUIT - .QUIT - QUIT - ; =================== -GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail - N I,J,K,L - S (I,K)=0 - S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) - F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D - . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) - . D ; :L - . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails - . . S LST(NAM,"MSG",I)=L - . . D GETTYP(I) - . .QUIT - .QUIT - S LST(NAM,"NUMBER")=K - QUIT - ; =================== - ; D0 is the IEN into the Message Global ^XMB(3.9,D0) - ; The products of these emails are scanned to identify - ; the number of documents stored in the MIME package. - ; The protocol runs like this; - ; Line 1 is the --separator - ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD - ; Line n+2 thru t-1 where t does NOT have "Content-" - ; Line t is Next Section Terminator, or Message Terminator, --separator - ; Line t+1 should not exist in the data set if Message Terminator - ; CON = "Content-" - ; FLG = "--" - ; SEP = FLG+7 or more characters ; Separator - ; END = SEP+FLG - ; SGC = Segment Count - ; Note: separator is a string of specific characters of - ; indeterminate length - ; LST() the transfer array - ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line - ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data - ; -GETTYP(D0) ; Look for the goodies in the Mail - N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM - S CON="Content-" - S FLG="--" - S SEP="" ; Start SEP as null, so we can use this to help identify the type - S (BCN,CNT,D1,END,SGC)=0 - S XX=$G(^XMB(3.9,D0,0)) - S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) - S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) - F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) - S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) - S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) - ; Get the folks the email is sent to. - S D1=0 - F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D - . N T - . S T=+$G(^XMB(3.9,D0,1,D1,0)) - . S:T T=$P($G(^VA(200,+T,0)),"^") - . S LST("TO",D1)=T - . S T=$G(^XMB(3.9,D0,6,D1,0)) - . S:T T=$P($G(^VA(200,+T,0)),"^") - . S:T="" T="" - . 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="" - D - . ; Look first for a value to use with the NEW PERSON file - . ; - . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q - . ; - . I $L(NM) S NAME=NM Q - . ; - . ; Else, pull the data from the message and display the foreign source - . ; of the message. - . N T - . S VAL=$G(^XMB(3.9,D0,.7)) - . S:VAL T=$P(^VA(200,VAL,0),U) - . I $L($G(T)) S NAME=T Q - . ; - .QUIT - QUIT NAME - ; =================== -TIME(Y) ; The time and date of the sending - X ^DD("DD") - QUIT Y - ; =================== - ; Segments in Message need to be identified and decoded properly - ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message - ; ARRAY will have the details of this one call - ; - ; Inputs; - ; C0CINPUT - The IEN of the message to expand - ; Outputs; - ; C0CDATA - Carrier for the returned structure of the Message - ; C0CDATA(D0,"SEG")=number of SEGMENTS - ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type - ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details - ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details - ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details - ; -DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery - N LST,D0,D1,U - S U="^" - S D0=+$G(C0CINPUT) - I D0 D QUIT - . I $D(^XMB(3.9,D0))<10 D ERROR("ER01") QUIT - . ; - . D GETTYP2(D0) - . I $D(LST) M C0CDATA(D0)=LST Q - . ; - . D ERROR("ER02") - .QUIT - QUIT - ; =================== - ; End note if needed - ; MSK - Set of characters that do not exist in 64 bit encoding -GETTYP2(D0) ; Try to get the types and MSK for the - N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM - S CON="Content-",U="^" - S FLG="--",MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" - S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type - S (BCN,CNT,D1,END,SGC)=0 - S XX=$G(^XMB(3.9,D0,0)) - ; S K=$P(^XMB(3.9,D0,2,0),U,3) - S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) - S LST("CREATED")=$$TIME($P(XX,U,3)) - F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) - S LST("FROM")=$$NAME(XXNM) - ; Get the folks the email is sent to. - S D1=0 - F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" - . N I,T - . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) - . S:T T=$P($G(^VA(200,T,0)),"^") - . S LST("TO",+D1)=T - . S T=$G(^XMB(3.9,D0,6,+D1,0)) - . S:T="" T=$P($G(^VA(200,+T,0)),"^") - . S:T="" T="" - . S LST("TO NAME",D1)=T - .QUIT - ; Get the Header for the message and store as "HDR" - S D1=0,SGC=0 - F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D - . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) - .QUIT - N BNDRY,STKL,SEG - S STKL=0,SEG=0 - ; Find boundaries and map them - S D1=0 - F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D - . ; Clear any control characters (cr/lf/ff) off - . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) - . ; Look for " boundary=" in the various parts. Map the establishment and the - . ; terminator markers and the actual boundary markers. - . I X[" boundary=" D Q - . . S SEP=$P(X," boundary=",2) - . . S:$E(SEP)="""" SEP=$TR(SEP,"""") - . . S STKL=STKL+1 - . . S END=SEP_FLG - . . S BNDRY(STKL,SEP)=0 - . . S BNDRX(SEP)=STKL,BNDRZ(END)=0 - . .QUIT - . ; - . ; Look for information as to how amy boudaries are present and where - . ; they terminate - . D:X'=""&($E(X,1,2)="--")&($E(X,$L(X)-1,9999)'="--") - . . ; Boundary Found - . . I $D(BNDRX(X)) D Q - . . . S SEG=SEG+1 - . . . S BNDRE(X)=$G(BNDRE(X))_D1_";" - . . . S BND1(D1)=STKL_";B;"_SEG_";"_X - . . . S BNDR(X,D1,"B")=STKL - . . . I BNDRX(X)=X D ERROR("ER13") - . . .QUIT - . . ; - . . ; Boundary Terminator - . . I $D(BNDRZ(X)) D Q - . . . S BNDR(X,D1,"E")=STKL - . . . S BNDRZ(X)=BNDRZ(X)+1 - . . . S BND1(D1)=STKL_";E;"_SEG_";"_X - . . . S SEG=SEG+1 - . . . I BNDRX(X)=X D ERROR("ER14") - . . . S STKL=STKL-1 - . . .QUIT - . .QUIT - .QUIT - ; Start walking the TEXT/XML/64-BIT ENCODING sections of the message - N A,B,C,STACK,STYP,SEG,AX - S D1=.99999,SGC=0 - F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D - . ; Clear any control characters (cr/lf/ff) off - . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) - . ; - . D - . . I $D(BND1(D1)) D BOUNDARY(X) QUIT - . . ; - . . S DX=$O(BND1(D1)) - . . I DX="" D ERROR("ER15") Q - . . ; - . . ; Good situation, extract the parts for the section - . . S A=$G(BND1(DX)) - . . S STACK=+A,STYP=$P(A,";",2),SGC=$P(A,";",3),AX=$P(A,";",4,999) - . .QUIT - . ; Enter once to set the SEP to capture the separator - . ; - . ; A new SEGMENT separator is set, process original - . I $D(BND1(X)) D QUIT - . . ; Save Current Values - . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF) - . . ; Close this Segment and prepare to start a New Segment - . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1) - . . ; Put the result in LST("SEG",SGC,"XML") - . . I $L(BF) D - . . . S ZN=1 - . . . N I,T,TBF - . . . S TBF=BF - . . . F I=1:1:($L(TBF,"=")) D - . . . . S BF=$P(TBF,"=",I)_"=" - . . . . I "="'[BF D DECODER(.BF,.TYP) - . . . .QUIT - . . . S BF="" - . . .QUIT - . . S SGC=SGC+1,BCN=0 - . . ; Incriment SGC to start a new Segment - . . S LST("SEG",SGC)=D1 - . .QUIT - . ; - . ; Accumulate the 64 bit encoding, no spaces, or other non-64bit characters - . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT - . ; - . ; Ending Condition, close out the Segment - . I $D(BNDRZ(X)) D QUIT - . . S $P(LST("SEG",SGC),"^",2)=D1-1 - . . I $L(BF) S ZN=1 D DECODER(.BF,.TYP) S BF="" Q - . .QUIT - . ; - . ; Accumulate the content lines of the message - . S BCN=BCN+$L(X) - . ; Split out the Content Info - . I X[CON D Q - . . S J=$P(X,CON,2) - . . S TYP="CONTENT" - . . S LST("SEG",SGC,TYP,$P(J,":"))=$P(J,":",2,9) - . . D CONTENT(D1) - . .QUIT - . ; - . ; Everything else is Text, Check for CCR/CCD. - . N KK,UBF - . D - . . S UBF=$$UPPER(X) - . . I UBF["1) S TYP=$P(UP,".",2) Q - . I UP["XML" S TYP="XML" Q - . I UP["P7S" S TYP="P7S" Q - . I J[" boundary=" D BOUNDARY(J) - .QUIT - S LIS("CON",SGC,D1)=X - S LIS("CON",SGC,D1,"TYP")=TYP - ; If there is a follow-on, look for another line after this. - I $E($RE(X),1)=";" D CONTENT(D1+1) - QUIT - ; =================== -BOUNDARY(X) ; Set an additional BOUNDARY, and activate another stack level - S SEP=$P($P(X," boundary=",2),"""",2),END=SEP_FLG - Q:SEP?2"-".ANP - ; - D ERROR("ER11") - Q:SEP'[" " - ; - D ERROR("ER12") - QUIT - ; =================== - ; Break down the Buffer Array so it can be saved. - ; BF is passed in. - ; TYP is the type of -DECODER(BF,TYP) ; - N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE - S:$G(TYP)="" TYP="XML" - S ZBF=BF - ; Full Buffer, BF, now check for Encryption and Unpack - F RCNT=1:1:$L(ZBF,"=") D - . N BF - . S BF=$P(ZBF,"=",RCNT) - . ; Unpacking the 64 bit encoding - . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) - . D:$L(TBF) - . . N C,OK,OKCNT,KK,XBF,UBF - . . D - . . . S UBF=$$UPPER(TBF) - . . . I UBF["126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q - . . ; - . . D - . . . I 'OK S (BF,UBF,TBF,XBF)="" Q - . . . ; - . . . S BF=BF_"=" - . . . D NORMAL(.XBF,.TBF) - . . .QUIT - . . M LST("SEG",SGC,TYP,RCNT)=XBF - . .QUIT - .QUIT - QUIT - ; =================== - ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT - ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT - ; >D NORMAL^C0CMAIL(.OUT,BF) -NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML - ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME - ; - N ZN,OUTBF,XX,ZSEP - S INXML=$TR(INXML,$C(10,12,13)) - S ZN=1,ZSEP=">" - S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 - F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" - . S XX=$P(INXML,"><",ZN) - . S:$E($RE(XX))=">" ZSEP="" - . Q:XX="" - . ; - . S XX="<"_XX_ZSEP - . D - . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q - . . ; - . . D ERROR("ER05") - . . F ZL=ZL+1:1 D Q:XX="" - . . . N XL - . . . S XL=$E(XX,1,4000) - . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters - . . . S OUTBF(ZL)=XL - . . .QUIT - . .QUIT - .QUIT - M OUTXML=OUTBF - QUIT - ; =================== -UPPER(X) ; Convert any lowercase letters to Uppercase letters - QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ; =================== - ; EN is a counter that remains between error events -ERROR(ER) ; Error Handler - N TXXQ,XXXQ - S XXXQ="Unknown Error Encountered = "_ER - S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) - I TXXQ'="" D - . I TXXQ["_" X "S TXXQ="_TXXQ - . S XXXQ=TXXQ - .QUIT - S EN(ER)=$G(EN(ER))+1 - S LST("ERR",ER,EN(ER))=XXXQ - QUIT - ; =================== -ER01 ;;Message Missing -ER02 ;;Message Text Missing -ER03 ;;Message Not Identifiable -ER04 ;;Segment is too large -ER05 ;;Mailbox Missing -ER06 ;;"User Missing = "_$G(DUZ) -ER07 ;;"Bad DUZ = "_DUZ -ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) -ER10 ;;"Bad Separator found = "_X -ER11 ;;"Non-Standard Separator Found:>"_$G(J) -ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) -ER13 ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X - ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv - ; End note if needed - QUIT - ; =================== +C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr +V ;;0.1;C0C;nopatch;noreleasedate + ;Copyright 2011 Chris Richardson, Richardson Computer Research + ; Modified 3110619@2038 + ; rcr@rcresearch.us + ; Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; ------------------ + ;Entry Points + ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments + ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) + ; Input: + ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL + ; or "*" for all boxes, default is "IN" if missing]" + ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", + ; "*" for All or 9,999 maximum + ; MALL?1.n = that number of the n most recent + ; Internally: + ; BNAM = Box Name + ; Output: + ; C0CDATA + ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket + ; (BNAM,"MSG",C0CIEN,"FROM")=Name + ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title + ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments + ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text + ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text + ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes + ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) + ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data + ; + ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments + ; Input; + ; D0 - The IEN for the message in file 3.9, MESSAGE global + ; Output + ; OUTBF - The array of your choice to save the expanded and decoded message. + ; +GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data + K:'$G(C0CDATA("KEEP")) C0CDATA + N U + S U="^" + D:$G(C0CINPUT) + . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL + . S INPUT=C0CINPUT + . S DUZ=+INPUT + . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q + . ; + . D:$D(^XMB(3.7,DUZ,0))#2 + . . S MBLST=$P(INPUT,";",2) + . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag + . . S:MALL["*" MALL=99999 + . . ; Only one of these can be correct + . . D + . . . ; If nul, make it "IN" only + . . . I MBLST="" D QUIT + . . . . S MBLST("IN")=0,I=0 + . . . . D GATHER(DUZ,"IN",.LST) + . . . .QUIT + . . . ; + . . . ; If "*", Get all Mailboxes and look for New Messages + . . . I MBLST["*" D QUIT + . . . . N NAM,NUM + . . . . S NUM=0 + . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D + . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) + . . . . . D GATHER(DUZ,NAM,.LST) + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If comma separated, look for mailboxes with new messages + . . . I $L(MBLST,",")>1 D QUIT + . . . . S NAM="" + . . . . N TN,V + . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D + . . . . . I $L(V) D QUIT + . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) + . . . . . . S:NAM="" NAM=V + . . . . . . D GATHER(DUZ,NAM,.LST) + . . . . . .QUIT + . . . . . ; + . . . . . D ERROR("ER08") + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If only 1 mailbox named, go get it + . . . I $L(MBLST) D QUIT + . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT + . . . . ; + . . . . D ERROR("ER07") + . . .QUIT + . . MERGE C0CDATA=LST + . .QUIT + .QUIT + QUIT + ; =================== +GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail + N I,J,K,L + S (I,K)=0 + S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) + F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D + . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) + . D ; :L + . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails + . . S LST(NAM,"MSG",I)=L + . . D GETTYP(I) + . .QUIT + .QUIT + S LST(NAM,"NUMBER")=K + QUIT + ; =================== + ; D0 is the IEN into the Message Global ^XMB(3.9,D0) + ; The products of these emails are scanned to identify + ; the number of documents stored in the MIME package. + ; The protocol runs like this; + ; Line 1 is the --separator + ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD + ; Line n+2 thru t-1 where t does NOT have "Content-" + ; Line t is Next Section Terminator, or Message Terminator, --separator + ; Line t+1 should not exist in the data set if Message Terminator + ; CON = "Content-" + ; FLG = "--" + ; SEP = FLG+7 or more characters ; Separator + ; END = SEP+FLG + ; SGC = Segment Count + ; Note: separator is a string of specific characters of + ; indeterminate length + ; LST() the transfer array + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data + ; +GETTYP(D0) ; Look for the goodies in the Mail + N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM + S CON="Content-" + S FLG="--" + S SEP="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) + S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D + . N T + . S T=+$G(^XMB(3.9,D0,1,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S LST("TO",D1)=T + . S T=$G(^XMB(3.9,D0,6,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . 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="" + D + . ; Look first for a value to use with the NEW PERSON file + . ; + . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q + . ; + . I $L(NM) S NAME=NM Q + . ; + . ; Else, pull the data from the message and display the foreign source + . ; of the message. + . N T + . S VAL=$G(^XMB(3.9,D0,.7)) + . S:VAL T=$P(^VA(200,VAL,0),U) + . I $L($G(T)) S NAME=T Q + . ; + .QUIT + QUIT NAME + ; =================== +TIME(Y) ; The time and date of the sending + X ^DD("DD") + QUIT Y + ; =================== + ; Segments in Message need to be identified and decoded properly + ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message + ; ARRAY will have the details of this one call + ; + ; Inputs; + ; C0CINPUT - The IEN of the message to expand + ; Outputs; + ; C0CDATA - Carrier for the returned structure of the Message + ; C0CDATA(D0,"SEG")=number of SEGMENTS + ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type + ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details + ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details + ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details + ; +DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery + N LST,D0,D1,U + S U="^" + S D0=+$G(C0CINPUT) + I D0 D QUIT + . I $D(^XMB(3.9,D0))<10 D ERROR("ER01") QUIT + . ; + . D GETTYP2(D0) + . I $D(LST) M C0CDATA(D0)=LST Q + . ; + . D ERROR("ER02") + .QUIT + QUIT + ; =================== + ; End note if needed + ; MSK - Set of characters that do not exist in 64 bit encoding +GETTYP2(D0) ; Try to get the types and MSK for the + N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM + S CON="Content-",U="^" + S FLG="--",MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" + S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + ; S K=$P(^XMB(3.9,D0,2,0),U,3) + S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST("CREATED")=$$TIME($P(XX,U,3)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST("FROM")=$$NAME(XXNM) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" + . N I,T + . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) + . S:T T=$P($G(^VA(200,T,0)),"^") + . S LST("TO",+D1)=T + . S T=$G(^XMB(3.9,D0,6,+D1,0)) + . S:T="" T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . S LST("TO NAME",D1)=T + .QUIT + ; Get the Header for the message and store as "HDR" + S D1=0,SGC=0 + F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D + . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) + .QUIT + N BNDRY,STKL,SEG + S STKL=0,SEG=0 + ; Find boundaries and map them + S D1=0 + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; Look for " boundary=" in the various parts. Map the establishment and the + . ; terminator markers and the actual boundary markers. + . I X[" boundary=" D Q + . . S SEP=$P(X," boundary=",2) + . . S:$E(SEP)="""" SEP=$TR(SEP,"""") + . . S STKL=STKL+1 + . . S END=SEP_FLG + . . S BNDRY(STKL,SEP)=0 + . . S BNDRX(SEP)=STKL,BNDRZ(END)=0 + . .QUIT + . ; + . ; Look for information as to how amy boudaries are present and where + . ; they terminate + . D:X'=""&($E(X,1,2)="--")&($E(X,$L(X)-1,9999)'="--") + . . ; Boundary Found + . . I $D(BNDRX(X)) D Q + . . . S SEG=SEG+1 + . . . S BNDRE(X)=$G(BNDRE(X))_D1_";" + . . . S BND1(D1)=STKL_";B;"_SEG_";"_X + . . . S BNDR(X,D1,"B")=STKL + . . . I BNDRX(X)=X D ERROR("ER13") + . . .QUIT + . . ; + . . ; Boundary Terminator + . . I $D(BNDRZ(X)) D Q + . . . S BNDR(X,D1,"E")=STKL + . . . S BNDRZ(X)=BNDRZ(X)+1 + . . . S BND1(D1)=STKL_";E;"_SEG_";"_X + . . . S SEG=SEG+1 + . . . I BNDRX(X)=X D ERROR("ER14") + . . . S STKL=STKL-1 + . . .QUIT + . .QUIT + .QUIT + ; Start walking the TEXT/XML/64-BIT ENCODING sections of the message + N A,B,C,STACK,STYP,SEG,AX + S D1=.99999,SGC=0 + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; + . D + . . I $D(BND1(D1)) D BOUNDARY(X) QUIT + . . ; + . . S DX=$O(BND1(D1)) + . . I DX="" D ERROR("ER15") Q + . . ; + . . ; Good situation, extract the parts for the section + . . S A=$G(BND1(DX)) + . . S STACK=+A,STYP=$P(A,";",2),SGC=$P(A,";",3),AX=$P(A,";",4,999) + . .QUIT + . ; Enter once to set the SEP to capture the separator + . ; + . ; A new SEGMENT separator is set, process original + . I $D(BND1(X)) D QUIT + . . ; Save Current Values + . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF) + . . ; Close this Segment and prepare to start a New Segment + . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1) + . . ; Put the result in LST("SEG",SGC,"XML") + . . I $L(BF) D + . . . S ZN=1 + . . . N I,T,TBF + . . . S TBF=BF + . . . F I=1:1:($L(TBF,"=")) D + . . . . S BF=$P(TBF,"=",I)_"=" + . . . . I "="'[BF D DECODER(.BF,.TYP) + . . . .QUIT + . . . S BF="" + . . .QUIT + . . S SGC=SGC+1,BCN=0 + . . ; Incriment SGC to start a new Segment + . . S LST("SEG",SGC)=D1 + . .QUIT + . ; + . ; Accumulate the 64 bit encoding, no spaces, or other non-64bit characters + . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT + . ; + . ; Ending Condition, close out the Segment + . I $D(BNDRZ(X)) D QUIT + . . S $P(LST("SEG",SGC),"^",2)=D1-1 + . . I $L(BF) S ZN=1 D DECODER(.BF,.TYP) S BF="" Q + . .QUIT + . ; + . ; Accumulate the content lines of the message + . S BCN=BCN+$L(X) + . ; Split out the Content Info + . I X[CON D Q + . . S J=$P(X,CON,2) + . . S TYP="CONTENT" + . . S LST("SEG",SGC,TYP,$P(J,":"))=$P(J,":",2,9) + . . D CONTENT(D1) + . .QUIT + . ; + . ; Everything else is Text, Check for CCR/CCD. + . N KK,UBF + . D + . . S UBF=$$UPPER(X) + . . I UBF["1) S TYP=$P(UP,".",2) Q + . I UP["XML" S TYP="XML" Q + . I UP["P7S" S TYP="P7S" Q + . I J[" boundary=" D BOUNDARY(J) + .QUIT + S LIS("CON",SGC,D1)=X + S LIS("CON",SGC,D1,"TYP")=TYP + ; If there is a follow-on, look for another line after this. + I $E($RE(X),1)=";" D CONTENT(D1+1) + QUIT + ; =================== +BOUNDARY(X) ; Set an additional BOUNDARY, and activate another stack level + S SEP=$P($P(X," boundary=",2),"""",2),END=SEP_FLG + Q:SEP?2"-".ANP + ; + D ERROR("ER11") + Q:SEP'[" " + ; + D ERROR("ER12") + QUIT + ; =================== + ; Break down the Buffer Array so it can be saved. + ; BF is passed in. + ; TYP is the type of +DECODER(BF,TYP) ; + N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE + S:$G(TYP)="" TYP="XML" + S ZBF=BF + ; Full Buffer, BF, now check for Encryption and Unpack + F RCNT=1:1:$L(ZBF,"=") D + . N BF + . S BF=$P(ZBF,"=",RCNT) + . ; Unpacking the 64 bit encoding + . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) + . D:$L(TBF) + . . N C,OK,OKCNT,KK,XBF,UBF + . . D + . . . S UBF=$$UPPER(TBF) + . . . I UBF["126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q + . . ; + . . D + . . . I 'OK S (BF,UBF,TBF,XBF)="" Q + . . . ; + . . . S BF=BF_"=" + . . . D NORMAL(.XBF,.TBF) + . . .QUIT + . . M LST("SEG",SGC,TYP,RCNT)=XBF + . .QUIT + .QUIT + QUIT + ; =================== + ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT + ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT + ; >D NORMAL^C0CMAIL(.OUT,BF) +NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML + ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME + ; + N ZN,OUTBF,XX,ZSEP + S INXML=$TR(INXML,$C(10,12,13)) + S ZN=1,ZSEP=">" + S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 + F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" + . S XX=$P(INXML,"><",ZN) + . S:$E($RE(XX))=">" ZSEP="" + . Q:XX="" + . ; + . S XX="<"_XX_ZSEP + . D + . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q + . . ; + . . D ERROR("ER05") + . . F ZL=ZL+1:1 D Q:XX="" + . . . N XL + . . . S XL=$E(XX,1,4000) + . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters + . . . S OUTBF(ZL)=XL + . . .QUIT + . .QUIT + .QUIT + M OUTXML=OUTBF + QUIT + ; =================== +UPPER(X) ; Convert any lowercase letters to Uppercase letters + QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + ; =================== + ; EN is a counter that remains between error events +ERROR(ER) ; Error Handler + N TXXQ,XXXQ + S XXXQ="Unknown Error Encountered = "_ER + S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) + I TXXQ'="" D + . I TXXQ["_" X "S TXXQ="_TXXQ + . S XXXQ=TXXQ + .QUIT + S EN(ER)=$G(EN(ER))+1 + S LST("ERR",ER,EN(ER))=XXXQ + QUIT + ; =================== +ER01 ;;Message Missing +ER02 ;;Message Text Missing +ER03 ;;Message Not Identifiable +ER04 ;;Segment is too large +ER05 ;;Mailbox Missing +ER06 ;;"User Missing = "_$G(DUZ) +ER07 ;;"Bad DUZ = "_DUZ +ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) +ER10 ;;"Bad Separator found = "_X +ER11 ;;"Non-Standard Separator Found:>"_$G(J) +ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) +ER13 ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X + ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv + ; End note if needed + QUIT + ; =================== Index: ccr/branches/ohum/p/C0CMCCD.m =================================================================== --- ccr/branches/ohum/p/C0CMCCD.m (revision 1333) +++ ccr/branches/ohum/p/C0CMCCD.m (revision 1337) @@ -1,293 +1,293 @@ -C0CMCCD ; GPL - MXML based CCD utilities;12/04/09 17:05 - ;;0.1;C0C;nopatch;noreleasedate;Build 1 - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q - ; -PARSCCD(DOC,OPTION) ; THIS WAS COPIED FROM EN^MXMLDOM TO CUSTIMIZE FOR - ; PROCESSING CCDS - N CBK,SUCCESS,LEVEL,NODE,HANDLE - K ^TMP("MXMLERR",$J) - L +^TMP("MXMLDOM",$J):5 - E Q 0 - S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)="" - L -^TMP("MXMLDOM",$J) - S CBK("STARTELEMENT")="STARTELE^C0CMCCD" ; ONLY THIS ONE IS CHANGED ;GPL - S CBK("ENDELEMENT")="ENDELE^MXMLDOM" - S CBK("COMMENT")="COMMENT^MXMLDOM" - S CBK("CHARACTERS")="CHAR^MXMLDOM" - S CBK("ENDDOCUMENT")="ENDDOC^MXMLDOM" - S CBK("ERROR")="ERROR^MXMLDOM" - S (SUCCESS,LEVEL,LEVEL(0),NODE)=0,OPTION=$G(OPTION,"V1") - D EN^MXMLPRSE(DOC,.CBK,OPTION) - D:'SUCCESS DELETE^MXMLDOM(HANDLE) - Q $S(SUCCESS:HANDLE,1:0) - ; Start element - ; Create new child node and push info on stack -STARTELE(ELE,ATTR) ; COPIED FROM STARTELE^MXMLDOM AND MODIFIED TO TREAT - ; ATTRIBUTES AS SUBELEMENTS TO MAKE CCD XPATH PROCESSING EASIER - N PARENT - S PARENT=LEVEL(LEVEL),NODE=NODE+1 - S:PARENT ^TMP("MXMLDOM",$J,HANDLE,PARENT,"C",NODE)=ELE - S LEVEL=LEVEL+1,LEVEL(LEVEL)=NODE,LEVEL(LEVEL,0)=ELE - S ^TMP("MXMLDOM",$J,HANDLE,NODE)=ELE,^(NODE,"P")=PARENT - ;M ^("A")=ATTR - N ZI S ZI="" ; INDEX FOR ATTR - F S ZI=$O(ATTR(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE - . N ELE,TXT ; ABOUT TO RECURSE - . S ELE=ZI ; TAG - . S TXT=ATTR(ZI) ; DATA - . D STARTELE(ELE,"") ; CREATE A NEW SUBNODE - . D TXT^MXMLDOM("T") ; INSERT DATA TO TAG - . D ENDELE^MXMLDOM(ELE) ; POP BACK UP A LEVEL - Q - ; -ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE - N ZN - ;I $$TAG(ZOID)["entry" B - S ZN=$$NXTSIB(ZOID) - I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG - Q 0 - ; -FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID - Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) - ; -PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID - Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) - ; -ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID - S HANDLE=C0CDOCID - K @RTN - D GETTXT^MXMLDOM("A") - Q - ; -TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE - ;I ZOID=149 B ;GPLTEST - N X,Y - S Y="" - S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE - I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y - I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) - Q Y - ; -NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING - Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) - ; -DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE - ;N ZT,ZN S ZT="" - ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) - ;Q $G(@C0CDOM@(ZOID,"T",1)) - S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) - Q - ; -CLEANARY(OUTARY,INARY) ; GOES THROUGH AN ARRAY AND CALLS CLEAN ON EACH NODE - ; INARY AND OUTARY PASSED BY NAME - N ZI S ZI="" - F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH NODE - . S @OUTARY@(ZI)=$$CLEAN(@INARY@(ZI)) ; CLEAN THE NODE - Q - ; -CLEAN(STR) ; extrinsic function; returns string - ;; Removes all non printable characters from a string. - ;; STR by Value - N TR,I - F I=0:1:31 S TR=$G(TR)_$C(I) - S TR=TR_$C(127) - QUIT $TR(STR,TR) - ; -STRIPTXT(OUTARY,ZARY) ; STRIPS THE "TEXT" PORTION OUT OF AN XML FILE - ; THIS IS USED TO DELETE THE NARATIVE HTML OUT OF THE CCD XML FILES BECAUSE - ; THEY DO NOT WORK RIGHT WITH THE PARSER - ;N ZWRK,ZBLD,ZI ; WORK ARRAY,BUILD ARRAY, AND COUNTER - S ZI=$O(@ZARY@("")) ; GET FIRST LINE NUMBER - D C0CBEGIN("ZWRK",ZI) ; INSERT FIRST LINE IN WORK ARRAY - F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH LINE OF THE ARRAY - . I $O(@ZARY@(ZI))="" D Q ; AT THE END - . . D C0CEND("ZWRK",ZI) ; INCLUDE LAST LINE IN WORK ARRAY - . I ZI=1 D C0CBEGIN("ZWRK",ZI) ; START WITH FIRST LINE - . I @ZARY@(ZI)["" D C0CBEGIN("ZWRK",ZI+1) ;NEXT LINE IS A BEGIN - S ZI="" - F S ZI=$O(ZWRK(ZI)) Q:ZI="" D ; MAKE A BUILD LIST FROM THE WORK ARRAY - . D QUEUE^C0CXPATH("ZBLD",ZARY,$P(ZWRK(ZI),"^",1),$P(ZWRK(ZI),"^",2)) - D BUILD^C0CXPATH("ZBLD",OUTARY) ; BUILD NEW ARRAY WITHOUT TEXT SECTIONS - K @OUTARY@(0) ; GET RID OF THE LINE COUNT - Q - ; -C0CBEGIN(ZA,LN) ; INSERTS A BEGIN LINE LN INTO ARRAY ZWRK, PASSED BY NAME - N ZI - S ZI=$O(@ZA@(""),-1) - I ZI="" S ZI=1 - E S ZI=ZI+1 ; INCREMENT COUNT IN WORK ARRAY - S $P(@ZA@(ZI),"^",1)=LN - Q - ; -C0CEND(ZB,LN) ; INSERTS AN END LINE LN INTO ARRAY ZWRK, PASSED BY NAME - N ZI - S ZI=$O(@ZB@(""),-1) - I ZI="" S ZI=1 - S $P(@ZB@(ZI),"^",2)=LN - Q - ; -SEPARATE(OUTARY,INARY) ; SEPARATES XPATH VARIABLES ACCORDING TO THEIR - ; ROOT ; /Problems/etc/etc goes to @OUTARY@("Problems","/Problems/etc/etc") - S ZI="" - F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH ELEMENT OF THE ARRAY - . I $P(ZI,"//",2)'="" D ; FOR NON-BODY ENTRIES - . . S ZJ=$P(ZI,"/",4) ; things like From Patient Actor - . E D ; FOR BODY PARTS - . . S ZJ=$P(ZI,"/",2) ; - . . I ZJ="" S ZJ=$P(ZI,"/",3) ; - . S @OUTARY@(ZJ,ZI)=$G(@INARY@(ZI)) ;FIX THIS FOR MULTILINE COMMENTS - Q - ; -FINDTID ; FIND TEMPLATE IDS IN DOM 1 - S C0CDOCID=1 - S ZD=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) - S ZN="" - S CURSEC="" - S TID="" - F S ZN=$O(@ZD@(ZN)) Q:ZN="" D ; - . I $$TAG(ZN)="root" D ; - . . I $$TAG($$PARENT(ZN))="templateId" D ; ONLY LOOKING FOR TEMPLATES - . . . S ZG=$$PARENT($$PARENT(ZN)) - . . . S ZG2=$$PARENT(ZG) ;COMPONENT THAT HOLDS THIS SECTION - . . . S CMT=$G(@ZD@(ZG,"X",1)) - . . . I CMT="" S CMT="?" - . . . I $$TAG(ZG)="section" D ;START OF A SECTION - . . . . S CURSEC=$$PARENT(ZG) - . . . . S SECCMT=$G(@ZD@(CURSEC,"X",1)) - . . . . I SECCMT="" S SECCMT="?" - . . . . S SECTID=$G(@ZD@(ZN,"T",1)) ;SECTION TEMPLATE ID - . . . S TID=$G(@ZD@(ZN,"T",1)) ;TEMPLATE ID - . . . I CURSEC'="" D ; IF WE ARE IN A SECTION - . . . . S CCDDIR(ZG2,CURSEC,$$TAG(ZG2),CMT,SECCMT)=TID - . . . . S DOMMAP(ZG2)=CURSEC_U_$$TAG(ZG2)_U_TID_U_SECTID - . . . W !,$$TAG(ZG2)," ",$G(@ZD@(ZG,"X",1)) - . . . W " root ",ZN," ",@ZD@(ZN,"T",1) - Q - ; -FINDALT ; PROCESS THE DOMMAP AND FIND THE ALT TAGS FOR COMPONENTS - ; - S ZI="" - F S ZI=$O(DOMMAP(ZI)) Q:ZI="" D ; FOR EACH NODE IN THE MAP - . S ZJ=DOMMAP(ZI) ; - . S PARNODE=$P(ZJ,U,1) ;PARENT NODE - . S TAG=$P(ZJ,U,2) ;THIS TAG - . S TID=$P(ZJ,U,3) ;THIS TEMPLATE ID - . S PARTID=$P(ZJ,U,4) ;PARENT TEMPLATE ID - . S ZIEN=$O(^C0CXDS(178.101,"TID",TID,"")) ;THIS NODE IEN - . S PARIEN=$O(^C0CXDS(178.101,"TID",PARTID,"")) ;PARENT NODE IEN - . I ZI=PARNODE D ; IF THIS IS A SECTION NODE - . . S ALTTAG=$$GET1^DIQ(178.101,PARIEN_",",.03) ;ALT TAG FIELD FOR PARENT - . . S NAME=$$GET1^DIQ(178.101,ZIEN_",",.01) ;NAME OF THIS NODE'S TEMPLATE - . . W ZI," ",TAG," ",ALTTAG," ",NAME,! - . . S C0CTAGS(ZI)=ALTTAG - . E D ; NOT A SECTION NODE - . . N ZJ S ZJ="" - . . S ZJ=$O(^C0CXDS(178.101,"D",PARIEN,ZIEN,"")) ;A WHEREUSED POINTER? - . . I ZJ'="" D ; THERE IS A NEW LABEL FOR THIS NODE - . . . N ZK - . . . S ZK=$$GET1^DIQ(178.111,ZJ_","_ZIEN_",",2) - . . . I ZK'="" D ; - . . . . W "FOUND ",ZK,! - . . . . S C0CTAGS(ZI)=ZK ; NEW TAG FOR INTERSECTION - Q - ; -ALTTAG(NODE) ; SET Y EQUAL TO THE ALT TAG FOUND IN C0CTAGS IF NODE IF FOUND - ; - S Y=$G(C0CTAGS(NODE)) - Q - ; -SETCBK ; SET THE TAG CALLBACK FOR XPATH PROCESSSING OF THE CCD - S C0CCBK("TAG")="D ALTTAG^C0CMCCD(ZOID)" - Q - ; -OUTCCD(GARYIN) ; OUTPUT THE PARSED CCD TO A TEXT FILE - ;D TEST3^C0CMXML - N ZT S ZT=$NA(^TMP("CCDOUT",$J)) - N ZI,ZJ - S ZI=1 S ZJ="" - K @ZT - F S ZJ=$O(GARYIN(ZJ)) Q:ZJ="" D ; - . S @ZT@(ZI)=ZJ_"^"_GARYIN(ZJ) - . S ZI=ZI+1 - S ONAME=$NA(@ZT@(1)) - W $$OUTPUT^C0CXPATH(ONAME,"CCDOUT.txt","/home/vademo2/CCR") - K @ZT - Q - ; -GENXDS(ZD) ; GENERATE THE XDS PROTOTYPE RECORDS FROM A CCDDIR ARRAY - ; ARRAY ELEMENTS LOOK LIKE: - ; CCDDIR(1659,1634,"observation"," Result observaion template "," Vital signs section template ")="2.16.840.1.113883.10.20.1.31" - ;or CCDDIR(cur node,section node,cur tag,cur name,sec name)=templateId - S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE - S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT - S DONE=0 - F Q:DONE D ; - . W @ZI,! - . S ZJ=$QS(ZI,5) - . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE - . S C0CFDA(ZF,"?+1,",.01)=ZJ - . S C0CFDA(ZF,"?+1,",.02)=$QS(ZI,4) ; TAG FOR THIS TEMPLATE - . S C0CFDA(ZF,"?+1,",1)=@ZI - . D UPDIE - . S ZI=$Q(@ZI) - . I ZI="" S DONE=1 - Q - ; -WHRUSD(ZD) ; UPDATE THE C0C XDS FILE WITH WHERE USED DATA FROM - ; CCDDIR PASS BY NAME - ; ARRAY ELEMENTS LOOK LIKE: - ; CCDDIR(1634," Vital signs section template ",1659,"observation"," Result observaion template ")="2.16.840.1.113883.10.20.1.31" - ;or CCDDIR(section node,sec name, cur node,cur tag,cur name)=templateId - S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE - S ZSF=178.111 ; WHERE USED SUBFILE OF C0C XDS PROTOTYPE FILE - S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT - S DONE=0 - F Q:DONE D ; - . W @ZI - . S ZIEN=$O(^C0CXDS(178.101,"TID",@ZI,"")) ; IEN FOR THIS NODE'S TEMPLATE - . W " IEN:",ZIEN - . S ZJ=$QS(ZI,2) - . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE - . S ZPIEN=$O(^C0CXDS(178.101,"B",ZJ,"")) ; PARENT IEN - . W " PARENT IEN:",ZPIEN - . S ZTAG=$QS(ZI,4) ; TAG FOR THIS TEMPLATE - . W " TAG:",ZTAG,! - . I ZIEN'=ZPIEN D ; ONLY FOR CHILD TEMPLATES - . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",.01)=ZPIEN ; NEW SUBFILE ENTRY WITH PAR PTR - . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",1)=ZTAG ; TAG FOR NEW ENTRY - . . D UPDIE - . ;S C0CFDA(ZF,"?+1,",1)=@ZI - . ;D UPDIE - . S ZI=$Q(@ZI) - . I ZI="" S DONE=1 - Q - ; -UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS - K ZERR - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","","ZERR") - I $D(ZERR) D ; - . W "ERROR",! - . ZWR ZERR - . B - K C0CFDA - Q - ; +C0CMCCD ; GPL - MXML based CCD utilities;12/04/09 17:05 + ;;0.1;C0C;nopatch;noreleasedate + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q + ; +PARSCCD(DOC,OPTION) ; THIS WAS COPIED FROM EN^MXMLDOM TO CUSTIMIZE FOR + ; PROCESSING CCDS + N CBK,SUCCESS,LEVEL,NODE,HANDLE + K ^TMP("MXMLERR",$J) + L +^TMP("MXMLDOM",$J):5 + E Q 0 + S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)="" + L -^TMP("MXMLDOM",$J) + S CBK("STARTELEMENT")="STARTELE^C0CMCCD" ; ONLY THIS ONE IS CHANGED ;GPL + S CBK("ENDELEMENT")="ENDELE^MXMLDOM" + S CBK("COMMENT")="COMMENT^MXMLDOM" + S CBK("CHARACTERS")="CHAR^MXMLDOM" + S CBK("ENDDOCUMENT")="ENDDOC^MXMLDOM" + S CBK("ERROR")="ERROR^MXMLDOM" + S (SUCCESS,LEVEL,LEVEL(0),NODE)=0,OPTION=$G(OPTION,"V1") + D EN^MXMLPRSE(DOC,.CBK,OPTION) + D:'SUCCESS DELETE^MXMLDOM(HANDLE) + Q $S(SUCCESS:HANDLE,1:0) + ; Start element + ; Create new child node and push info on stack +STARTELE(ELE,ATTR) ; COPIED FROM STARTELE^MXMLDOM AND MODIFIED TO TREAT + ; ATTRIBUTES AS SUBELEMENTS TO MAKE CCD XPATH PROCESSING EASIER + N PARENT + S PARENT=LEVEL(LEVEL),NODE=NODE+1 + S:PARENT ^TMP("MXMLDOM",$J,HANDLE,PARENT,"C",NODE)=ELE + S LEVEL=LEVEL+1,LEVEL(LEVEL)=NODE,LEVEL(LEVEL,0)=ELE + S ^TMP("MXMLDOM",$J,HANDLE,NODE)=ELE,^(NODE,"P")=PARENT + ;M ^("A")=ATTR + N ZI S ZI="" ; INDEX FOR ATTR + F S ZI=$O(ATTR(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE + . N ELE,TXT ; ABOUT TO RECURSE + . S ELE=ZI ; TAG + . S TXT=ATTR(ZI) ; DATA + . D STARTELE(ELE,"") ; CREATE A NEW SUBNODE + . D TXT^MXMLDOM("T") ; INSERT DATA TO TAG + . D ENDELE^MXMLDOM(ELE) ; POP BACK UP A LEVEL + Q + ; +ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE + N ZN + ;I $$TAG(ZOID)["entry" B + S ZN=$$NXTSIB(ZOID) + I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG + Q 0 + ; +FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID + Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) + ; +PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID + Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) + ; +ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID + S HANDLE=C0CDOCID + K @RTN + D GETTXT^MXMLDOM("A") + Q + ; +TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE + ;I ZOID=149 B ;GPLTEST + N X,Y + S Y="" + S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE + I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y + I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) + Q Y + ; +NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING + Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) + ; +DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE + ;N ZT,ZN S ZT="" + ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) + ;Q $G(@C0CDOM@(ZOID,"T",1)) + S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) + Q + ; +CLEANARY(OUTARY,INARY) ; GOES THROUGH AN ARRAY AND CALLS CLEAN ON EACH NODE + ; INARY AND OUTARY PASSED BY NAME + N ZI S ZI="" + F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH NODE + . S @OUTARY@(ZI)=$$CLEAN(@INARY@(ZI)) ; CLEAN THE NODE + Q + ; +CLEAN(STR) ; extrinsic function; returns string + ;; Removes all non printable characters from a string. + ;; STR by Value + N TR,I + F I=0:1:31 S TR=$G(TR)_$C(I) + S TR=TR_$C(127) + QUIT $TR(STR,TR) + ; +STRIPTXT(OUTARY,ZARY) ; STRIPS THE "TEXT" PORTION OUT OF AN XML FILE + ; THIS IS USED TO DELETE THE NARATIVE HTML OUT OF THE CCD XML FILES BECAUSE + ; THEY DO NOT WORK RIGHT WITH THE PARSER + ;N ZWRK,ZBLD,ZI ; WORK ARRAY,BUILD ARRAY, AND COUNTER + S ZI=$O(@ZARY@("")) ; GET FIRST LINE NUMBER + D C0CBEGIN("ZWRK",ZI) ; INSERT FIRST LINE IN WORK ARRAY + F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH LINE OF THE ARRAY + . I $O(@ZARY@(ZI))="" D Q ; AT THE END + . . D C0CEND("ZWRK",ZI) ; INCLUDE LAST LINE IN WORK ARRAY + . I ZI=1 D C0CBEGIN("ZWRK",ZI) ; START WITH FIRST LINE + . I @ZARY@(ZI)["" D C0CBEGIN("ZWRK",ZI+1) ;NEXT LINE IS A BEGIN + S ZI="" + F S ZI=$O(ZWRK(ZI)) Q:ZI="" D ; MAKE A BUILD LIST FROM THE WORK ARRAY + . D QUEUE^C0CXPATH("ZBLD",ZARY,$P(ZWRK(ZI),"^",1),$P(ZWRK(ZI),"^",2)) + D BUILD^C0CXPATH("ZBLD",OUTARY) ; BUILD NEW ARRAY WITHOUT TEXT SECTIONS + K @OUTARY@(0) ; GET RID OF THE LINE COUNT + Q + ; +C0CBEGIN(ZA,LN) ; INSERTS A BEGIN LINE LN INTO ARRAY ZWRK, PASSED BY NAME + N ZI + S ZI=$O(@ZA@(""),-1) + I ZI="" S ZI=1 + E S ZI=ZI+1 ; INCREMENT COUNT IN WORK ARRAY + S $P(@ZA@(ZI),"^",1)=LN + Q + ; +C0CEND(ZB,LN) ; INSERTS AN END LINE LN INTO ARRAY ZWRK, PASSED BY NAME + N ZI + S ZI=$O(@ZB@(""),-1) + I ZI="" S ZI=1 + S $P(@ZB@(ZI),"^",2)=LN + Q + ; +SEPARATE(OUTARY,INARY) ; SEPARATES XPATH VARIABLES ACCORDING TO THEIR + ; ROOT ; /Problems/etc/etc goes to @OUTARY@("Problems","/Problems/etc/etc") + S ZI="" + F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH ELEMENT OF THE ARRAY + . I $P(ZI,"//",2)'="" D ; FOR NON-BODY ENTRIES + . . S ZJ=$P(ZI,"/",4) ; things like From Patient Actor + . E D ; FOR BODY PARTS + . . S ZJ=$P(ZI,"/",2) ; + . . I ZJ="" S ZJ=$P(ZI,"/",3) ; + . S @OUTARY@(ZJ,ZI)=$G(@INARY@(ZI)) ;FIX THIS FOR MULTILINE COMMENTS + Q + ; +FINDTID ; FIND TEMPLATE IDS IN DOM 1 + S C0CDOCID=1 + S ZD=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) + S ZN="" + S CURSEC="" + S TID="" + F S ZN=$O(@ZD@(ZN)) Q:ZN="" D ; + . I $$TAG(ZN)="root" D ; + . . I $$TAG($$PARENT(ZN))="templateId" D ; ONLY LOOKING FOR TEMPLATES + . . . S ZG=$$PARENT($$PARENT(ZN)) + . . . S ZG2=$$PARENT(ZG) ;COMPONENT THAT HOLDS THIS SECTION + . . . S CMT=$G(@ZD@(ZG,"X",1)) + . . . I CMT="" S CMT="?" + . . . I $$TAG(ZG)="section" D ;START OF A SECTION + . . . . S CURSEC=$$PARENT(ZG) + . . . . S SECCMT=$G(@ZD@(CURSEC,"X",1)) + . . . . I SECCMT="" S SECCMT="?" + . . . . S SECTID=$G(@ZD@(ZN,"T",1)) ;SECTION TEMPLATE ID + . . . S TID=$G(@ZD@(ZN,"T",1)) ;TEMPLATE ID + . . . I CURSEC'="" D ; IF WE ARE IN A SECTION + . . . . S CCDDIR(ZG2,CURSEC,$$TAG(ZG2),CMT,SECCMT)=TID + . . . . S DOMMAP(ZG2)=CURSEC_U_$$TAG(ZG2)_U_TID_U_SECTID + . . . W !,$$TAG(ZG2)," ",$G(@ZD@(ZG,"X",1)) + . . . W " root ",ZN," ",@ZD@(ZN,"T",1) + Q + ; +FINDALT ; PROCESS THE DOMMAP AND FIND THE ALT TAGS FOR COMPONENTS + ; + S ZI="" + F S ZI=$O(DOMMAP(ZI)) Q:ZI="" D ; FOR EACH NODE IN THE MAP + . S ZJ=DOMMAP(ZI) ; + . S PARNODE=$P(ZJ,U,1) ;PARENT NODE + . S TAG=$P(ZJ,U,2) ;THIS TAG + . S TID=$P(ZJ,U,3) ;THIS TEMPLATE ID + . S PARTID=$P(ZJ,U,4) ;PARENT TEMPLATE ID + . S ZIEN=$O(^C0CXDS(178.101,"TID",TID,"")) ;THIS NODE IEN + . S PARIEN=$O(^C0CXDS(178.101,"TID",PARTID,"")) ;PARENT NODE IEN + . I ZI=PARNODE D ; IF THIS IS A SECTION NODE + . . S ALTTAG=$$GET1^DIQ(178.101,PARIEN_",",.03) ;ALT TAG FIELD FOR PARENT + . . S NAME=$$GET1^DIQ(178.101,ZIEN_",",.01) ;NAME OF THIS NODE'S TEMPLATE + . . W ZI," ",TAG," ",ALTTAG," ",NAME,! + . . S C0CTAGS(ZI)=ALTTAG + . E D ; NOT A SECTION NODE + . . N ZJ S ZJ="" + . . S ZJ=$O(^C0CXDS(178.101,"D",PARIEN,ZIEN,"")) ;A WHEREUSED POINTER? + . . I ZJ'="" D ; THERE IS A NEW LABEL FOR THIS NODE + . . . N ZK + . . . S ZK=$$GET1^DIQ(178.111,ZJ_","_ZIEN_",",2) + . . . I ZK'="" D ; + . . . . W "FOUND ",ZK,! + . . . . S C0CTAGS(ZI)=ZK ; NEW TAG FOR INTERSECTION + Q + ; +ALTTAG(NODE) ; SET Y EQUAL TO THE ALT TAG FOUND IN C0CTAGS IF NODE IF FOUND + ; + S Y=$G(C0CTAGS(NODE)) + Q + ; +SETCBK ; SET THE TAG CALLBACK FOR XPATH PROCESSSING OF THE CCD + S C0CCBK("TAG")="D ALTTAG^C0CMCCD(ZOID)" + Q + ; +OUTCCD(GARYIN) ; OUTPUT THE PARSED CCD TO A TEXT FILE + ;D TEST3^C0CMXML + N ZT S ZT=$NA(^TMP("CCDOUT",$J)) + N ZI,ZJ + S ZI=1 S ZJ="" + K @ZT + F S ZJ=$O(GARYIN(ZJ)) Q:ZJ="" D ; + . S @ZT@(ZI)=ZJ_"^"_GARYIN(ZJ) + . S ZI=ZI+1 + S ONAME=$NA(@ZT@(1)) + W $$OUTPUT^C0CXPATH(ONAME,"CCDOUT.txt","/home/vademo2/CCR") + K @ZT + Q + ; +GENXDS(ZD) ; GENERATE THE XDS PROTOTYPE RECORDS FROM A CCDDIR ARRAY + ; ARRAY ELEMENTS LOOK LIKE: + ; CCDDIR(1659,1634,"observation"," Result observaion template "," Vital signs section template ")="2.16.840.1.113883.10.20.1.31" + ;or CCDDIR(cur node,section node,cur tag,cur name,sec name)=templateId + S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE + S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT + S DONE=0 + F Q:DONE D ; + . W @ZI,! + . S ZJ=$QS(ZI,5) + . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE + . S C0CFDA(ZF,"?+1,",.01)=ZJ + . S C0CFDA(ZF,"?+1,",.02)=$QS(ZI,4) ; TAG FOR THIS TEMPLATE + . S C0CFDA(ZF,"?+1,",1)=@ZI + . D UPDIE + . S ZI=$Q(@ZI) + . I ZI="" S DONE=1 + Q + ; +WHRUSD(ZD) ; UPDATE THE C0C XDS FILE WITH WHERE USED DATA FROM + ; CCDDIR PASS BY NAME + ; ARRAY ELEMENTS LOOK LIKE: + ; CCDDIR(1634," Vital signs section template ",1659,"observation"," Result observaion template ")="2.16.840.1.113883.10.20.1.31" + ;or CCDDIR(section node,sec name, cur node,cur tag,cur name)=templateId + S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE + S ZSF=178.111 ; WHERE USED SUBFILE OF C0C XDS PROTOTYPE FILE + S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT + S DONE=0 + F Q:DONE D ; + . W @ZI + . S ZIEN=$O(^C0CXDS(178.101,"TID",@ZI,"")) ; IEN FOR THIS NODE'S TEMPLATE + . W " IEN:",ZIEN + . S ZJ=$QS(ZI,2) + . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE + . S ZPIEN=$O(^C0CXDS(178.101,"B",ZJ,"")) ; PARENT IEN + . W " PARENT IEN:",ZPIEN + . S ZTAG=$QS(ZI,4) ; TAG FOR THIS TEMPLATE + . W " TAG:",ZTAG,! + . I ZIEN'=ZPIEN D ; ONLY FOR CHILD TEMPLATES + . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",.01)=ZPIEN ; NEW SUBFILE ENTRY WITH PAR PTR + . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",1)=ZTAG ; TAG FOR NEW ENTRY + . . D UPDIE + . ;S C0CFDA(ZF,"?+1,",1)=@ZI + . ;D UPDIE + . S ZI=$Q(@ZI) + . I ZI="" S DONE=1 + Q + ; +UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS + K ZERR + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","","ZERR") + I $D(ZERR) D ; + . W "ERROR",! + . ZWR ZERR + . B + K C0CFDA + Q + ; Index: ccr/branches/ohum/p/C0CMED.m =================================================================== --- ccr/branches/ohum/p/C0CMED.m (revision 1333) +++ ccr/branches/ohum/p/C0CMED.m (revision 1337) @@ -1,114 +1,114 @@ -C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 - ;;1.0;C0C;;May 19, 2009;Build 1 - ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel. - ; Licensed under the terms of the GNU General Public License. - ; See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; --Revision History - ; July 2008 - Initial Version/GPL - ; July 2008 - March 2009 various revisions - ; March 2009 - Reconstruction of routine as driver for other med routines/SMH - ; - Q -EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template - ; DFN passed by reference - ; MEDXML and MEDOUTXML are passed by Name - ; MEDXML is the input template - ; MEDOUTXML is the output template - ; Both of them refer to ^TMP globals where the XML documents are stored - ; - ; -- This ep is the driver for extracting medications into the provided XML template - ; 1. VA Outpatient Meds are in C0CMED1 - ; 2. VA Pending Meds are in C0CMED2 - ; 3. VA non-VA Meds are in C0CMED3 - ; 4. VA Inpatient IV Meds are in C0CMED4 (not functional) - ; 5. VA Inpatient UD Meds are in C0CMED5 (doesn't exist yet)--March 2009 - ; 6. RPMS Meds are in C0CMED6. Need to create other routines for subdivisions of RPMS Meds is not known at this time. - ; - ; --Get parameters for meds - S @MEDOUTXML@(0)=0 ; By default, empty. - N C0CMFLAG - S C0CMFLAG=$$GET^C0CPARMS("MEDALL")_"^"_$$GET^C0CPARMS("MEDLIMIT")_"^"_$$GET^C0CPARMS("MEDACTIVE")_"^"_$$GET^C0CPARMS("MEDPENDING") - W:$G(DEBUG) "Med Parameters: ",! - W:$G(DEBUG) "ALL: ",+C0CMFLAG,! - W:$G(DEBUG) "LIMIT: ",$P(C0CMFLAG,U,2),! - W:$G(DEBUG) "ACTIVE: ",$P(C0CMFLAG,U,3),! - W:$G(DEBUG) "PEND: ",$P(C0CMFLAG,U,4),! - ; --Find out what system we are on and branch out... - W:$G(DEBUG) "Agenecy: ",$G(DUZ("AG")) - I $$RPMS^C0CUTIL() D RPMS QUIT - I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT -RPMS - ;D EXTRACT^C0CMED6(MEDXML,DFN,MEDOUTXML,C0CMFLAG) QUIT - N MEDCOUNT S MEDCOUNT=0 - K ^TMP($J,"MED") - N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed - N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds - S @HIST@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors) - D EXTRACT^C0CMED6(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds - D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds - I @HIST@(0)>0 D - . D CP^C0CXPATH(HIST,MEDOUTXML) - . W:$G(DEBUG) "HAS ACTIVE OP MEDS",! - I @NVA@(0)>0 D - . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,NVA) - . ;E D CP^C0CXPATH(NVA,MEDOUTXML) - . W:$G(DEBUG) "HAS NON-VA MEDS",! - Q -VISTA - N MEDCOUNT S MEDCOUNT=0 - K ^TMP($J,"MED") - N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed - N PEND S PEND=$NA(^TMP($J,"MED","PEND")) ; Pending Meds - N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds - K @HIST K @PEND K @NVA ; MAKE SURE THEY ARE EMPTY - S @HIST@(0)=0,@PEND@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors) - ; N IPIV ; Inpatient IV Meds - N IPUD S IPUD=$NA(^TMP($J,"MED","IPUD")) ; Inpatient UD Meds - K @IPUD - S @IPUD@(0)=0 - ; - D EXTRACT^C0CMED1(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds - D:$P(C0CMFLAG,U,4) EXTRACT^C0CMED2(MEDXML,DFN,PEND,.MEDCOUNT) ; Pending Meds - ;D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds - D EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds GPL - D EXTRACT^C0CNMED4(MEDXML,DFN,IPUD,.MEDCOUNT) ; inpatient gpl - I @HIST@(0)>0 D - . D CP^C0CXPATH(HIST,MEDOUTXML) - . W:$G(DEBUG) "HAS ACTIVE OP MEDS",! - I @PEND@(0)>0 D - . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,PEND) ;Add Pending to Historical - . E D CP^C0CXPATH(PEND,MEDOUTXML) ; No historical, just copy - . W:$G(DEBUG) "HAS OP PENDING MEDS",! - I @NVA@(0)>0 D - . I @HIST@(0)>0!(@PEND@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,NVA) - . E D CP^C0CXPATH(NVA,MEDOUTXML) - . W:$G(DEBUG) "HAS NON-VA MEDS",! - I @IPUD@(0)>0 D - . I @HIST@(0)>0!(@PEND@(0)>0)!(@NVA@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,IPUD) - . E D CP^C0CXPATH(IPUD,MEDOUTXML) - . W:$G(DEBUG) "HAS INPATIENT MEDS",! - N ZI - S ZI=$NA(^TMP("C0CCCR",$J,"MEDMAP")) - M ^TMP("C0CRIM","VARS",DFN,"MEDS")=@ZI ; PERSIST MEDS VARIABLES - K @ZI ; CLEAN UP MED MAP AFTER - GPL 10/10 - K @PEND - K @HIST - K @NVA - K @IPUD - Q - +C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 + ;;1.0;C0C;;May 19, 2009;Build 38 + ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel. + ; Licensed under the terms of the GNU General Public License. + ; See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; --Revision History + ; July 2008 - Initial Version/GPL + ; July 2008 - March 2009 various revisions + ; March 2009 - Reconstruction of routine as driver for other med routines/SMH + ; + Q +EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template + ; DFN passed by reference + ; MEDXML and MEDOUTXML are passed by Name + ; MEDXML is the input template + ; MEDOUTXML is the output template + ; Both of them refer to ^TMP globals where the XML documents are stored + ; + ; -- This ep is the driver for extracting medications into the provided XML template + ; 1. VA Outpatient Meds are in C0CMED1 + ; 2. VA Pending Meds are in C0CMED2 + ; 3. VA non-VA Meds are in C0CMED3 + ; 4. VA Inpatient IV Meds are in C0CMED4 (not functional) + ; 5. VA Inpatient UD Meds are in C0CMED5 (doesn't exist yet)--March 2009 + ; 6. RPMS Meds are in C0CMED6. Need to create other routines for subdivisions of RPMS Meds is not known at this time. + ; + ; --Get parameters for meds + S @MEDOUTXML@(0)=0 ; By default, empty. + N C0CMFLAG + S C0CMFLAG=$$GET^C0CPARMS("MEDALL")_"^"_$$GET^C0CPARMS("MEDLIMIT")_"^"_$$GET^C0CPARMS("MEDACTIVE")_"^"_$$GET^C0CPARMS("MEDPENDING") + W:$G(DEBUG) "Med Parameters: ",! + W:$G(DEBUG) "ALL: ",+C0CMFLAG,! + W:$G(DEBUG) "LIMIT: ",$P(C0CMFLAG,U,2),! + W:$G(DEBUG) "ACTIVE: ",$P(C0CMFLAG,U,3),! + W:$G(DEBUG) "PEND: ",$P(C0CMFLAG,U,4),! + ; --Find out what system we are on and branch out... + W:$G(DEBUG) "Agenecy: ",$G(DUZ("AG")) + I $$RPMS^C0CUTIL() D RPMS QUIT + I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT +RPMS + ;D EXTRACT^C0CMED6(MEDXML,DFN,MEDOUTXML,C0CMFLAG) QUIT + N MEDCOUNT S MEDCOUNT=0 + K ^TMP($J,"MED") + N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed + N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds + S @HIST@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors) + D EXTRACT^C0CMED6(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds + D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds + I @HIST@(0)>0 D + . D CP^C0CXPATH(HIST,MEDOUTXML) + . W:$G(DEBUG) "HAS ACTIVE OP MEDS",! + I @NVA@(0)>0 D + . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,NVA) + . ;E D CP^C0CXPATH(NVA,MEDOUTXML) + . W:$G(DEBUG) "HAS NON-VA MEDS",! + Q +VISTA + N MEDCOUNT S MEDCOUNT=0 + K ^TMP($J,"MED") + N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed + N PEND S PEND=$NA(^TMP($J,"MED","PEND")) ; Pending Meds + N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds + K @HIST K @PEND K @NVA ; MAKE SURE THEY ARE EMPTY + S @HIST@(0)=0,@PEND@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors) + ; N IPIV ; Inpatient IV Meds + N IPUD S IPUD=$NA(^TMP($J,"MED","IPUD")) ; Inpatient UD Meds + K @IPUD + S @IPUD@(0)=0 + ; + D EXTRACT^C0CMED1(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds + D:$P(C0CMFLAG,U,4) EXTRACT^C0CMED2(MEDXML,DFN,PEND,.MEDCOUNT) ; Pending Meds + ;D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds + D EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds GPL + D EXTRACT^C0CNMED4(MEDXML,DFN,IPUD,.MEDCOUNT) ; inpatient gpl + I @HIST@(0)>0 D + . D CP^C0CXPATH(HIST,MEDOUTXML) + . W:$G(DEBUG) "HAS ACTIVE OP MEDS",! + I @PEND@(0)>0 D + . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,PEND) ;Add Pending to Historical + . E D CP^C0CXPATH(PEND,MEDOUTXML) ; No historical, just copy + . W:$G(DEBUG) "HAS OP PENDING MEDS",! + I @NVA@(0)>0 D + . I @HIST@(0)>0!(@PEND@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,NVA) + . E D CP^C0CXPATH(NVA,MEDOUTXML) + . W:$G(DEBUG) "HAS NON-VA MEDS",! + I @IPUD@(0)>0 D + . I @HIST@(0)>0!(@PEND@(0)>0)!(@NVA@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,IPUD) + . E D CP^C0CXPATH(IPUD,MEDOUTXML) + . W:$G(DEBUG) "HAS INPATIENT MEDS",! + N ZI + S ZI=$NA(^TMP("C0CCCR",$J,"MEDMAP")) + M ^TMP("C0CRIM","VARS",DFN,"MEDS")=@ZI ; PERSIST MEDS VARIABLES + K @ZI ; CLEAN UP MED MAP AFTER - GPL 10/10 + K @PEND + K @HIST + K @NVA + K @IPUD + Q + Index: ccr/branches/ohum/p/C0CMED1.m =================================================================== --- ccr/branches/ohum/p/C0CMED1.m (revision 1333) +++ ccr/branches/ohum/p/C0CMED1.m (revision 1337) @@ -1,238 +1,238 @@ -C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;;Last modified Sat Jan 10 21:42:27 PST 2009 - ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU - ; General Public License See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE - ; - ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED - ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE - ; - ; MEDS is return array from RPC. - ; MAP is a mapping variable map (store result) for each med - ; MED is holds each array element from MEDS(J), one medicine - ; MEDCOUNT is a counter passed by Reference. - ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool) - ; FLAGS are set-up in C0CMED. - ; - ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all - ; med data available. - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf - ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). - ; D PARY^C0CXPATH(MINXML) - N MEDS,MAP - K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! - N ALL S ALL=+FLAGS - N ACTIVE S ACTIVE=$P(FLAGS,U,3) - ; Below, X1 is today; X2 is the number of days we want to go back - ; X is the result of this calculation using C^%DTC. - N X,X1,X2 - S X1=DT - S X2=-$P($P(FLAGS,U,2),"-",2) - D C^%DTC - ; I discovered that I shouldn't put an ending date (last parameter) - ; because it seems that it will get meds whose beginning is after X but - ; whose exipriation is before the ending date. - D RX^PSO52API(DFN,"CCDCCR","","","",X,"") - M MEDS=^TMP($J,"CCDCCR",DFN) - ; @(0) contains the number of meds or -1^NO DATA FOUND - ; If it is -1, we quit. - I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 Q - ZWRITE:$G(DEBUG) MEDS - N RXIEN S RXIEN=0 - F S RXIEN=$O(MEDS(RXIEN)) Q:$G(RXIEN)="" D ; FOR EACH MEDICATION IN THE LIST - . N MED M MED=MEDS(RXIEN) - . I 'ALL,ACTIVE,$P(MED(100),U,2)'="ACTIVE" QUIT - . S MEDCOUNT=MEDCOUNT+1 - . W:$G(DEBUG) "RXIEN IS ",RXIEN,! - . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) - . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED - . W:$G(DEBUG) "MAP= ",MAP,! - . S @MAP@("MEDOBJECTID")="MED"_MEDCOUNT ; MEDCOUNT FOR ID - . ; S @MAP@("MEDOBJECTID")="MED"_MED(.01) ;Rx Number - . S @MAP@("MEDISSUEDATETXT")="Issue Date" - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(1),U)) - . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" - . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P($G(MED(101)),U)) - . S @MAP@("MEDRXNOTXT")="Prescription Number" - . S @MAP@("MEDRXNO")=MED(.01) - . S @MAP@("MEDTYPETEXT")="Medication" - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses - . S @MAP@("MEDSTATUSTEXT")=$P(MED(100),U,2) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(4),U) - . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(6),U,2) - . ; 12/30/08: I will be using RxNorm for coding... - . ; 176.001 is the file for Concepts; 176.003 is the file for - . ; sources (i.e. for RxNorm Version) - . ; - . ; We need the VUID first for the National Drug File entry first - . ; We get the VUID of the drug, by looking up the VA Product entry - . ; (file 50.68) using the call NDF^PSS50, returned in node 22. - . ; Field 99.99 is the VUID. - . ; - . ; We use the VUID to look up the RxNorm in file 176.001; same idea. - . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by - . ; $$GET1^DIQ. - . ; - . ; I get the RxNorm name and version from the RxNorm Sources (file - . ; 176.003), by searching for "RXNORM", then get the data. - . N MEDIEN S MEDIEN=$P(MED(6),U) - . D NDF^PSS50(MEDIEN,,,,,"NDF") - . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) - . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) - . N VAPROD S VAPROD=$P(NDFDATA(22),U) - . ; - . ; NDFIEN is not necessarily defined; it won't be if the drug - . ; is not matched to the national drug file (e.g. if the drug is - . ; new on the market, compounded, or is a fake drug [blue pill]. - . ; To protect against failure, I will put an if/else block - . ; - . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER - . I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. - . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) - . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") - . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) - . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") - . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) - . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) - . ; - . E S (RXNORM,RXNNAME,RXNVER)="" - . ; End if/else block - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME - . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER - . ; - . S @MAP@("MEDBRANDNAMETEXT")=MED(6.5) - . D DOSE^PSS50(MEDIEN,,,,,"DOSE") - . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) - . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) - . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) - . ; Units, concentration, etc, come from another call - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters - . ; NDF Entry IEN, and VA Product IEN - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") - . ; These have been collected above. - . N CONCDATA - . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" - . ; and this will crash the call. So... - . I NDFIEN="" S CONCDATA="" - . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) - . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) - . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) - . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) - . S @MAP@("MEDQUANTITYVALUE")=MED(7) - . ; Oddly, there is no easy place to find the dispense unit. - . ; It's not included in the original call, so we have to go to the drug file. - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") - . ; Node 14.5 is the Dispense Unit - . D DATA^PSS50(MEDIEN,,,,,"QTY") - . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) - . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) - . ; - . ; --- START OF DIRECTIONS --- - . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... - . ; we want the compoenents. - . ; It's in node 6 of ^PSRX(IEN) - . ; So, here we go again - . ; ^PSRX(D0,6,D1,0)= (#.01) DOSAGE ORDERED [1F] ^ (#1) DISPENSE UNITS PER DOSE - . ; ==>[2N] ^ (#2) UNITS [3P:50.607] ^ (#3) NOUN [4F] ^ (#4) - . ; ==>DURATION [5F] ^ (#5) CONJUNCTION [6S] ^ (#6) ROUTE - . ; ==>[7P:51.2] ^ (#7) SCHEDULE [8F] ^ (#8) VERB [9F] ^ - . ; - . N DIRNUM S DIRNUM=0 ; Sigline number - . S DIRCNT=0 ; COUNT OF MULTIPLE DIRECTIONS - . F S DIRNUM=$O(^PSRX(RXIEN,6,DIRNUM)) Q:DIRNUM="" D - . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. - . . N SIGDATA S SIGDATA=^PSRX(RXIEN,6,DIRNUM,0) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$P(SIGDATA,U,9) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$P(SIGDATA,U,1) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$$GET1^DIQ(51.2,$P(SIGDATA,U,7),.01) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$P(SIGDATA,U,8) - . . ; Invervals... again another call. - . . ; In the wisdom of the original programmers, the schedule is a free text field - . . ; However, it gets translated by a call to the administration schedule file - . . ; to see if that schedule exists. - . . ; That's the same thing I am going to do. - . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). - . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- - . . ; I looked), PSSFT is the name, and list is the ^TMP name to store the data in. - . . ; So... - . . D AP^PSS51P1("PSJ",$P(SIGDATA,U,8),,,"SCHEDULE") - . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") - . . N INTERVAL - . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" - . . E D - . . . N SUB S SUB=$O(SCHEDATA(0)) - . . . S INTERVAL=SCHEDATA(SUB,2) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$P(SIGDATA,U,5) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$P(SIGDATA,U,8)["PRN" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM - . . N DIRMOD S DIRMOD=$P(SIGDATA,U,6) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$S(DIRMOD="T":"THEN",DIRMOD="A":"AND",DIRMOD="X":"EXCEPT",1:"") - . ; - . ; --- END OF DIRECTIONS --- - . ; - . ; ^PSRX(22,"INS1",1,0)="FOR BLOOD PRESSURE" - . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"INS1",1,0)) - . ; ^PSRX(22,"PRC",1,0)="Pharmacist: you must obey my command" - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PRC",1,0)) - . S @MAP@("MEDRFNO")=MED(9) - . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) - . K @RESULT - . D MAP^C0CXPATH(MINXML,MAP,RESULT) - . ; MAPPING DIRECTIONS - . N DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE - . N DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT - . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) - . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") - . ; N MDZ1,MDZNA - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) - . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) - . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") - . I MEDCOUNT=1 D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy - . E D INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML - N MEDTMP,MEDI - D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ - . W "MEDICATION MISSING ",! - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! - Q - ; +C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;;Last modified Sat Jan 10 21:42:27 PST 2009 + ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE + ; + ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE + ; + ; MEDS is return array from RPC. + ; MAP is a mapping variable map (store result) for each med + ; MED is holds each array element from MEDS(J), one medicine + ; MEDCOUNT is a counter passed by Reference. + ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool) + ; FLAGS are set-up in C0CMED. + ; + ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all + ; med data available. + ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf + ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). + ; D PARY^C0CXPATH(MINXML) + N MEDS,MAP + K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! + N ALL S ALL=+FLAGS + N ACTIVE S ACTIVE=$P(FLAGS,U,3) + ; Below, X1 is today; X2 is the number of days we want to go back + ; X is the result of this calculation using C^%DTC. + N X,X1,X2 + S X1=DT + S X2=-$P($P(FLAGS,U,2),"-",2) + D C^%DTC + ; I discovered that I shouldn't put an ending date (last parameter) + ; because it seems that it will get meds whose beginning is after X but + ; whose exipriation is before the ending date. + D RX^PSO52API(DFN,"CCDCCR","","","",X,"") + M MEDS=^TMP($J,"CCDCCR",DFN) + ; @(0) contains the number of meds or -1^NO DATA FOUND + ; If it is -1, we quit. + I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT + ZWRITE:$G(DEBUG) MEDS + N RXIEN S RXIEN=0 + F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="" D ; FOR EACH MEDICATION IN THE LIST + . N MED M MED=MEDS(RXIEN) + . I 'ALL,ACTIVE,$P(MED(100),U,2)'="ACTIVE" QUIT + . S MEDCOUNT=MEDCOUNT+1 + . W:$G(DEBUG) "RXIEN IS ",RXIEN,! + . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) + . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED + . W:$G(DEBUG) "MAP= ",MAP,! + . S @MAP@("MEDOBJECTID")="MED"_MEDCOUNT ; MEDCOUNT FOR ID + . ; S @MAP@("MEDOBJECTID")="MED"_MED(.01) ;Rx Number + . S @MAP@("MEDISSUEDATETXT")="Issue Date" + . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(1),U)) + . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" + . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P($G(MED(101)),U)) + . S @MAP@("MEDRXNOTXT")="Prescription Number" + . S @MAP@("MEDRXNO")=MED(.01) + . S @MAP@("MEDTYPETEXT")="Medication" + . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses + . S @MAP@("MEDSTATUSTEXT")=$P(MED(100),U,2) + . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(4),U) + . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(6),U,2) + . ; 12/30/08: I will be using RxNorm for coding... + . ; 176.001 is the file for Concepts; 176.003 is the file for + . ; sources (i.e. for RxNorm Version) + . ; + . ; We need the VUID first for the National Drug File entry first + . ; We get the VUID of the drug, by looking up the VA Product entry + . ; (file 50.68) using the call NDF^PSS50, returned in node 22. + . ; Field 99.99 is the VUID. + . ; + . ; We use the VUID to look up the RxNorm in file 176.001; same idea. + . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by + . ; $$GET1^DIQ. + . ; + . ; I get the RxNorm name and version from the RxNorm Sources (file + . ; 176.003), by searching for "RXNORM", then get the data. + . N MEDIEN S MEDIEN=$P(MED(6),U) + . D NDF^PSS50(MEDIEN,,,,,"NDF") + . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) + . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) + . N VAPROD S VAPROD=$P(NDFDATA(22),U) + . ; + . ; NDFIEN is not necessarily defined; it won't be if the drug + . ; is not matched to the national drug file (e.g. if the drug is + . ; new on the market, compounded, or is a fake drug [blue pill]. + . ; To protect against failure, I will put an if/else block + . ; + . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER + . I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. + . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) + . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") + . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) + . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") + . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) + . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) + . ; + . E S (RXNORM,RXNNAME,RXNVER)="" + . ; End if/else block + . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM + . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME + . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER + . ; + . S @MAP@("MEDBRANDNAMETEXT")=MED(6.5) + . D DOSE^PSS50(MEDIEN,,,,,"DOSE") + . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) + . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) + . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) + . ; Units, concentration, etc, come from another call + . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit + . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters + . ; NDF Entry IEN, and VA Product IEN + . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") + . ; These have been collected above. + . N CONCDATA + . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" + . ; and this will crash the call. So... + . I NDFIEN="" S CONCDATA="" + . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) + . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) + . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) + . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) + . S @MAP@("MEDQUANTITYVALUE")=MED(7) + . ; Oddly, there is no easy place to find the dispense unit. + . ; It's not included in the original call, so we have to go to the drug file. + . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") + . ; Node 14.5 is the Dispense Unit + . D DATA^PSS50(MEDIEN,,,,,"QTY") + . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) + . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) + . ; + . ; --- START OF DIRECTIONS --- + . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... + . ; we want the compoenents. + . ; It's in node 6 of ^PSRX(IEN) + . ; So, here we go again + . ; ^PSRX(D0,6,D1,0)= (#.01) DOSAGE ORDERED [1F] ^ (#1) DISPENSE UNITS PER DOSE + . ; ==>[2N] ^ (#2) UNITS [3P:50.607] ^ (#3) NOUN [4F] ^ (#4) + . ; ==>DURATION [5F] ^ (#5) CONJUNCTION [6S] ^ (#6) ROUTE + . ; ==>[7P:51.2] ^ (#7) SCHEDULE [8F] ^ (#8) VERB [9F] ^ + . ; + . N DIRNUM S DIRNUM=0 ; Sigline number + . S DIRCNT=0 ; COUNT OF MULTIPLE DIRECTIONS + . F S DIRNUM=$O(^PSRX(RXIEN,6,DIRNUM)) Q:DIRNUM="" D + . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. + . . N SIGDATA S SIGDATA=^PSRX(RXIEN,6,DIRNUM,0) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$P(SIGDATA,U,9) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$P(SIGDATA,U,1) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$$GET1^DIQ(51.2,$P(SIGDATA,U,7),.01) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$P(SIGDATA,U,8) + . . ; Invervals... again another call. + . . ; In the wisdom of the original programmers, the schedule is a free text field + . . ; However, it gets translated by a call to the administration schedule file + . . ; to see if that schedule exists. + . . ; That's the same thing I am going to do. + . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). + . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- + . . ; I looked), PSSFT is the name, and list is the ^TMP name to store the data in. + . . ; So... + . . D AP^PSS51P1("PSJ",$P(SIGDATA,U,8),,,"SCHEDULE") + . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") + . . N INTERVAL + . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" + . . E D + . . . N SUB S SUB=$O(SCHEDATA(0)) + . . . S INTERVAL=SCHEDATA(SUB,2) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$P(SIGDATA,U,5) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$P(SIGDATA,U,8)["PRN" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM + . . N DIRMOD S DIRMOD=$P(SIGDATA,U,6) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$S(DIRMOD="T":"THEN",DIRMOD="A":"AND",DIRMOD="X":"EXCEPT",1:"") + . ; + . ; --- END OF DIRECTIONS --- + . ; + . ; ^PSRX(22,"INS1",1,0)="FOR BLOOD PRESSURE" + . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"INS1",1,0)) + . ; ^PSRX(22,"PRC",1,0)="Pharmacist: you must obey my command" + . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PRC",1,0)) + . S @MAP@("MEDRFNO")=MED(9) + . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) + . K @RESULT + . D MAP^C0CXPATH(MINXML,MAP,RESULT) + . ; MAPPING DIRECTIONS + . N DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) + . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") + . ; N MDZ1,MDZNA + . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS + . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION + . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) + . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) + . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") + . I MEDCOUNT=1 D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy + . E D INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML + N MEDTMP,MEDI + D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "MEDICATION MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; Index: ccr/branches/ohum/p/C0CMED2.m =================================================================== --- ccr/branches/ohum/p/C0CMED2.m (revision 1333) +++ ccr/branches/ohum/p/C0CMED2.m (revision 1337) @@ -1,267 +1,267 @@ -C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista - ;;1.0;C0C;;May 19, 2009;Build 1 - ;;Last Modified Sat Jan 10 21:41:14 PST 2009 - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ; General Public License See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE - ; - ; MINXML is the Input XML Template, passed by name - ; DFN is Patient IEN (by Value) - ; OUTXML is the resultant XML (by Name) - ; MEDCOUNT is the current count of extracted meds, passed by Reference - ; - ; MEDS is return array from RPC. - ; MAP is a mapping variable map (store result) for each med - ; MED is holds each array element from MEDS, one medicine - ; - ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending - ; meds data available. - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf - ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). - ; File for pending meds is 52.41 - ; Unfortuantely, API does not supply us with any useful info beyond - ; the IEN in 52.41, and the Med Name, and route. - ; So, most of the info is going to get pulled from 52.41. - N MEDS,MAP - K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! - D PEN^PSO5241(DFN,"CCDCCR") - M MEDS=^TMP($J,"CCDCCR",DFN) - ; @(0) contains the number of meds or -1^NO DATA FOUND - ; If it is -1, we quit. - I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT - ZWRITE:$G(DEBUG) MEDS - N RXIEN S RXIEN=0 - N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED IN THIS SECTION FOR MERGING - F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B" D ; FOR EACH MEDICATION IN THE LIST - . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT ; Dont' want refill request as a "pending" order - . S MEDCOUNT=MEDCOUNT+1 - . I DEBUG W "RXIEN IS ",RXIEN,! - . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) - . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN C0CMED - . I DEBUG W "MAP= ",MAP,! - . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM - . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID - . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN - . S @MAP@("MEDISSUEDATETXT")="Issue Date" - . ; Field 6 is "Effective date", and we pull it in timson format w/ I - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($$GET1^DIQ(52.41,RXIEN,6,"I"),"DT") - . ; Med never filled; next 4 fields are not applicable. - . S @MAP@("MEDLASTFILLDATETXT")="" - . S @MAP@("MEDLASTFILLDATE")="" - . S @MAP@("MEDRXNOTXT")="" - . S @MAP@("MEDRXNO")="" - . S @MAP@("MEDTYPETEXT")="Medication" - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses - . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I") - . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2) - . ; NDC not supplied in API, but is rather trivial to obtain - . ; MED(11) piece 1 has the IEN of the drug (file 50) - . ; IEN is field 31 in the drug file. - . ; - . ; MEDIEN (node 11 in the returned output) might not necessarily be defined - . ; It is not defined when a dose in not chosen in CPRS. There is a long - . ; series of fields that depend on it. We will use If and Else to deal - . ; with that - . N MEDIEN S MEDIEN=$P(MED(11),U) - . I +MEDIEN>0 D ; start of if/else block - . . ; 12/30/08: I will be using RxNorm for coding... - . . ; 176.001 is the file for Concepts; 176.003 is the file for - . . ; sources (i.e. for RxNorm Version) - . . ; - . . ; We need the VUID first for the National Drug File entry first - . . ; We get the VUID of the drug, by looking up the VA Product entry - . . ; (file 50.68) using the call NDF^PSS50, returned in node 22. - . . ; Field 99.99 is the VUID. - . . ; - . . ; We use the VUID to look up the RxNorm in file 176.001; same idea. - . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by - . . ; $$GET1^DIQ. - . . ; - . . ; I get the RxNorm name and version from the RxNorm Sources (file - . . ; 176.003), by searching for "RXNORM", then get the data. - . . D NDF^PSS50(MEDIEN,,,,,"NDF") - . . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) - . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) - . . N VAPROD S VAPROD=$P(NDFDATA(22),U) - . . ; - . . ; NDFIEN is not necessarily defined; it won't be if the drug - . . ; is not matched to the national drug file (e.g. if the drug is - . . ; new on the market, compounded, or is a fake drug [blue pill]. - . . ; To protect against failure, I will put an if/else block - . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER - . . I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. - . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) - . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") - . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) - . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") - . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) - . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) - . . ; - . . E S (RXNORM,RXNNAME,RXNVER)="" - . . ; End if/else block - . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM - . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME - . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER - . . ; - . . S @MAP@("MEDBRANDNAMETEXT")="" - . . D DOSE^PSS50(MEDIEN,,,,,"DOSE") - . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) - . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) - . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) - . . ; Units, concentration, etc, come from another call - . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit - . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters - . . ; NDF Entry IEN, and VA Product Name - . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") - . . ; Documented in the same manual; executed above. - . . N CONCDATA - . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" - . . ; and this will crash the call. So... - . . I NDFIEN="" S CONCDATA="" - . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) - . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) - . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) - . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) - . . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12) - . . ; Oddly, there is no easy place to find the dispense unit. - . . ; It's not included in the original call, so we have to go to the drug file. - . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") - . . ; Node 14.5 is the Dispense Unit - . . D DATA^PSS50(MEDIEN,,,,,"QTY") - . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) - . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) - . E D - . . S @MAP@("MEDPRODUCTNAMECODEVALUE")="" - . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" - . . S @MAP@("MEDPRODUCTNAMECODEVERSION")="" - . . S @MAP@("MEDBRANDNAMETEXT")="" - . . S @MAP@("MEDSTRENGTHVALUE")="" - . . S @MAP@("MEDSTRENGTHUNIT")="" - . . S @MAP@("MEDFORMTEXT")="" - . . S @MAP@("MEDCONCVALUE")="" - . . S @MAP@("MEDCONCUNIT")="" - . . S @MAP@("MEDSIZETEXT")="" - . . S @MAP@("MEDQUANTITYVALUE")="" - . . S @MAP@("MEDQUANTITYUNIT")="" - . ; end of if/else block - . ; - . ; --- START OF DIRECTIONS --- - . ; Sig data is not in any API. We obtain it using the IEN from - . ; the PEN API to file 52.41. It's in field 3, which is a multiple. - . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT) - . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call - . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG") - . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman. - . ; FMSIGNUM gets outputted as "IEN,RXIEN,". - . ; DIRNUM will be first piece for IEN. - . ; DIRNUM is the proper Sigline numer. - . ; SIGDATA is the simplfied array. Subscripts are really field numbers - . ; in subfile 52.413. - . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS - . F S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM="" D - . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",") - . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT - . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM) - . . ; If this is an order for a refill; it's not really a new order; move on to next - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1) - . . ; Invervals... again another call. - . . ; The schedule is a free text field - . . ; However, it gets translated by a call to the administration - . . ; schedule file to see if that schedule exists. - . . ; That's the same thing I am going to do. - . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). - . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- - . . ; I looked), PSSFT is the name, - . . ; and list is the ^TMP name to store the data in. - . . ; Also, freqency may have "PRN" in it, so strip that out - . . N FREQ S FREQ=SIGDATA(1) - . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp - . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE") - . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") - . . N INTERVAL - . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" - . . E D - . . . N SUB S SUB=$O(SCHEDATA(0)) - . . . S INTERVAL=SCHEDATA(SUB,2) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" - . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months - . . N DUR S DUR=SIGDATA(2) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR)) - . . N DURUNIT S DURUNIT=$E(DUR) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"") - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6) - . ; - . ; --- END OF DIRECTIONS --- - . ; - . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" - . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL - . ; W @MAP@("MEDPTINSTRUCTIONS"),! - . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9" - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL - . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),! - . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13) - . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) - . K @RESULT - . D MAP^C0CXPATH(MINXML,MAP,RESULT) - . ; D PARY^C0CXPATH(RESULT) - . ; MAPPING DIRECTIONS - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT - . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) - . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") - . ; N MDZ1,MDZNA - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) - . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) - . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") - . I MEDFIRST D ; - . . S MEDFIRST=0 ; RESET FIRST FLAG - . . D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy - . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER - N MEDTMP,MEDI - D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ - . W "Pending Medication MISSING ",! - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! - Q - ; +C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista + ;;1.0;C0C;;May 19, 2009;Build 38 + ;;Last Modified Sat Jan 10 21:41:14 PST 2009 + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE + ; + ; MINXML is the Input XML Template, passed by name + ; DFN is Patient IEN (by Value) + ; OUTXML is the resultant XML (by Name) + ; MEDCOUNT is the current count of extracted meds, passed by Reference + ; + ; MEDS is return array from RPC. + ; MAP is a mapping variable map (store result) for each med + ; MED is holds each array element from MEDS, one medicine + ; + ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending + ; meds data available. + ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf + ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). + ; File for pending meds is 52.41 + ; Unfortuantely, API does not supply us with any useful info beyond + ; the IEN in 52.41, and the Med Name, and route. + ; So, most of the info is going to get pulled from 52.41. + N MEDS,MAP + K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! + D PEN^PSO5241(DFN,"CCDCCR") + M MEDS=^TMP($J,"CCDCCR",DFN) + ; @(0) contains the number of meds or -1^NO DATA FOUND + ; If it is -1, we quit. + I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT + ZWRITE:$G(DEBUG) MEDS + N RXIEN S RXIEN=0 + N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED IN THIS SECTION FOR MERGING + F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B" D ; FOR EACH MEDICATION IN THE LIST + . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT ; Dont' want refill request as a "pending" order + . S MEDCOUNT=MEDCOUNT+1 + . I DEBUG W "RXIEN IS ",RXIEN,! + . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) + . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN C0CMED + . I DEBUG W "MAP= ",MAP,! + . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM + . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID + . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN + . S @MAP@("MEDISSUEDATETXT")="Issue Date" + . ; Field 6 is "Effective date", and we pull it in timson format w/ I + . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($$GET1^DIQ(52.41,RXIEN,6,"I"),"DT") + . ; Med never filled; next 4 fields are not applicable. + . S @MAP@("MEDLASTFILLDATETXT")="" + . S @MAP@("MEDLASTFILLDATE")="" + . S @MAP@("MEDRXNOTXT")="" + . S @MAP@("MEDRXNO")="" + . S @MAP@("MEDTYPETEXT")="Medication" + . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses + . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds + . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I") + . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2) + . ; NDC not supplied in API, but is rather trivial to obtain + . ; MED(11) piece 1 has the IEN of the drug (file 50) + . ; IEN is field 31 in the drug file. + . ; + . ; MEDIEN (node 11 in the returned output) might not necessarily be defined + . ; It is not defined when a dose in not chosen in CPRS. There is a long + . ; series of fields that depend on it. We will use If and Else to deal + . ; with that + . N MEDIEN S MEDIEN=$P(MED(11),U) + . I +MEDIEN>0 D ; start of if/else block + . . ; 12/30/08: I will be using RxNorm for coding... + . . ; 176.001 is the file for Concepts; 176.003 is the file for + . . ; sources (i.e. for RxNorm Version) + . . ; + . . ; We need the VUID first for the National Drug File entry first + . . ; We get the VUID of the drug, by looking up the VA Product entry + . . ; (file 50.68) using the call NDF^PSS50, returned in node 22. + . . ; Field 99.99 is the VUID. + . . ; + . . ; We use the VUID to look up the RxNorm in file 176.001; same idea. + . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by + . . ; $$GET1^DIQ. + . . ; + . . ; I get the RxNorm name and version from the RxNorm Sources (file + . . ; 176.003), by searching for "RXNORM", then get the data. + . . D NDF^PSS50(MEDIEN,,,,,"NDF") + . . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) + . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) + . . N VAPROD S VAPROD=$P(NDFDATA(22),U) + . . ; + . . ; NDFIEN is not necessarily defined; it won't be if the drug + . . ; is not matched to the national drug file (e.g. if the drug is + . . ; new on the market, compounded, or is a fake drug [blue pill]. + . . ; To protect against failure, I will put an if/else block + . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER + . . I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. + . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) + . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") + . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) + . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") + . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) + . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) + . . ; + . . E S (RXNORM,RXNNAME,RXNVER)="" + . . ; End if/else block + . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM + . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME + . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER + . . ; + . . S @MAP@("MEDBRANDNAMETEXT")="" + . . D DOSE^PSS50(MEDIEN,,,,,"DOSE") + . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) + . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) + . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) + . . ; Units, concentration, etc, come from another call + . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit + . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters + . . ; NDF Entry IEN, and VA Product Name + . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") + . . ; Documented in the same manual; executed above. + . . N CONCDATA + . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" + . . ; and this will crash the call. So... + . . I NDFIEN="" S CONCDATA="" + . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) + . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) + . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) + . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) + . . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12) + . . ; Oddly, there is no easy place to find the dispense unit. + . . ; It's not included in the original call, so we have to go to the drug file. + . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") + . . ; Node 14.5 is the Dispense Unit + . . D DATA^PSS50(MEDIEN,,,,,"QTY") + . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) + . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) + . E D + . . S @MAP@("MEDPRODUCTNAMECODEVALUE")="" + . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" + . . S @MAP@("MEDPRODUCTNAMECODEVERSION")="" + . . S @MAP@("MEDBRANDNAMETEXT")="" + . . S @MAP@("MEDSTRENGTHVALUE")="" + . . S @MAP@("MEDSTRENGTHUNIT")="" + . . S @MAP@("MEDFORMTEXT")="" + . . S @MAP@("MEDCONCVALUE")="" + . . S @MAP@("MEDCONCUNIT")="" + . . S @MAP@("MEDSIZETEXT")="" + . . S @MAP@("MEDQUANTITYVALUE")="" + . . S @MAP@("MEDQUANTITYUNIT")="" + . ; end of if/else block + . ; + . ; --- START OF DIRECTIONS --- + . ; Sig data is not in any API. We obtain it using the IEN from + . ; the PEN API to file 52.41. It's in field 3, which is a multiple. + . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT) + . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call + . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG") + . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman. + . ; FMSIGNUM gets outputted as "IEN,RXIEN,". + . ; DIRNUM will be first piece for IEN. + . ; DIRNUM is the proper Sigline numer. + . ; SIGDATA is the simplfied array. Subscripts are really field numbers + . ; in subfile 52.413. + . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS + . F S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM="" D + . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",") + . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT + . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM) + . . ; If this is an order for a refill; it's not really a new order; move on to next + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1) + . . ; Invervals... again another call. + . . ; The schedule is a free text field + . . ; However, it gets translated by a call to the administration + . . ; schedule file to see if that schedule exists. + . . ; That's the same thing I am going to do. + . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). + . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- + . . ; I looked), PSSFT is the name, + . . ; and list is the ^TMP name to store the data in. + . . ; Also, freqency may have "PRN" in it, so strip that out + . . N FREQ S FREQ=SIGDATA(1) + . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp + . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE") + . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") + . . N INTERVAL + . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" + . . E D + . . . N SUB S SUB=$O(SCHEDATA(0)) + . . . S INTERVAL=SCHEDATA(SUB,2) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" + . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months + . . N DUR S DUR=SIGDATA(2) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR)) + . . N DURUNIT S DURUNIT=$E(DUR) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"") + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6) + . ; + . ; --- END OF DIRECTIONS --- + . ; + . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" + . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL + . ; W @MAP@("MEDPTINSTRUCTIONS"),! + . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9" + . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL + . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),! + . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13) + . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) + . K @RESULT + . D MAP^C0CXPATH(MINXML,MAP,RESULT) + . ; D PARY^C0CXPATH(RESULT) + . ; MAPPING DIRECTIONS + . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) + . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") + . ; N MDZ1,MDZNA + . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS + . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION + . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) + . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) + . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") + . I MEDFIRST D ; + . . S MEDFIRST=0 ; RESET FIRST FLAG + . . D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy + . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER + N MEDTMP,MEDI + D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "Pending Medication MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; Index: ccr/branches/ohum/p/C0CMED3.m =================================================================== --- ccr/branches/ohum/p/C0CMED3.m (revision 1333) +++ ccr/branches/ohum/p/C0CMED3.m (revision 1337) @@ -1,310 +1,310 @@ -C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista - ;;1.0;C0C;;May 19, 2009;Build 1 - ;;Last Modified: Sun Jan 11 05:45:03 UTC 2009 - ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU - ; General Public License See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml template - ; - ; MINXML is the Input XML Template, (passed by name) - ; DFN is Patient IEN (passed by value) - ; OUTXML is the resultant XML (passed by name) - ; MEDCOUNT is the number of Meds extracted so far (passed by reference) - ; - ; MEDS is return array from RPC. - ; MAP is a mapping variable map (store result) for each med - ; MED is holds each array element from MEDS, one medicine - ; - ; Non-VA meds don't have an API. They are stored in file 55, subfile 52.2 - ; Discontinued meds are indicated by the presence of a value in fields - ; 5 or 6 (STATUS 1 or 2, and DISCONTINUED DATE) - ; Will use Fileman API GETS^DIQ - ; - N MEDS,MAP - K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! - N NVA - D GETS^DIQ(55,DFN,"52.2*","IE","NVA") ; Output in NVA in FDA array format. - ; If NVA does not exist, then patient has no non-VA meds - I $D(NVA)=0 S @OUTXML@(0)=0 QUIT - ; Otherwise, we go on... - M MEDS=NVA(55.05) - ; We are done with NVA - K NVA - ; - I DEBUG ZWRITE MEDS - N FDAIEN S FDAIEN=0 ; For use in $Order in the MEDS array. - N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED PROCESSED HERE - F S FDAIEN=$O(MEDS(FDAIEN)) Q:FDAIEN="" D ; FOR EACH MEDICATION IN THE LIST - . N MED M MED=MEDS(FDAIEN) - . I MED(5,"I")!MED(6,"I") QUIT ; If disconinued, we don't want to pull it. - . S MEDCOUNT=MEDCOUNT+1 - . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) - . N RXIEN S RXIEN=$P(FDAIEN,",") ; First piece of FDAIEN is the number of the med for this patient - . I DEBUG W "RXIEN IS ",RXIEN,! - . I DEBUG W "MAP= ",MAP,! - . S @MAP@("MEDOBJECTID")="MED_OUTSIDE"_MEDCOUNT ; MEDCOUNT FOR ID - . S @MAP@("MEDISSUEDATETXT")="Documented Date" - . ; Field 6 is "Effective date", and we pull it in timson format w/ I - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL(MED(11,"I"),"DT") - . ; Med never filled; next 4 fields are not applicable. - . S @MAP@("MEDLASTFILLDATETXT")="" - . S @MAP@("MEDLASTFILLDATE")="" - . S @MAP@("MEDRXNOTXT")="" - . S @MAP@("MEDRXNO")="" - . S @MAP@("MEDTYPETEXT")="Medication" - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses - . S @MAP@("MEDSTATUSTEXT")="Active" ; nearest status for pending meds - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I") - . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E") - . ; NDC is field 31 in the drug file. - . ; The actual drug entry in the drug file (MEDIEN) is not necessarily supplied. - . ; It' node 1, internal form. - . N MEDIEN S MEDIEN=MED(1,"I") - . I +MEDIEN D ; start of if/else block - . . ; 12/30/08: I will be using RxNorm for coding... - . . ; 176.001 is the file for Concepts; 176.003 is the file for - . . ; sources (i.e. for RxNorm Version) - . . ; - . . ; We need the VUID first for the National Drug File entry first - . . ; We get the VUID of the drug, by looking up the VA Product entry - . . ; (file 50.68) using the call NDF^PSS50, returned in node 22. - . . ; Field 99.99 is the VUID. - . . ; - . . ; We use the VUID to look up the RxNorm in file 176.001; same idea. - . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by - . . ; $$GET1^DIQ. - . . ; - . . ; I get the RxNorm name and version from the RxNorm Sources (file - . . ; 176.003), by searching for "RXNORM", then get the data. - . . ; NDF^PSS50 ONLY EXISTS ON VISTA - . . N NDFDATA,NDFIEN,VAPROD - . . S NDFIEN="" - . . I '$$RPMS^C0CUTIL() D - . . . D NDF^PSS50(MEDIEN,,,,,"NDF") - . . . ;N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) - . . . ;N NDFIEN S NDFIEN=$P(NDFDATA(20),U) - . . . ;N VAPROD S VAPROD=$P(NDFDATA(22),U) - . . . M NDFDATA=^TMP($J,"NDF",MEDIEN) - . . . S NDFIEN=$P(NDFDATA(20),U) - . . . S VAPROD=$P(NDFDATA(22),U) - . . . S @MAP@("MEDPRODUCTNAMETEXT")=$$GET1^DIQ(50.68,VAPROD,.01) ; - . . ; GPL - RESET THE NAME TO THE REAL NAME OF THE DRUG NOW THAT WE - . . ; HAVE IT. - . . ; - . . ; NDFIEN is not necessarily defined; it won't be if the drug - . . ; is not matched to the national drug file (e.g. if the drug is - . . ; new on the market, compounded, or is a fake drug [blue pill]. - . . ; To protect against failure, I will put an if/else block - . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER - . . ; - . . ; begin changes for systems that have eRx installed - . . ; RxNorm is found in the ^C0P("RXN") global - gpl - . . ; - . . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION - . . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE - . . S (RXNORM,RXNNAME,RXNVER)="" ;INITIALIZE - . . I NDFIEN,$D(^C0P("RXN")) D ; - . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) - . . . S ZC=$$CODE^C0CUTIL(VUID) - . . . S ZCD=$P(ZC,"^",1) ; CODE TO USE - . . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID - . . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION - . . . S RXNORM=ZCD ; THE CODE - . . . S RXNNAME=ZCDS ; THE CODING SYSTEM - . . . S RXNVER=ZCDSV ; THE CODING SYSTEM VERSION - . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT") - . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_ZCDS_": "_ZCD - . . E I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. - . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) - . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") - . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) - . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") - . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) - . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) - . . ; - . . ;E S (RXNORM,RXNNAME,RXNVER)="" - . . ; End if/else block - . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM - . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME - . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER - . . ; - . . S @MAP@("MEDBRANDNAMETEXT")="" - . . ; DOSE^PSS50 ONLY ESISTS ON VISTA - . . I '$$RPMS^C0CUTIL() D - . . . D DOSE^PSS50(MEDIEN,,,,,"DOSE") - . . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) - . . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) - . . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) - . . E S @MAP@("MEDSTRENGTHVALUE")="" S @MAP@("MEDSTRENGTHUNIT")="" - . . ; Units, concentration, etc, come from another call - . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit - . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters - . . ; NDF Entry IEN, and VA Product Name - . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") - . . ; Documented in the same manual; executed above. - . . ; - . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" - . . ; and this will crash the call. So... - . . I NDFIEN="" S CONCDATA="" - . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) - . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) - . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) - . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) - . . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. - . . ; Oddly, there is no easy place to find the dispense unit. - . . ; It's not included in the original call, so we have to go to the drug file. - . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") - . . ; Node 14.5 is the Dispense Unit - . . ; PSS50 ONLY EXISTS ON VISTA - . . I '$$RPMS^C0CUTIL() D - . . . D DATA^PSS50(MEDIEN,,,,,"QTY") - . . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) - . . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) - . . E S @MAP@("MEDQUANTITYUNIT")="" - . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these - . E D - . . S @MAP@("MEDPRODUCTNAMECODEVALUE")="" - . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" - . . S @MAP@("MEDPRODUCTNAMECODEVERSION")="" - . . S @MAP@("MEDBRANDNAMETEXT")="" - . . S @MAP@("MEDSTRENGTHVALUE")="" - . . S @MAP@("MEDSTRENGTHUNIT")="" - . . S @MAP@("MEDFORMTEXT")="" - . . S @MAP@("MEDCONCVALUE")="" - . . S @MAP@("MEDCONCUNIT")="" - . . S @MAP@("MEDSIZETEXT")="" - . . S @MAP@("MEDQUANTITYVALUE")="" - . . S @MAP@("MEDQUANTITYUNIT")="" - . ; End If/Else - . ; --- START OF DIRECTIONS --- - . ; Dosage is field 2, route is 3, schedule is 4 - . ; These are all free text fields, and don't point to any files - . ; For that reason, I will use the field I never used before: - . ; MEDDIRECTIONDESCRIPTIONTEXT - . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS - . ; - . ; change for eRx meds - gpl 6/25/2011 - . ; - . N ZERX S ZERX=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") - . I ZERX["|" S ZERX=$P(ZERX,"|",2) ; GET RID OF MED NAME - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=ZERX - . N ZERX2 S ZERX2=$P(MED(2,"E"),"|",2) ; sig for quantity - . N ZFDBDRUG S ZFDBDRUG=$P(MED(2,"E"),"|",1) ; FDB DRUG NAME - . I @MAP@("MEDPRODUCTNAMETEXT")["FREE TXT" D ; FIX THE DRUG NAME - . . S @MAP@("MEDPRODUCTNAMETEXT")=ZFDBDRUG ; USE FDB NAME - . . S RXNORM=$P($P($G(MED(14,7)),"RXNORM:",2)," ",1) ; THE RXNORM - . . S RXNORM=$$NISTMAP^C0CUTIL(RXNORM) ; CHANGE IF NECESSARY - . . I RXNORM'="" D ; - . . . W !,"FOUND FREE TEXT RXNORM:",RXNORM - . . . S RXNNAME="RXNORM" ; THE CODING SYSTEM - . . . S RXNVER="" ; THE CODING SYSTEM VERSION - . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT") - . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_RXNNAME_": "_RXNORM - . . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM - . . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME - . . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER - . . . I RXNORM["979334" D ; PATCH FOR CERTIFICATION - . . . . S @MAP@("MEDSTRENGTHVALUE")=650 - . . . . S @MAP@("MEDSTRENGTHUNIT")="mcg" - . . . . S @MAP@("MEDFORMTEXT")="INHALER" - . S @MAP@("MEDQUANTITYUNIT")=$P(ZERX2," ",3) ; THE UNITS - . S @MAP@("MEDQUANTITYVALUE")=$P(ZERX2," ",2) ; THE QUANTITY - . I @MAP@("MEDFORMTEXT")="" S @MAP@("MEDFORMTEXT")=$P(ZERX2," ",3) ; - . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. - . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" - . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" - . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" - . ; - . ; --- END OF DIRECTIONS --- - . ; - . S @MAP@("MEDRFNO")="" - . I $D(MED(14,1)) D ; - . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field - . E S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" ; don't put in these - gpl - . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) - . K @RESULT - . D MAP^C0CXPATH(MINXML,MAP,RESULT) - . ; D PARY^C0CXPATH(RESULT) - . ; MAPPING DIRECTIONS - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT - . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) - . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") - . N MDZ1,MDZNA - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) - . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) - . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") - . ; - . ; MAP PATIENT INSTRUCTIONS - HAVE TO DO THIS AFTER MAPPING DIRECTIONS DUE TO XML SCHEMA VALIDATION - . N MEDINT1,INTXML1 S INTXML1="MENINT1" ; VARIABLE AND NAME VARIABLE TEMPLATE - . N MEDINT2,INTXML2 S INTXML2="MEDINT2" ; VARIABLE AND NAME VARIABLE RESULT - . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/PatientInstructions",INTXML1) - . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/PatientInstructions") - . ;N MDI1 ; removing the "I" which is not in the protocol gpl 1/2010 - . ;S MDI1=$NA(@MAP@("I")) - . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" - . I $D(MED(10,1)) D ; - . . ;S @MAP@("I","MEDPTINSTRUCTIONS")=$P(MED(10,1)," ",1) ; WP Field - . . S @MAP@("MEDPTINSTRUCTIONS")=$P(MED(10,1)," ",1) ; WP Field - . E S @MAP@("MEDPTINSTRUCTIONS")="" - . ;E S @MAP@("I","MEDPTINSTRUCTIONS")="" - . ;D MAP^C0CXPATH(INTXML1,MDI1,INTXML2) - . D MAP^C0CXPATH(INTXML1,MAP,INTXML2) ; JUST MAP WORKS.. GPL - . D INSERT^C0CXPATH(RESULT,INTXML2,"//Medications/Medication") - . ; - . ; FLAG HAS TO BE RESET OUTSIDE THE IF STATMENT. - . ;I MEDFIRST D ; - . ;. S MEDFIRST=0 ; RESET FIRST FLAG - . ;. D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy - . ;D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML - . D:MEDFIRST CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy - . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML - . I MEDFIRST S MEDFIRST=0 - N MEDTMP,MEDI - D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ - . W "MEDICATION MISSING ",! - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! - Q - ; +C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista + ;;1.0;C0C;;May 19, 2009;Build 38 + ;;Last Modified: Sun Jan 11 05:45:03 UTC 2009 + ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml template + ; + ; MINXML is the Input XML Template, (passed by name) + ; DFN is Patient IEN (passed by value) + ; OUTXML is the resultant XML (passed by name) + ; MEDCOUNT is the number of Meds extracted so far (passed by reference) + ; + ; MEDS is return array from RPC. + ; MAP is a mapping variable map (store result) for each med + ; MED is holds each array element from MEDS, one medicine + ; + ; Non-VA meds don't have an API. They are stored in file 55, subfile 52.2 + ; Discontinued meds are indicated by the presence of a value in fields + ; 5 or 6 (STATUS 1 or 2, and DISCONTINUED DATE) + ; Will use Fileman API GETS^DIQ + ; + N MEDS,MAP + K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! + N NVA + D GETS^DIQ(55,DFN,"52.2*","IE","NVA") ; Output in NVA in FDA array format. + ; If NVA does not exist, then patient has no non-VA meds + I $D(NVA)=0 S @OUTXML@(0)=0 QUIT + ; Otherwise, we go on... + M MEDS=NVA(55.05) + ; We are done with NVA + K NVA + ; + I DEBUG ZWRITE MEDS + N FDAIEN S FDAIEN=0 ; For use in $Order in the MEDS array. + N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED PROCESSED HERE + F S FDAIEN=$O(MEDS(FDAIEN)) Q:FDAIEN="" D ; FOR EACH MEDICATION IN THE LIST + . N MED M MED=MEDS(FDAIEN) + . I MED(5,"I")!MED(6,"I") QUIT ; If disconinued, we don't want to pull it. + . S MEDCOUNT=MEDCOUNT+1 + . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) + . N RXIEN S RXIEN=$P(FDAIEN,",") ; First piece of FDAIEN is the number of the med for this patient + . I DEBUG W "RXIEN IS ",RXIEN,! + . I DEBUG W "MAP= ",MAP,! + . S @MAP@("MEDOBJECTID")="MED_OUTSIDE"_MEDCOUNT ; MEDCOUNT FOR ID + . S @MAP@("MEDISSUEDATETXT")="Documented Date" + . ; Field 6 is "Effective date", and we pull it in timson format w/ I + . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL(MED(11,"I"),"DT") + . ; Med never filled; next 4 fields are not applicable. + . S @MAP@("MEDLASTFILLDATETXT")="" + . S @MAP@("MEDLASTFILLDATE")="" + . S @MAP@("MEDRXNOTXT")="" + . S @MAP@("MEDRXNO")="" + . S @MAP@("MEDTYPETEXT")="Medication" + . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses + . S @MAP@("MEDSTATUSTEXT")="Active" ; nearest status for pending meds + . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I") + . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E") + . ; NDC is field 31 in the drug file. + . ; The actual drug entry in the drug file (MEDIEN) is not necessarily supplied. + . ; It' node 1, internal form. + . N MEDIEN S MEDIEN=MED(1,"I") + . I +MEDIEN D ; start of if/else block + . . ; 12/30/08: I will be using RxNorm for coding... + . . ; 176.001 is the file for Concepts; 176.003 is the file for + . . ; sources (i.e. for RxNorm Version) + . . ; + . . ; We need the VUID first for the National Drug File entry first + . . ; We get the VUID of the drug, by looking up the VA Product entry + . . ; (file 50.68) using the call NDF^PSS50, returned in node 22. + . . ; Field 99.99 is the VUID. + . . ; + . . ; We use the VUID to look up the RxNorm in file 176.001; same idea. + . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by + . . ; $$GET1^DIQ. + . . ; + . . ; I get the RxNorm name and version from the RxNorm Sources (file + . . ; 176.003), by searching for "RXNORM", then get the data. + . . ; NDF^PSS50 ONLY EXISTS ON VISTA + . . N NDFDATA,NDFIEN,VAPROD + . . S NDFIEN="" + . . I '$$RPMS^C0CUTIL() D + . . . D NDF^PSS50(MEDIEN,,,,,"NDF") + . . . ;N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) + . . . ;N NDFIEN S NDFIEN=$P(NDFDATA(20),U) + . . . ;N VAPROD S VAPROD=$P(NDFDATA(22),U) + . . . M NDFDATA=^TMP($J,"NDF",MEDIEN) + . . . S NDFIEN=$P(NDFDATA(20),U) + . . . S VAPROD=$P(NDFDATA(22),U) + . . . S @MAP@("MEDPRODUCTNAMETEXT")=$$GET1^DIQ(50.68,VAPROD,.01) ; + . . ; GPL - RESET THE NAME TO THE REAL NAME OF THE DRUG NOW THAT WE + . . ; HAVE IT. + . . ; + . . ; NDFIEN is not necessarily defined; it won't be if the drug + . . ; is not matched to the national drug file (e.g. if the drug is + . . ; new on the market, compounded, or is a fake drug [blue pill]. + . . ; To protect against failure, I will put an if/else block + . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER + . . ; + . . ; begin changes for systems that have eRx installed + . . ; RxNorm is found in the ^C0P("RXN") global - gpl + . . ; + . . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION + . . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE + . . S (RXNORM,RXNNAME,RXNVER)="" ;INITIALIZE + . . I NDFIEN,$D(^C0P("RXN")) D ; + . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) + . . . S ZC=$$CODE^C0CUTIL(VUID) + . . . S ZCD=$P(ZC,"^",1) ; CODE TO USE + . . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID + . . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION + . . . S RXNORM=ZCD ; THE CODE + . . . S RXNNAME=ZCDS ; THE CODING SYSTEM + . . . S RXNVER=ZCDSV ; THE CODING SYSTEM VERSION + . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT") + . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_ZCDS_": "_ZCD + . . E I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. + . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) + . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") + . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) + . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") + . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) + . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) + . . ; + . . ;E S (RXNORM,RXNNAME,RXNVER)="" + . . ; End if/else block + . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM + . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME + . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER + . . ; + . . S @MAP@("MEDBRANDNAMETEXT")="" + . . ; DOSE^PSS50 ONLY ESISTS ON VISTA + . . I '$$RPMS^C0CUTIL() D + . . . D DOSE^PSS50(MEDIEN,,,,,"DOSE") + . . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) + . . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) + . . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) + . . E S @MAP@("MEDSTRENGTHVALUE")="" S @MAP@("MEDSTRENGTHUNIT")="" + . . ; Units, concentration, etc, come from another call + . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit + . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters + . . ; NDF Entry IEN, and VA Product Name + . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") + . . ; Documented in the same manual; executed above. + . . ; + . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" + . . ; and this will crash the call. So... + . . I NDFIEN="" S CONCDATA="" + . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) + . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) + . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) + . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) + . . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. + . . ; Oddly, there is no easy place to find the dispense unit. + . . ; It's not included in the original call, so we have to go to the drug file. + . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") + . . ; Node 14.5 is the Dispense Unit + . . ; PSS50 ONLY EXISTS ON VISTA + . . I '$$RPMS^C0CUTIL() D + . . . D DATA^PSS50(MEDIEN,,,,,"QTY") + . . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) + . . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) + . . E S @MAP@("MEDQUANTITYUNIT")="" + . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these + . E D + . . S @MAP@("MEDPRODUCTNAMECODEVALUE")="" + . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" + . . S @MAP@("MEDPRODUCTNAMECODEVERSION")="" + . . S @MAP@("MEDBRANDNAMETEXT")="" + . . S @MAP@("MEDSTRENGTHVALUE")="" + . . S @MAP@("MEDSTRENGTHUNIT")="" + . . S @MAP@("MEDFORMTEXT")="" + . . S @MAP@("MEDCONCVALUE")="" + . . S @MAP@("MEDCONCUNIT")="" + . . S @MAP@("MEDSIZETEXT")="" + . . S @MAP@("MEDQUANTITYVALUE")="" + . . S @MAP@("MEDQUANTITYUNIT")="" + . ; End If/Else + . ; --- START OF DIRECTIONS --- + . ; Dosage is field 2, route is 3, schedule is 4 + . ; These are all free text fields, and don't point to any files + . ; For that reason, I will use the field I never used before: + . ; MEDDIRECTIONDESCRIPTIONTEXT + . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS + . ; + . ; change for eRx meds - gpl 6/25/2011 + . ; + . N ZERX S ZERX=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") + . I ZERX["|" S ZERX=$P(ZERX,"|",2) ; GET RID OF MED NAME + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=ZERX + . N ZERX2 S ZERX2=$P(MED(2,"E"),"|",2) ; sig for quantity + . N ZFDBDRUG S ZFDBDRUG=$P(MED(2,"E"),"|",1) ; FDB DRUG NAME + . I @MAP@("MEDPRODUCTNAMETEXT")["FREE TXT" D ; FIX THE DRUG NAME + . . S @MAP@("MEDPRODUCTNAMETEXT")=ZFDBDRUG ; USE FDB NAME + . . S RXNORM=$P($P($G(MED(14,7)),"RXNORM:",2)," ",1) ; THE RXNORM + . . S RXNORM=$$NISTMAP^C0CUTIL(RXNORM) ; CHANGE IF NECESSARY + . . I RXNORM'="" D ; + . . . W !,"FOUND FREE TEXT RXNORM:",RXNORM + . . . S RXNNAME="RXNORM" ; THE CODING SYSTEM + . . . S RXNVER="" ; THE CODING SYSTEM VERSION + . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT") + . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_RXNNAME_": "_RXNORM + . . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM + . . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME + . . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER + . . . I RXNORM["979334" D ; PATCH FOR CERTIFICATION + . . . . S @MAP@("MEDSTRENGTHVALUE")=650 + . . . . S @MAP@("MEDSTRENGTHUNIT")="mcg" + . . . . S @MAP@("MEDFORMTEXT")="INHALER" + . S @MAP@("MEDQUANTITYUNIT")=$P(ZERX2," ",3) ; THE UNITS + . S @MAP@("MEDQUANTITYVALUE")=$P(ZERX2," ",2) ; THE QUANTITY + . I @MAP@("MEDFORMTEXT")="" S @MAP@("MEDFORMTEXT")=$P(ZERX2," ",3) ; + . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. + . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" + . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" + . ; + . ; --- END OF DIRECTIONS --- + . ; + . S @MAP@("MEDRFNO")="" + . I $D(MED(14,1)) D ; + . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field + . E S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" + . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" ; don't put in these - gpl + . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) + . K @RESULT + . D MAP^C0CXPATH(MINXML,MAP,RESULT) + . ; D PARY^C0CXPATH(RESULT) + . ; MAPPING DIRECTIONS + . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) + . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") + . N MDZ1,MDZNA + . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS + . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION + . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) + . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) + . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") + . ; + . ; MAP PATIENT INSTRUCTIONS - HAVE TO DO THIS AFTER MAPPING DIRECTIONS DUE TO XML SCHEMA VALIDATION + . N MEDINT1,INTXML1 S INTXML1="MENINT1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N MEDINT2,INTXML2 S INTXML2="MEDINT2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/PatientInstructions",INTXML1) + . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/PatientInstructions") + . ;N MDI1 ; removing the "I" which is not in the protocol gpl 1/2010 + . ;S MDI1=$NA(@MAP@("I")) + . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" + . I $D(MED(10,1)) D ; + . . ;S @MAP@("I","MEDPTINSTRUCTIONS")=$P(MED(10,1)," ",1) ; WP Field + . . S @MAP@("MEDPTINSTRUCTIONS")=$P(MED(10,1)," ",1) ; WP Field + . E S @MAP@("MEDPTINSTRUCTIONS")="" + . ;E S @MAP@("I","MEDPTINSTRUCTIONS")="" + . ;D MAP^C0CXPATH(INTXML1,MDI1,INTXML2) + . D MAP^C0CXPATH(INTXML1,MAP,INTXML2) ; JUST MAP WORKS.. GPL + . D INSERT^C0CXPATH(RESULT,INTXML2,"//Medications/Medication") + . ; + . ; FLAG HAS TO BE RESET OUTSIDE THE IF STATMENT. + . ;I MEDFIRST D ; + . ;. S MEDFIRST=0 ; RESET FIRST FLAG + . ;. D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy + . ;D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML + . D:MEDFIRST CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy + . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML + . I MEDFIRST S MEDFIRST=0 + N MEDTMP,MEDI + D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "MEDICATION MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; Index: ccr/branches/ohum/p/C0CMED4.m =================================================================== --- ccr/branches/ohum/p/C0CMED4.m (revision 1333) +++ ccr/branches/ohum/p/C0CMED4.m (revision 1337) @@ -1,178 +1,178 @@ -C0CMED4 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 - ;;0.1;CCDCCR;;;Build 1 - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ; General Public License See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE - ; - ; MINXML is the Input XML Template, passed by name - ; DFN is Patient IEN - ; OUTXML is the resultant XML. - ; - ; MEDS is return array from API. - ; MED is holds each array element from MEDS, one medicine - ; MAP is a mapping variable map (store result) for each med - ; - ; Inpatient Meds will be extracted using this routine and and the one following. - ; Inpatient Meds Unit Dose is going to be C0CMED4 - ; Inpatient Meds IVs is going to be C0CMED5 - ; - ; We will use two Pharmacy ReEnginnering API's: - ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info - ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info - ; For more information, see the PRE documentation at: - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf - ; - ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient - ; - N MEDS,MAP - K ^TMP($J) - D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*) - I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT ; No Meds - Quit - ; Otherwise, we go on... - M MEDS=^TMP($J,"UD") - I DEBUG ZWR MEDS - S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) - N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array - N I S I=0 - F S I=$O(MEDS("B",I)) Q:'I D ; For each medication in B index - . N MED M MED=MEDS(I) - . S MEDCOUNT=MEDCOUNT+1 - . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter - . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) - . N RXIEN S RXIEN=MED(.01) ; Order Number - . I DEBUG W "RXIEN IS ",RXIEN,! - . I DEBUG W "MAP= ",MAP,! - . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN - . S @MAP@("MEDISSUEDATETXT")="Order Date" - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT") - . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient - . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient - . S @MAP@("MEDRXNOTXT")="" ; For Outpatient - . S @MAP@("MEDRXNO")="" ; For Outpatient - . S @MAP@("MEDTYPETEXT")="Medication" - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses - . S @MAP@("MEDSTATUSTEXT")="ACTIVE" - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) - . S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) - . ; NDC is field 31 in the drug file. - . ; The actual drug entry in the drug file is not necessarily supplied. - . ; It' node 1, internal form. - . N MEDIEN S MEDIEN=MED(1,"I") - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") - . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") - . S @MAP@("MEDBRANDNAMETEXT")="" - . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") - . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) - . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") - . S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") - . ; Units, concentration, etc, come from another call - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters - . ; NDF Entry IEN, and VA Product Name - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") - . ; Documented in the same manual. - . N NDFDATA,CONCDATA - . I $L(MEDIEN) D - . . D NDF^PSS50(MEDIEN,,,,,"CONC") - . . M NDFDATA=^TMP($J,"CONC",MEDIEN) - . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) - . . N VAPROD S VAPROD=$P(NDFDATA(22),U) - . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" - . . ; and this will crash the call. So... - . . I NDFIEN="" S CONCDATA="" - . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) - . E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. - . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") - . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") - . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") - . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. - . ; Oddly, there is no easy place to find the dispense unit. - . ; It's not included in the original call, so we have to go to the drug file. - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") - . ; Node 14.5 is the Dispense Unit - . I $L(MEDIEN) D - . . D DATA^PSS50(MEDIEN,,,,,"QTY") - . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) - . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) - E S @MAP@("MEDQUANTITYUNIT")="" - . ; - . ; --- START OF DIRECTIONS --- - . ; Dosage is field 2, route is 3, schedule is 4 - . ; These are all free text fields, and don't point to any files - . ; For that reason, I will use the field I never used before: - . ; MEDDIRECTIONDESCRIPTIONTEXT - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. - . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" - . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" - . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" - . ; - . ; --- END OF DIRECTIONS --- - . ; - . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" - . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field - . S @MAP@("MEDRFNO")="" - . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) - . K @RESULT - . D MAP^GPLXPATH(MINXML,MAP,RESULT) - . ; D PARY^GPLXPATH(RESULT) - . ; MAPPING DIRECTIONS - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT - . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) - . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") - . ; N MDZ1,MDZNA - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) - . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) - . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") - . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy - . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML - N MEDTMP,MEDI - D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ - . W "MEDICATION MISSING ",! - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! - Q - ; +C0CMED4 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 + ;;0.1;CCDCCR;;; + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE + ; + ; MINXML is the Input XML Template, passed by name + ; DFN is Patient IEN + ; OUTXML is the resultant XML. + ; + ; MEDS is return array from API. + ; MED is holds each array element from MEDS, one medicine + ; MAP is a mapping variable map (store result) for each med + ; + ; Inpatient Meds will be extracted using this routine and and the one following. + ; Inpatient Meds Unit Dose is going to be C0CMED4 + ; Inpatient Meds IVs is going to be C0CMED5 + ; + ; We will use two Pharmacy ReEnginnering API's: + ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info + ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info + ; For more information, see the PRE documentation at: + ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf + ; + ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient + ; + N MEDS,MAP + K ^TMP($J) + D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*) + I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT ; No Meds - Quit + ; Otherwise, we go on... + M MEDS=^TMP($J,"UD") + I DEBUG ZWR MEDS + S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) + N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array + N I S I=0 + F S I=$O(MEDS("B",I)) Q:'I D ; For each medication in B index + . N MED M MED=MEDS(I) + . S MEDCOUNT=MEDCOUNT+1 + . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter + . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) + . N RXIEN S RXIEN=MED(.01) ; Order Number + . I DEBUG W "RXIEN IS ",RXIEN,! + . I DEBUG W "MAP= ",MAP,! + . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN + . S @MAP@("MEDISSUEDATETXT")="Order Date" + . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT") + . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient + . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient + . S @MAP@("MEDRXNOTXT")="" ; For Outpatient + . S @MAP@("MEDRXNO")="" ; For Outpatient + . S @MAP@("MEDTYPETEXT")="Medication" + . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses + . S @MAP@("MEDSTATUSTEXT")="ACTIVE" + . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) + . S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) + . ; NDC is field 31 in the drug file. + . ; The actual drug entry in the drug file is not necessarily supplied. + . ; It' node 1, internal form. + . N MEDIEN S MEDIEN=MED(1,"I") + . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") + . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") + . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") + . S @MAP@("MEDBRANDNAMETEXT")="" + . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") + . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) + . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") + . S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") + . ; Units, concentration, etc, come from another call + . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit + . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters + . ; NDF Entry IEN, and VA Product Name + . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") + . ; Documented in the same manual. + . N NDFDATA,CONCDATA + . I $L(MEDIEN) D + . . D NDF^PSS50(MEDIEN,,,,,"CONC") + . . M NDFDATA=^TMP($J,"CONC",MEDIEN) + . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) + . . N VAPROD S VAPROD=$P(NDFDATA(22),U) + . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" + . . ; and this will crash the call. So... + . . I NDFIEN="" S CONCDATA="" + . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) + . E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. + . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") + . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") + . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") + . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. + . ; Oddly, there is no easy place to find the dispense unit. + . ; It's not included in the original call, so we have to go to the drug file. + . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") + . ; Node 14.5 is the Dispense Unit + . I $L(MEDIEN) D + . . D DATA^PSS50(MEDIEN,,,,,"QTY") + . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) + . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) + E S @MAP@("MEDQUANTITYUNIT")="" + . ; + . ; --- START OF DIRECTIONS --- + . ; Dosage is field 2, route is 3, schedule is 4 + . ; These are all free text fields, and don't point to any files + . ; For that reason, I will use the field I never used before: + . ; MEDDIRECTIONDESCRIPTIONTEXT + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. + . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" + . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" + . ; + . ; --- END OF DIRECTIONS --- + . ; + . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" + . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field + . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field + . S @MAP@("MEDRFNO")="" + . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) + . K @RESULT + . D MAP^GPLXPATH(MINXML,MAP,RESULT) + . ; D PARY^GPLXPATH(RESULT) + . ; MAPPING DIRECTIONS + . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) + . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") + . ; N MDZ1,MDZNA + . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS + . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION + . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) + . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) + . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") + . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy + . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML + N MEDTMP,MEDI + D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "MEDICATION MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; Index: ccr/branches/ohum/p/C0CMED6.m =================================================================== --- ccr/branches/ohum/p/C0CMED6.m (revision 1333) +++ ccr/branches/ohum/p/C0CMED6.m (revision 1337) @@ -1,331 +1,331 @@ -C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09 - ;;1.0;C0C;;May 19, 2009;Build 1 - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ; General Public License See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE - ; - ; MINXML and OUTXML are passed by name so globals can be used - ; MINXML will contain only the medications skeleton of the overall template - ; MEDCOUNT is a counter passed by Reference. - ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool) - ; FLAGS are set-up in C0CMED. - ; - ; MEDS is return array from RPC. - ; MAP is a mapping variable map (store result) for each med - ; MED is holds each array element from MEDS(J), one medicine - ; J is a counter. - ; - ; GETRXS^BEHORXFN(ARRAYNAME,DFN,DAYS) will be the the API used. - ; This API has been developed by Medsphere for IHS for getting - ; Medications from RPMS. It has most of what we need. - ; API written by Doug Martin when he worked for Medsphere (thanks Doug!) - ; -- ARRAYNAME is passed by name (required) - ; -- DFN is passed by value (required) - ; -- DAYS is passed by value (optional; if not passed defaults to 365) - ; - ; Return: - ; ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID - ; ^Status^LastFill^Chronic^Issued^Rx #^Provider^ - ; Status Reason^DEA Handling - ; - N MEDS,MEDS1,MAP - D GETRXS^BEHORXFN("MEDS1",DFN,$P($P(FLAGS,U,2),"-",2)) ; 2nd piece of FLAGS is # of days to retrieve, which comes in the form "T-360" - N ALL S ALL=+FLAGS - N ACTIVE S ACTIVE=$P(FLAGS,U,3) - N PENDING S PENDING=$P(FLAGS,U,4) - S @OUTXML@(0)=0 ;By default, no meds - ; If MEDS1 is not defined, then no meds - I '$D(MEDS1) QUIT - I DEBUG ZWR MEDS1,MINXML - N MEDCNT S MEDCNT=0 ; Med Count - ; The next line is a super line. It goes through the array return - ; and if the first characters are ~OP, it grabs the line. - ; This means that line is for a dispensed Outpatient Med. - ; That line has the metadata about the med that I need. - ; The next lines, however many, are the med and the sig. - ; I won't be using those because I have to get the sig parsed exactly. - N J S J="" F S J=$O(MEDS1(J)) Q:J="" I $E(MEDS1(J),1,3)="~OP" S MEDCNT=MEDCNT+1 S MEDS(MEDCNT)=MEDS1(J) - K MEDS1 - S MEDCNT="" ; Initialize for $Order - F S MEDCNT=$O(MEDS(MEDCNT)) Q:MEDCNT="" D ; for each medication in the list - . I 'ALL,ACTIVE,$P(MEDS(MEDCNT),U,10)'="ACTIVE" QUIT - . I 'ALL,PENDING,$P(MEDS(MEDCNT),U,10)'="PENDING" QUIT - . I DEBUG W "MEDCNT IS ",MEDCNT,! - . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCNT)) - . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED - . I DEBUG W "MAP= ",MAP,! - . S @MAP@("MEDOBJECTID")="MED"_MEDCNT ; MEDCNT FOR ID - . S @MAP@("MEDISSUEDATETXT")="Issue Date" - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,15),"DT") - . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" - . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,11),"DT") - . S @MAP@("MEDRXNOTXT")="Prescription Number" - . S @MAP@("MEDRXNO")=$P(MEDS(MEDCNT),U,14) - . S @MAP@("MEDTYPETEXT")="Medication" - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses - . S @MAP@("MEDSTATUSTEXT")=$P(MEDS(MEDCNT),U,10) - . ; Provider only provided in API as text, not DUZ. - . ; We need to get DUZ from filman file 52 (Prescription) - . ; Field 4; IEN is Piece 2 of Meds stripped of trailing characters. - . ; Note that I will use RXIEN several times later - . N RXIEN S RXIEN=+$P(MEDS(MEDCNT),U,2) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52,RXIEN,4,"I") - . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MEDS(MEDCNT),U,3) - . ; --- RxNorm Stuff - . ; 176.001 is the file for Concepts; 176.003 is the file for - . ; sources (i.e. for RxNorm Version) - . ; - . ; I use 176.001 for the Vista version of this routine (files 1-3) - . ; Since IHS does not have VUID's, I will be getting RxNorm codes - . ; using NDCs. My specially crafted index (sounds evil) named "NDC" - . ; is in file 176.002. The file is called RxNorm NDC to VUID. - . ; Except that I don't need the VUID, but it's there if I need it. - . ; - . ; We obviously need the NDC. That is easily obtained from the prescription. - . ; Field 27 in file 52 - . N NDC S NDC=$$GET1^DIQ(52,RXIEN,27,"I") - . ; I discovered that file 176.002 might give you two codes for the NDC - . ; One for the Clinical Drug, and one for the ingredient. - . ; So the plan is to get the two RxNorm codes, and then find from - . ; file 176.001 which one is the Clinical Drug. - . ; ... I refactored this into GETRXN - . N RXNORM,SRCIEN,RXNNAME,RXNVER - . I +NDC,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. - . . S RXNORM=$$GETRXN(NDC) - . . S SRCIEN=$$FIND1^DIC(176.003,,,"RXNORM","B") - . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) - . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) - . ; - . E S (RXNORM,RXNNAME,RXNVER)="" - . ; End if/else block - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME - . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER - . ; --- End RxNorm section - . ; - . ; Brand name is 52 field 6.5 - . S @MAP@("MEDBRANDNAMETEXT")=$$GET1^DIQ(52,RXIEN,6.5) - . ; - . ; Next I need Med Form (tab, cap etc), strength (250mg) - . ; concentration for liquids (250mg/mL) - . ; Since IHS does not have any of the new calls that - . ; Vista has, I will be doing a crosswalk: - . ; File 52, field 6 is Drug IEN in file 50 - . ; File 50, field 22 is VA Product IEN in file 50.68 - . ; In file 50.68, I will get the following: - . ; -- 1: Dosage Form - . ; -- 2: Strength - . ; -- 3: Units - . ; -- 8: Dispense Units - . ; -- Conc is 2 concatenated with 3 - . ; - . ; *** If Drug is not matched to NDF, then VA Product will be "" *** - . ; - . N MEDIEN S MEDIEN=$$GET1^DIQ(52,RXIEN,6,"I") ; Drug IEN in 50 - . N VAPROD S VAPROD=$$GET1^DIQ(50,MEDIEN,22,"I") ; VA Product in file 50.68 - . I +VAPROD D - . . S @MAP@("MEDSTRENGTHVALUE")=$$GET1^DIQ(50.68,VAPROD,2) - . . S @MAP@("MEDSTRENGTHUNIT")=$$GET1^DIQ(50.68,VAPROD,3) - . . S @MAP@("MEDFORMTEXT")=$$GET1^DIQ(50.68,VAPROD,1) - . . S @MAP@("MEDCONCVALUE")=@MAP@("MEDSTRENGTHVALUE") - . . S @MAP@("MEDCONCUNIT")=@MAP@("MEDSTRENGTHUNIT") - . E D - . . S @MAP@("MEDSTRENGTHVALUE")="" - . . S @MAP@("MEDSTRENGTHUNIT")="" - . . S @MAP@("MEDFORMTEXT")="" - . . S @MAP@("MEDCONCVALUE")="" - . . S @MAP@("MEDCONCUNIT")="" - . ; End Strengh/Conc stuff - . ; - . ; Quantity is in the prescription, field 7 - . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52,RXIEN,7) - . ; Dispense unit is in the drug file, field 14.5 - . S @MAP@("MEDQUANTITYUNIT")=$$GET1^DIQ(50,MEDIEN,14.5) - . ; - . ; --- START OF DIRECTIONS --- - . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... - . ; we want the components. - . ; It's in multiple 113 in the Prescription File (52) - . ; #.01 DOSAGE ORDERED [1F] "20" - . ; #1 DISPENSE UNITS PER DOSE [2N] "1" - . ; #2 UNITS [3P:50.607] "MG" - . ; #3 NOUN [4F] "TABLET" - . ; #4 DURATION [5F] "10D" - . ; #5 CONJUNCTION [6S] "AND" - . ; #6 ROUTE [7P:51.2] "ORAL" - . ; #7 SCHEDULE [8F] "BID" - . ; #8 VERB [9F] "TAKE" - . ; - . ; Will use GETS^DIQ to get fields. - . ; Data comes out like this: - . ; SAMINS(52.0113,"1,23,",.01)=20 - . ; SAMINS(52.0113,"1,23,",1)=1 - . ; SAMINS(52.0113,"1,23,",2)="MG" - . ; SAMINS(52.0113,"1,23,",3)="TABLET" - . ; SAMINS(52.0113,"1,23,",4)="5D" - . ; SAMINS(52.0113,"1,23,",5)="THEN" - . ; - . N RAWDATA - . D GETS^DIQ(52,RXIEN,"113*",,"RAWDATA","DIERR") - . D:$D(DIERR) ^%ZTER ; Log if there's an error in retrieving sig field - . ; none the less, continue; some parts are retrievable. - . N FMSIG M FMSIG=RAWDATA(52.0113) ; Merge into subfile... - . K RAWDATA - . N FMSIGNUM S FMSIGNUM="" ; Sigline number in fileman. - . ; FMSIGNUM gets outputted as "IEN,RXIEN,". - . ; DIRCNT is the proper Sigline numer. - . ; SIGDATA is the simplfied array. - . F S FMSIGNUM=$O(FMSIG(FMSIGNUM)) Q:FMSIGNUM="" D - . . N DIRCNT S DIRCNT=$P(FMSIGNUM,",") - . . N SIGDATA M SIGDATA=FMSIG(FMSIGNUM) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$G(SIGDATA(8)) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$G(SIGDATA(.01)) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=$G(SIGDATA(2)) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$G(SIGDATA(6)) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$G(SIGDATA(7)) - . . ; Invervals... again another call. - . . ; In the wisdom of the original programmers, the schedule is a free text field - . . ; However, it gets translated by a call to the administration schedule file - . . ; to see if that schedule exists. - . . ; That's the same thing I am going to do. - . . ; Search B index of 51.1 (Admin Schedule) with schedule - . . ; First, remove "PRN" if it exists (don't ask, that's how the file - . . ; works; I wouldn't do it that way). - . . N SCHNOPRN S SCHNOPRN=$G(SIGDATA(7)) - . . I SCHNOPRN["PRN" S SCHNOPRN=$E(SCHNOPRN,1,$F(SCHNOPRN,"PRN")-5) - . . ; Super call below: - . . ; 1=File 51.1 3=Field 2 (Frequency in Minutes) - . . ; 4=Packed format, Exact Match 5=Lookup Value - . . ; 6=# of entries to return 7=Index 10=Return Array - . . ; - . . ; I do not account for the fact that two schedules can be - . . ; spelled identically (ie duplicate entry). In that case, - . . ; I get the first. That's just a bad pharmacy pkg maintainer. - . . N C0C515 - . . D FIND^DIC(51.1,,"@;2","PX",SCHNOPRN,1,"B",,,"C0C515") - . . N INTERVAL S INTERVAL="" ; Default - . . ; If there are entries found, get it - . . I +$G(C0C515("DILIST",0)) S INTERVAL=$P(C0C515("DILIST",1,0),U,2) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" - . . ; Duration is 10M minutes, 10H hours, 10D for Days - . . ; 10W for weeks, 10L for months. I smell $Select - . . ; But we don't need to do that if there isn't a duration - . . I +$G(SIGDATA(4)) D - . . . N DURUNIT S DURUNIT=$E(SIGDATA(4),$L(SIGDATA(4))) ; get last char - . . . N DURTXT S DURTXT=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"Days") - . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=+SIGDATA(4) - . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=DURTXT - . . E D - . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")="" - . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$G(SIGDATA(4))["PRN" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" ; when avail - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; not stored - . . ; Another confusing line; I am pretty bad: - . . ; If there is another entry in the FMSIG array (i.e. another line - . . ; in the sig), set the direction count indicator. - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")="" ; Default - . . S:+$O(FMSIG(FMSIGNUM)) @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRCNT - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$G(SIGDATA(5)) - . ; - . ; --- END OF DIRECTIONS --- - . ; - . ; Med instructions is a WP field, thus the acrobatics - . ; Notice buffer overflow protection set at 10,000 chars - . ; -- 1. Med Patient Instructions - . N MEDPTIN1 S MEDPTIN1=$$GET1^DIQ(52,RXIEN,115,,"MEDPTIN1") - . N MEDPTIN2,J S (MEDPTIN2,J)="" - . I $L(MEDPTIN1) F S J=$O(@MEDPTIN1@(J)) Q:J="" Q:$L(MEDPTIN2)>10000 S MEDPTIN2=MEDPTIN2_@MEDPTIN1@(J)_" " - . S @MAP@("MEDPTINSTRUCTIONS")=MEDPTIN2 - . K J - . ; -- 2. Med Provider Instructions - . N MEDPVIN1 S MEDPVIN1=$$GET1^DIQ(52,RXIEN,39,,"MEDPVIN1") - . N MEDPVIN2,J S (MEDPVIN2,J)="" - . I $L(MEDPVIN1) F S J=$O(@MEDPVIN1@(J)) Q:J="" Q:$L(MEDPVIN2)>10000 S MEDPVIN2=MEDPVIN2_@MEDPVIN1@(J)_" " - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MEDPVIN2 - . ; - . ; Remaining refills - . S @MAP@("MEDRFNO")=$P(MEDS(MEDCNT),U,6) - . ; ------ END OF MAPPING - . ; - . ; ------ BEGIN XML INSERTION - . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) - . K @RESULT - . D MAP^C0CXPATH(MINXML,MAP,RESULT) - . ; D PARY^C0CXPATH(RESULT) - . ; MAPPING DIRECTIONS - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT - . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) - . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") - . ; N MDZ1,MDZNA - . N DIRCNT S DIRCNT="" - . I +$O(@MAP@("M","DIRECTIONS",DIRCNT)) D ; IF THERE ARE DIRCTIONS - . . F DIRCNT=$O(@MAP@("M","DIRECTIONS",DIRCNT)) D ; FOR EACH DIRECTION - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",DIRCNT)) - . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) - . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") - . D:MEDCNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy - . D:MEDCNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML - . S MEDCOUNT=MEDCNT - N MEDTMP,MEDI - D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ - . W "MEDICATION MISSING ",! - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! - Q - ; -GETRXN(NDC) ; Extrinsic Function; PUBLIC; NDC to RxNorm - ;; Get RxNorm Concept Number for a Given NDC - ; - S NDC=$TR(NDC,"-") ; Remove dashes - N RXNORM,C0CZRXN,DIERR - D FIND^DIC(176.002,,"@;.01","PX",NDC,"*","NDC",,,"C0CZRXN","DIERR") - I $D(DIERR) D ^%ZTER BREAK - S RXNORM(0)=+C0CZRXN("DILIST",0) ; RxNorm(0) will be # of entries - N I S I=0 - F S I=$O(C0CZRXN("DILIST",I)) Q:I="" S RXNORM(I)=$P(C0CZRXN("DILIST",I,0),U,2) - ; At this point, RxNorm(0) is # of entries; RxNorm(1...) are the entries - ; If RxNorm(0) is 1, then we only have one entry, and that's it. - I RXNORM(0)=1 QUIT RXNORM(1) ; RETURN RXNORM(1) - ; Otherwise, we need to find out which one is the semantic - ; clinical drug. I built an index on 176.001 (RxNorm Concepts) - ; for that purpose. - I RXNORM(0)>1 D - . S I=0 - . F S I=$O(RXNORM(I)) Q:I="" D Q:$G(RXNORM) - . . N RXNIEN S RXNIEN=$$FIND1^DIC(176.001,,,RXNORM(I),"SCD") - . . I +$G(RXNIEN)=0 QUIT ; try the next entry... - . . E S RXNORM=RXNORM(I) QUIT ; We found the right code - QUIT +$G(RXNORM) ; RETURN RXNORM; if we couldn't find a clnical drug, return with 0 - +C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09 + ;;1.0;C0C;;May 19, 2009; + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE + ; + ; MINXML and OUTXML are passed by name so globals can be used + ; MINXML will contain only the medications skeleton of the overall template + ; MEDCOUNT is a counter passed by Reference. + ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool) + ; FLAGS are set-up in C0CMED. + ; + ; MEDS is return array from RPC. + ; MAP is a mapping variable map (store result) for each med + ; MED is holds each array element from MEDS(J), one medicine + ; J is a counter. + ; + ; GETRXS^BEHORXFN(ARRAYNAME,DFN,DAYS) will be the the API used. + ; This API has been developed by Medsphere for IHS for getting + ; Medications from RPMS. It has most of what we need. + ; API written by Doug Martin when he worked for Medsphere (thanks Doug!) + ; -- ARRAYNAME is passed by name (required) + ; -- DFN is passed by value (required) + ; -- DAYS is passed by value (optional; if not passed defaults to 365) + ; + ; Return: + ; ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID + ; ^Status^LastFill^Chronic^Issued^Rx #^Provider^ + ; Status Reason^DEA Handling + ; + N MEDS,MEDS1,MAP + D GETRXS^BEHORXFN("MEDS1",DFN,$P($P(FLAGS,U,2),"-",2)) ; 2nd piece of FLAGS is # of days to retrieve, which comes in the form "T-360" + N ALL S ALL=+FLAGS + N ACTIVE S ACTIVE=$P(FLAGS,U,3) + N PENDING S PENDING=$P(FLAGS,U,4) + S @OUTXML@(0)=0 ;By default, no meds + ; If MEDS1 is not defined, then no meds + I '$D(MEDS1) QUIT + I DEBUG ZWR MEDS1,MINXML + N MEDCNT S MEDCNT=0 ; Med Count + ; The next line is a super line. It goes through the array return + ; and if the first characters are ~OP, it grabs the line. + ; This means that line is for a dispensed Outpatient Med. + ; That line has the metadata about the med that I need. + ; The next lines, however many, are the med and the sig. + ; I won't be using those because I have to get the sig parsed exactly. + N J S J="" F S J=$O(MEDS1(J)) Q:J="" I $E(MEDS1(J),1,3)="~OP" S MEDCNT=MEDCNT+1 S MEDS(MEDCNT)=MEDS1(J) + K MEDS1 + S MEDCNT="" ; Initialize for $Order + F S MEDCNT=$O(MEDS(MEDCNT)) Q:MEDCNT="" D ; for each medication in the list + . I 'ALL,ACTIVE,$P(MEDS(MEDCNT),U,10)'="ACTIVE" QUIT + . I 'ALL,PENDING,$P(MEDS(MEDCNT),U,10)'="PENDING" QUIT + . I DEBUG W "MEDCNT IS ",MEDCNT,! + . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCNT)) + . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED + . I DEBUG W "MAP= ",MAP,! + . S @MAP@("MEDOBJECTID")="MED"_MEDCNT ; MEDCNT FOR ID + . S @MAP@("MEDISSUEDATETXT")="Issue Date" + . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,15),"DT") + . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" + . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,11),"DT") + . S @MAP@("MEDRXNOTXT")="Prescription Number" + . S @MAP@("MEDRXNO")=$P(MEDS(MEDCNT),U,14) + . S @MAP@("MEDTYPETEXT")="Medication" + . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses + . S @MAP@("MEDSTATUSTEXT")=$P(MEDS(MEDCNT),U,10) + . ; Provider only provided in API as text, not DUZ. + . ; We need to get DUZ from filman file 52 (Prescription) + . ; Field 4; IEN is Piece 2 of Meds stripped of trailing characters. + . ; Note that I will use RXIEN several times later + . N RXIEN S RXIEN=+$P(MEDS(MEDCNT),U,2) + . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52,RXIEN,4,"I") + . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MEDS(MEDCNT),U,3) + . ; --- RxNorm Stuff + . ; 176.001 is the file for Concepts; 176.003 is the file for + . ; sources (i.e. for RxNorm Version) + . ; + . ; I use 176.001 for the Vista version of this routine (files 1-3) + . ; Since IHS does not have VUID's, I will be getting RxNorm codes + . ; using NDCs. My specially crafted index (sounds evil) named "NDC" + . ; is in file 176.002. The file is called RxNorm NDC to VUID. + . ; Except that I don't need the VUID, but it's there if I need it. + . ; + . ; We obviously need the NDC. That is easily obtained from the prescription. + . ; Field 27 in file 52 + . N NDC S NDC=$$GET1^DIQ(52,RXIEN,27,"I") + . ; I discovered that file 176.002 might give you two codes for the NDC + . ; One for the Clinical Drug, and one for the ingredient. + . ; So the plan is to get the two RxNorm codes, and then find from + . ; file 176.001 which one is the Clinical Drug. + . ; ... I refactored this into GETRXN + . N RXNORM,SRCIEN,RXNNAME,RXNVER + . I +NDC,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. + . . S RXNORM=$$GETRXN(NDC) + . . S SRCIEN=$$FIND1^DIC(176.003,,,"RXNORM","B") + . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) + . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) + . ; + . E S (RXNORM,RXNNAME,RXNVER)="" + . ; End if/else block + . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM + . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME + . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER + . ; --- End RxNorm section + . ; + . ; Brand name is 52 field 6.5 + . S @MAP@("MEDBRANDNAMETEXT")=$$GET1^DIQ(52,RXIEN,6.5) + . ; + . ; Next I need Med Form (tab, cap etc), strength (250mg) + . ; concentration for liquids (250mg/mL) + . ; Since IHS does not have any of the new calls that + . ; Vista has, I will be doing a crosswalk: + . ; File 52, field 6 is Drug IEN in file 50 + . ; File 50, field 22 is VA Product IEN in file 50.68 + . ; In file 50.68, I will get the following: + . ; -- 1: Dosage Form + . ; -- 2: Strength + . ; -- 3: Units + . ; -- 8: Dispense Units + . ; -- Conc is 2 concatenated with 3 + . ; + . ; *** If Drug is not matched to NDF, then VA Product will be "" *** + . ; + . N MEDIEN S MEDIEN=$$GET1^DIQ(52,RXIEN,6,"I") ; Drug IEN in 50 + . N VAPROD S VAPROD=$$GET1^DIQ(50,MEDIEN,22,"I") ; VA Product in file 50.68 + . I +VAPROD D + . . S @MAP@("MEDSTRENGTHVALUE")=$$GET1^DIQ(50.68,VAPROD,2) + . . S @MAP@("MEDSTRENGTHUNIT")=$$GET1^DIQ(50.68,VAPROD,3) + . . S @MAP@("MEDFORMTEXT")=$$GET1^DIQ(50.68,VAPROD,1) + . . S @MAP@("MEDCONCVALUE")=@MAP@("MEDSTRENGTHVALUE") + . . S @MAP@("MEDCONCUNIT")=@MAP@("MEDSTRENGTHUNIT") + . E D + . . S @MAP@("MEDSTRENGTHVALUE")="" + . . S @MAP@("MEDSTRENGTHUNIT")="" + . . S @MAP@("MEDFORMTEXT")="" + . . S @MAP@("MEDCONCVALUE")="" + . . S @MAP@("MEDCONCUNIT")="" + . ; End Strengh/Conc stuff + . ; + . ; Quantity is in the prescription, field 7 + . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52,RXIEN,7) + . ; Dispense unit is in the drug file, field 14.5 + . S @MAP@("MEDQUANTITYUNIT")=$$GET1^DIQ(50,MEDIEN,14.5) + . ; + . ; --- START OF DIRECTIONS --- + . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... + . ; we want the components. + . ; It's in multiple 113 in the Prescription File (52) + . ; #.01 DOSAGE ORDERED [1F] "20" + . ; #1 DISPENSE UNITS PER DOSE [2N] "1" + . ; #2 UNITS [3P:50.607] "MG" + . ; #3 NOUN [4F] "TABLET" + . ; #4 DURATION [5F] "10D" + . ; #5 CONJUNCTION [6S] "AND" + . ; #6 ROUTE [7P:51.2] "ORAL" + . ; #7 SCHEDULE [8F] "BID" + . ; #8 VERB [9F] "TAKE" + . ; + . ; Will use GETS^DIQ to get fields. + . ; Data comes out like this: + . ; SAMINS(52.0113,"1,23,",.01)=20 + . ; SAMINS(52.0113,"1,23,",1)=1 + . ; SAMINS(52.0113,"1,23,",2)="MG" + . ; SAMINS(52.0113,"1,23,",3)="TABLET" + . ; SAMINS(52.0113,"1,23,",4)="5D" + . ; SAMINS(52.0113,"1,23,",5)="THEN" + . ; + . N RAWDATA + . D GETS^DIQ(52,RXIEN,"113*",,"RAWDATA","DIERR") + . D:$D(DIERR) ^%ZTER ; Log if there's an error in retrieving sig field + . ; none the less, continue; some parts are retrievable. + . N FMSIG M FMSIG=RAWDATA(52.0113) ; Merge into subfile... + . K RAWDATA + . N FMSIGNUM S FMSIGNUM="" ; Sigline number in fileman. + . ; FMSIGNUM gets outputted as "IEN,RXIEN,". + . ; DIRCNT is the proper Sigline numer. + . ; SIGDATA is the simplfied array. + . F S FMSIGNUM=$O(FMSIG(FMSIGNUM)) Q:FMSIGNUM="" D + . . N DIRCNT S DIRCNT=$P(FMSIGNUM,",") + . . N SIGDATA M SIGDATA=FMSIG(FMSIGNUM) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$G(SIGDATA(8)) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$G(SIGDATA(.01)) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=$G(SIGDATA(2)) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$G(SIGDATA(6)) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$G(SIGDATA(7)) + . . ; Invervals... again another call. + . . ; In the wisdom of the original programmers, the schedule is a free text field + . . ; However, it gets translated by a call to the administration schedule file + . . ; to see if that schedule exists. + . . ; That's the same thing I am going to do. + . . ; Search B index of 51.1 (Admin Schedule) with schedule + . . ; First, remove "PRN" if it exists (don't ask, that's how the file + . . ; works; I wouldn't do it that way). + . . N SCHNOPRN S SCHNOPRN=$G(SIGDATA(7)) + . . I SCHNOPRN["PRN" S SCHNOPRN=$E(SCHNOPRN,1,$F(SCHNOPRN,"PRN")-5) + . . ; Super call below: + . . ; 1=File 51.1 3=Field 2 (Frequency in Minutes) + . . ; 4=Packed format, Exact Match 5=Lookup Value + . . ; 6=# of entries to return 7=Index 10=Return Array + . . ; + . . ; I do not account for the fact that two schedules can be + . . ; spelled identically (ie duplicate entry). In that case, + . . ; I get the first. That's just a bad pharmacy pkg maintainer. + . . N C0C515 + . . D FIND^DIC(51.1,,"@;2","PX",SCHNOPRN,1,"B",,,"C0C515") + . . N INTERVAL S INTERVAL="" ; Default + . . ; If there are entries found, get it + . . I +$G(C0C515("DILIST",0)) S INTERVAL=$P(C0C515("DILIST",1,0),U,2) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" + . . ; Duration is 10M minutes, 10H hours, 10D for Days + . . ; 10W for weeks, 10L for months. I smell $Select + . . ; But we don't need to do that if there isn't a duration + . . I +$G(SIGDATA(4)) D + . . . N DURUNIT S DURUNIT=$E(SIGDATA(4),$L(SIGDATA(4))) ; get last char + . . . N DURTXT S DURTXT=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"Days") + . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=+SIGDATA(4) + . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=DURTXT + . . E D + . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")="" + . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$G(SIGDATA(4))["PRN" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" ; when avail + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; not stored + . . ; Another confusing line; I am pretty bad: + . . ; If there is another entry in the FMSIG array (i.e. another line + . . ; in the sig), set the direction count indicator. + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")="" ; Default + . . S:+$O(FMSIG(FMSIGNUM)) @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRCNT + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$G(SIGDATA(5)) + . ; + . ; --- END OF DIRECTIONS --- + . ; + . ; Med instructions is a WP field, thus the acrobatics + . ; Notice buffer overflow protection set at 10,000 chars + . ; -- 1. Med Patient Instructions + . N MEDPTIN1 S MEDPTIN1=$$GET1^DIQ(52,RXIEN,115,,"MEDPTIN1") + . N MEDPTIN2,J S (MEDPTIN2,J)="" + . I $L(MEDPTIN1) F S J=$O(@MEDPTIN1@(J)) Q:J="" Q:$L(MEDPTIN2)>10000 S MEDPTIN2=MEDPTIN2_@MEDPTIN1@(J)_" " + . S @MAP@("MEDPTINSTRUCTIONS")=MEDPTIN2 + . K J + . ; -- 2. Med Provider Instructions + . N MEDPVIN1 S MEDPVIN1=$$GET1^DIQ(52,RXIEN,39,,"MEDPVIN1") + . N MEDPVIN2,J S (MEDPVIN2,J)="" + . I $L(MEDPVIN1) F S J=$O(@MEDPVIN1@(J)) Q:J="" Q:$L(MEDPVIN2)>10000 S MEDPVIN2=MEDPVIN2_@MEDPVIN1@(J)_" " + . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MEDPVIN2 + . ; + . ; Remaining refills + . S @MAP@("MEDRFNO")=$P(MEDS(MEDCNT),U,6) + . ; ------ END OF MAPPING + . ; + . ; ------ BEGIN XML INSERTION + . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) + . K @RESULT + . D MAP^C0CXPATH(MINXML,MAP,RESULT) + . ; D PARY^C0CXPATH(RESULT) + . ; MAPPING DIRECTIONS + . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) + . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") + . ; N MDZ1,MDZNA + . N DIRCNT S DIRCNT="" + . I +$O(@MAP@("M","DIRECTIONS",DIRCNT)) D ; IF THERE ARE DIRCTIONS + . . F DIRCNT=$O(@MAP@("M","DIRECTIONS",DIRCNT)) D ; FOR EACH DIRECTION + . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",DIRCNT)) + . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) + . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") + . D:MEDCNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy + . D:MEDCNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML + . S MEDCOUNT=MEDCNT + N MEDTMP,MEDI + D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "MEDICATION MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; +GETRXN(NDC) ; Extrinsic Function; PUBLIC; NDC to RxNorm + ;; Get RxNorm Concept Number for a Given NDC + ; + S NDC=$TR(NDC,"-") ; Remove dashes + N RXNORM,C0CZRXN,DIERR + D FIND^DIC(176.002,,"@;.01","PX",NDC,"*","NDC",,,"C0CZRXN","DIERR") + I $D(DIERR) D ^%ZTER BREAK + S RXNORM(0)=+C0CZRXN("DILIST",0) ; RxNorm(0) will be # of entries + N I S I=0 + F S I=$O(C0CZRXN("DILIST",I)) Q:I="" S RXNORM(I)=$P(C0CZRXN("DILIST",I,0),U,2) + ; At this point, RxNorm(0) is # of entries; RxNorm(1...) are the entries + ; If RxNorm(0) is 1, then we only have one entry, and that's it. + I RXNORM(0)=1 QUIT RXNORM(1) ; RETURN RXNORM(1) + ; Otherwise, we need to find out which one is the semantic + ; clinical drug. I built an index on 176.001 (RxNorm Concepts) + ; for that purpose. + I RXNORM(0)>1 D + . S I=0 + . F S I=$O(RXNORM(I)) Q:I="" D Q:$G(RXNORM) + . . N RXNIEN S RXNIEN=$$FIND1^DIC(176.001,,,RXNORM(I),"SCD") + . . I +$G(RXNIEN)=0 QUIT ; try the next entry... + . . E S RXNORM=RXNORM(I) QUIT ; We found the right code + QUIT +$G(RXNORM) ; RETURN RXNORM; if we couldn't find a clnical drug, return with 0 + Index: ccr/branches/ohum/p/C0CMIME.m =================================================================== --- ccr/branches/ohum/p/C0CMIME.m (revision 1333) +++ ccr/branches/ohum/p/C0CMIME.m (revision 1337) @@ -1,339 +1,339 @@ -C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm - ;;1.0;C0C;;Mar 8, 2011;Build 1 - ;Copyright 2008 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q - ; -TEST(ZDFN) ; - D CCRRPC^C0CCCR(.ZCCR,ZDFN) ; GET A CCR TO WORK WITH - ;M ZCOPY=ZCCR - S ZCOPY(1)="" - N ZI S ZI=0 - F S ZI=$O(ZCCR(ZI)) Q:ZI="" D ; FOR EACH LINE - . S ZCOPY(1)=ZCOPY(1)_ZCCR(ZI) - ;D ENCODE("ZCOPY",1,ZCOPY(1)) - S G(1)=$$ENCODE^RGUTUU(ZCOPY(1)) - D CHUNK("G2","G",45) - Q -ENCODE(ZRTN,ZARY) ; - ; ROUTINE TO ENCODE AN XML DOCUMENT FOR SENDING - ; ZARY IS PASSED BY NAME - ; ZRTN IS PASSED BY REFERENCE AND IS THE RETURN - ; - S ZCOPY(1)="" - N ZI S ZI=0 - F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH LINE - . S ZCOPY(1)=ZCOPY(1)_@ZARY@(ZI) - N G - S G(1)=$$ENCODE^RGUTUU(ZCOPY(1)) - D CHUNK(ZRTN,"G",45) - Q - ; THIS ROUTINE WAS COPIED FROM LRSRVR4 AND THEN MODIFIED . THANKS JOHN -ENCODEOLD(IARY,LRNODE,LRSTR) ; Encode a string, keep remainder for next line - ; Call with LRSTR by reference, Remainder returned in LRSTR - ; IARY IS PASSED BY NAME - S LRQUIT=0,LRLEN=$L(LRSTR) - F D Q:LRQUIT - . I $L(LRSTR)<45 S LRQUIT=1 Q - . S LRX=$E(LRSTR,1,45) - . S LRNODE=LRNODE+1,@IARY@(LRNODE)=$$UUEN^LRSRVR4(LRX) - . S LRSTR=$E(LRSTR,46,LRLEN) - Q - ; -TESTMAIL ; - ; TEST OF MAILSEND - ;S ZTO("glilly@glilly.net")="" - S ZTO("mish@nhin.openforum.opensourcevista.net")="" - ;S ZTO("martijn@djigzo.com")="" - ;S ZTO("profmish@gmail.com")="" - ;S ZTO("nanthracite@earthlink.net")="" - S ZFROM="ANTHRACITE.NANCY" - S ZATTACH=$NA(^GPL("CCR")) - I $G(@ZATTACH@(1))="" D ; NO CCR THERE - . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2 - . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME - S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE" - D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,,ZATTACH) - ZWR GR - Q - ; -TESTMAIL2 ; - ; TEST OF MAILSEND TO gpl.mdc-crew.net - N C0CGM - S C0CGM(1)="This is a test message." - S C0CGM(2)="A Continuity of Care record is attached" - S C0CGM(3)="It contains no Protected Health Information (PHI)" - S C0CGM(4)="It is purely test data used for software development" - S C0CGM(5)="It does not represent information about any person living or dead" - ;S ZTO("glilly@glilly.net")="" - ;S ZTO("george.lilly@pobox.com")="" - ;S ZTO("george@nhin.openforum.opensourcevista.net")="" - ;S ZTO("mish@nhin.openforum.opensourcevista.net")="" - S ZTO("brooks.richard@securemail.opensourcevista.net")="" - ;S ZTO("LILLY.GEORGE@mdc-crew.net")="" - ;S ZTO("ncoal@live.com")="" - ;S ZTO("martijn@djigzo.com")="" - ;S ZTO("profmish@gmail.com")="" - ;S ZTO("nanthracite@earthlink.net")="" - S ZTO("gpl.doctortest@gmail.com")="" - S ZFROM="LILLY.GEORGE" - S ZATTACH=$NA(^GPL("CCR")) - I $G(@ZATTACH@(1))="" D ; NO CCR THERE - . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2 - . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME - S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE" - D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH,"CCR.xml") - ZWR GR - Q - ; -LINE(C0CFILE,C0CTO) ; read a file name passed in C0CFILE and send it to - ; the email address in C0CTO - ; the directory and the "from" are all hard coded - ; - N ZZFROM S ZZFROM="LILLY.GEORGE" - N GN S GN=$NA(^TMP("C0CMIME2",$J)) - N GN1 S GN1=$NA(@GN@(1)) - K @GN - I '$D(C0CFILE) Q ; NO FILENAME PASSED - I '$D(C0CTO) S C0CTO="brooks.richard@securemail.opensourcevista.net" - S ZZTO(C0CTO)="" - N ZMESS S ZMESS(1)="file transmission from wvehr3-09" - N GD S GD="/home/wvehr3-09/EHR/" ; directory - I '$$FTG^%ZISH(GD,C0CFILE,GN1,3) Q D ; - . W !,"error reading file",C0CFILE - D MAILSEND(.ZRTN,ZZFROM,"ZZTO",,"file transmission","ZMESS",GN,C0CFILE) - K @GN ; CLEAN UP - ;ZWR ZRTN - W !,$G(ZRTN(1)) - Q - ; -MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FNAME,FLAGS) ; MAIL SENDING INTERFACE - ; RTN IS THE RETURN ARRAY PASSED BY REFERENCE - ; FROM IS PASSED BY VALUE AND IS THE EMAIL ADDRESS OF THE SENDER - ; IF NULL, WILL SEND FROM THE CURRENT DUZ - ; TO AND CC ARE RECIEPIENT EMAIL ADDRESSES PASSED BY NAME - ; @TO@("addr1@domain1.net") - ; @CC@("addr2@domain2.com") both can be multiples - ; SUBJECT IS PASSED BY VALUE AND WILL GO IN THE SUBJECT LINE - ; MESSAGE IS PASSED BY NAME AND IS AN ARRAY OF TEXT - ; ATTACH IS PASSED BY NAME AND IS AN XML OR HTML FILE TO BE ATTACHED - ; FNAME IS THE FILENAME OF THE ATTACHMENT, DEFAULT IS ccr.xml - ; - I '$D(FNAME) S FNAME="ccr.xml" ; default filename - N GN - S GN=$NA(^TMP($J,"C0CMIME")) - K @GN - S GM(1)="MIME-Version: 1.0" - S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" - S GM(3)="" - S GM(4)="" - ;S GM(5)="--123456788888" - ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) - S GM(5)="--123456899999" - S GM(6)="Content-Type: text/xml; name="_FNAME - S GM(7)="Content-Transfer-Encoding: base64" - S GM(8)="Content-Disposition: attachment; filename="_FNAME - S GM(9)="" - S GM(10)="" ; FOR THE END - ;S GM(11)="--123456788888--" - S GM(11)="--123456899999--" - S GM(12)="" - S GM(13)="" - S GG(1)="--123456899999" - S GG(2)="Content-Type: text/plain; charset=ISO-8859-1; format=flowed" - S GG(3)="Content-Transfer-Encoding: 7bit" - S GG(4)="" - S GG(5)="This is a test message." - S GG(6)="A Continuity of Care record is attached" - S GG(7)="It contains no Protected Health Information (PHI)" - S GG(8)="It is purely test data used for software development" - S GG(9)="It does not represent information about any person living or dead" - S GG(10)="" - S GG(11)="--123456899999--" - ;S GG(11)="Content-Type: text/plain; charset=""us-ascii""" - S GG(12)="" - ;S GG(13)="This is a test message." - S GG(14)="A Continuity of Care record is attached" - S GG(15)="It contains no Protected Health Information (PHI)" - S GG(16)="It is purely test data used for software development" - S GG(17)="It does not represent information about any person living or dead" - S GG(18)="" - S GG(19)="--123456899999" - S GG(20)="--987654321--" - K GBLD - ;D QUEUE^C0CXPATH("GBLD","GGG",1,3) ; THE MESSAGE - ;D QUEUE^C0CXPATH("GBLD","GG",1,10) ; THE MESSAGE - I $D(MESSAGE)'="" D ; THERE IS A MESSAGE - . D QUEUE^C0CXPATH("GBLD","GG",1,4) ; THE MIME BOUNDARY - . D QUEUE^C0CXPATH("GBLD",MESSAGE,1,$O(@MESSAGE@(""),-1)) ;THE MESSAGE - . D QUEUE^C0CXPATH("GBLD","GG",10,10) ;A BLANK LINE - D QUEUE^C0CXPATH("GBLD","GM",5,9) - I $D(ATTACH)'="" D ; IF WE HAVE AN ATTACHMENT - . D ENCODE("G2",ATTACH) ; ENCODE FOR SENDING - . D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1)) - D QUEUE^C0CXPATH("GBLD","GM",11,12) - D BUILD^C0CXPATH("GBLD",GN) - ;S GGG=$NA(^GPL("MIME2")) - K @GN@(0) ; KILL THE LINE COUNT - K LRINSTR,LRTASK,LRTO,XMERR,XMZ - M LRTO=@TO - I $D(CC) M LRTO=@CC - S LRINSTR("ADDR FLAGS")="R" - S LRINSTR("FROM")=$G(FROM) - S LRMSUBJ=$G(SUBJECT) - S LRMSUBJ=$E(LRMSUBJ,1,65) - D SENDMSG^XMXAPI(DUZ,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK) - I $G(XMERR)=1 S RTN(1)="ERROR SENDING MESSAGE" Q ; - S RTN(1)="OK" - Q - ; -MAILSEND0(LRMSUBJ) ; Send extract back to requestor. - ; - ;D TEST - S GN=$NA(^TMP($J,"C0CMIME")) - K @GN - ;M @GN=G2 - S GM(1)="MIME-Version: 1.0" - S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" - S GM(3)="" - S GM(4)="" - S GM(5)="--1234567" - ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) - S GM(6)="Content-Type: text/xml; name=""ccr.xml""" - S GM(7)="Content-Transfer-Encoding: base64" - S GM(8)="Content-Disposition: attachment; filename=""ccr.xml""" - ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml") - S GM(9)="" - S GM(10)="" ; FOR THE END - S GM(11)="--frontier--" - S GM(12)="." - S GM(13)="" - K GBLD - ;D QUEUE^C0CXPATH("GBLD","GM",1,9) - ;D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1)) - ;D QUEUE^C0CXPATH("GBLD","GM",10,13) - ;D BUILD^C0CXPATH("GBLD",GN) - S GGG=$NA(^GPL("MIME2")) - ;D QUEUE^C0CXPATH("GBLD","GM",1,1) - D QUEUE^C0CXPATH("GBLD",GGG,21,159) - D BUILD^C0CXPATH("GBLD",GN) - K @GN@(0) ; KILL THE LINE COUNT - K LRINSTR,LRTASK,LRTO,XMERR,XMZ - S XQSND="glilly@glilly.net" - ;S XQSND="nanthracite@earthlink.net" - ;S XQSND="dlefevre@orohosp.com" - ;S XQSND="gregwoodhouse@me.com" - ;S XQSND="rick.marshall@vistaexpertise.net" - S LRTO(XQSND)="" - S LRINSTR("ADDR FLAGS")="R" - S LRINSTR("FROM")="CCR_PACKAGE" - S LRMSUBJ="A SAMPLE CCR" - S LRMSUBJ=$E(LRMSUBJ,1,65) - D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK) - I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q ; - ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0" - ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9" - Q - ; -MAILSEND2(UDFN,ADDR) ; Send extract back to requestor. - ; - I +$G(UDFN)=0 S UDFN=2 ; - D TEST(UDFN) - S GN=$NA(^TMP($J,"C0CMIME")) - K @GN - ;M @GN=G2 - S GM(1)="MIME-Version: 1.0" - S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" - S GM(3)="" - S GM(4)="" - S GM(5)="--1234567" - ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) - S GM(6)="Content-Type: text/xml; name=""ccr.xml""" - S GM(7)="Content-Transfer-Encoding: base64" - S GM(8)="Content-Disposition: attachment; filename=""ccr.xml""" - ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml") - S GM(9)="" - S GM(10)="" ; FOR THE END - S GM(11)="--1234567--" - S GM(12)="" - S GM(13)="" - K GBLD - D QUEUE^C0CXPATH("GBLD","GM",5,9) - D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1)) - D QUEUE^C0CXPATH("GBLD","GM",10,12) - D BUILD^C0CXPATH("GBLD",GN) - S GGG=$NA(^GPL("MIME2")) - ;D QUEUE^C0CXPATH("GBLD","GM",1,1) - ;D QUEUE^C0CXPATH("GBLD",GGG,21,159) - ;D BUILD^C0CXPATH("GBLD",GN) - K @GN@(0) ; KILL THE LINE COUNT - K LRINSTR,LRTASK,LRTO,XMERR,XMZ - I $G(ADDR)'="" S XQSND=ADDR - E S XQSND="glilly@glilly.net" - ;S XQSND="nanthracite@earthlink.net" - ;S XQSND="dlefevre@orohosp.com" - ;S XQSND="gregwoodhouse@me.com" - ;S XQSND="rick.marshall@vistaexpertise.net" - S LRTO(XQSND)="" - ;S LRTO("glilly@glilly.net")="" - S LRINSTR("ADDR FLAGS")="R" - S LRINSTR("FROM")="ANTHRACITE.NANCY" - S LRMSUBJ="Sending a CCR with Mailman" - S LRMSUBJ=$E(LRMSUBJ,1,65) - D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK) - I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q ; - ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0" - ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9" - Q - ; -SIMPLE ; - S GN(1)="SIMPLE TEST MESSAGE" - K LRINSTR,LRTASK,LRTO,XMERR,XMZ - S XQSND="glilly@glilly.net" - S LRTO(XQSND)="" - S LRINSTR("ADDR FLAGS")="R" - S LRINSTR("FROM")="CCR_PACKAGE" - S LRMSUBJ="A SAMPLE CCR" - S LRMSUBJ=$E(LRMSUBJ,1,65) - D SENDMSG^XMXAPI(9,LRMSUBJ,"GN",.LRTO,.LRINSTR,.LRTASK) - Q -CHUNK(OUTXML,INXML,ZSIZE) ; BREAKS INXML INTO ZSIZE BLOCKS - ; INXML IS AN ARRAY PASSED BY NAME OF STRINGS - ; OUTXML IS ALSO PASSED BY NAME - ; IF ZSIZE IS NOT PASSED, 1000 IS USED - I '$D(ZSIZE) S ZSIZE=1000 ; DEFAULT BLOCK SIZE - N ZB,ZI,ZJ,ZK,ZL,ZN - S ZB=ZSIZE-1 - S ZN=1 - S ZI=0 ; BEGINNING OF INDEX TO INXML - F S ZI=$O(@INXML@(ZI)) Q:+ZI=0 D ; FOR EACH STRING IN INXML - . S ZL=$L(@INXML@(ZI)) ; LENGTH OF THE STRING - . F ZJ=1:ZSIZE:ZL D ; - . . S ZK=$S(ZJ+ZB0 S NEWNUM="["_ZNUM_"]" - S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE - I $G(ZREDUX)'="" D ; REDUX PROVIDED? - . N GT S GT=$P(NEWPATH,ZREDUX,2) - . I GT'="" S NEWPATH=GT - S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX - N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE - I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY - E I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY - N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD - I ZFRST'=0 D ; THERE IS A CHILD - . N ZNUM - . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE - . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD - N GNXT S GNXT=$$NXTSIB(ZOID) - I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES - I GNXT'=0 D ; - . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? - . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES - . . N ZNUM S ZNUM=1 ; - . . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB - . E D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB - Q - ; -PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME - ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW - ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML - ;Q $$EN^MXMLDOM(INXML) - Q $$EN^MXMLDOM(INXML,"W") - ; -ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE - N ZN - ;I $$TAG(ZOID)["entry" B - S ZN=$$NXTSIB(ZOID) - I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG - Q 0 - ; -FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID - Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) - ; -PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID - Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) - ; -ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID - S HANDLE=C0CDOCID - K @RTN - D GETTXT^MXMLDOM("A") - Q - ; -TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE - ;I ZOID=149 B ;GPLTEST - N X,Y - S Y="" - S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE - I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y - I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) - Q Y - ; -NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING - Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) - ; -DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE - ;N ZT,ZN S ZT="" - ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) - ;Q $G(@C0CDOM@(ZOID,"T",1)) - S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) - Q - ; -OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM - ; - S C0CDOCID=INID - D START^C0CMXMLB($$TAG(1),,"G") - D NDOUT($$FIRST(1)) - D END^C0CMXMLB ;END THE DOCUMENT - M @ZRTN=^TMP("MXMLBLD",$J) - K ^TMP("MXMLBLD",$J) - Q - ; -NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE - N ZI S ZI=$$FIRST(ZOID) - I ZI'=0 D ; THERE IS A CHILD - . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT - . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN - E D ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT - . ;W "DOING",ZOID,! - . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA - . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES - . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN - I $$NXTSIB(ZOID)'=0 D ; THERE IS A SIBLING - . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS - Q - ; -UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS - K ZERR - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","","ZERR") - I $D(ZERR) D ; - . W "ERROR",! - . ZWR ZERR - . B - K C0CFDA - Q - ; +C0CMXML ; GPL - MXML based XPath utilities;10/13/09 17:05 + ;;0.1;C0C;nopatch;noreleasedate;Build 38 + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q + ; THIS FILE CONTAINS THE XPATH CREATOR, THE PARSE CALL TO THE MXML PARSER + ; AND THE OUTXML XML GENERATOR THAT OUTPUTS XML FROM AN MXML DOM + ; FOR CCD SPECIFIC ROUTINES, SEE C0CMCCD + ; FOR TEMPLATE FILE RELATED ROUTINES, SEE C0CMXP + ; +TEST ; + S C0CXMLIN=$NA(^TMP("C0CMXML",$J)) + K GARY + W $$FTG^%ZISH("/home/vademo2/EHR/p/","mxml-test.xml",$NA(@C0CXMLIN@(1)),3) + S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DocID: ",C0CDOCID + S REDUX="//ContinuityOfCareRecord/Body" + D XPATH(1,"/","GIDX","GARY",,REDUX) + D SEPARATE^C0CMCCD("GARY2","GARY") + S ZI="" + F S ZI=$O(GARY2(ZI)) Q:ZI="" D ; + . N GTMP,G2 + . M G2=GARY2(ZI) + . D DEMUX2^C0CMXP("GTMP","G2",2) + . M GARY3(ZI)=GTMP + Q + ; +TEST2 ; + S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail" + D XPATH(1,"/","GIDX","GARY","",REDUX) + Q + ; +TEST3 + S C0CXMLIN=$NA(^TMP("C0CMXML",$J)) + K GARY,GTMP,GIDX + K @C0CXMLIN + W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3) + D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS + K @C0CXMLIN + M @C0CXMLIN=GTMP + K GTMP + D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN) + K @C0CXMLIN + M @C0CXMLIN=GTMP + K GTMP + S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID + S REDUX="//ClinicalDocument/component/structuredBody" + D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS + D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS + D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS + D XPATH(1,"/","GIDX","GARY",,REDUX) + K C0CCBK("TAG") + D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING + D TEST3A + Q + ; +TEST3A ; INTERNAL ROUTINE + S ZI="" + F S ZI=$O(GARY2(ZI)) Q:ZI="" D ; + . N GTMP,G2 + . M G2=GARY2(ZI) + . D DEMUX2^C0CMXP("GTMP","G2",2) + . M GARY4(ZI)=GTMP + Q + ; +TESTQ ; TEST OF THE QRDA TEMPLATE GPL 7/8/2010 + S C0CXMLIN=$NA(^TMP("C0CMXML",$J)) + K GARY,GTMP,GIDX + K @C0CXMLIN + W $$FTG^%ZISH("/home/vademo2/","QRDA_CategoryI_WorldVistA1.xml",$NA(@C0CXMLIN@(1)),3) + D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS + K @C0CXMLIN + S GTMP(1)="<"_$P(GTMP(1),"<",2) + M @C0CXMLIN=GTMP + K GTMP + D TESTQ2 + Q + ; +TESTQ2 ; SECOND PART OF TESTQ + D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN) + K @C0CXMLIN + M @C0CXMLIN=GTMP + K GTMP + S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID + S REDUX="//ClinicalDocument/component/structuredBody" + D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS + D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS + D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS + D XPATH(1,"/","GIDX","GARY",,REDUX) + K C0CCBK("TAG") + D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING + D TEST3A + Q + ; +TEST4 ; TEST OF OUTPUTING AN XML FILE FROM THE DOM .. this one is the CCR + ; + D TEST ; SET UP THE DOM + D START^C0CMXMLB($$TAG(1),,"G") + D NDOUT($$FIRST(1)) + D END^C0CMXMLB ;END THE DOCUMENT + M ZCCR=^TMP("MXMLBLD",$J) + ZWR ZCCR + Q + ; +TEST5 ; SAME AS TEST4, BUT THIS TIME THE CCD + S C0CXMLIN=$NA(^TMP("C0CMXML",$J)) + K GARY,GTMP,GIDX + K @C0CXMLIN + W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3) + D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS + K @C0CXMLIN + M @C0CXMLIN=GTMP + K GTMP + D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN) + K @C0CXMLIN + M @C0CXMLIN=GTMP + K GTMP + S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DOCID: ",C0CDOCID ;CALL REGULAR PARSER + ;D XPATH(1,"/","GIDX2","GARY2",,REDUX) + D OUTXML("ZCCD",C0CDOCID) + ;D START^C0CMXMLB($$TAG(1),,"G") + ;D NDOUT($$FIRST(1)) + ;D END^C0CMXMLB ;EOND THE DOCUMENT + ;M ZCCD=^TMP("MXMLBLD",$J) + ZWR ZCCD(1:30) + Q + ; +XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE + ; THE XPATH INDEX ZXIDX, PASSED BY NAME + ; THE XPATH ARRAY XPARY, PASSED BY NAME + ; ZOID IS THE STARTING OID + ; ZPATH IS THE STARTING XPATH, USUALLY "/" + ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE + ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT + I $G(ZREDUX)="" S ZREDUX="" + N NEWPATH + N NEWNUM S NEWNUM="" + I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" + S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE + I $G(ZREDUX)'="" D ; REDUX PROVIDED? + . N GT S GT=$P(NEWPATH,ZREDUX,2) + . I GT'="" S NEWPATH=GT + S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX + N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE + I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY + E I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY + N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD + I ZFRST'=0 D ; THERE IS A CHILD + . N ZNUM + . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE + . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD + N GNXT S GNXT=$$NXTSIB(ZOID) + I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES + I GNXT'=0 D ; + . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? + . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES + . . N ZNUM S ZNUM=1 ; + . . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB + . E D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB + Q + ; +PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME + ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW + ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML + ;Q $$EN^MXMLDOM(INXML) + Q $$EN^MXMLDOM(INXML,"W") + ; +ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE + N ZN + ;I $$TAG(ZOID)["entry" B + S ZN=$$NXTSIB(ZOID) + I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG + Q 0 + ; +FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID + Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) + ; +PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID + Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) + ; +ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID + S HANDLE=C0CDOCID + K @RTN + D GETTXT^MXMLDOM("A") + Q + ; +TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE + ;I ZOID=149 B ;GPLTEST + N X,Y + S Y="" + S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE + I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y + I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) + Q Y + ; +NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING + Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) + ; +DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE + ;N ZT,ZN S ZT="" + ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) + ;Q $G(@C0CDOM@(ZOID,"T",1)) + S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) + Q + ; +OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM + ; + S C0CDOCID=INID + D START^C0CMXMLB($$TAG(1),,"G") + D NDOUT($$FIRST(1)) + D END^C0CMXMLB ;END THE DOCUMENT + M @ZRTN=^TMP("MXMLBLD",$J) + K ^TMP("MXMLBLD",$J) + Q + ; +NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE + N ZI S ZI=$$FIRST(ZOID) + I ZI'=0 D ; THERE IS A CHILD + . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT + . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN + E D ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT + . ;W "DOING",ZOID,! + . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA + . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES + . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN + I $$NXTSIB(ZOID)'=0 D ; THERE IS A SIBLING + . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS + Q + ; +UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS + K ZERR + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","","ZERR") + I $D(ZERR) D ; + . W "ERROR",! + . ZWR ZERR + . B + K C0CFDA + Q + ; Index: ccr/branches/ohum/p/C0CMXMLB.m =================================================================== --- ccr/branches/ohum/p/C0CMXMLB.m (revision 1333) +++ ccr/branches/ohum/p/C0CMXMLB.m (revision 1337) @@ -1,106 +1,106 @@ -MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09 16:55 - ;;8.0;KERNEL;;;Build 1 - QUIT - ; - ;DOC - The top level tag - ;DOCTYPE - Want to include a DOCTYPE node - ;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J, -START(DOC,DOCTYPE,FLAG,NO1ST) ;Call this once at the begining. - K ^TMP("MXMLBLD",$J) - S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0 - I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1 - I $G(NO1ST)'=1 D OUTPUT($$XMLHDR) - D:$L($G(DOCTYPE)) OUTPUT("") D OUTPUT("<"_DOC_">") - Q - ; -END ;Call this once to close out the document - D OUTPUT("") - I '$G(^TMP("MXMLBLD",$J,"CNT")) K ^TMP("MXMLBLD",$J) - K ^TMP("MXMLBLD",$J,"DOC"),^("CNT"),^("STK") - Q - ; -ITEM(INDENT,TAG,ATT,VALUE) ;Output a Item - N I,X - S ATT=$G(ATT) - I '$D(VALUE) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_" />") Q - D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">"_$$CHARCHK(VALUE)_"") - Q - ;DOITEM is a callback to output the lower level. -MULTI(INDENT,TAG,ATT,DOITEM) ;Output a Multipule - N I,X,S - S ATT=$G(ATT) - D PUSH($G(INDENT),TAG,.ATT) - D @DOITEM - D POP - Q - ; -ATT(ATT) ;Output a string of attributes - I $D(ATT)<9 Q "" - N I,S,V - S S="",I="" - F S I=$O(ATT(I)) Q:I="" S S=S_" "_I_"="_$$Q(ATT(I)) - Q S - ; -Q(X) ;Add Quotes - Changed by gpl to use single instead of double quotes 6/11 - ;I X'[$C(34) Q $C(34)_X_$C(34) - I X'[$C(39) Q $C(39)_X_$C(39) - ;N Q,Y,I,Z S Q=$C(34),(Y,Z)="" - N Q,Y,I,Z S Q=$C(39),(Y,Z)="" - F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q - S Y=Y_$P(X,Q,$L(X,Q)) - ;Q $C(34)_Y_$C(34) - Q $C(39)_Y_$C(39) - ; -XMLHDR() ; -- provides current XML standard header - Q "" - ; -OUTPUT(S) ;Output - N C S C=$G(^TMP("MXMLBLD",$J,"CNT")) - I C S ^TMP("MXMLBLD",$J,C)=S,^TMP("MXMLBLD",$J,"CNT")=C+1 Q - W S,! - Q - ; -CHARCHK(STR) ; -- replace xml character limits with entities - N A,I,X,Y,Z,NEWSTR - S (Y,Z)="" - ;IF STR["&" SET NEWSTR=STR DO SET STR=Y_Z - ;. FOR X=1:1 SET Y=Y_$PIECE(NEWSTR,"&",X)_"&",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&" - I STR["&" F I=1:1:$L(STR,"&")-1 S STR=$P(STR,"&",1,I)_"&"_$P(STR,"&",I+1,999) - I STR["<" F S STR=$PIECE(STR,"<",1)_"<"_$PIECE(STR,"<",2,99) Q:STR'["<" - I STR[">" F S STR=$PIECE(STR,">",1)_">"_$PIECE(STR,">",2,99) Q:STR'[">" - I STR["'" F S STR=$PIECE(STR,"'",1)_"'"_$PIECE(STR,"'",2,99) Q:STR'["'" - I STR["""" F S STR=$PIECE(STR,"""",1)_"""_$PIECE(STR,"""",2,99) Q:STR'["""" - ; - S STR=$TR(STR,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31)) - QUIT STR - ; -COMMENT(VAL) ;Add Comments - N I,L - ;I $D($G(VAL))=1 D OUTPUT("") Q - I $D(VAL) D OUTPUT("") Q ;CHANGED BY GPL FOR GTM - S I="",L="") - Q - ; -PUSH(INDENT,TAG,ATT) ;Write a TAG and save. - N CNT - S ATT=$G(ATT) - D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">") - S CNT=$G(^TMP("MXMLBLD",$J,"STK"))+1,^TMP("MXMLBLD",$J,"STK")=CNT,^TMP("MXMLBLD",$J,"STK",CNT)=INDENT_"^"_TAG - Q - ; -POP ;Write last pushed tag and pop - N CNT,TAG,INDENT,X - S CNT=$G(^TMP("MXMLBLD",$J,"STK")),X=^TMP("MXMLBLD",$J,"STK",CNT),^TMP("MXMLBLD",$J,"STK")=CNT-1 - S INDENT=+X,TAG=$P(X,"^",2) - D OUTPUT($$BLS(INDENT)_"") - Q - ; -BLS(I) ;Return INDENT string - N S - S S="",I=$G(I) S:I>0 $P(S," ",I)=" " - Q S - ; -INDENT() ;Renturn indent level - Q +$G(^TMP("MXMLBLD",$J,"STK")) +MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09 16:55 + ;;8.0;KERNEL;; + QUIT + ; + ;DOC - The top level tag + ;DOCTYPE - Want to include a DOCTYPE node + ;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J, +START(DOC,DOCTYPE,FLAG,NO1ST) ;Call this once at the begining. + K ^TMP("MXMLBLD",$J) + S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0 + I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1 + I $G(NO1ST)'=1 D OUTPUT($$XMLHDR) + D:$L($G(DOCTYPE)) OUTPUT("") D OUTPUT("<"_DOC_">") + Q + ; +END ;Call this once to close out the document + D OUTPUT("") + I '$G(^TMP("MXMLBLD",$J,"CNT")) K ^TMP("MXMLBLD",$J) + K ^TMP("MXMLBLD",$J,"DOC"),^("CNT"),^("STK") + Q + ; +ITEM(INDENT,TAG,ATT,VALUE) ;Output a Item + N I,X + S ATT=$G(ATT) + I '$D(VALUE) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_" />") Q + D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">"_$$CHARCHK(VALUE)_"") + Q + ;DOITEM is a callback to output the lower level. +MULTI(INDENT,TAG,ATT,DOITEM) ;Output a Multipule + N I,X,S + S ATT=$G(ATT) + D PUSH($G(INDENT),TAG,.ATT) + D @DOITEM + D POP + Q + ; +ATT(ATT) ;Output a string of attributes + I $D(ATT)<9 Q "" + N I,S,V + S S="",I="" + F S I=$O(ATT(I)) Q:I="" S S=S_" "_I_"="_$$Q(ATT(I)) + Q S + ; +Q(X) ;Add Quotes - Changed by gpl to use single instead of double quotes 6/11 + ;I X'[$C(34) Q $C(34)_X_$C(34) + I X'[$C(39) Q $C(39)_X_$C(39) + ;N Q,Y,I,Z S Q=$C(34),(Y,Z)="" + N Q,Y,I,Z S Q=$C(39),(Y,Z)="" + F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q + S Y=Y_$P(X,Q,$L(X,Q)) + ;Q $C(34)_Y_$C(34) + Q $C(39)_Y_$C(39) + ; +XMLHDR() ; -- provides current XML standard header + Q "" + ; +OUTPUT(S) ;Output + N C S C=$G(^TMP("MXMLBLD",$J,"CNT")) + I C S ^TMP("MXMLBLD",$J,C)=S,^TMP("MXMLBLD",$J,"CNT")=C+1 Q + W S,! + Q + ; +CHARCHK(STR) ; -- replace xml character limits with entities + N A,I,X,Y,Z,NEWSTR + S (Y,Z)="" + ;IF STR["&" SET NEWSTR=STR DO SET STR=Y_Z + ;. FOR X=1:1 SET Y=Y_$PIECE(NEWSTR,"&",X)_"&",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&" + I STR["&" F I=1:1:$L(STR,"&")-1 S STR=$P(STR,"&",1,I)_"&"_$P(STR,"&",I+1,999) + I STR["<" F S STR=$PIECE(STR,"<",1)_"<"_$PIECE(STR,"<",2,99) Q:STR'["<" + I STR[">" F S STR=$PIECE(STR,">",1)_">"_$PIECE(STR,">",2,99) Q:STR'[">" + I STR["'" F S STR=$PIECE(STR,"'",1)_"'"_$PIECE(STR,"'",2,99) Q:STR'["'" + I STR["""" F S STR=$PIECE(STR,"""",1)_"""_$PIECE(STR,"""",2,99) Q:STR'["""" + ; + S STR=$TR(STR,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31)) + QUIT STR + ; +COMMENT(VAL) ;Add Comments + N I,L + ;I $D($G(VAL))=1 D OUTPUT("") Q + I $D(VAL) D OUTPUT("") Q ;CHANGED BY GPL FOR GTM + S I="",L="") + Q + ; +PUSH(INDENT,TAG,ATT) ;Write a TAG and save. + N CNT + S ATT=$G(ATT) + D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">") + S CNT=$G(^TMP("MXMLBLD",$J,"STK"))+1,^TMP("MXMLBLD",$J,"STK")=CNT,^TMP("MXMLBLD",$J,"STK",CNT)=INDENT_"^"_TAG + Q + ; +POP ;Write last pushed tag and pop + N CNT,TAG,INDENT,X + S CNT=$G(^TMP("MXMLBLD",$J,"STK")),X=^TMP("MXMLBLD",$J,"STK",CNT),^TMP("MXMLBLD",$J,"STK")=CNT-1 + S INDENT=+X,TAG=$P(X,"^",2) + D OUTPUT($$BLS(INDENT)_"") + Q + ; +BLS(I) ;Return INDENT string + N S + S S="",I=$G(I) S:I>0 $P(S," ",I)=" " + Q S + ; +INDENT() ;Renturn indent level + Q +$G(^TMP("MXMLBLD",$J,"STK")) Index: ccr/branches/ohum/p/C0CMXP.m =================================================================== --- ccr/branches/ohum/p/C0CMXP.m (revision 1333) +++ ccr/branches/ohum/p/C0CMXP.m (revision 1337) @@ -1,292 +1,292 @@ -C0CMXP ; GPL - MXML based XPath utilities;12/04/09 17:05 - ;;0.1;C0C;nopatch;noreleasedate;Build 1 - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q - ; -INITXPF(ARY) ;INITIAL XML/XPATH FILE ARRAY - ; DON'T USE THIS ONE ... USE INITFARY^C0CSOAP("FARY") INSTEAD - D INITFARY^C0CSOAP(ARY) ; - Q - S @ARY@("XML FILE NUMBER")=178.101 - S @ARY@("XML SOURCE FIELD")=2.1 - S @ARY@("XML TEMPLATE FIELD")=3 - S @ARY@("XPATH BINDING SUBFILE")=178.1014 - S @ARY@("REDUX FIELD")=2.5 - Q - ; -SETXPF(ARY) ; SET FILE AND FIELD VARIABLES FROM XPF ARRAY - ; - S C0CXPF=@ARY@("XML FILE NUMBER") - S C0CXFLD=@ARY@("XML") - S C0CXTFLD=@ARY@("TEMPLATE XML") - S C0CXPBF=@ARY@("BINDING SUBFILE NUMBER") - S C0CRDUXF=@ARY@("XPATH REDUCTION STRING") - Q - ; -ADDXP(INARY,TID,FARY) ;ADD XPATH .01 FIELD TO BINDING SUBFILE OF TEMPLATE TID - I '$D(FARY) D ; - . S FARY="FARY" ; FILE ARRAY - . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE - D SETXPF(FARY) ;SET FILE VARIABLES - N C0CA,C0CB - S C0CA="" S C0CB=0 - F S C0CA=$O(@INARY@(C0CA)) Q:C0CA="" D ; FOR EACH XPATH - . S C0CB=C0CB+1 ; COUNT OF XPATHS - . S C0CFDA(C0CXPBF,"?+"_C0CB_","_TID_",",.01)=C0CA - . D UPDIE ; CREATE THE BINDING SUBFILE FOR THIS XPATH - Q - ; -FIXICD9 ; FIX THE ICD9RESULT XML - D GETXML("GPL","ICD9RESULT") ; GET SOME BAD XML OUT OF THE FILE - S ZI="" - S G="" - F S ZI=$O(GPL(ZI)) Q:ZI="" D ; FOR EACH LINE - . S G=G_GPL(ZI) ; MAKE ONE BIG STRING OF XML - D NORMAL^C0CSOAP("G2","G") ;NO NORMALIZE IT BACK INTO AN ARRAY - D ADDXML("G2","ICD9RESULT") ; AND PUT IT BACK - Q -ADDXML(INXML,TEMPID,INFARY) ;ADD XML TO A TEMPLATE ID TEMPID - ; INXML IS PASSED BY NAME - I '$D(INFARY) D ; - . S INFARY="FARY" ; FILE ARRAY - . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE - I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME - D SETXPF(INFARY) ;SET FILE VARIABLES - D WP^DIE(C0CXPF,TEMPID_",",C0CXFLD,,INXML) - Q - ; -ADDTEMP(INXML,TEMPID,INFARY) ;ADD XML TEMPLATE TO TEMPLATE RECORD TEMPID - ; - I '$D(INFARY) D ; - . S INFARY="FARY" ; FILE ARRAY - . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE - I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME - D SETXPF(INFARY) ;SET FILE VARIABLES - D WP^DIE(C0CXPF,TEMPID_",",C0CXTFLD,,INXML) - Q - ; -GETXML(OUTXML,TEMPID,INFARY) ;GET THE XML FROM TEMPLATE TEMPID - ; - I '$D(INFARY) D ; - . S INFARY="FARY" ; FILE ARRAY - . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE - D SETXPF(INFARY) ;SET FILE VARIABLES - I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME - I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXFLD,,OUTXML)'=OUTXML D Q ; - . W "ERROR RETRIEVING TEMPLATE",! - Q - ; -GETTEMP(OUTXML,TEMPID,FARY) ;GET THE TEMPLATE XML FROM TEMPLATE TEMPID - ; - I '$D(FARY) D ; - . S FARY="FARY" ; FILE ARRAY - . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE - D SETXPF(FARY) ;SET FILE VARIABLES - I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,FARY) ;RESOLVE TEMPLATE NAME - I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXTFLD,,OUTXML)'=OUTXML D Q ; - . W "ERROR RETRIEVING TEMPLATE",! - Q - ; -COPYWP(ZFLD,ZSRCREC,ZDESTREC,ZSRCF,ZDESTF) ; COPIES A WORD PROCESSING FIELD - ; FROM ONE RECORD TO ANOTHER RECORD - ; ZFLD IS EITHER A NUMBERIC FIELD OR A NAME IN ZSRCF - ; ZSRCF IS THE SOURCE FILE, IN FILE REDIRECT FORMAT - ; IF ZSRCF IS OMMITED, THE DEFAULT C0C XML MISC FILE WILL BE ASSUMED - ; ZDESTF IS DESTINATION FILE. IF OMMITED, IS ASSUMED TO BE THE SAME - ; A ZSRCF - I '$D(ZSRCF) D ; - . S ZSRCF="ZSRCF" - . D INITFARY^C0CSOAP(ZSRCF) - I '$D(ZDESTF) D ; - . S ZDESTF="ZDESTF" - . M @ZDESTF=@ZSRCF - N ZSF,ZDF,ZSFREF,ZDFREF - S ZSF=@ZSRCF@("XML FILE NUMBER") - S ZSFREF=$$FILEREF^C0CRNF(ZSF) - S ZDF=@ZDESTF@("XML FILE NUMBER") - S ZDFREF=$$FILEREF^C0CRNF(ZDF) - N ZSIEN,ZDIEN - S ZSIEN=$O(@ZSFREF@("B",ZSRCREC,"")) - I ZSIEN="" W !,"ERROR SOURCE RECORD NOT FOUND" Q ; - S ZDIEN=$O(@ZDFREF@("B",ZDESTREC,"")) - I ZDIEN="" W !,"ERROR DESTINATION RECORD NOT FOUND" Q ; - N ZFLDNUM - I +ZFLD=0 S ZFLDNUM=@ZSRCF@(ZFLD) ; IF FIELD IS PASSED BY NAME - E S ZFLDNUM=ZFLD ; IF FIELD IS PASSED BY NUMBER - N ZWP,ZWPN - S ZWPN=$$GET1^DIQ(ZSF,ZSIEN_",",ZFLDNUM,,"ZWP") ; GET WP FROM SOURCE - I ZWPN'="ZWP" W !,"ERROR SOURCE FIELD EMPTY" Q ; - D WP^DIE(ZDF,ZDIEN_",",ZFLDNUM,,"ZWP") ; PUT WP FIELD TO DEST - Q - ; -COMPILE(TID,UFARY) ; COMPILES AN XML TEMPLATE AND GENERATES XPATH BINDINGS - ; UFARY IF SPECIFIED WILL REDIRECT THE XML FILE TO USE - ; INTID IS THE IEN OF THE RECORD TO USE IN THE XML FILE - ; XML IS PULLED FROM THE "XML" FIELD AND THE COMPILED RESULT PUT - ; IN THE "XML TEMPLATE" FIELD. ALL XPATHS USED IN THE TEMPLATE - ; WILL BE POPULATED TO THE XPATH BINDINGS SUBFILE AS .01 - I '$D(UFARY) D ; - . S UFARY="DEFFARY" ; FILE ARRAY - . ;D INITXPF("UFARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE - . D INITFARY^C0CSOAP(UFARY) - D SETXPF(UFARY) ;SET FILE VARIABLES - I +TID=0 S INTID=$$RESTID^C0CSOAP(TID,UFARY) - E S INTID=TID - ;B - ;N C0CXML,C0CREDUX,C0CTEMP,C0CIDX - D GETXML("C0CXML",INTID,UFARY) - S C0CREDUX=$$GET1^DIQ(C0CXPF,INTID_",",C0CRDUXF,"E") ;XPATH REDUCTION STRING - D MKTPLATE("C0CTEMP","C0CIDX","C0CXML",C0CREDUX) ; CREATE TEMPLATE AND IDX - D ADDTEMP("C0CTEMP",INTID,UFARY) ; WRITE THE TEMPLATE TO FILE - D ADDXP("C0CIDX",INTID,UFARY) ;CREATE XPATH SUBFILE ENTRIES FOR EVERY XPATH - Q - ; -MKTPLATE(OUTT,OUTIDX,INXML,REDUX) ;MAKE A TEMPLATE FROM INXML, RETURNED IN OUTT - ; BOTH PASSED BY NAME. THE REDUX XPATH REDUCTION STRING IS USED IF PASSED - ; OUTIDX IS AN ARRAY OF THE XPATHS USED IN MAKING THE TEMPLATE - ; - S C0CXLOC=$NA(^TMP("C0CXML",$J)) - K @C0CXLOC - M @C0CXLOC=@INXML - S C0CDOCID=$$PARSE^C0CMXML(C0CXLOC,"C0CMKT") - K @C0CXLOC - S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) - ;N GIDX,GIDX2,GARY,GARY2 - I '$D(REDUX) S REDUX="" - D XPATH^C0CMXML(1,"/","GIDX","GARY",,REDUX) - D INVERT("GIDX2","GIDX") ;MAKE ARRAY TO LOOK UP XPATH BY NODE - N ZI,ZD S ZI="" - F S ZI=$O(@C0CDOM@(ZI)) Q:ZI="" D ; FOR EACH NODE IN THE DOM - . K ZD ;FOR DATA - . D DATA^C0CMXML("ZD",ZI) ;SEE IF THERE IS DATA FOR THIS NODE - . ;I $D(ZD(1)) D ; IF YES - . I $$FIRST^C0CMXML(ZI)=0 D ; IF THERE ARE NO CHILDREN TO THIS NODE - . . ;I ZI<3 B ;W !,ZD(1) - . . K @C0CDOM@(ZI,"T") ; KILL THE DATA - . . N ZXPATH - . . S ZXPATH=$G(GIDX2(ZI)) ;FIND AN XPATH FOR THIS NODE - . . S @C0CDOM@(ZI,"T",1)="@@"_ZXPATH_"@@" - . . I ZXPATH'="" S @OUTIDX@(ZXPATH)="" ; PASS BACK XPATH USED IN IDX - D OUTXML^C0CMXML(OUTT,C0CDOCID) - Q - ; -INVERT(OUTX,INX) ;INVERTS AN XPATH INDEX RETURNING @OUTX@(x)=XPath from - ; @INX@(XPath)=x - N ZI S ZI="" - F S ZI=$O(@INX@(ZI)) Q:ZI="" D ;FOR EACH XPATH IN THE INPUT - . S @OUTX@(@INX@(ZI))=ZI ; SET INVERTED ENTRY - Q - ; -DEMUX(OUTX,INX) ;PARSES XPATH PASSED BY VALUE IN INX TO REMOVE [x] MULTIPLES - ; RETURNS OUTX: MULTIPLE^SUBMULTIPLE^XPATH - N ZX,ZY,ZZ,ZZ1,ZMULT,ZSUB - S (ZMULT,ZSUB)="" - S ZX=$P(INX,"[",2) - I ZX'="" D ; THERE IS A [x] MULTIPLE - . S ZY=$P(INX,"[",1) ;FIRST PART OF XPATH - . S ZMULT=$P(ZX,"]",1) ; NUMBER OF THE MULTIPLE - . S ZX=ZY_$P(ZX,"]",2) ; REST OF THE XPATH - . I $P(ZX,"[",2)'="" D ; A SUB MULTIPLE EXISTS - . . S ZZ=$P(ZX,"[",1) ; FIRST PART OF XPATH - . . S ZX=$P(ZX,"[",2) ; DELETE THE [ - . . S ZSUB=$P(ZX,"]",1) ; NUMBER OF THE SUBMULTIPLE - . . S ZX=ZZ_$P(ZX,"]",2) ; REST OF THE XPATH - E S ZX=INX ;NO MULTIPLE HERE - S @OUTX=ZMULT_"^"_ZSUB_"^"_ZX ;RETURN MULTIPLE^SUBMULTIPLE^XPATH - Q - ; -DEMUXARY(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO - ; FORMAT @OARY@(x,variablename) where x is the first multiple - ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED - N ZI,ZJ,ZK,ZL,ZM S ZI="" - F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; - . D DEMUX^C0CMXP("ZJ",ZI) - . S ZK=$P(ZJ,"^",3) - . S ZM=$RE($P($RE(ZK),"/",1)) - . I $G(DEPTH)=2 D ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME - . . S ZM=$RE($P($RE(ZK),"/",2))_ZM - . S ZL=$P(ZJ,"^",1) - . I ZL="" S ZL=1 - . I $D(@OARY@(ZL,ZM)) D ;IT'S A DUP - . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI) - . E S @OARY@(ZL,ZM)=@IARY@(ZI) - Q - ; -DEMUX2(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO - ; FORMAT @OARY@(x,variablename) where x is the first multiple - ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED - N ZI,ZJ,ZK,ZL,ZM S ZI="" - F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; - . D DEMUX^C0CMXP("ZJ",ZI) - . S ZK=$P(ZJ,"^",3) - . S ZM=$RE($P($RE(ZK),"/",1)) - . I $G(DEPTH)=2 D ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME - . . S ZM=$RE($P($RE(ZK),"/",2))_"."_ZM - . S ZL=$P(ZJ,"^",1) - . I ZL="" S ZL=1 - . I $D(@OARY@(ZL,ZM)) D ;IT'S A DUP - . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI) - . E S @OARY@(ZL,ZM)=@IARY@(ZI) - Q - ; -DEMUXXP1(OARY,IARY) ;IARY IS INCOMING XPATH ARRAY - ; BOTH IARY AND OARY ARE PASSED BY NAME - ; RETURNS A SIMPLE XPATH ARRAY WITHOUT MULTIPLES. DUPLICATES ARE REMOVED - N ZI,ZJ,ZK - S ZI="" - F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH XPATH IN IARY - . D DEMUX^C0CMXP("ZJ",ZI) - . S ZK=$P(ZJ,"^",3) ;THE XPATH - . S @OARY@(ZK)=@IARY@(ZI) ;THE RESULT. DUPLICATES WILL NOT SHOW - . ; CAUTION, IF THERE ARE MULTIPLES, ONLY THE DATA FOR THE LAST - . ; MULTIPLE WILL BE INCLUDED IN THE OUTPUT ARRAY, ASSIGNED TO THE - . ; COMMON XPATH - Q - ; -DEMUXXP2(OARY,IARY) ; IARY AND OARY ARE PASSED BY NAME - ; IARY IS AN XPATH ARRAY THAT MAY CONTAIN MULTIPLES - ; OARY IS THE OUTPUT ARRAY WHERE MULTIPLES ARE RETURNED IN THE FORM - ; @OARY@(x,Xpath)=data or @OARY@(x,y,Xpath)=data WHERE x AND y ARE - ; THE MULTIPLES AND Xpath IS THE BASE XPATH WITHOUT [x] AND [y] - ; - N ZI,ZJ,ZK,ZX,ZY,ZP - S ZI="" - F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH INPUT XPATH - . D DEMUX("ZJ",ZI) ; PULL OUT THE MULTIPLES - . S ZX=$P(ZJ,"^",1) ;x - . S ZY=$P(ZJ,"^",2) ;y - . S ZP=$P(ZJ,"^",3) ;Xpath - . I ZX="" S ZX=1 ; NO MULTIPLE WILL STORE IN x=1 - . I ZY'="" D ;IS THERE A y? - . . S @OARY@(ZX,ZY,ZP)=@IARY@(ZI) - . E D ;NO y - . . S @OARY@(ZX,ZP)=@IARY@(ZI) - Q - ; -UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS - K ZERR - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","","ZERR") - I $D(ZERR) D ; - . W "ERROR",! - . ZWR ZERR - . B - K C0CFDA - Q - ; +C0CMXP ; GPL - MXML based XPath utilities;12/04/09 17:05 + ;;0.1;C0C;nopatch;noreleasedate;Build 38 + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q + ; +INITXPF(ARY) ;INITIAL XML/XPATH FILE ARRAY + ; DON'T USE THIS ONE ... USE INITFARY^C0CSOAP("FARY") INSTEAD + D INITFARY^C0CSOAP(ARY) ; + Q + S @ARY@("XML FILE NUMBER")=178.101 + S @ARY@("XML SOURCE FIELD")=2.1 + S @ARY@("XML TEMPLATE FIELD")=3 + S @ARY@("XPATH BINDING SUBFILE")=178.1014 + S @ARY@("REDUX FIELD")=2.5 + Q + ; +SETXPF(ARY) ; SET FILE AND FIELD VARIABLES FROM XPF ARRAY + ; + S C0CXPF=@ARY@("XML FILE NUMBER") + S C0CXFLD=@ARY@("XML") + S C0CXTFLD=@ARY@("TEMPLATE XML") + S C0CXPBF=@ARY@("BINDING SUBFILE NUMBER") + S C0CRDUXF=@ARY@("XPATH REDUCTION STRING") + Q + ; +ADDXP(INARY,TID,FARY) ;ADD XPATH .01 FIELD TO BINDING SUBFILE OF TEMPLATE TID + I '$D(FARY) D ; + . S FARY="FARY" ; FILE ARRAY + . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE + D SETXPF(FARY) ;SET FILE VARIABLES + N C0CA,C0CB + S C0CA="" S C0CB=0 + F S C0CA=$O(@INARY@(C0CA)) Q:C0CA="" D ; FOR EACH XPATH + . S C0CB=C0CB+1 ; COUNT OF XPATHS + . S C0CFDA(C0CXPBF,"?+"_C0CB_","_TID_",",.01)=C0CA + . D UPDIE ; CREATE THE BINDING SUBFILE FOR THIS XPATH + Q + ; +FIXICD9 ; FIX THE ICD9RESULT XML + D GETXML("GPL","ICD9RESULT") ; GET SOME BAD XML OUT OF THE FILE + S ZI="" + S G="" + F S ZI=$O(GPL(ZI)) Q:ZI="" D ; FOR EACH LINE + . S G=G_GPL(ZI) ; MAKE ONE BIG STRING OF XML + D NORMAL^C0CSOAP("G2","G") ;NO NORMALIZE IT BACK INTO AN ARRAY + D ADDXML("G2","ICD9RESULT") ; AND PUT IT BACK + Q +ADDXML(INXML,TEMPID,INFARY) ;ADD XML TO A TEMPLATE ID TEMPID + ; INXML IS PASSED BY NAME + I '$D(INFARY) D ; + . S INFARY="FARY" ; FILE ARRAY + . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE + I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME + D SETXPF(INFARY) ;SET FILE VARIABLES + D WP^DIE(C0CXPF,TEMPID_",",C0CXFLD,,INXML) + Q + ; +ADDTEMP(INXML,TEMPID,INFARY) ;ADD XML TEMPLATE TO TEMPLATE RECORD TEMPID + ; + I '$D(INFARY) D ; + . S INFARY="FARY" ; FILE ARRAY + . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE + I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME + D SETXPF(INFARY) ;SET FILE VARIABLES + D WP^DIE(C0CXPF,TEMPID_",",C0CXTFLD,,INXML) + Q + ; +GETXML(OUTXML,TEMPID,INFARY) ;GET THE XML FROM TEMPLATE TEMPID + ; + I '$D(INFARY) D ; + . S INFARY="FARY" ; FILE ARRAY + . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE + D SETXPF(INFARY) ;SET FILE VARIABLES + I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME + I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXFLD,,OUTXML)'=OUTXML D Q ; + . W "ERROR RETRIEVING TEMPLATE",! + Q + ; +GETTEMP(OUTXML,TEMPID,FARY) ;GET THE TEMPLATE XML FROM TEMPLATE TEMPID + ; + I '$D(FARY) D ; + . S FARY="FARY" ; FILE ARRAY + . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE + D SETXPF(FARY) ;SET FILE VARIABLES + I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,FARY) ;RESOLVE TEMPLATE NAME + I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXTFLD,,OUTXML)'=OUTXML D Q ; + . W "ERROR RETRIEVING TEMPLATE",! + Q + ; +COPYWP(ZFLD,ZSRCREC,ZDESTREC,ZSRCF,ZDESTF) ; COPIES A WORD PROCESSING FIELD + ; FROM ONE RECORD TO ANOTHER RECORD + ; ZFLD IS EITHER A NUMBERIC FIELD OR A NAME IN ZSRCF + ; ZSRCF IS THE SOURCE FILE, IN FILE REDIRECT FORMAT + ; IF ZSRCF IS OMMITED, THE DEFAULT C0C XML MISC FILE WILL BE ASSUMED + ; ZDESTF IS DESTINATION FILE. IF OMMITED, IS ASSUMED TO BE THE SAME + ; A ZSRCF + I '$D(ZSRCF) D ; + . S ZSRCF="ZSRCF" + . D INITFARY^C0CSOAP(ZSRCF) + I '$D(ZDESTF) D ; + . S ZDESTF="ZDESTF" + . M @ZDESTF=@ZSRCF + N ZSF,ZDF,ZSFREF,ZDFREF + S ZSF=@ZSRCF@("XML FILE NUMBER") + S ZSFREF=$$FILEREF^C0CRNF(ZSF) + S ZDF=@ZDESTF@("XML FILE NUMBER") + S ZDFREF=$$FILEREF^C0CRNF(ZDF) + N ZSIEN,ZDIEN + S ZSIEN=$O(@ZSFREF@("B",ZSRCREC,"")) + I ZSIEN="" W !,"ERROR SOURCE RECORD NOT FOUND" Q ; + S ZDIEN=$O(@ZDFREF@("B",ZDESTREC,"")) + I ZDIEN="" W !,"ERROR DESTINATION RECORD NOT FOUND" Q ; + N ZFLDNUM + I +ZFLD=0 S ZFLDNUM=@ZSRCF@(ZFLD) ; IF FIELD IS PASSED BY NAME + E S ZFLDNUM=ZFLD ; IF FIELD IS PASSED BY NUMBER + N ZWP,ZWPN + S ZWPN=$$GET1^DIQ(ZSF,ZSIEN_",",ZFLDNUM,,"ZWP") ; GET WP FROM SOURCE + I ZWPN'="ZWP" W !,"ERROR SOURCE FIELD EMPTY" Q ; + D WP^DIE(ZDF,ZDIEN_",",ZFLDNUM,,"ZWP") ; PUT WP FIELD TO DEST + Q + ; +COMPILE(TID,UFARY) ; COMPILES AN XML TEMPLATE AND GENERATES XPATH BINDINGS + ; UFARY IF SPECIFIED WILL REDIRECT THE XML FILE TO USE + ; INTID IS THE IEN OF THE RECORD TO USE IN THE XML FILE + ; XML IS PULLED FROM THE "XML" FIELD AND THE COMPILED RESULT PUT + ; IN THE "XML TEMPLATE" FIELD. ALL XPATHS USED IN THE TEMPLATE + ; WILL BE POPULATED TO THE XPATH BINDINGS SUBFILE AS .01 + I '$D(UFARY) D ; + . S UFARY="DEFFARY" ; FILE ARRAY + . ;D INITXPF("UFARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE + . D INITFARY^C0CSOAP(UFARY) + D SETXPF(UFARY) ;SET FILE VARIABLES + I +TID=0 S INTID=$$RESTID^C0CSOAP(TID,UFARY) + E S INTID=TID + ;B + ;N C0CXML,C0CREDUX,C0CTEMP,C0CIDX + D GETXML("C0CXML",INTID,UFARY) + S C0CREDUX=$$GET1^DIQ(C0CXPF,INTID_",",C0CRDUXF,"E") ;XPATH REDUCTION STRING + D MKTPLATE("C0CTEMP","C0CIDX","C0CXML",C0CREDUX) ; CREATE TEMPLATE AND IDX + D ADDTEMP("C0CTEMP",INTID,UFARY) ; WRITE THE TEMPLATE TO FILE + D ADDXP("C0CIDX",INTID,UFARY) ;CREATE XPATH SUBFILE ENTRIES FOR EVERY XPATH + Q + ; +MKTPLATE(OUTT,OUTIDX,INXML,REDUX) ;MAKE A TEMPLATE FROM INXML, RETURNED IN OUTT + ; BOTH PASSED BY NAME. THE REDUX XPATH REDUCTION STRING IS USED IF PASSED + ; OUTIDX IS AN ARRAY OF THE XPATHS USED IN MAKING THE TEMPLATE + ; + S C0CXLOC=$NA(^TMP("C0CXML",$J)) + K @C0CXLOC + M @C0CXLOC=@INXML + S C0CDOCID=$$PARSE^C0CMXML(C0CXLOC,"C0CMKT") + K @C0CXLOC + S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) + ;N GIDX,GIDX2,GARY,GARY2 + I '$D(REDUX) S REDUX="" + D XPATH^C0CMXML(1,"/","GIDX","GARY",,REDUX) + D INVERT("GIDX2","GIDX") ;MAKE ARRAY TO LOOK UP XPATH BY NODE + N ZI,ZD S ZI="" + F S ZI=$O(@C0CDOM@(ZI)) Q:ZI="" D ; FOR EACH NODE IN THE DOM + . K ZD ;FOR DATA + . D DATA^C0CMXML("ZD",ZI) ;SEE IF THERE IS DATA FOR THIS NODE + . ;I $D(ZD(1)) D ; IF YES + . I $$FIRST^C0CMXML(ZI)=0 D ; IF THERE ARE NO CHILDREN TO THIS NODE + . . ;I ZI<3 B ;W !,ZD(1) + . . K @C0CDOM@(ZI,"T") ; KILL THE DATA + . . N ZXPATH + . . S ZXPATH=$G(GIDX2(ZI)) ;FIND AN XPATH FOR THIS NODE + . . S @C0CDOM@(ZI,"T",1)="@@"_ZXPATH_"@@" + . . I ZXPATH'="" S @OUTIDX@(ZXPATH)="" ; PASS BACK XPATH USED IN IDX + D OUTXML^C0CMXML(OUTT,C0CDOCID) + Q + ; +INVERT(OUTX,INX) ;INVERTS AN XPATH INDEX RETURNING @OUTX@(x)=XPath from + ; @INX@(XPath)=x + N ZI S ZI="" + F S ZI=$O(@INX@(ZI)) Q:ZI="" D ;FOR EACH XPATH IN THE INPUT + . S @OUTX@(@INX@(ZI))=ZI ; SET INVERTED ENTRY + Q + ; +DEMUX(OUTX,INX) ;PARSES XPATH PASSED BY VALUE IN INX TO REMOVE [x] MULTIPLES + ; RETURNS OUTX: MULTIPLE^SUBMULTIPLE^XPATH + N ZX,ZY,ZZ,ZZ1,ZMULT,ZSUB + S (ZMULT,ZSUB)="" + S ZX=$P(INX,"[",2) + I ZX'="" D ; THERE IS A [x] MULTIPLE + . S ZY=$P(INX,"[",1) ;FIRST PART OF XPATH + . S ZMULT=$P(ZX,"]",1) ; NUMBER OF THE MULTIPLE + . S ZX=ZY_$P(ZX,"]",2) ; REST OF THE XPATH + . I $P(ZX,"[",2)'="" D ; A SUB MULTIPLE EXISTS + . . S ZZ=$P(ZX,"[",1) ; FIRST PART OF XPATH + . . S ZX=$P(ZX,"[",2) ; DELETE THE [ + . . S ZSUB=$P(ZX,"]",1) ; NUMBER OF THE SUBMULTIPLE + . . S ZX=ZZ_$P(ZX,"]",2) ; REST OF THE XPATH + E S ZX=INX ;NO MULTIPLE HERE + S @OUTX=ZMULT_"^"_ZSUB_"^"_ZX ;RETURN MULTIPLE^SUBMULTIPLE^XPATH + Q + ; +DEMUXARY(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO + ; FORMAT @OARY@(x,variablename) where x is the first multiple + ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED + N ZI,ZJ,ZK,ZL,ZM S ZI="" + F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; + . D DEMUX^C0CMXP("ZJ",ZI) + . S ZK=$P(ZJ,"^",3) + . S ZM=$RE($P($RE(ZK),"/",1)) + . I $G(DEPTH)=2 D ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME + . . S ZM=$RE($P($RE(ZK),"/",2))_ZM + . S ZL=$P(ZJ,"^",1) + . I ZL="" S ZL=1 + . I $D(@OARY@(ZL,ZM)) D ;IT'S A DUP + . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI) + . E S @OARY@(ZL,ZM)=@IARY@(ZI) + Q + ; +DEMUX2(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO + ; FORMAT @OARY@(x,variablename) where x is the first multiple + ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED + N ZI,ZJ,ZK,ZL,ZM S ZI="" + F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; + . D DEMUX^C0CMXP("ZJ",ZI) + . S ZK=$P(ZJ,"^",3) + . S ZM=$RE($P($RE(ZK),"/",1)) + . I $G(DEPTH)=2 D ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME + . . S ZM=$RE($P($RE(ZK),"/",2))_"."_ZM + . S ZL=$P(ZJ,"^",1) + . I ZL="" S ZL=1 + . I $D(@OARY@(ZL,ZM)) D ;IT'S A DUP + . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI) + . E S @OARY@(ZL,ZM)=@IARY@(ZI) + Q + ; +DEMUXXP1(OARY,IARY) ;IARY IS INCOMING XPATH ARRAY + ; BOTH IARY AND OARY ARE PASSED BY NAME + ; RETURNS A SIMPLE XPATH ARRAY WITHOUT MULTIPLES. DUPLICATES ARE REMOVED + N ZI,ZJ,ZK + S ZI="" + F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH XPATH IN IARY + . D DEMUX^C0CMXP("ZJ",ZI) + . S ZK=$P(ZJ,"^",3) ;THE XPATH + . S @OARY@(ZK)=@IARY@(ZI) ;THE RESULT. DUPLICATES WILL NOT SHOW + . ; CAUTION, IF THERE ARE MULTIPLES, ONLY THE DATA FOR THE LAST + . ; MULTIPLE WILL BE INCLUDED IN THE OUTPUT ARRAY, ASSIGNED TO THE + . ; COMMON XPATH + Q + ; +DEMUXXP2(OARY,IARY) ; IARY AND OARY ARE PASSED BY NAME + ; IARY IS AN XPATH ARRAY THAT MAY CONTAIN MULTIPLES + ; OARY IS THE OUTPUT ARRAY WHERE MULTIPLES ARE RETURNED IN THE FORM + ; @OARY@(x,Xpath)=data or @OARY@(x,y,Xpath)=data WHERE x AND y ARE + ; THE MULTIPLES AND Xpath IS THE BASE XPATH WITHOUT [x] AND [y] + ; + N ZI,ZJ,ZK,ZX,ZY,ZP + S ZI="" + F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH INPUT XPATH + . D DEMUX("ZJ",ZI) ; PULL OUT THE MULTIPLES + . S ZX=$P(ZJ,"^",1) ;x + . S ZY=$P(ZJ,"^",2) ;y + . S ZP=$P(ZJ,"^",3) ;Xpath + . I ZX="" S ZX=1 ; NO MULTIPLE WILL STORE IN x=1 + . I ZY'="" D ;IS THERE A y? + . . S @OARY@(ZX,ZY,ZP)=@IARY@(ZI) + . E D ;NO y + . . S @OARY@(ZX,ZP)=@IARY@(ZI) + Q + ; +UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS + K ZERR + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","","ZERR") + I $D(ZERR) D ; + . W "ERROR",! + . ZWR ZERR + . B + K C0CFDA + Q + ; Index: ccr/branches/ohum/p/C0CNHIN.m =================================================================== --- ccr/branches/ohum/p/C0CNHIN.m (revision 1333) +++ ccr/branches/ohum/p/C0CNHIN.m (revision 1337) @@ -1,323 +1,323 @@ -C0CNHIN ; GPL - PROCESSING FOR OUTPUT OF NHINV ROUTINES;6/3/11 17:05 - ;;0.1;C0C;nopatch;noreleasedate;Build 1 - ;Copyright 2011 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q -EN(ZRTN,ZDFN,ZPART,KEEP) ; GENERATE AN NHIN ARRAY FOR A PATIENT - ; - K GARY,GNARY,GIDX,C0CDOCID - N GN - K ^TMP("NHINV",$J) ; CLEAN UP FROM LAST CALL - K ^TMP("MXMLDOM",$J) ; CLEAN UP DOM - K ^TMP("MXMLERR",$J) ; CLEAN UP MXML ERRORS - D GET^NHINV(.GN,ZDFN,ZPART) ; CALL NHINV ROUTINES TO PULL XML - S GN=$P(GN,")",1)_")" ; CUT OFF THE REST OF LINE PROTOCOL - S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML - D DOMO^C0CDOM(C0CDOCID,"/","ZRTN","GIDX","GARY",,"/results/") ; BLD ARRAYS - I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 - ;D PROCESS("ZRTN",GN,"/result/",$G(KEEP)) - Q - ; -PQRI(ZOUT,KEEP) ; RETURN THE NHIN ARRAY FOR THE PQRI XML TEMPLATE - ; - N ZG - S ZG=$NA(^TMP("PQRIXML",$J)) - K @ZG - D GETXML^C0CMXP(ZG,"PQRIXML") ; GET THE XML FROM C0C MISC XML - N C0CDOCID - S C0CDOCID=$$PARSE^C0CDOM(ZG,"PQRIXML") ; PARSE THE XML - D DOMO^C0CDOM(C0CDOCID,"/","ZOUT","GIDX","GARY",,"//submission") ; BLD ARRAYS - I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 - Q - ; -PQRI2(ZRTN) ; RETURN THE NHIN ARRAY FOR PQRI ONE MEASURE - ; - ;N GG - D GETXML^C0CMXP("GG","PQRI ONE MEASURE") - D PROCESS(ZRTN,"GG","root",1) - Q - ; -PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP) ; PARSE AND RUN DOMO ON XML - ; ZRTN IS PASSED BY REFERENCE - ; ZXML IS PASSED BY NAME - ; IF KEEP IS 1, GARY AND GIDX ARE NOT KILLED - ; - N GN - S GN=$NA(^TMP("C0CPROCESS",$J)) - K @GN - M @GN=@ZXML - S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML - K @GN - D DOMO^C0CDOM(C0CDOCID,"/","ZRSLT","GIDX","GARY",,$G(ZREDUCE)) ; BLD ARRAYS - I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 - Q - ; -LOADSMRT ; - ; - K ^GPL("SMART") - S GN=$NA(^GPL("SMART",1)) - I $$FTG^%ZISH("/home/george/","alex-lewis2.xml",GN,2) W !,"SMART FILE LOADED" - Q - ; -SMART ; TRY IT WITH SMART - ; - S GN=$NA(^GPL("SMART")) - ;K ^TMP("MXMLDOM",$J) - K ^TMP("MXMLERR",$J) - S C0CDOCID=$$PARSE(GN,"SMART") - D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//rdf:RDF/") - ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG - Q - ; -CCR ; TRY IT WITH A CCR - ; - S GN=$NA(^GPL("CCR")) - ;K ^TMP("MXMLDOM",$J) - K ^TMP("MXMLERR",$J) - S C0CDOCID=$$PARSE(GN,"CCR") - D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ContinuityOfCareRecord/Body/") - ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG - Q - ; -MED ; TRY IT WITH A CCR MED SECTION - ; - S GN=$NA(^GPL("MED")) - K ^TMP("MXMLDOM",$J) - K ^TMP("MXMLERR",$J) - S C0CDOCID=$$PARSE(GN,"MED") - D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//Medications/") - ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG - Q - ; -CCD ; TRY IT WITH A CCD - ; - S GN=$NA(^GPL("CCD")) - ;K ^TMP("MXMLDOM",$J) - K ^TMP("MXMLERR",$J) - S C0CDOCID=$$PARSE(GN,"CCD") - D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ClinicalDocument/component/structuredBody/") - ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG - Q - ; -TEST1 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") - ; PARSED WITH MXML - ; RUN THROUGH XPATH - K GARY,GIDX,C0CDOCID - S GN=$NA(^GPL("NHIN")) - ;S GN=$NA(^GPL("DOMI")) - S C0CDOCID=$$PARSE(GN,"GPLTEST") - D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/") - K ^GPL("GNARY") - M ^GPL("GNARY")=GNARY - Q - ; -TEST2 ; PUT GNARY THROUGH DOMI AND STORE XML IN ^GPL("DOMI") - ; - S GN=$NA(^GPL("GNARY")) - S C0CDOCID=$$DOMI^C0CDOM(GN,,"results") - D OUTXML^C0CDOM("G",C0CDOCID) - K ^GPL("DOMI") - M ^GPL("DOMI")=G - Q - ; -TEST3 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") - ; PARSED WITH MXML - ; RUN THROUGH XPATH - K GARY,GIDX,C0CDOCID - ;S GN=$NA(^GPL("NHIN")) - S GN=$NA(^GPL("DOMI")) - S C0CDOCID=$$PARSE(GN,"GPLTEST") - D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/") - Q - ; -DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE - ; THE XPATH INDEX ZXIDX, PASSED BY NAME - ; THE XPATH ARRAY XPARY, PASSED BY NAME - ; ZOID IS THE STARTING OID - ; ZPATH IS THE STARTING XPATH, USUALLY "/" - ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE - ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT - I $G(ZREDUX)="" S ZREDUX="" - N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY - N NEWNUM S NEWNUM="" - I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" - S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE - I $G(ZREDUX)'="" D ; REDUX PROVIDED? - . N GT S GT=$P(NEWPATH,ZREDUX,2) - . I GT'="" S NEWPATH=GT - S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX - N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE - I $D(GA) D ; PROCESS THE ATTRIBUTES - . N ZI S ZI="" - . F S ZI=$O(GA(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE - . . N ZP S ZP=NEWPATH_"/"_ZI ; PATH FOR ATTRIBUTE - . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY - . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE - N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE - I $D(GD(2)) D ; - . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY - E I $D(GD(1)) D ; - . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY - . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY - N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD - I ZFRST'=0 D ; THERE IS A CHILD - . N ZNUM - . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE - . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD - N GNXT S GNXT=$$NXTSIB(ZOID) - I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES - I GNXT'=0 D ; - . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? - . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES - . . N ZNUM S ZNUM=1 ; - . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB - . E D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB - Q - ; -ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY - ; - N ZZI,ZZJ,ZZN - S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY - I ZZI="" Q ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE - S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY - S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH . - I ZZI'["]" D ; A SINGLETON - . S ZZN=1 - E D ; THERE IS AN [x] OCCURANCE - . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE - . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X] - I ZZJ'="" S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE - Q - ; -PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME - ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW - ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML - ;Q $$EN^MXMLDOM(INXML) - Q $$EN^MXMLDOM(INXML,"W") - ; -ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE - N ZN - ;I $$TAG(ZOID)["entry" B - S ZN=$$NXTSIB(ZOID) - I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG - Q 0 - ; -FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID - Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) - ; -PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID - Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) - ; -ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID - S HANDLE=C0CDOCID - K @RTN - D GETTXT^MXMLDOM("A") - Q - ; -TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE - ;I ZOID=149 B ;GPLTEST - N X,Y - S Y="" - S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE - I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y - I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) - Q Y - ; -NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING - Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) - ; -DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE - ;N ZT,ZN S ZT="" - ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) - ;Q $G(@C0CDOM@(ZOID,"T",1)) - S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) - Q - ; -OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM - ; - S C0CDOCID=INID - D START^C0CMXMLB($$TAG(1),,"G") - D NDOUT($$FIRST(1)) - D END^C0CMXMLB ;END THE DOCUMENT - M @ZRTN=^TMP("MXMLBLD",$J) - K ^TMP("MXMLBLD",$J) - Q - ; -NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE - N ZI S ZI=$$FIRST(ZOID) - I ZI'=0 D ; THERE IS A CHILD - . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT - . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN - E D ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT - . ;W "DOING",ZOID,! - . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA - . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES - . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN - I $$NXTSIB(ZOID)'=0 D ; THERE IS A SIBLING - . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS - Q - ; -WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE - ; - N GN,GN2 - D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML - S GN2=$NA(@GN@(1)) - W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/") - Q - ; -TESTNARY ; TEST MAKING A NHIN ARRAY - N ZI S ZI="" - N ZH ; DOM HANDLE - D TEST1 ; PARSE AN NHIN RESULT INTO THE DOM - S ZH=C0CDOCID ; SET THE HANDLE - N ZD S ZD=$NA(^TMP("MXMLDOM",$J,ZH)) - F S ZI=$O(@ZD@(ZI)) Q:ZI="" D ; FOR EACH NODE - . N ZATT - . D MNARY(.ZATT,ZH,ZI) - . N ZPRE,ZN - . S ZPRE=$$PRE(ZI) - . S ZN=$P(ZPRE,",",2) - . S ZPRE=$P(ZPRE,",",1) - . ;I $D(ZATT) ZWR ZATT - . N ZJ S ZJ="" - . F S ZJ=$O(ZATT(ZJ)) Q:ZJ="" D ; FOR EACH ATTRIBUTE - . . W ZPRE_"["_ZN_"]"_$$TAG(ZI)_"."_ZJ_"="_ZATT(ZJ),! - . . S GOUT(ZPRE,ZN,$$TAG(ZI)_"."_ZJ)=ZATT(ZJ) - Q - ; -PRE(ZNODE) ; EXTRINSIC WHICH RETURNS THE PREFIX FOR A NODE - ; - N GI,GI2,GPT,GJ,GN - S GI=$$PARENT(ZNODE) ; PARENT NODE - I GI=0 Q "" ; NO PARENT - S GPT=$$TAG(GI) ; TAG OF PARENT - S GI2=$$PARENT(GI) ; PARENT OF PARENT - I (GI2'=0)&($$TAG(GI2)'="results") S GPT=$$TAG(GI2)_"."_GPT - S GJ=$$FIRST(GI) ; NODE OF FIRST SIB - I GJ=ZNODE Q:$$TAG(GI)_",1" - F GN=2:1 Q:GJ=ZNODE D ; - . S GJ=$$NXTSIB(GJ) ; NEXT SIBLING - Q GPT_","_GN - ; -MNARY(ZRTN,ZHANDLE,ZOID) ; MAKE A NHIN ARRAY FROM A DOM NODE - ; RETURNED IN ZRTN, PASSED BY REFERENCE - ; ZHANDLE IS THE DOM DOCUMENT ID - ; ZOID IS THE DOM NODE - D ATT("ZRTN",ZOID) - Q - ; +C0CNHIN ; GPL - PROCESSING FOR OUTPUT OF NHINV ROUTINES;6/3/11 17:05 + ;;0.1;C0C;nopatch;noreleasedate;Build 38 + ;Copyright 2011 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q +EN(ZRTN,ZDFN,ZPART,KEEP) ; GENERATE AN NHIN ARRAY FOR A PATIENT + ; + K GARY,GNARY,GIDX,C0CDOCID + N GN + K ^TMP("NHINV",$J) ; CLEAN UP FROM LAST CALL + K ^TMP("MXMLDOM",$J) ; CLEAN UP DOM + K ^TMP("MXMLERR",$J) ; CLEAN UP MXML ERRORS + D GET^NHINV(.GN,ZDFN,ZPART) ; CALL NHINV ROUTINES TO PULL XML + S GN=$P(GN,")",1)_")" ; CUT OFF THE REST OF LINE PROTOCOL + S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML + D DOMO^C0CDOM(C0CDOCID,"/","ZRTN","GIDX","GARY",,"/results/") ; BLD ARRAYS + I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 + ;D PROCESS("ZRTN",GN,"/result/",$G(KEEP)) + Q + ; +PQRI(ZOUT,KEEP) ; RETURN THE NHIN ARRAY FOR THE PQRI XML TEMPLATE + ; + N ZG + S ZG=$NA(^TMP("PQRIXML",$J)) + K @ZG + D GETXML^C0CMXP(ZG,"PQRIXML") ; GET THE XML FROM C0C MISC XML + N C0CDOCID + S C0CDOCID=$$PARSE^C0CDOM(ZG,"PQRIXML") ; PARSE THE XML + D DOMO^C0CDOM(C0CDOCID,"/","ZOUT","GIDX","GARY",,"//submission") ; BLD ARRAYS + I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 + Q + ; +PQRI2(ZRTN) ; RETURN THE NHIN ARRAY FOR PQRI ONE MEASURE + ; + ;N GG + D GETXML^C0CMXP("GG","PQRI ONE MEASURE") + D PROCESS(ZRTN,"GG","root",1) + Q + ; +PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP) ; PARSE AND RUN DOMO ON XML + ; ZRTN IS PASSED BY REFERENCE + ; ZXML IS PASSED BY NAME + ; IF KEEP IS 1, GARY AND GIDX ARE NOT KILLED + ; + N GN + S GN=$NA(^TMP("C0CPROCESS",$J)) + K @GN + M @GN=@ZXML + S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML + K @GN + D DOMO^C0CDOM(C0CDOCID,"/","ZRSLT","GIDX","GARY",,$G(ZREDUCE)) ; BLD ARRAYS + I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 + Q + ; +LOADSMRT ; + ; + K ^GPL("SMART") + S GN=$NA(^GPL("SMART",1)) + I $$FTG^%ZISH("/home/george/","alex-lewis2.xml",GN,2) W !,"SMART FILE LOADED" + Q + ; +SMART ; TRY IT WITH SMART + ; + S GN=$NA(^GPL("SMART")) + ;K ^TMP("MXMLDOM",$J) + K ^TMP("MXMLERR",$J) + S C0CDOCID=$$PARSE(GN,"SMART") + D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//rdf:RDF/") + ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG + Q + ; +CCR ; TRY IT WITH A CCR + ; + S GN=$NA(^GPL("CCR")) + ;K ^TMP("MXMLDOM",$J) + K ^TMP("MXMLERR",$J) + S C0CDOCID=$$PARSE(GN,"CCR") + D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ContinuityOfCareRecord/Body/") + ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG + Q + ; +MED ; TRY IT WITH A CCR MED SECTION + ; + S GN=$NA(^GPL("MED")) + K ^TMP("MXMLDOM",$J) + K ^TMP("MXMLERR",$J) + S C0CDOCID=$$PARSE(GN,"MED") + D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//Medications/") + ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG + Q + ; +CCD ; TRY IT WITH A CCD + ; + S GN=$NA(^GPL("CCD")) + ;K ^TMP("MXMLDOM",$J) + K ^TMP("MXMLERR",$J) + S C0CDOCID=$$PARSE(GN,"CCD") + D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ClinicalDocument/component/structuredBody/") + ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG + Q + ; +TEST1 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") + ; PARSED WITH MXML + ; RUN THROUGH XPATH + K GARY,GIDX,C0CDOCID + S GN=$NA(^GPL("NHIN")) + ;S GN=$NA(^GPL("DOMI")) + S C0CDOCID=$$PARSE(GN,"GPLTEST") + D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/") + K ^GPL("GNARY") + M ^GPL("GNARY")=GNARY + Q + ; +TEST2 ; PUT GNARY THROUGH DOMI AND STORE XML IN ^GPL("DOMI") + ; + S GN=$NA(^GPL("GNARY")) + S C0CDOCID=$$DOMI^C0CDOM(GN,,"results") + D OUTXML^C0CDOM("G",C0CDOCID) + K ^GPL("DOMI") + M ^GPL("DOMI")=G + Q + ; +TEST3 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") + ; PARSED WITH MXML + ; RUN THROUGH XPATH + K GARY,GIDX,C0CDOCID + ;S GN=$NA(^GPL("NHIN")) + S GN=$NA(^GPL("DOMI")) + S C0CDOCID=$$PARSE(GN,"GPLTEST") + D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/") + Q + ; +DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE + ; THE XPATH INDEX ZXIDX, PASSED BY NAME + ; THE XPATH ARRAY XPARY, PASSED BY NAME + ; ZOID IS THE STARTING OID + ; ZPATH IS THE STARTING XPATH, USUALLY "/" + ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE + ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT + I $G(ZREDUX)="" S ZREDUX="" + N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY + N NEWNUM S NEWNUM="" + I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" + S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE + I $G(ZREDUX)'="" D ; REDUX PROVIDED? + . N GT S GT=$P(NEWPATH,ZREDUX,2) + . I GT'="" S NEWPATH=GT + S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX + N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE + I $D(GA) D ; PROCESS THE ATTRIBUTES + . N ZI S ZI="" + . F S ZI=$O(GA(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE + . . N ZP S ZP=NEWPATH_"/"_ZI ; PATH FOR ATTRIBUTE + . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY + . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE + N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE + I $D(GD(2)) D ; + . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY + E I $D(GD(1)) D ; + . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY + . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY + N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD + I ZFRST'=0 D ; THERE IS A CHILD + . N ZNUM + . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE + . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD + N GNXT S GNXT=$$NXTSIB(ZOID) + I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES + I GNXT'=0 D ; + . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? + . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES + . . N ZNUM S ZNUM=1 ; + . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB + . E D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB + Q + ; +ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY + ; + N ZZI,ZZJ,ZZN + S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY + I ZZI="" Q ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE + S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY + S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH . + I ZZI'["]" D ; A SINGLETON + . S ZZN=1 + E D ; THERE IS AN [x] OCCURANCE + . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE + . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X] + I ZZJ'="" S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE + Q + ; +PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME + ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW + ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML + ;Q $$EN^MXMLDOM(INXML) + Q $$EN^MXMLDOM(INXML,"W") + ; +ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE + N ZN + ;I $$TAG(ZOID)["entry" B + S ZN=$$NXTSIB(ZOID) + I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG + Q 0 + ; +FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID + Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) + ; +PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID + Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) + ; +ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID + S HANDLE=C0CDOCID + K @RTN + D GETTXT^MXMLDOM("A") + Q + ; +TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE + ;I ZOID=149 B ;GPLTEST + N X,Y + S Y="" + S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE + I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y + I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) + Q Y + ; +NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING + Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) + ; +DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE + ;N ZT,ZN S ZT="" + ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) + ;Q $G(@C0CDOM@(ZOID,"T",1)) + S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) + Q + ; +OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM + ; + S C0CDOCID=INID + D START^C0CMXMLB($$TAG(1),,"G") + D NDOUT($$FIRST(1)) + D END^C0CMXMLB ;END THE DOCUMENT + M @ZRTN=^TMP("MXMLBLD",$J) + K ^TMP("MXMLBLD",$J) + Q + ; +NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE + N ZI S ZI=$$FIRST(ZOID) + I ZI'=0 D ; THERE IS A CHILD + . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT + . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN + E D ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT + . ;W "DOING",ZOID,! + . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA + . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES + . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN + I $$NXTSIB(ZOID)'=0 D ; THERE IS A SIBLING + . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS + Q + ; +WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE + ; + N GN,GN2 + D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML + S GN2=$NA(@GN@(1)) + W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/") + Q + ; +TESTNARY ; TEST MAKING A NHIN ARRAY + N ZI S ZI="" + N ZH ; DOM HANDLE + D TEST1 ; PARSE AN NHIN RESULT INTO THE DOM + S ZH=C0CDOCID ; SET THE HANDLE + N ZD S ZD=$NA(^TMP("MXMLDOM",$J,ZH)) + F S ZI=$O(@ZD@(ZI)) Q:ZI="" D ; FOR EACH NODE + . N ZATT + . D MNARY(.ZATT,ZH,ZI) + . N ZPRE,ZN + . S ZPRE=$$PRE(ZI) + . S ZN=$P(ZPRE,",",2) + . S ZPRE=$P(ZPRE,",",1) + . ;I $D(ZATT) ZWR ZATT + . N ZJ S ZJ="" + . F S ZJ=$O(ZATT(ZJ)) Q:ZJ="" D ; FOR EACH ATTRIBUTE + . . W ZPRE_"["_ZN_"]"_$$TAG(ZI)_"."_ZJ_"="_ZATT(ZJ),! + . . S GOUT(ZPRE,ZN,$$TAG(ZI)_"."_ZJ)=ZATT(ZJ) + Q + ; +PRE(ZNODE) ; EXTRINSIC WHICH RETURNS THE PREFIX FOR A NODE + ; + N GI,GI2,GPT,GJ,GN + S GI=$$PARENT(ZNODE) ; PARENT NODE + I GI=0 Q "" ; NO PARENT + S GPT=$$TAG(GI) ; TAG OF PARENT + S GI2=$$PARENT(GI) ; PARENT OF PARENT + I (GI2'=0)&($$TAG(GI2)'="results") S GPT=$$TAG(GI2)_"."_GPT + S GJ=$$FIRST(GI) ; NODE OF FIRST SIB + I GJ=ZNODE Q:$$TAG(GI)_",1" + F GN=2:1 Q:GJ=ZNODE D ; + . S GJ=$$NXTSIB(GJ) ; NEXT SIBLING + Q GPT_","_GN + ; +MNARY(ZRTN,ZHANDLE,ZOID) ; MAKE A NHIN ARRAY FROM A DOM NODE + ; RETURNED IN ZRTN, PASSED BY REFERENCE + ; ZHANDLE IS THE DOM DOCUMENT ID + ; ZOID IS THE DOM NODE + D ATT("ZRTN",ZOID) + Q + ; Index: ccr/branches/ohum/p/C0CNMED2.m =================================================================== --- ccr/branches/ohum/p/C0CNMED2.m (revision 1333) +++ ccr/branches/ohum/p/C0CNMED2.m (revision 1337) @@ -1,121 +1,121 @@ -C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 - ;;1.0;C0C;;May 19, 2009;Build 1 - ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel. - ; Licensed under the terms of the GNU General Public License. - ; See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; --Revision History - ; July 2008 - Initial Version/GPL - ; July 2008 - March 2009 various revisions - ; March 2009 - Reconstruction of routine as driver for other med routines/SMH - ; June 2011 - Redone to support all meds using the FOIA NHIN routines/gpl - ; - Q - ; - ; THIS VERSION IS DEPRECATED BECAUSE IT DOES NOT GENEREATE XML IN - ; THE RIGHT ORDER... AND IT HAS TO BE IN THE RIGHT ORDER... :( - ; GPL - ; -EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template - ; DFN passed by reference - ; MEDXML and MEDOUTXML are passed by Name - ; MEDXML is the input template - ; MEDOUTXML is the output template - ; Both of them refer to ^TMP globals where the XML documents are stored - ; - N GN - D EN^C0CNHIN(.GN,DFN,"MED;",1) ; RETRIEVE NHIN ARRAY OF MEDS - ; this call uses GET^NHINV to retrieve xml of the meds and then - ; parses with MXML and uses DOMO^C0CDOM to extract an NHIN array - ; - ; we now create an NHIN Array of the Meds section of the CCR - ; - N ZI S ZI="" - F S ZI=$O(GN("med",ZI)) Q:ZI="" D ; for each med - . N GA S GA=$NA(GN("med",ZI)) - . N GM S GM="Medication" ; to keep the lines shorter - . S GC(GM,ZI,"CCRDataObjectID")="MED_"_ZI - . N ZD,ZD2 S ZD=$G(@GA@("ordered@value")) ; FILEMAN DATE - . I ZD="" S ZD=$G(@GA@("start@value")) ; for inpatient meds - . S ZD2=$$FMDTOUTC^C0CUTIL(ZD,"DT") - . S GC(GM,ZI,"DateTime[1].ExactDateTime")=ZD2 - . S GC(GM,ZI,"DateTime[1].Type.Text")="Documented Date" - . ;S GC(GM,ZI,"DateTime[2].ExactDateTime")="" - . ;S GC(GM,ZI,"DateTime[2].Type.Text")="" - . N GSIG S GSIG=$G(@GA@("sig")) - . I GSIG["|" S GSIG=$P(GSIG,"|",2) ; eRx has name of drug separated by | - . S GC(GM,ZI,"Description.Text")=GSIG - . N GD S GD="Directions.Direction" ; MAKING THE STRINGS SHORTER - . ;S GC(GM,ZI,GD_".DeliveryMethod.Text")="@@MEDDELIVERYMETHOD@@" - . ;S GC(GM,ZI,GD_".Description.Text")="" - . ;S GC(GM,ZI,GD_".DirectionSequenceModifier")="@@MEDDIRSEQ@@" - . ;S GC(GM,ZI,GD_".Dose.Rate.Units.Unit")="@@MEDRATEUNIT@@" - . ;S GC(GM,ZI,GD_".Dose.Rate.Value")="@@MEDRATEVALUE@@" - . ;S GC(GM,ZI,GD_".Dose.Units.Unit")="@@MEDDOSEUNIT@@" - . ;S GC(GM,ZI,GD_".Dose.Value")="@@MEDDOSEVALUE@@" - . ;S GC(GM,ZI,GD_".DoseIndicator.Text")="@@MEDDOSEINDICATOR@@" - . ;S GC(GM,ZI,GD_".Duration.Units.Unit")="@@MEDDURATIONUNIT@@" - . ;S GC(GM,ZI,GD_".Duration.Value")="@@MEDDURATIONVALUE@@" - . ;S GC(GM,ZI,GD_".Frequency.Value")="@@MEDFREQUENCYVALUE@@" - . ;S GC(GM,ZI,GD_".Indication.PRNFlag.Text")="@@MEDPRNFLAG@@" - . ;S GC(GM,ZI,GD_".Indication.Problem.CCRDataObjectID")="" - . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.CodingSystem")="" - . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Value")="" - . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Version")="" - . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Text")="" - . ;S GC(GM,ZI,GD_".Indication.Problem.Source.Actor.ActorID")="" - . ;S GC(GM,ZI,GD_".Indication.Problem.Type.Text")="" - . ;S GC(GM,ZI,GD_".Interval.Units.Unit")="@@MEDINTERVALUNIT@@" - . ;S GC(GM,ZI,GD_".Interval.Value")="@@MEDINTERVALVALUE@@" - . ;S GC(GM,ZI,GD_".MultipleDirectionModifier.Text")="@@MEDMULDIRMOD@@" - . S GC(GM,ZI,GD_".Route.Text")=$G(@GA@("doses.dose@route")) - . ;S GC(GM,ZI,GD_".StopIndicator.Text")="@@MEDSTOPINDICATOR@@" - . ;S GC(GM,ZI,GD_".Vehicle.Text")="@@MEDVEHICLETEXT@@" - . ;S GC(GM,ZI,"FullfillmentInstructions.Text")="" - . ;S GC(GM,ZI,"IDs.ID")="@@MEDRXNO@@" - . ;S GC(GM,ZI,"IDs.Type.Text")="@@MEDRXNOTXT@@" - . ;S GC(GM,ZI,"PatientInstructions.Instruction.Text")="@@MEDPTINSTRUCTIONS@@" - . ;S GC(GM,ZI,"Product.BrandName.Text")="@@MEDBRANDNAMETEXT@@" - . S GC(GM,ZI,"Product.Concentration.Units.Unit")=$G(@GA@("doses.dose@units")) - . S GC(GM,ZI,"Product.Concentration.Value")=$G(@GA@("doses.dose@dose")) - . S GC(GM,ZI,"Product.Form.Text")=$G(@GA@("form@value")) - . N GV S GV=$G(@GA@("products.product.vaProduct@vuid")) - . N GR S GR=$$RXNCUI3^C0PLKUP(GV) - . S GC(GM,ZI,"Product.ProductName.Code.CodingSystem")=$S(GR:"RxNorm",1:"VUID") - . S GC(GM,ZI,"Product.ProductName.Code.Value")=$S(GR:GR,1:GV) - . S GC(GM,ZI,"Product.ProductName.Code.Version")="08AB_081201F" - . S GC(GM,ZI,"Product.ProductName.Text")=$G(@GA@("name@value")) - . S GC(GM,ZI,"Product.Strength.Units.Unit")=$G(@GA@("doses.dose@units")) - . S GC(GM,ZI,"Product.Strength.Value")=$G(@GA@("doses.dose@dose")) - . ;S GC(GM,ZI,"Quantity.Units.Unit")="@@MEDQUANTITYUNIT@@" - . ;S GC(GM,ZI,"Quantity.Value")="@@MEDQUANTITYVALUE@@" - . ;S GC(GM,ZI,"Refills.Refill.Number")="@@MEDRFNO@@" - . N GDUZ S GDUZ=$G(@GA@("orderingProvider@code")) ;PROVIDER DUZ - . S GC(GM,ZI,"Source.Actor.ActorID")="PROVIDER_"_GDUZ - . S GC(GM,ZI,"Status.Text")=$G(@GA@("status@value")) - . S GC(GM,ZI,"Type.Text")="Medication" - N C0CDOCID - S C0CDOCID=$$DOMI^C0CDOM("GC",,"Medications") ; insert to dom - D OUTXML^C0CDOM(MEDOUTXML,C0CDOCID,1) ; render the xml - N ZSIZE S ZSIZE=$O(@MEDOUTXML@(""),-1) - S @MEDOUTXML@(0)=ZSIZE ; RETURN STATUS IS NUMBER OF LINES OF XML - W !,MEDOUTXML - ;ZWR GN - ;ZWR GC - ;B - Q - ; +C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 + ;;1.0;C0C;;May 19, 2009;Build 38 + ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel. + ; Licensed under the terms of the GNU General Public License. + ; See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; --Revision History + ; July 2008 - Initial Version/GPL + ; July 2008 - March 2009 various revisions + ; March 2009 - Reconstruction of routine as driver for other med routines/SMH + ; June 2011 - Redone to support all meds using the FOIA NHIN routines/gpl + ; + Q + ; + ; THIS VERSION IS DEPRECATED BECAUSE IT DOES NOT GENEREATE XML IN + ; THE RIGHT ORDER... AND IT HAS TO BE IN THE RIGHT ORDER... :( + ; GPL + ; +EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template + ; DFN passed by reference + ; MEDXML and MEDOUTXML are passed by Name + ; MEDXML is the input template + ; MEDOUTXML is the output template + ; Both of them refer to ^TMP globals where the XML documents are stored + ; + N GN + D EN^C0CNHIN(.GN,DFN,"MED;",1) ; RETRIEVE NHIN ARRAY OF MEDS + ; this call uses GET^NHINV to retrieve xml of the meds and then + ; parses with MXML and uses DOMO^C0CDOM to extract an NHIN array + ; + ; we now create an NHIN Array of the Meds section of the CCR + ; + N ZI S ZI="" + F S ZI=$O(GN("med",ZI)) Q:ZI="" D ; for each med + . N GA S GA=$NA(GN("med",ZI)) + . N GM S GM="Medication" ; to keep the lines shorter + . S GC(GM,ZI,"CCRDataObjectID")="MED_"_ZI + . N ZD,ZD2 S ZD=$G(@GA@("ordered@value")) ; FILEMAN DATE + . I ZD="" S ZD=$G(@GA@("start@value")) ; for inpatient meds + . S ZD2=$$FMDTOUTC^C0CUTIL(ZD,"DT") + . S GC(GM,ZI,"DateTime[1].ExactDateTime")=ZD2 + . S GC(GM,ZI,"DateTime[1].Type.Text")="Documented Date" + . ;S GC(GM,ZI,"DateTime[2].ExactDateTime")="" + . ;S GC(GM,ZI,"DateTime[2].Type.Text")="" + . N GSIG S GSIG=$G(@GA@("sig")) + . I GSIG["|" S GSIG=$P(GSIG,"|",2) ; eRx has name of drug separated by | + . S GC(GM,ZI,"Description.Text")=GSIG + . N GD S GD="Directions.Direction" ; MAKING THE STRINGS SHORTER + . ;S GC(GM,ZI,GD_".DeliveryMethod.Text")="@@MEDDELIVERYMETHOD@@" + . ;S GC(GM,ZI,GD_".Description.Text")="" + . ;S GC(GM,ZI,GD_".DirectionSequenceModifier")="@@MEDDIRSEQ@@" + . ;S GC(GM,ZI,GD_".Dose.Rate.Units.Unit")="@@MEDRATEUNIT@@" + . ;S GC(GM,ZI,GD_".Dose.Rate.Value")="@@MEDRATEVALUE@@" + . ;S GC(GM,ZI,GD_".Dose.Units.Unit")="@@MEDDOSEUNIT@@" + . ;S GC(GM,ZI,GD_".Dose.Value")="@@MEDDOSEVALUE@@" + . ;S GC(GM,ZI,GD_".DoseIndicator.Text")="@@MEDDOSEINDICATOR@@" + . ;S GC(GM,ZI,GD_".Duration.Units.Unit")="@@MEDDURATIONUNIT@@" + . ;S GC(GM,ZI,GD_".Duration.Value")="@@MEDDURATIONVALUE@@" + . ;S GC(GM,ZI,GD_".Frequency.Value")="@@MEDFREQUENCYVALUE@@" + . ;S GC(GM,ZI,GD_".Indication.PRNFlag.Text")="@@MEDPRNFLAG@@" + . ;S GC(GM,ZI,GD_".Indication.Problem.CCRDataObjectID")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.CodingSystem")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Value")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Version")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Text")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Source.Actor.ActorID")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Type.Text")="" + . ;S GC(GM,ZI,GD_".Interval.Units.Unit")="@@MEDINTERVALUNIT@@" + . ;S GC(GM,ZI,GD_".Interval.Value")="@@MEDINTERVALVALUE@@" + . ;S GC(GM,ZI,GD_".MultipleDirectionModifier.Text")="@@MEDMULDIRMOD@@" + . S GC(GM,ZI,GD_".Route.Text")=$G(@GA@("doses.dose@route")) + . ;S GC(GM,ZI,GD_".StopIndicator.Text")="@@MEDSTOPINDICATOR@@" + . ;S GC(GM,ZI,GD_".Vehicle.Text")="@@MEDVEHICLETEXT@@" + . ;S GC(GM,ZI,"FullfillmentInstructions.Text")="" + . ;S GC(GM,ZI,"IDs.ID")="@@MEDRXNO@@" + . ;S GC(GM,ZI,"IDs.Type.Text")="@@MEDRXNOTXT@@" + . ;S GC(GM,ZI,"PatientInstructions.Instruction.Text")="@@MEDPTINSTRUCTIONS@@" + . ;S GC(GM,ZI,"Product.BrandName.Text")="@@MEDBRANDNAMETEXT@@" + . S GC(GM,ZI,"Product.Concentration.Units.Unit")=$G(@GA@("doses.dose@units")) + . S GC(GM,ZI,"Product.Concentration.Value")=$G(@GA@("doses.dose@dose")) + . S GC(GM,ZI,"Product.Form.Text")=$G(@GA@("form@value")) + . N GV S GV=$G(@GA@("products.product.vaProduct@vuid")) + . N GR S GR=$$RXNCUI3^C0PLKUP(GV) + . S GC(GM,ZI,"Product.ProductName.Code.CodingSystem")=$S(GR:"RxNorm",1:"VUID") + . S GC(GM,ZI,"Product.ProductName.Code.Value")=$S(GR:GR,1:GV) + . S GC(GM,ZI,"Product.ProductName.Code.Version")="08AB_081201F" + . S GC(GM,ZI,"Product.ProductName.Text")=$G(@GA@("name@value")) + . S GC(GM,ZI,"Product.Strength.Units.Unit")=$G(@GA@("doses.dose@units")) + . S GC(GM,ZI,"Product.Strength.Value")=$G(@GA@("doses.dose@dose")) + . ;S GC(GM,ZI,"Quantity.Units.Unit")="@@MEDQUANTITYUNIT@@" + . ;S GC(GM,ZI,"Quantity.Value")="@@MEDQUANTITYVALUE@@" + . ;S GC(GM,ZI,"Refills.Refill.Number")="@@MEDRFNO@@" + . N GDUZ S GDUZ=$G(@GA@("orderingProvider@code")) ;PROVIDER DUZ + . S GC(GM,ZI,"Source.Actor.ActorID")="PROVIDER_"_GDUZ + . S GC(GM,ZI,"Status.Text")=$G(@GA@("status@value")) + . S GC(GM,ZI,"Type.Text")="Medication" + N C0CDOCID + S C0CDOCID=$$DOMI^C0CDOM("GC",,"Medications") ; insert to dom + D OUTXML^C0CDOM(MEDOUTXML,C0CDOCID,1) ; render the xml + N ZSIZE S ZSIZE=$O(@MEDOUTXML@(""),-1) + S @MEDOUTXML@(0)=ZSIZE ; RETURN STATUS IS NUMBER OF LINES OF XML + W !,MEDOUTXML + ;ZWR GN + ;ZWR GC + ;B + Q + ; Index: ccr/branches/ohum/p/C0CNMED4.m =================================================================== --- ccr/branches/ohum/p/C0CNMED4.m (revision 1333) +++ ccr/branches/ohum/p/C0CNMED4.m (revision 1337) @@ -1,221 +1,221 @@ -C0CMED4 ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 - ;;0.1;CCDCCR;;;Build 1 - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ; General Public License See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE - ; - ; this routine has be adapted to retrieve meds from GET^NHINV by gpl 6/2011 - ; - ; MINXML is the Input XML Template, passed by name - ; DFN is Patient IEN - ; OUTXML is the resultant XML. - ; - ; MEDS is return array from API. - ; MED is holds each array element from MEDS, one medicine - ; MAP is a mapping variable map (store result) for each med - ; - ; Inpatient Meds will be extracted using this routine and and the one following. - ; Inpatient Meds Unit Dose is going to be C0CMED4 - ; Inpatient Meds IVs is going to be C0CMED5 - ; - ; We will use two Pharmacy ReEnginnering API's: - ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info - ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info - ; For more information, see the PRE documentation at: - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf - ; - ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient - ; - N MEDS,MAP - ;K ^TMP($J) - ;D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*) - ;I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT ; No Meds - Quit - ;; Otherwise, we go on... - D EN^C0CNHIN(.MEDS,DFN,"MED;") ; gpl get the NHIN Array of meds - I '$D(MEDS) Q ; no meds - N ZI S ZI="" - N ZCOUNT S ZCOUNT=0 - F S ZI=$O(MEDS("med",ZI)) Q:ZI="" D ; for each returned med - . I $G(MEDS("med",ZI,"vaType@value"))="I" S ZCOUNT=ZCOUNT+1 - IF ZCOUNT=0 Q ; no inpatient meds - ;M MEDS=^TMP($J,"UD") - I DEBUG ZWR MEDS - S MEDMAP=$NA(^TMP("C0CCCR",$J,"MEDMAP")) - ;N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array - N I S I=0 - F S I=$O(MEDS("med",I)) Q:'I D ; For each medication - . N MED M MED=MEDS("med",I) - . I $G(MED("vaType@value"))'="I" Q ; not inpatient - . S MEDCOUNT=MEDCOUNT+1 - . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter - . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) - . ;N RXIEN S RXIEN=MED(.01) ; Order Number - . N RXIEN S RXIEN=$G(MED("orderID@value")) ; ien of the med - . I DEBUG W "RXIEN IS ",RXIEN,! - . I DEBUG W "MAP= ",MAP,! - . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN - . S @MAP@("MEDISSUEDATETXT")="Order Date" - . ;S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT") - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($G(MED("start@value")),"DT") - . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient - . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient - . S @MAP@("MEDRXNOTXT")="" ; For Outpatient - . S @MAP@("MEDRXNO")="" ; For Outpatient - . S @MAP@("MEDTYPETEXT")="Medication" - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses - . ;S @MAP@("MEDSTATUSTEXT")="ACTIVE" - . N C0CMST S C0CMST=$G(MED("vaStatus@value")) ; need to filter status - . I C0CMST="EXPIRED" S C0CMST="Prior History No Longer Active" - . I C0CMST="ACTIVE" S C0CMST="Active" ; - . S @MAP@("MEDSTATUSTEXT")=C0CMST - . ;S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$G(MED("orderingProvider@code")) - . ;S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) - . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value")) - . ; NDC is field 31 in the drug file. - . ; The actual drug entry in the drug file is not necessarily supplied. - . ; It' node 1, internal form. - . ;N MEDIEN S MEDIEN=MED(1,"I") - . ;S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") - . N ZVUID S ZVUID=$G(MED("products.product.vaProduct@vuid")) ; VUID - . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION - . D ; - . . S ZC=$$CODE^C0CUTIL(ZVUID) - . . S ZCD=$P(ZC,"^",1) ; CODE TO USE - . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID - . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION - . ;N ZRXNORM S ZRXNORM="" - . ;S ZRXNORM=$$RXNCUI3^C0PLKUP(ZVUID) - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=ZCD - . ;S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=ZCDS - . ;S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") - . S @MAP@("MEDPRODUCTNAMECODEVERSION")=ZCDSV - . S @MAP@("MEDBRANDNAMETEXT")="" - . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))_" "_ZCDS_": "_ZCD - . ;I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") - . ;I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) - . ;S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") - . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("doses.dose@dose")) - . ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") - . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("doses.dose@units")) - . ; Units, concentration, etc, come from another call - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters - . ; NDF Entry IEN, and VA Product Name - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") - . ; Documented in the same manual. - . ;N NDFDATA,CONCDATA - . ;I $L(MEDIEN) D - . ;. D NDF^PSS50(MEDIEN,,,,,"CONC") - . ;. M NDFDATA=^TMP($J,"CONC",MEDIEN) - . ;. N NDFIEN S NDFIEN=$P(NDFDATA(20),U) - . ;. N VAPROD S VAPROD=$P(NDFDATA(22),U) - . ;. ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" - . ;. ; and this will crash the call. So... - . ;. I NDFIEN="" S CONCDATA="" - . ;. E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) - . ;E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. - . ;S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") - . S @MAP@("MEDFORMTEXT")=$G(MED("form@value")) - . ;S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") - . S @MAP@("MEDCONCVALUE")=$G(MED("doses.dose@dose")) - . ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") - . S @MAP@("MEDCONCUNIT")=$G(MED("doses.does@units")) - . ;S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. - . S @MAP@("MEDQUANTITYVALUE")=$G(MED("doses.dose@unitsPerDose")) ; - . ; Oddly, there is no easy place to find the dispense unit. - . ; It's not included in the original call, so we have to go to the drug file. - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") - . ; Node 14.5 is the Dispense Unit - . ;I $L(MEDIEN) D - . ;. D DATA^PSS50(MEDIEN,,,,,"QTY") - . ;. N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) - . ;. S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) - . ;E S @MAP@("MEDQUANTITYUNIT")="" - . S @MAP@("MEDQUANTITYUNIT")=$G(MED("dose.dose@unitsPerDose")) - . ; - . ; --- START OF DIRECTIONS --- - . ; Dosage is field 2, route is 3, schedule is 4 - . ; These are all free text fields, and don't point to any files - . ; For that reason, I will use the field I never used before: - . ; MEDDIRECTIONDESCRIPTIONTEXT - . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=$G(MED("sig")) - . ; $G(MED("products.product.vaProduct@name")) - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. - . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" - . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" - . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" - . ; - . ; --- END OF DIRECTIONS --- - . ; - . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" - . ;S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field - . S @MAP@("MEDPTINSTRUCTIONS")="" - . ;S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" - . S @MAP@("MEDRFNO")="" - . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) - . K @RESULT - . D MAP^C0CXPATH(MINXML,MAP,RESULT) - . ; D PARY^C0CXPATH(RESULT) - . ; MAPPING DIRECTIONS - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT - . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) - . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") - . ; N MDZ1,MDZNA - . N DIRCNT S DIRCNT=1 ; THERE ARE ALWAYS DIRECTIONS - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) - . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) - . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") - . D:MEDCOUNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy - . D:MEDCOUNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML - N MEDTMP,MEDI - D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ - . W "MEDICATION MISSING ",! - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! - Q - ; +C0CMED4 ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 + ;;0.1;CCDCCR;;; + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE + ; + ; this routine has be adapted to retrieve meds from GET^NHINV by gpl 6/2011 + ; + ; MINXML is the Input XML Template, passed by name + ; DFN is Patient IEN + ; OUTXML is the resultant XML. + ; + ; MEDS is return array from API. + ; MED is holds each array element from MEDS, one medicine + ; MAP is a mapping variable map (store result) for each med + ; + ; Inpatient Meds will be extracted using this routine and and the one following. + ; Inpatient Meds Unit Dose is going to be C0CMED4 + ; Inpatient Meds IVs is going to be C0CMED5 + ; + ; We will use two Pharmacy ReEnginnering API's: + ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info + ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info + ; For more information, see the PRE documentation at: + ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf + ; + ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient + ; + N MEDS,MAP + ;K ^TMP($J) + ;D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*) + ;I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT ; No Meds - Quit + ;; Otherwise, we go on... + D EN^C0CNHIN(.MEDS,DFN,"MED;") ; gpl get the NHIN Array of meds + I '$D(MEDS) Q ; no meds + N ZI S ZI="" + N ZCOUNT S ZCOUNT=0 + F S ZI=$O(MEDS("med",ZI)) Q:ZI="" D ; for each returned med + . I $G(MEDS("med",ZI,"vaType@value"))="I" S ZCOUNT=ZCOUNT+1 + IF ZCOUNT=0 Q ; no inpatient meds + ;M MEDS=^TMP($J,"UD") + I DEBUG ZWR MEDS + S MEDMAP=$NA(^TMP("C0CCCR",$J,"MEDMAP")) + ;N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array + N I S I=0 + F S I=$O(MEDS("med",I)) Q:'I D ; For each medication + . N MED M MED=MEDS("med",I) + . I $G(MED("vaType@value"))'="I" Q ; not inpatient + . S MEDCOUNT=MEDCOUNT+1 + . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter + . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) + . ;N RXIEN S RXIEN=MED(.01) ; Order Number + . N RXIEN S RXIEN=$G(MED("orderID@value")) ; ien of the med + . I DEBUG W "RXIEN IS ",RXIEN,! + . I DEBUG W "MAP= ",MAP,! + . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN + . S @MAP@("MEDISSUEDATETXT")="Order Date" + . ;S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT") + . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($G(MED("start@value")),"DT") + . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient + . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient + . S @MAP@("MEDRXNOTXT")="" ; For Outpatient + . S @MAP@("MEDRXNO")="" ; For Outpatient + . S @MAP@("MEDTYPETEXT")="Medication" + . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses + . ;S @MAP@("MEDSTATUSTEXT")="ACTIVE" + . N C0CMST S C0CMST=$G(MED("vaStatus@value")) ; need to filter status + . I C0CMST="EXPIRED" S C0CMST="Prior History No Longer Active" + . I C0CMST="ACTIVE" S C0CMST="Active" ; + . S @MAP@("MEDSTATUSTEXT")=C0CMST + . ;S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) + . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$G(MED("orderingProvider@code")) + . ;S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) + . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value")) + . ; NDC is field 31 in the drug file. + . ; The actual drug entry in the drug file is not necessarily supplied. + . ; It' node 1, internal form. + . ;N MEDIEN S MEDIEN=MED(1,"I") + . ;S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") + . N ZVUID S ZVUID=$G(MED("products.product.vaProduct@vuid")) ; VUID + . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION + . D ; + . . S ZC=$$CODE^C0CUTIL(ZVUID) + . . S ZCD=$P(ZC,"^",1) ; CODE TO USE + . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID + . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION + . ;N ZRXNORM S ZRXNORM="" + . ;S ZRXNORM=$$RXNCUI3^C0PLKUP(ZVUID) + . S @MAP@("MEDPRODUCTNAMECODEVALUE")=ZCD + . ;S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") + . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=ZCDS + . ;S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") + . S @MAP@("MEDPRODUCTNAMECODEVERSION")=ZCDSV + . S @MAP@("MEDBRANDNAMETEXT")="" + . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))_" "_ZCDS_": "_ZCD + . ;I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") + . ;I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) + . ;S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") + . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("doses.dose@dose")) + . ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") + . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("doses.dose@units")) + . ; Units, concentration, etc, come from another call + . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit + . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters + . ; NDF Entry IEN, and VA Product Name + . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") + . ; Documented in the same manual. + . ;N NDFDATA,CONCDATA + . ;I $L(MEDIEN) D + . ;. D NDF^PSS50(MEDIEN,,,,,"CONC") + . ;. M NDFDATA=^TMP($J,"CONC",MEDIEN) + . ;. N NDFIEN S NDFIEN=$P(NDFDATA(20),U) + . ;. N VAPROD S VAPROD=$P(NDFDATA(22),U) + . ;. ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" + . ;. ; and this will crash the call. So... + . ;. I NDFIEN="" S CONCDATA="" + . ;. E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) + . ;E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. + . ;S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") + . S @MAP@("MEDFORMTEXT")=$G(MED("form@value")) + . ;S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") + . S @MAP@("MEDCONCVALUE")=$G(MED("doses.dose@dose")) + . ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") + . S @MAP@("MEDCONCUNIT")=$G(MED("doses.does@units")) + . ;S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. + . S @MAP@("MEDQUANTITYVALUE")=$G(MED("doses.dose@unitsPerDose")) ; + . ; Oddly, there is no easy place to find the dispense unit. + . ; It's not included in the original call, so we have to go to the drug file. + . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") + . ; Node 14.5 is the Dispense Unit + . ;I $L(MEDIEN) D + . ;. D DATA^PSS50(MEDIEN,,,,,"QTY") + . ;. N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) + . ;. S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) + . ;E S @MAP@("MEDQUANTITYUNIT")="" + . S @MAP@("MEDQUANTITYUNIT")=$G(MED("dose.dose@unitsPerDose")) + . ; + . ; --- START OF DIRECTIONS --- + . ; Dosage is field 2, route is 3, schedule is 4 + . ; These are all free text fields, and don't point to any files + . ; For that reason, I will use the field I never used before: + . ; MEDDIRECTIONDESCRIPTIONTEXT + . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=$G(MED("sig")) + . ; $G(MED("products.product.vaProduct@name")) + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. + . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" + . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" + . ; + . ; --- END OF DIRECTIONS --- + . ; + . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" + . ;S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field + . S @MAP@("MEDPTINSTRUCTIONS")="" + . ;S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field + . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" + . S @MAP@("MEDRFNO")="" + . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) + . K @RESULT + . D MAP^C0CXPATH(MINXML,MAP,RESULT) + . ; D PARY^C0CXPATH(RESULT) + . ; MAPPING DIRECTIONS + . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) + . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") + . ; N MDZ1,MDZNA + . N DIRCNT S DIRCNT=1 ; THERE ARE ALWAYS DIRECTIONS + . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS + . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION + . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) + . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) + . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") + . D:MEDCOUNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy + . D:MEDCOUNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML + N MEDTMP,MEDI + D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "MEDICATION MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; Index: ccr/branches/ohum/p/C0CORSLT.m =================================================================== --- ccr/branches/ohum/p/C0CORSLT.m (revision 1333) +++ ccr/branches/ohum/p/C0CORSLT.m (revision 1337) @@ -1,69 +1,69 @@ -C0CORSLT ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11 - ;;1.0;C0C;;Jan 21, 2010;Build 1 - ;Copyright 2011 George Lilly. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EN(ZVARS,DFN) ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS - ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE - ; AN EXAMPLE IS EKG RESULTS THAT ARE FOUND IN NOTES AND CONSULTS - ; THIS IS CREATED FOR MU CERTIFICATION BY GPL - D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE - N ZN ; RESULT NUMBER - S ZN=$O(@ZVARS@(""),-1) ; NEXT RESULT - N ZI S ZI="" - F S ZI=$O(VISIT(ZI)) Q:ZI="" D ; FOR EACH VISIT - . I $G(VISIT(ZI,"TEXT",1))["ECG DONE" D ; GOT AN ECG - . . S ZN=ZN+1 ; INCREMENT RESULT COUNT - . . N ZDATE,ZPRV,ZTXT - . . S ZDATE=$G(VISIT(ZI,"DATE",0)) ; DATE OF PROCEDURE - . . S ZPRV=$P($G(VISIT(ZI,"PRV",2)),"^",1) ;PROVIDER - . . S ZTXT=$P($G(VISIT(ZI,"TEXT",4)),"ECG RESULTS: ",2) - . . S @ZVARS@(ZN,"RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") - . . S @ZVARS@(ZN,"RESULTCODE")="34534-8" - . . S @ZVARS@(ZN,"RESULTCODINGSYSTEM")="LOINC" - . . S @ZVARS@(ZN,"RESULTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" - . . S @ZVARS@(ZN,"RESULTOBJECTID")="RESULT"_ZN - . . S @ZVARS@(ZN,"RESULTSOURCEACTORID")="ACTORPROVIDER_"_ZPRV - . . S @ZVARS@(ZN,"RESULTSTATUS")="" - . . S @ZVARS@(ZN,"M","TEST",0)=1 - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODEVALUE")="34534-8" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODINGSYSTEM")="LOINC" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTFLAG")="" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALDESCTEXT")="" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALSOURCEACTORID")="ACTORORGANIZATION_VASTANUM" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTOBJECTID")="RESULTTEST_ECG_"_ZN - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSOURCEACTORID")="ACTORPROVIDER"_ZPRV - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSTATUSTEXT")="F" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTUNITS")="" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTVALUE")=ZTXT - . . S @ZVARS@(0)=ZN ; UPDATE RESULTS COUNT - Q - ; -OLD ; OLD CODE FOR OTHER WAYS OF DOING THE ECG - ; FOR CERTIFICATION - SAVE EKG RESULTS gpl - W !,"CPT=",ZCPT - I ZCPT["93000" D ; THIS IS AN EKG - . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS - . M ^GPL("RNF2")=@C0CPRSLT - Q - ; +C0CORSLT ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11 + ;;1.0;C0C;;Jan 21, 2010;Build 38 + ;Copyright 2011 George Lilly. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EN(ZVARS,DFN) ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS + ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE + ; AN EXAMPLE IS EKG RESULTS THAT ARE FOUND IN NOTES AND CONSULTS + ; THIS IS CREATED FOR MU CERTIFICATION BY GPL + D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE + N ZN ; RESULT NUMBER + S ZN=$O(@ZVARS@(""),-1) ; NEXT RESULT + N ZI S ZI="" + F S ZI=$O(VISIT(ZI)) Q:ZI="" D ; FOR EACH VISIT + . I $G(VISIT(ZI,"TEXT",1))["ECG DONE" D ; GOT AN ECG + . . S ZN=ZN+1 ; INCREMENT RESULT COUNT + . . N ZDATE,ZPRV,ZTXT + . . S ZDATE=$G(VISIT(ZI,"DATE",0)) ; DATE OF PROCEDURE + . . S ZPRV=$P($G(VISIT(ZI,"PRV",2)),"^",1) ;PROVIDER + . . S ZTXT=$P($G(VISIT(ZI,"TEXT",4)),"ECG RESULTS: ",2) + . . S @ZVARS@(ZN,"RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") + . . S @ZVARS@(ZN,"RESULTCODE")="34534-8" + . . S @ZVARS@(ZN,"RESULTCODINGSYSTEM")="LOINC" + . . S @ZVARS@(ZN,"RESULTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" + . . S @ZVARS@(ZN,"RESULTOBJECTID")="RESULT"_ZN + . . S @ZVARS@(ZN,"RESULTSOURCEACTORID")="ACTORPROVIDER_"_ZPRV + . . S @ZVARS@(ZN,"RESULTSTATUS")="" + . . S @ZVARS@(ZN,"M","TEST",0)=1 + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODEVALUE")="34534-8" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODINGSYSTEM")="LOINC" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTFLAG")="" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALDESCTEXT")="" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALSOURCEACTORID")="ACTORORGANIZATION_VASTANUM" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTOBJECTID")="RESULTTEST_ECG_"_ZN + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSOURCEACTORID")="ACTORPROVIDER"_ZPRV + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSTATUSTEXT")="F" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTUNITS")="" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTVALUE")=ZTXT + . . S @ZVARS@(0)=ZN ; UPDATE RESULTS COUNT + Q + ; +OLD ; OLD CODE FOR OTHER WAYS OF DOING THE ECG + ; FOR CERTIFICATION - SAVE EKG RESULTS gpl + W !,"CPT=",ZCPT + I ZCPT["93000" D ; THIS IS AN EKG + . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS + . M ^GPL("RNF2")=@C0CPRSLT + Q + ; Index: ccr/branches/ohum/p/C0CPARMS.m =================================================================== --- ccr/branches/ohum/p/C0CPARMS.m (revision 1333) +++ ccr/branches/ohum/p/C0CPARMS.m (revision 1337) @@ -1,74 +1,62 @@ -C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; -SET(INPARMS) ;INITIALIZE RUNTIME PARMS USING INPARMS TO OVERRIDE DEFAULTS - ; PARAMETERS ARE PASSED AS A STRING: "PARM1:VALUE1^PARM2:VALUE2^ETC" - ; THE SAME FORMAT IS USED BY RPC AND COMMAND LINE ENTRY POINTS - ; - N PTMP ; - S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;BASE FOR THIS RUN - K @C0CPARMS ;START WITH EMPTY PARMS; MAY NOT WANT TO DO THIS KILL - I $G(INPARMS)'="" D ; OVERRIDES PROVIDED - . N C0CI S C0CI="" - . N C0CN S C0CN=1 - . F S C0CI=$P(INPARMS,"^",C0CN) Q:C0CI="" D ; - . . S C0CN=C0CN+1 ;NEXT PARM - . . N C1,C2 - . . S C1=$P(C0CI,":",1) ; PARAMETER - . . S C2=$P(C0CI,":",2) ; VALUE - . . I C2="" S C2=1 - . . S @C0CPARMS@(C1)=C2 - . I C0CN=1 S @C0CPARMS@($P(INPARMS,":",1))=$P(C0CI,":",2) ; ONLY ONE - ; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS - ; IF THEY FAIL, THE FOLLOWING WILL BE HARDCODED DEFAULTS - ;OHUM/RUT commented the hardcoded limits - ;I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH - ;I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY - ;I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS - ;I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY - ;I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY - ;I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS - ;I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES - ;I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO - ;I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE - S @C0CPARMS@("LABLIMIT")=^TMP("C0CCCR","LABLIMIT"),@C0CPARMS@("VITLIMIT")=^TMP("C0CCCR","VITLIMIT"),@C0CPARMS@("TIULIMIT")=^TMP("C0CCCR","TIULIMIT"),@C0CPARMS@("MEDLIMIT")=^TMP("C0CCCR","MEDLIMIT") - I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY - I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY - I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY - I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES - I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO - I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=1 ; NON-PENDING NON-ACTIVE - ;I '$D(@C0CPARMS@("RALIMIT")) S @C0CPARMS@("RALIMIT")="T-36500" ;ONE YR WORTH - ;I '$D(@C0CPARMS@("RASTART")) S @C0CPARMS@("RASTART")="T" ;TODAY - I '$D(@C0CPARMS@("TIUSTART")) S @C0CPARMS@("TIUSTART")="T" ;TODAY - ;OHUM/RUT - Q - ; -CHECK ; CHECK TO SEE IF PARMS ARE PRESENT, ELSE RUN SET - ; - I '$D(C0CPARMS) S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;SHOULDN'T HAPPEN - I '$D(@C0CPARMS) D SET("SETWITHCHECK:1") - Q - ; -GET(WHICHP) ;EXTRINSIC TO RETURN THE VALUE OF PARAMETER WHICHP - ; - D CHECK ; SHOULDN'T HAPPEN BUT TO BE SAFE - N GTMP - Q $G(@C0CPARMS@(WHICHP)) ;PULL THE PARM FROM THE TABLE - ; +C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; +SET(INPARMS) ;INITIALIZE RUNTIME PARMS USING INPARMS TO OVERRIDE DEFAULTS + ; PARAMETERS ARE PASSED AS A STRING: "PARM1:VALUE1^PARM2:VALUE2^ETC" + ; THE SAME FORMAT IS USED BY RPC AND COMMAND LINE ENTRY POINTS + ; + N PTMP ; + S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;BASE FOR THIS RUN + K @C0CPARMS ;START WITH EMPTY PARMS; MAY NOT WANT TO DO THIS KILL + I $G(INPARMS)'="" D ; OVERRIDES PROVIDED + . N C0CI S C0CI="" + . N C0CN S C0CN=1 + . F S C0CI=$P(INPARMS,"^",C0CN) Q:C0CI="" D ; + . . S C0CN=C0CN+1 ;NEXT PARM + . . N C1,C2 + . . S C1=$P(C0CI,":",1) ; PARAMETER + . . S C2=$P(C0CI,":",2) ; VALUE + . . I C2="" S C2=1 + . . S @C0CPARMS@(C1)=C2 + . I C0CN=1 S @C0CPARMS@($P(INPARMS,":",1))=$P(C0CI,":",2) ; ONLY ONE + ; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS + ; IF THEY FAIL, THE FOLLOWING WILL BE HARDCODED DEFAULTS + I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH + I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY + I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS + I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY + I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY + I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS + I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES + I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO + I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE + Q + ; +CHECK ; CHECK TO SEE IF PARMS ARE PRESENT, ELSE RUN SET + ; + I '$D(C0CPARMS) S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;SHOULDN'T HAPPEN + I '$D(@C0CPARMS) D SET("SETWITHCHECK:1") + Q + ; +GET(WHICHP) ;EXTRINSIC TO RETURN THE VALUE OF PARAMETER WHICHP + ; + D CHECK ; SHOULDN'T HAPPEN BUT TO BE SAFE + N GTMP + Q $G(@C0CPARMS@(WHICHP)) ;PULL THE PARM FROM THE TABLE + ; Index: ccr/branches/ohum/p/C0CPROBS.m =================================================================== --- ccr/branches/ohum/p/C0CPROBS.m (revision 1333) +++ ccr/branches/ohum/p/C0CPROBS.m (revision 1337) @@ -1,185 +1,185 @@ -C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008,2009 George Lilly, University of Minnesota. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; - ; PROCESS THE PROBLEMS SECTION OF THE CCR - ; -EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT PROBLEMS INTO PROVIDED XML TEMPLATE - ; - ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED - ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE - ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE - ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS - ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT - ; - N RPCRSLT,J,K,PTMP,X,VMAP,TBU - S TVMAP=$NA(^TMP("C0CCCR",$J,"PROBVALS")) - S TARYTMP=$NA(^TMP("C0CCCR",$J,"PROBARYTMP")) - K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES - I $$RPMS^C0CUTIL() D RPMS ; IF BGOPRB ROUTINE IS MISSING (IE RPMS) - I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT - Q - ; -RPMS ; GETS THE PROBLEM LIST FOR RPMS - S RPCGLO=$NA(^TMP("BGO",$J)) - D GET^BGOPROB(.RPCRSLT,DFN) ; CALL THE PROBLEM LIST RPC - ; FORMAT OF RPC: - ; Number Code [1] ^ Patient IEN [2] ^ ICD Code [3] ^ Modify Date [4] ^ Class [5] ^ Provider Narrative [6] ^ - ; Date Entered [7] ^ Status [8] ^ Date Onset [9] ^ Problem IEN [10] ^ Notes [11] ^ ICD9 IEN [12] ^ - ; ICD9 Short Name [13] ^ Provider [14] ^ Facility IEN [15] ^ Priority [16] - I '$D(@RPCGLO) W "NULL RESULT FROM GET^BGOPROB ",! S @OUTXML@(0)=0 Q - S J="" - F S J=$O(@RPCGLO@(J)) Q:J="" D ; FOR EACH PROBLEM IN THE LIST - . S VMAP=$NA(@TVMAP@(J)) - . K @VMAP - . I DEBUG W "VMAP= ",VMAP,! - . S PTMP=@RPCRSLT@(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY - . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL - . D GETN1^C0CRNF("C0CG1",9000011,$P(PTMP,U,10),"") ;GET VALUES BY NAME - . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM - . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,10) - . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,8)="A":"Active",$P(PTMP,U,8)="I":"Inactive",1:"") - . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,6) - . S @VMAP@("PROBLEMCODINGVERSION")="" - . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,3) - . ; FOR CERTIFICATION - GPL - . I @VMAP@("PROBLEMCODEVALUE")=493.90 S @VMAP@("PROBLEMCODEVALUE")=493 - . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT") - . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT") - . ;S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) ;UNKNOWN NOT MAPPED IN C0CCCR0 - . ;S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) ;UNKNOWN NOT MAPPED IN C0CCCR0 - . ;S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) ;NOT MAPPED IN C0CCCR0 - . ;S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) ;NOT MAPPED IN C0CCCR0 - . ;S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) ;NOT MAPPED IN C0CCCR0 - . ;S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) ;NOT MAPPED IN C0CCCR0 - . ;S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER - . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$$ZVALUEI^C0CRNF("RECORDING PROVIDER","C0CG1") - . ;S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) ;NOT MAPPED IN C0CCCR0 - . ;S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) ;NOT MAPPED IN C0CCCR0 - . ;S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") ;NOT MAPPED IN C0CCCR0 - . ;S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") ;NOT MAPPED IN C0CCCR0 - . S ARYTMP=$NA(@TARYTMP@(J)) - . ; W "ARYTMP= ",ARYTMP,! - . K @ARYTMP - . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ; - . I J=1 D ; FIRST ONE IS JUST A COPY - . . ; W "FIRST ONE",! - . . D CP^C0CXPATH(ARYTMP,OUTXML) - . . ; W "OUTXML ",OUTXML,! - . I J>1 D ; AFTER THE FIRST, INSERT INNER XML - . . D INSINNER^C0CXPATH(OUTXML,ARYTMP) - ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*) - ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS - ; ZWR @OUTXML - ; $$HTML^DILF( - ; GENERATE THE NARITIVE HTML FOR THE CCD - I CCD D CCD ; IF THIS IS FOR A CCD - D MISSINGVARS - Q - ; -VISTA ; GETS THE PROBLEM LIST FOR VISTA - D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC - I '$D(RPCRSLT(1)) D Q ; RPC RETURNS NULL - . W "NULL RESULT FROM LIST^ORQQPL3 ",! - . S @OUTXML@(0)=0 - . ; Q - ; I DEBUG ZWR RPCRSLT - S @TVMAP@(0)=RPCRSLT(0) ; SAVE NUMBER OF PROBLEMS - F J=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM IN THE LIST - . S VMAP=$NA(@TVMAP@(J)) - . K @VMAP - . I DEBUG W "VMAP= ",VMAP,! - . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY - . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM - . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1) - . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"") - . N ZPRIOR S ZPRIOR=$P(PTMP,U,14) ;PRIORITY FLAG - . ; turn off acute/chronic for certification gpl - . ;S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status - . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3) - . S @VMAP@("PROBLEMCODINGVERSION")="" - . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4) - . ; FOR CERTIFICATION - GPL - . I @VMAP@("PROBLEMCODEVALUE")["493.90" S @VMAP@("PROBLEMCODEVALUE")=493 - . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT") - . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT") - . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) - . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) - . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) - . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) - . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) - . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) - . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER - . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1) - . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) - . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) - . S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") - . S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") - . S ARYTMP=$NA(@TARYTMP@(J)) - . ; W "ARYTMP= ",ARYTMP,! - . K @ARYTMP - . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ; - . I J=1 D ; FIRST ONE IS JUST A COPY - . . ; W "FIRST ONE",! - . . D CP^C0CXPATH(ARYTMP,OUTXML) - . . ; W "OUTXML ",OUTXML,! - . I J>1 D ; AFTER THE FIRST, INSERT INNER XML - . . D INSINNER^C0CXPATH(OUTXML,ARYTMP) - ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*) - ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS - ; ZWR @OUTXML - ; $$HTML^DILF( - ; GENERATE THE NARITIVE HTML FOR THE CCD - I CCD D CCD ; IF THIS IS FOR A CCD - D MISSINGVARS - Q -CCD - N HTMP,HOUT,HTMLO,C0CPROBI,ZX - F C0CPROBI=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM - . S VMAP=$NA(@TVMAP@(C0CPROBI)) - . I DEBUG W "VMAP =",VMAP,! - . D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Body/PROBLEMS-HTML","HTMP") ; GET THE HTML FROM THE TEMPLATE - . D UNMARK^C0CXPATH("HTMP") ; REMOVE MARKUP - . ; D PARY^C0CXPATH("HTMP") ; PRINT IT - . D MAP^C0CXPATH("HTMP",VMAP,"HOUT") ; MAP THE VARIABLES - . ; D PARY^C0CXPATH("HOUT") ; PRINT IT AGAIN - . I C0CPROBI=1 D ; FIRST ONE IS JUST A COPY - . . D CP^C0CXPATH("HOUT","HTMLO") - . I C0CPROBI>1 D ; AFTER THE FIRST, INSERT INNER HTML - . . I DEBUG W "DOING INNER",! - . . N HTMLBLD,HTMLTMP - . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",1,HTMLO(0)-1) - . . D QUEUE^C0CXPATH("HTMLBLD","HOUT",2,HOUT(0)-1) - . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",HTMLO(0),HTMLO(0)) - . . D BUILD^C0CXPATH("HTMLBLD","HTMLTMP") - . . D CP^C0CXPATH("HTMLTMP","HTMLO") - . . ; D INSINNER^C0CXPATH("HOUT","HTMLO","//") - I DEBUG D PARY^C0CXPATH("HTMLO") - D INSB4^C0CXPATH(OUTXML,"HTMLO") ; INSERT AT TOP OF SECTION - Q -MISSINGVARS - N PROBSTMP,I - D MISSING^C0CXPATH(ARYTMP,"PROBSTMP") ; SEARCH XML FOR MISSING VARS - I PROBSTMP(0)>0 D ; IF THERE ARE MISSING VARS - - . ; STRINGS MARKED AS @@X@@ - . W !,"PROBLEMS Missing list: ",! - . F I=1:1:PROBSTMP(0) W PROBSTMP(I),! - Q - ; +C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008,2009 George Lilly, University of Minnesota. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; + ; PROCESS THE PROBLEMS SECTION OF THE CCR + ; +EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT PROBLEMS INTO PROVIDED XML TEMPLATE + ; + ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE + ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE + ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS + ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT + ; + N RPCRSLT,J,K,PTMP,X,VMAP,TBU + S TVMAP=$NA(^TMP("C0CCCR",$J,"PROBVALS")) + S TARYTMP=$NA(^TMP("C0CCCR",$J,"PROBARYTMP")) + K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES + I $$RPMS^C0CUTIL() D RPMS ; IF BGOPRB ROUTINE IS MISSING (IE RPMS) + I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT + Q + ; +RPMS ; GETS THE PROBLEM LIST FOR RPMS + S RPCGLO=$NA(^TMP("BGO",$J)) + D GET^BGOPROB(.RPCRSLT,DFN) ; CALL THE PROBLEM LIST RPC + ; FORMAT OF RPC: + ; Number Code [1] ^ Patient IEN [2] ^ ICD Code [3] ^ Modify Date [4] ^ Class [5] ^ Provider Narrative [6] ^ + ; Date Entered [7] ^ Status [8] ^ Date Onset [9] ^ Problem IEN [10] ^ Notes [11] ^ ICD9 IEN [12] ^ + ; ICD9 Short Name [13] ^ Provider [14] ^ Facility IEN [15] ^ Priority [16] + I '$D(@RPCGLO) W "NULL RESULT FROM GET^BGOPROB ",! S @OUTXML@(0)=0 Q + S J="" + F S J=$O(@RPCGLO@(J)) Q:J="" D ; FOR EACH PROBLEM IN THE LIST + . S VMAP=$NA(@TVMAP@(J)) + . K @VMAP + . I DEBUG W "VMAP= ",VMAP,! + . S PTMP=@RPCRSLT@(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY + . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL + . D GETN1^C0CRNF("C0CG1",9000011,$P(PTMP,U,10),"") ;GET VALUES BY NAME + . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM + . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,10) + . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,8)="A":"Active",$P(PTMP,U,8)="I":"Inactive",1:"") + . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,6) + . S @VMAP@("PROBLEMCODINGVERSION")="" + . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,3) + . ; FOR CERTIFICATION - GPL + . I @VMAP@("PROBLEMCODEVALUE")=493.90 S @VMAP@("PROBLEMCODEVALUE")=493 + . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT") + . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT") + . ;S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) ;UNKNOWN NOT MAPPED IN C0CCCR0 + . ;S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) ;UNKNOWN NOT MAPPED IN C0CCCR0 + . ;S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) ;NOT MAPPED IN C0CCCR0 + . ;S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) ;NOT MAPPED IN C0CCCR0 + . ;S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) ;NOT MAPPED IN C0CCCR0 + . ;S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) ;NOT MAPPED IN C0CCCR0 + . ;S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER + . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$$ZVALUEI^C0CRNF("RECORDING PROVIDER","C0CG1") + . ;S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) ;NOT MAPPED IN C0CCCR0 + . ;S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) ;NOT MAPPED IN C0CCCR0 + . ;S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") ;NOT MAPPED IN C0CCCR0 + . ;S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") ;NOT MAPPED IN C0CCCR0 + . S ARYTMP=$NA(@TARYTMP@(J)) + . ; W "ARYTMP= ",ARYTMP,! + . K @ARYTMP + . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ; + . I J=1 D ; FIRST ONE IS JUST A COPY + . . ; W "FIRST ONE",! + . . D CP^C0CXPATH(ARYTMP,OUTXML) + . . ; W "OUTXML ",OUTXML,! + . I J>1 D ; AFTER THE FIRST, INSERT INNER XML + . . D INSINNER^C0CXPATH(OUTXML,ARYTMP) + ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*) + ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS + ; ZWR @OUTXML + ; $$HTML^DILF( + ; GENERATE THE NARITIVE HTML FOR THE CCD + I CCD D CCD ; IF THIS IS FOR A CCD + D MISSINGVARS + Q + ; +VISTA ; GETS THE PROBLEM LIST FOR VISTA + D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC + I '$D(RPCRSLT(1)) D Q ; RPC RETURNS NULL + . W "NULL RESULT FROM LIST^ORQQPL3 ",! + . S @OUTXML@(0)=0 + . ; Q + ; I DEBUG ZWR RPCRSLT + S @TVMAP@(0)=RPCRSLT(0) ; SAVE NUMBER OF PROBLEMS + F J=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM IN THE LIST + . S VMAP=$NA(@TVMAP@(J)) + . K @VMAP + . I DEBUG W "VMAP= ",VMAP,! + . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY + . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM + . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1) + . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"") + . N ZPRIOR S ZPRIOR=$P(PTMP,U,14) ;PRIORITY FLAG + . ; turn off acute/chronic for certification gpl + . ;S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status + . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3) + . S @VMAP@("PROBLEMCODINGVERSION")="" + . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4) + . ; FOR CERTIFICATION - GPL + . I @VMAP@("PROBLEMCODEVALUE")["493.90" S @VMAP@("PROBLEMCODEVALUE")=493 + . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT") + . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT") + . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) + . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) + . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) + . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) + . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) + . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) + . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER + . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1) + . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) + . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) + . S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") + . S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") + . S ARYTMP=$NA(@TARYTMP@(J)) + . ; W "ARYTMP= ",ARYTMP,! + . K @ARYTMP + . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ; + . I J=1 D ; FIRST ONE IS JUST A COPY + . . ; W "FIRST ONE",! + . . D CP^C0CXPATH(ARYTMP,OUTXML) + . . ; W "OUTXML ",OUTXML,! + . I J>1 D ; AFTER THE FIRST, INSERT INNER XML + . . D INSINNER^C0CXPATH(OUTXML,ARYTMP) + ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*) + ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS + ; ZWR @OUTXML + ; $$HTML^DILF( + ; GENERATE THE NARITIVE HTML FOR THE CCD + I CCD D CCD ; IF THIS IS FOR A CCD + D MISSINGVARS + Q +CCD + N HTMP,HOUT,HTMLO,C0CPROBI,ZX + F C0CPROBI=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM + . S VMAP=$NA(@TVMAP@(C0CPROBI)) + . I DEBUG W "VMAP =",VMAP,! + . D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Body/PROBLEMS-HTML","HTMP") ; GET THE HTML FROM THE TEMPLATE + . D UNMARK^C0CXPATH("HTMP") ; REMOVE 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 + ; Index: ccr/branches/ohum/p/C0CPROC.m =================================================================== --- ccr/branches/ohum/p/C0CPROC.m (revision 1333) +++ ccr/branches/ohum/p/C0CPROC.m (revision 1337) @@ -1,146 +1,146 @@ -C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10 - ;;1.0;C0C;;Jan 21, 2010;Build 1 - ;Copyright 2010 George Lilly, University of Minnesota and others. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -SETVARS ; SET UP VARIABLES FOR PROCEDURES, ENCOUNTERS, AND NOTES - S C0CENC=$NA(^TMP("C0CCCR",$J,"C0CENC",DFN)) - S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN)) - S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN)) - ; ADDITION FOR CERTIFICATION - S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN)) - Q - ; -EXTRACT(PROCXML,DFN,PROCOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE - ; PROCXML AND PROCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED - ; - D SETVARS ; SET UP VARIABLES - I '$D(@C0CPRC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE - D MAP(PROCXML,C0CPRC,PROCOUT) ;MAP RESULTS FOR PROCEDURES - Q - ; -TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, - ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME - ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES - ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT - ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY - ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM - ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS - ; - K VISIT,LST,NOTE,C0CLPRC - ; C0CLPRC IS A LOOKUP TABLE FOR USE IN BUILDING ENCOUNTERS - ; FORMAT C0CLPRC(VISITIEN,CPT)=PROCOBJECTID FOR BUILDING LINKS TO PROCEDURES - D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE - ; NEED TO ADD START AND END DATES FROM PARAMETERS - N ZI S ZI="" - N PREVCPT,PREVDT S (PREVCPT,PREVDT)="" - F S ZI=$O(VISIT(ZI),-1) Q:ZI="" D ; REVERSE TIME ORDER - MOST RECENT FIRST - . N ZDATE - . S ZDATE=$$DATE(VISIT(ZI,"DATE",0)) - . S ZPRVARY=$NA(VISIT(ZI,"PRV")) - . N ZPRV - . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM - . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON - . N ZJ S ZJ="" - . F S ZJ=$O(VISIT(ZI,"CPT",ZJ)) Q:ZJ="" D ;FOR EACH CPT SEG - . . N ZRNF - . . N ZCPT S ZCPT=$$CPT(VISIT(ZI,"CPT",ZJ)) ;GET CPT CODE AND TEXT - . . I ZCPT'="" D ;IF CPT CODE IS PRESENT - . . . I (ZCPT=PREVCPT)&(ZDATE=PREVDT) Q ; NO DUPS ALLOWED - . . . W !,ZCPT," ",ZDATE," ",ZPRV - . . . S ZRNF("PROCACTOROBJID")=ZPRV - . . . N PROCCODE S PROCCODE=$P(ZCPT,U,1) - . . . S ZRNF("PROCCODE")=PROCCODE - . . . S ZRNF("PROCCODESYS")="CPT-4" - . . . S ZRNF("PROCDATETEXT")="Procedure Date" - . . . S ZRNF("PROCDATETIME")=ZDATE - . . . S ZRNF("PROCDESCOBJATTRCODE")="" ;NO PROC ATTRIBUTES YET - . . . S ZRNF("PROCDESCOBJATTR")="" - . . . S ZRNF("PROCDESCOBJATTRCODESYS")="" ;WE DON'T HAVE PROC ATTRIBUTES - . . . S ZRNF("PROCDESCOBJATTRVAL")="" - . . . S ZRNF("PROCDESCTEXT")=$P(ZCPT,U,3) - . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET - . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET - . . . ; additions for Certification - need to have EKG in Results - . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT - . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ - . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS - . . . S ZRNF("PROCSTATUS")="Completed" ; Is this right? - . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE - . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY - . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl - . . . W !,"CPT=",ZCPT - . . . I ZCPT["93000" D ; THIS IS AN EKG - . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS - . . . . M ^GPL("RNF2")=@C0CPRSLT - . . . S PREVCPT=ZCPT - . . . S PREVDT=ZDATE - N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"PROCEDURES")) - M @ZRIM=@C0CPRC@("V") - Q - ; -PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME - N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN="" - F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH PRV SEG - . I ZR'="" Q ;ONLY WANT THE FIRST PRIMARY PROVIDER - . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1) - I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR - Q ZRTN - ; -DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT - Q $$FMDTOUTC^C0CUTIL(ISTR,"DT") - ; -CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS - ; CPT^CATEGORY^TEXT - N Z1,Z2,Z3,ZRTN - S Z1=$P(ISTR,U,1) - I Z1="" D ; - . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1) - I Z1'="" D ; IF THERE IS A CPT CODE IN THERE - . ;S Z1=$P(ISTR,U,1) - . S Z2=$P(ISTR,U,2) - . S Z3=$P(ISTR,U,3) - . S ZRTN=Z1_U_Z2_U_Z3 - E S ZRTN="" - Q ZRTN - ; -MAP(PROCXML,C0CPRC,PROCOUT) ; MAP PROCEDURES XML - ; - N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"PROCTEMP")) ;WORK AREA FOR TEMPLATE - K @ZTEMP - N ZBLD - S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"PROCBLD")) ; BUILD LIST AREA - D QUEUE^C0CXPATH(ZBLD,PROCXML,1,1) ; FIRST LINE - N ZINNER - D QUERY^C0CXPATH(PROCXML,"//Procedures/Procedure","ZINNER") ;ONE PROC - N ZTMP,ZVAR,ZI - S ZI="" - F S ZI=$O(@C0CPRC@("V",ZI)) Q:ZI="" D ;FOR EACH PROCEDURE - . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS PROCEDURE XML - . S ZVAR=$NA(@C0CPRC@("V",ZI)) ;THIS PROCEDURE VARIABLES - . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE - . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD - D QUEUE^C0CXPATH(ZBLD,PROCXML,@PROCXML@(0),@PROCXML@(0)) - N ZZTMP - D BUILD^C0CXPATH(ZBLD,PROCOUT) ;BUILD FINAL XML - K @ZTEMP,@ZBLD,@C0CPRC - Q - ; +C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10 + ;;1.0;C0C;;Jan 21, 2010;Build 38 + ;Copyright 2010 George Lilly, University of Minnesota and others. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +SETVARS ; SET UP VARIABLES FOR PROCEDURES, ENCOUNTERS, AND NOTES + S C0CENC=$NA(^TMP("C0CCCR",$J,"C0CENC",DFN)) + S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN)) + S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN)) + ; ADDITION FOR CERTIFICATION + S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN)) + Q + ; +EXTRACT(PROCXML,DFN,PROCOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE + ; PROCXML AND PROCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; + D SETVARS ; SET UP VARIABLES + I '$D(@C0CPRC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE + D MAP(PROCXML,C0CPRC,PROCOUT) ;MAP RESULTS FOR PROCEDURES + Q + ; +TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, + ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME + ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES + ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT + ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY + ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM + ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS + ; + K VISIT,LST,NOTE,C0CLPRC + ; C0CLPRC IS A LOOKUP TABLE FOR USE IN BUILDING ENCOUNTERS + ; FORMAT C0CLPRC(VISITIEN,CPT)=PROCOBJECTID FOR BUILDING LINKS TO PROCEDURES + D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE + ; NEED TO ADD START AND END DATES FROM PARAMETERS + N ZI S ZI="" + N PREVCPT,PREVDT S (PREVCPT,PREVDT)="" + F S ZI=$O(VISIT(ZI),-1) Q:ZI="" D ; REVERSE TIME ORDER - MOST RECENT FIRST + . N ZDATE + . S ZDATE=$$DATE(VISIT(ZI,"DATE",0)) + . S ZPRVARY=$NA(VISIT(ZI,"PRV")) + . N ZPRV + . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM + . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON + . N ZJ S ZJ="" + . F S ZJ=$O(VISIT(ZI,"CPT",ZJ)) Q:ZJ="" D ;FOR EACH CPT SEG + . . N ZRNF + . . N ZCPT S ZCPT=$$CPT(VISIT(ZI,"CPT",ZJ)) ;GET CPT CODE AND TEXT + . . I ZCPT'="" D ;IF CPT CODE IS PRESENT + . . . I (ZCPT=PREVCPT)&(ZDATE=PREVDT) Q ; NO DUPS ALLOWED + . . . W !,ZCPT," ",ZDATE," ",ZPRV + . . . S ZRNF("PROCACTOROBJID")=ZPRV + . . . N PROCCODE S PROCCODE=$P(ZCPT,U,1) + . . . S ZRNF("PROCCODE")=PROCCODE + . . . S ZRNF("PROCCODESYS")="CPT-4" + . . . S ZRNF("PROCDATETEXT")="Procedure Date" + . . . S ZRNF("PROCDATETIME")=ZDATE + . . . S ZRNF("PROCDESCOBJATTRCODE")="" ;NO PROC ATTRIBUTES YET + . . . S ZRNF("PROCDESCOBJATTR")="" + . . . S ZRNF("PROCDESCOBJATTRCODESYS")="" ;WE DON'T HAVE PROC ATTRIBUTES + . . . S ZRNF("PROCDESCOBJATTRVAL")="" + . . . S ZRNF("PROCDESCTEXT")=$P(ZCPT,U,3) + . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET + . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET + . . . ; additions for Certification - need to have EKG in Results + . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT + . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ + . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS + . . . S ZRNF("PROCSTATUS")="Completed" ; Is this right? + . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE + . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY + . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl + . . . W !,"CPT=",ZCPT + . . . I ZCPT["93000" D ; THIS IS AN EKG + . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS + . . . . M ^GPL("RNF2")=@C0CPRSLT + . . . S PREVCPT=ZCPT + . . . S PREVDT=ZDATE + N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"PROCEDURES")) + M @ZRIM=@C0CPRC@("V") + Q + ; +PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME + N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN="" + F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH PRV SEG + . I ZR'="" Q ;ONLY WANT THE FIRST PRIMARY PROVIDER + . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1) + I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR + Q ZRTN + ; +DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT + Q $$FMDTOUTC^C0CUTIL(ISTR,"DT") + ; +CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS + ; CPT^CATEGORY^TEXT + N Z1,Z2,Z3,ZRTN + S Z1=$P(ISTR,U,1) + I Z1="" D ; + . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1) + I Z1'="" D ; IF THERE IS A CPT CODE IN THERE + . ;S Z1=$P(ISTR,U,1) + . S Z2=$P(ISTR,U,2) + . S Z3=$P(ISTR,U,3) + . S ZRTN=Z1_U_Z2_U_Z3 + E S ZRTN="" + Q ZRTN + ; +MAP(PROCXML,C0CPRC,PROCOUT) ; MAP PROCEDURES XML + ; + N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"PROCTEMP")) ;WORK AREA FOR TEMPLATE + K @ZTEMP + N ZBLD + S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"PROCBLD")) ; BUILD LIST AREA + D QUEUE^C0CXPATH(ZBLD,PROCXML,1,1) ; FIRST LINE + N ZINNER + D QUERY^C0CXPATH(PROCXML,"//Procedures/Procedure","ZINNER") ;ONE PROC + N ZTMP,ZVAR,ZI + S ZI="" + F S ZI=$O(@C0CPRC@("V",ZI)) Q:ZI="" D ;FOR EACH PROCEDURE + . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS PROCEDURE XML + . S ZVAR=$NA(@C0CPRC@("V",ZI)) ;THIS PROCEDURE VARIABLES + . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE + . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD + D QUEUE^C0CXPATH(ZBLD,PROCXML,@PROCXML@(0),@PROCXML@(0)) + N ZZTMP + D BUILD^C0CXPATH(ZBLD,PROCOUT) ;BUILD FINAL XML + K @ZTEMP,@ZBLD,@C0CPRC + Q + ; Index: ccr/branches/ohum/p/C0CPXRM.m =================================================================== --- ccr/branches/ohum/p/C0CPXRM.m (revision 1333) +++ ccr/branches/ohum/p/C0CPXRM.m (revision 1337) @@ -1,73 +1,74 @@ -C0CPXRM ; -DOIT ; - S G="PXRMXSEPCLINIC3110302.224804" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.223957" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.223738" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.223516" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.222158" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.213944" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.212219" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.211506" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.002714" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.001841" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.000846" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110115.141918" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110115.132312" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110115.131653" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110115.131008" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT988 3110224.210456" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT986 3110224.210456" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT932 3110224.210456" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT932 3110224.210455" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT8015 3110301.215142" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT8015 3110301.215141" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT5265 3110309.124047" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT5265 3110309.124046" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT4742 3101129.221201" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT4742 3101129.215741" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT4710 3101129.215701" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT3297 3101127.123134" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT32495 3110224.194246" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT32493 3110224.194246" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT32354 3110224.194246" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT32354 3110224.194245" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT31106 3110224.175105" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT31090 3110224.175105" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT30339 3110224.175105" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT30339 3110224.175103" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT2761 3110115.174109" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT2761 3110115.174108" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT27327 3110227.013658" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT27327 3110227.013657" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT27327 3110227.013523" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT27327 3110227.013522" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT27253 3110227.012747" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT27253 3110227.012746" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT2559 3110115.170835" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT25549 3110228.231135" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT25549 3110228.231134" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT2205 3101129.215343" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT21092 3110114.195621" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT21092 3110114.193803" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT19640 3110226.032943" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT19640 3110226.032941" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT19353 3101212.162833" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT18780 3110221.215603" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT18156 3101212.152654" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT17800 3110315.202432" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT1650 3110220.192925" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT16110 3110313.224636" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT16004 3110317.151215" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT16004 3110317.150834" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT14955 3110315.165018" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT14816 3110315.164839" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT14816 3110315.164512" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT12415 3110315.135514" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT11797 3110315.131141" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT11573 3110315.131811" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT10728 3110114.025022" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT10578 3110114.021524" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT10243 3110114.020338" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT10105 3101204.230554" ZWR ^XTMP(G,*) - Q - ; +C0CPXRM ; +;;; +DOIT ; + S G="PXRMXSEPCLINIC3110302.224804" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.223957" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.223738" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.223516" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.222158" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.213944" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.212219" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.211506" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.002714" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.001841" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.000846" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110115.141918" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110115.132312" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110115.131653" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110115.131008" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT988 3110224.210456" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT986 3110224.210456" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT932 3110224.210456" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT932 3110224.210455" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT8015 3110301.215142" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT8015 3110301.215141" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT5265 3110309.124047" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT5265 3110309.124046" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT4742 3101129.221201" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT4742 3101129.215741" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT4710 3101129.215701" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT3297 3101127.123134" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT32495 3110224.194246" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT32493 3110224.194246" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT32354 3110224.194246" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT32354 3110224.194245" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT31106 3110224.175105" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT31090 3110224.175105" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT30339 3110224.175105" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT30339 3110224.175103" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT2761 3110115.174109" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT2761 3110115.174108" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT27327 3110227.013658" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT27327 3110227.013657" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT27327 3110227.013523" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT27327 3110227.013522" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT27253 3110227.012747" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT27253 3110227.012746" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT2559 3110115.170835" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT25549 3110228.231135" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT25549 3110228.231134" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT2205 3101129.215343" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT21092 3110114.195621" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT21092 3110114.193803" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT19640 3110226.032943" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT19640 3110226.032941" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT19353 3101212.162833" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT18780 3110221.215603" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT18156 3101212.152654" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT17800 3110315.202432" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT1650 3110220.192925" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT16110 3110313.224636" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT16004 3110317.151215" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT16004 3110317.150834" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT14955 3110315.165018" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT14816 3110315.164839" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT14816 3110315.164512" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT12415 3110315.135514" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT11797 3110315.131141" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT11573 3110315.131811" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT10728 3110114.025022" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT10578 3110114.021524" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT10243 3110114.020338" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT10105 3101204.230554" ZWR ^XTMP(G,*) + Q + ; Index: ccr/branches/ohum/p/C0CQRY1.m =================================================================== --- ccr/branches/ohum/p/C0CQRY1.m (revision 1333) +++ ccr/branches/ohum/p/C0CQRY1.m (revision 1337) @@ -1,123 +1,123 @@ -LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99 13:48 - ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 1 - ; - Q - ; -CHKSC ; Check search NLT/LOINC codes - ; - N J - ; - S J=0 - F S J=$O(LA7SC(J)) Q:'J D - . N X - . S X=LA7SC(J) - . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D Q - . . S ^TMP("LA7-NLT",$J,$P(X,"^"))="" - . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D Q - . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))="" - . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed" - . K LA7SC(J) - Q - ; - ; -SPEC ; Convert HL7 Specimen Codes to File #61, Topography codes - ; Find all topographies that use this HL7 specimen code - N J,K,L - ; - S J=0 - F S J=$O(LA7SPEC(J)) Q:'J D - . S K=LA7SPEC(J),L=0 - . F S L=$O(^LAB(61,"HL7",K,L)) Q:'L S ^TMP("LA7-61",$J,L)="" - Q - ; - ; -BUILDMSG ; Build HL7 message with result of query - ; - N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X - ; - I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&" - S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5) - S (HLQ,HL("Q"))="""""" - ; Set flag to not send HL7 message - S LA7NOMSG=1 - ; Create dummy MSH to pass HL7 delimiters - S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS - D FILESEG^LA7VHLU(GBL,.LA7MSH) - ; - F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)="" - ; - ; Take search results and put in HL7 message structure - S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0 - ; F S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT D ;change per John M - F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" D Q:LA7QUIT - . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q - . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0 - . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR - . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR - . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR - . D OBX - ; - Q - ; - ; -PID ; Build PID segment - ; - N LA7PID - ; - S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3) - S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) - D DEM^LRX - D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL) - D FILESEG^LA7VHLU(GBL,.LA7PID) - S (LA("LRIDT"),LA("SUB"))="" - Q - ; - ; -ORC ; Build ORC segment - ; - N X - ; - S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5) - S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) - S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")) - S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4) - I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6) - S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0 - D ORC^LA7VORU - S LA("NLT")="" - ; - Q - ; - ; -OBR ; Build OBR segment - ; - N LA764,LA7NLT - ; - S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))="" - I $L(LA7NLT) D - . S LA764=+$O(^LAM("E",LA7NLT,0)) - . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01) - I LA("SUB")="CH" D - . D OBR^LA7VORU - . D NTE^LA7VORU - . S LA7OBXSN=0 - ; - Q - ; - ; -OBX ; Build OBX segment - ; - N LA7DATA,LA7VT - ; - S LA7NTESN=0 - I LA("SUB")="MI" D MI^LA7VORU1 Q - I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q - ; - S LA7VT=$QS(LA7ROOT,7) - D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH) - I '$D(LA7DATA) Q - D FILESEG^LA7VHLU(GBL,.LA7DATA) - ; Send any test interpretation from file #60 - D INTRP^LA7VORUA - ; - Q +LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99 13:48 + ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 31 + ; + Q + ; +CHKSC ; Check search NLT/LOINC codes + ; + N J + ; + S J=0 + F S J=$O(LA7SC(J)) Q:'J D + . N X + . S X=LA7SC(J) + . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D Q + . . S ^TMP("LA7-NLT",$J,$P(X,"^"))="" + . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D Q + . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))="" + . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed" + . K LA7SC(J) + Q + ; + ; +SPEC ; Convert HL7 Specimen Codes to File #61, Topography codes + ; Find all topographies that use this HL7 specimen code + N J,K,L + ; + S J=0 + F S J=$O(LA7SPEC(J)) Q:'J D + . S K=LA7SPEC(J),L=0 + . F S L=$O(^LAB(61,"HL7",K,L)) Q:'L S ^TMP("LA7-61",$J,L)="" + Q + ; + ; +BUILDMSG ; Build HL7 message with result of query + ; + N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X + ; + I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&" + S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5) + S (HLQ,HL("Q"))="""""" + ; Set flag to not send HL7 message + S LA7NOMSG=1 + ; Create dummy MSH to pass HL7 delimiters + S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS + D FILESEG^LA7VHLU(GBL,.LA7MSH) + ; + F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)="" + ; + ; Take search results and put in HL7 message structure + S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0 + ; F S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT D ;change per John M + F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" D Q:LA7QUIT + . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q + . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0 + . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR + . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR + . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR + . D OBX + ; + Q + ; + ; +PID ; Build PID segment + ; + N LA7PID + ; + S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3) + S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) + D DEM^LRX + D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL) + D FILESEG^LA7VHLU(GBL,.LA7PID) + S (LA("LRIDT"),LA("SUB"))="" + Q + ; + ; +ORC ; Build ORC segment + ; + N X + ; + S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5) + S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) + S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")) + S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4) + I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6) + S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0 + D ORC^LA7VORU + S LA("NLT")="" + ; + Q + ; + ; +OBR ; Build OBR segment + ; + N LA764,LA7NLT + ; + S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))="" + I $L(LA7NLT) D + . S LA764=+$O(^LAM("E",LA7NLT,0)) + . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01) + I LA("SUB")="CH" D + . D OBR^LA7VORU + . D NTE^LA7VORU + . S LA7OBXSN=0 + ; + Q + ; + ; +OBX ; Build OBX segment + ; + N LA7DATA,LA7VT + ; + S LA7NTESN=0 + I LA("SUB")="MI" D MI^LA7VORU1 Q + I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q + ; + S LA7VT=$QS(LA7ROOT,7) + D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH) + I '$D(LA7DATA) Q + D FILESEG^LA7VHLU(GBL,.LA7DATA) + ; Send any test interpretation from file #60 + D INTRP^LA7VORUA + ; + Q Index: ccr/branches/ohum/p/C0CQRY2.m =================================================================== --- ccr/branches/ohum/p/C0CQRY2.m (revision 1333) +++ ccr/branches/ohum/p/C0CQRY2.m (revision 1337) @@ -1,184 +1,184 @@ -LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09 - ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994;Build 1 - ; JMC - mods to check for IHS V LAB file - ; - Q - ; -PATID ; Resolve patient id and establish patient environment - ; - N LA7X - ; - S (DFN,LRDFN)="",LA7PTYP=0 - ; - ; SSN passed as patient identifier - I LA7PTID?9N.1A D - . S LA7PTYP=1 - . S LA7X=$O(^DPT("SSN",LA7PTID,0)) - . I LA7X>0 D SETDFN(LA7X) - ; - ; MPI/ICN (integration control number) passed as patient identifier - I LA7PTID?10N1"V"6N D - . S LA7PTYP=2 - . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V")) - . I LA7X>0 D SETDFN(LA7X) - ; - ; If no patient identified/no laboratory record - return exception message - I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed" - I 'DFN S LA7ERR(2)="No patient found with requested identifier" - I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient" - I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient" - Q - ; - ; -BCD ; Search by specimen collection date. - ; - N LA763,LA7QUIT - ; - S (LA7SDT(0),LA7EDT(0))=0 - I LA7SDT S LA7SDT(0)=9999999-LA7SDT - I LA7EDT S LA7EDT(0)=9999999-LA7EDT - ; - F LRSS="CH","MI","SP" D - . S (LA7QUIT,LRIDT)=0 - . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1) - . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT D - . . ; Quit if reached end of data or outside date criteria - . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q - . . D SEARCH - ; - Q - ; - ; -BRAD ; Search by results available date (completion date). - ; Assumes cross-references still exist for dates in LRO(69) global. - ; Collects specimen date/time values for a given LRDFN and completion date. - ; Cross-reference is by date only, time stripped from start date. - ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)="" - ; - N LA763,LA7DT,LA7ROOT,LA7SRC,X - ; - ; Check if orders still exist Iin file #69 for search range - S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0 - S X=$O(^LRO(69,LA7SDT(1))) - I X,XLA7EDT(1)) D - . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")" - . . F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN") D - . . . I $QS(LA7ROOT,6)'=LRDFN Q - . . . S LRIDT=$QS(LA7ROOT,7) - . . . F LRSS="CH","MI","SP" D SEARCH - ; - ; If no orders in #69 then do long search through file #63. - I 'LA7SRC D - . F LRSS="CH","MI","SP" D - . . S LRIDT=0 - . . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT D - . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) - . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)0 D SETDFN(LA7X) + ; + ; MPI/ICN (integration control number) passed as patient identifier + I LA7PTID?10N1"V"6N D + . S LA7PTYP=2 + . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V")) + . I LA7X>0 D SETDFN(LA7X) + ; + ; If no patient identified/no laboratory record - return exception message + I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed" + I 'DFN S LA7ERR(2)="No patient found with requested identifier" + I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient" + I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient" + Q + ; + ; +BCD ; Search by specimen collection date. + ; + N LA763,LA7QUIT + ; + S (LA7SDT(0),LA7EDT(0))=0 + I LA7SDT S LA7SDT(0)=9999999-LA7SDT + I LA7EDT S LA7EDT(0)=9999999-LA7EDT + ; + F LRSS="CH","MI","SP" D + . S (LA7QUIT,LRIDT)=0 + . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1) + . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT D + . . ; Quit if reached end of data or outside date criteria + . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q + . . D SEARCH + ; + Q + ; + ; +BRAD ; Search by results available date (completion date). + ; Assumes cross-references still exist for dates in LRO(69) global. + ; Collects specimen date/time values for a given LRDFN and completion date. + ; Cross-reference is by date only, time stripped from start date. + ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)="" + ; + N LA763,LA7DT,LA7ROOT,LA7SRC,X + ; + ; Check if orders still exist Iin file #69 for search range + S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0 + S X=$O(^LRO(69,LA7SDT(1))) + I X,XLA7EDT(1)) D + . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")" + . . F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN") D + . . . I $QS(LA7ROOT,6)'=LRDFN Q + . . . S LRIDT=$QS(LA7ROOT,7) + . . . F LRSS="CH","MI","SP" D SEARCH + ; + ; If no orders in #69 then do long search through file #63. + I 'LA7SRC D + . F LRSS="CH","MI","SP" D + . . S LRIDT=0 + . . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT D + . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) + . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)0 D APOST("SATTR","RIMTBL","IMMUNECODE") ;IMMUNIZATION CODES - I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES - . D APOST("SATTR","RIMTBL","MEDS") - . N ZR,ZI - . D GETPA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES - . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN - . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS - . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","MEDSCODE") ;CODES - . ; D PATD^C0CRIMA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES - I $D(@SBASE@("ALERTS",1)) D ; IF THE PATIENT HAS ALERTS - . D APOST("SATTR","RIMTBL","ALERTS") - . N ZR,ZI - . D GETPA(.ZR,SDFN,"ALERTS","ALERTAGENTPRODUCTCODEVALUE") ;REACTANT CODES - . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN - . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS - . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","ALERTSCODE") ;CODES - I $D(@SBASE@("RESULTS",1)) D ; IF THE PATIENT HAS LABS VARIABLES - . D APOST("SATTR","RIMTBL","RESULTS") - . N ZR,ZI - . S ZR(0)=0 ; INITIALIZE TO NONE - . D RPCGV(.ZR,SDFN,"RESULTS") ;CHECK FOR LABS CODES - . ; D PARY^C0CXPATH("ZR") ; - . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN - . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS - . . . I $P(ZR(ZI),"^",2)="RESULTTESTCODINGSYSTEM" D ; LOINC CODE CHECK - . . . . I $P(ZR(ZI),"^",3)="LOINC" D APOST("SATTR","RIMTBL","RESULTSLN") ; - ; D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED - I $D(@SBASE@("PROCEDURES",1)) D ; - . D APOST("SATTR","RIMTBL","PROCEDURES") - W "ATTRIBUTES: ",SATTR,! - Q SATTR - ; -RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES - K ^TMP("C0CRIM","RESUME") - K ^TMP("C0CRIM") - Q - ; -CLIST ; LIST THE CATEGORIES - ; - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS - N CLBASE,CLNUM,ZI,CLIDX - S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS")) - S CLNUM=@CLBASE@(0) - F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES - . S CLIDX=@CLBASE@(ZI) - . W "(",$P(@CLBASE@(CLIDX),"^",1) - . W ":",$P(@CLBASE@(CLIDX),"^",2),") " - . W CLIDX,! - ; D PARY^C0CXPATH(CLBASE) - Q - ; -CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES - ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT - ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE - ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME - ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, - ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" - ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES - ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY - ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING - ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY - ; NUMBER IE CTBL_X(CDFN)="" - ; - ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST - S CCTBL=$NA(@CBASE@(CTBL,"CATS")) - W "CBASE: ",CCTBL,! - ; - I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY - . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY - . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY - . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT - . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY - . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME - . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 - ; - S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY - S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT - S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK - ; - S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED - ; - S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT - W "PATS BASE: ",CPATLIST,! - S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST - ; - Q - ; -CHKSUM(CKDFN) ; DOES A CHECKSUM AND STORES IT IN MUMPS GLOBALS - ; - S C0CCKB=$NA(^TMP("C0CRIM","CHKSUM")) ;CHECKSUM BASE - S C0CGLB=$NA(^TMP("C0CRIM","VARS")) ;CCR VARIABLE BASE - S C0CI="" - F S C0CI=$O(@C0CGLB@(CKDFN,C0CI)) Q:C0CI="" D ;FOR EACH DOMAIN - . ;W "DFN:",CKDFN," DOMAIN:",C0CI,! - . S C0CJ=$NA(@C0CGLB@(CKDFN,C0CI)) - . I C0CI="HEADER" D ; HAVE TO TAKE OUT THE "DATE GENERATED" - . . S C0CDT=@C0CGLB@(CKDFN,C0CI,1,"DATETIME") - . . K @C0CGLB@(CKDFN,C0CI,1,"DATETIME") - . S C0CCK(C0CI)=$$CHKSUM^XUSESIG1(C0CJ) - . I C0CI="HEADER" D ; PUT IT BACK - . . S @C0CGLB@(CKDFN,C0CI,1,"DATETIME")=C0CDT - S C0CK="C0CCK" ; - S C0CALL=$$CHKSUM^XUSESIG1(C0CK) ;CHECKSUM OF ALL DOMAIN CHECKSUMS - S CHKR=0 ; RESULT DEFAULT - I $D(^TMP("C0CRIM","CHKSUM",CKDFN,"ALL")) D ; OLD CHECKSUM EXISTS - . I @C0CCKB@(CKDFN,"ALL")'=C0CALL S CHKR=1 - E S CHKR=1 ;CHECKSUM IS NEW - S @C0CCKB@(CKDFN,"ALL")=C0CALL - M @C0CCKB@(CKDFN,"DOMAIN")=C0CCK - ;ZWR ^TMP("C0CRIM","CHKSUM",CKDFN,*) - Q CHKR - ; -CCOUNT ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE - ; - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS - N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT - S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES - S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS - S ZTOT=0 ; INITIALIZE OVERALL TOTAL - F ZI=1:1:@ZCBASE@(0) D ; FOR ALL CATS - . S ZCNT=0 - . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY - . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME - . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST - . ; F ZJ=0:0 D Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS - . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT - . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,! - . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX)) - . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT))) - . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD - . S ZTOT=ZTOT+ZCNT - W "TOTAL: ",ZTOT,! - Q - ; -CNTLST(INLST) ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST - ; INLST IS PASSED BY NAME - N ZI,ZDX,ZCOUNT - W INLST,! - S ZCOUNT=0 - S ZDX="" - F ZI=$O(@INLST@(ZDX)):0 D Q:$O(@INLST@(ZDX))="" ; LOOP UNTIL THE END - . S ZCOUNT=ZCOUNT+1 - . S ZDX=$O(@INLST@(ZDX)) - . W "ZDX:",ZDX," ZCNT:",ZCOUNT,! - Q ZCOUNT - ; -XCPAT(CPATCAT,CPATPARM) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT - ; - I '$D(CPATPARM) S CPATPARM="" - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS - N ZI,ZJ,ZC,ZPATBASE - S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) - S ZI="" - F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END - . S ZI=$O(@ZPATBASE@(ZI)) - . D XPAT^C0CCCR(ZI,CPATPARM) ; EXPORT THE PATIENT TO A FILE - Q - ; -CPAT(CPATCAT) ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT - ; - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS - N ZI,ZJ,ZC,ZPATBASE - S ZC=0 ; COUNT FOR SPACING THE PRINTOUT - S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) - S ZI="" - F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END - . S ZI=$O(@ZPATBASE@(ZI)) - . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT - . W ZI," " - . I ZC=10 D ; NEW LINE - . . S ZC=0 - . . W ! - Q - ; -PATC(DFN) ; DISPLAY THE CATEGORY FOR THIS PATIENT - ; - N ATTR S ATTR="" - I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT - . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT - S ATTR=^TMP("C0CRIM","ATTR",DFN) - I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q ;NO ATTRIBUTES FOUND - I $D(^TMP("C0CRIM","RIMTBL","CATS",ATTR)) D ; FOUND A CAT - . N CAT - . S CAT=$P(^TMP("C0CRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT - . W CAT,": ",ATTR,! - Q - ; -APUSH(AMAP,AVAL) ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME) - ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT - ; AND AMAP(N)=AVAL IS THE NTH AVAL - ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE - ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE - ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED - ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED - ; - I '$D(@AMAP) D ; IF THE MAP DOES NOT EXIST - . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS - S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT - S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY - S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF - Q - ; -ASETUP ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL - I '$D(RIMBASE) S RIMBASE=$NA(^TMP("C0CRIM")) - I '$D(@RIMBASE) S @RIMBASE="" - I '$D(RIMTBL) S RIMTBL=$NA(^TMP("C0CRIM","RIMTBL","TABLE")) ; ATTR TABLE - S ^TMP("C0CRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES - Q - ; -AINIT ; INITIALIZE ATTRIBUTE TABLE - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS - K @RIMTBL - D APUSH(RIMTBL,"EXTRACTED") - D APUSH(RIMTBL,"NOTEXTRACTED") - D APUSH(RIMTBL,"HEADER") - D APUSH(RIMTBL,"NOPCP") - D APUSH(RIMTBL,"PCP") - D APUSH(RIMTBL,"PROBLEMS") - D APUSH(RIMTBL,"PROBCODE") - D APUSH(RIMTBL,"PROBNOCODE") - D APUSH(RIMTBL,"PROBDATE") - D APUSH(RIMTBL,"PROBNODATE") - D APUSH(RIMTBL,"VITALS") - D APUSH(RIMTBL,"VITALSCODE") - D APUSH(RIMTBL,"VITALSNOCODE") - D APUSH(RIMTBL,"VITALSDATE") - D APUSH(RIMTBL,"VITALSNODATE") - D APUSH(RIMTBL,"IMMUNE") - D APUSH(RIMTBL,"IMMUNECODE") - D APUSH(RIMTBL,"MEDS") - D APUSH(RIMTBL,"MEDSCODE") - D APUSH(RIMTBL,"MEDSNOCODE") - D APUSH(RIMTBL,"MEDSDATE") - D APUSH(RIMTBL,"MEDSNODATE") - D APUSH(RIMTBL,"ALERTS") - D APUSH(RIMTBL,"ALERTSCODE") - D APUSH(RIMTBL,"RESULTS") - D APUSH(RIMTBL,"RESULTSLN") - D APUSH(RIMTBL,"PROCEDURES") - D APUSH(RIMTBL,"ENCOUNTERS") - D APUSH(RIMTBL,"NOTES") - Q - ; -APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL - ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING - ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES - ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) - I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING - N USETBL - I '$D(@RIMBASE@("TABLES",PTBL)) D Q ; NO TABLE - . W "ERROR NO SUCH TABLE",! - S USETBL=@RIMBASE@("TABLES",PTBL) - S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL - Q -GETPA(RTN,DFN,ISEC,IVAR) ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN - ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT") - ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2 - ; IN SECTION "MEDS" - ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS - ; PENDING FOR MED 2 FOR PATIENT 2 - ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE - ; RETURNED. RTN IS PASSED BY REFERENCE - ; - S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE - I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES - S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES - I '$D(@ZVBASE@(DFN,ISEC,0)) D Q ; NO VARIABLES IN SECTION - . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,! - N ZZI,ZZS - S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT - ; ZWR @ZZS@(1) - S RTN(0)=@ZZS@(0) - F ZZI=1:1:RTN(0) D ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS) - . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE - . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE - Q - ; -PATD(DFN,ISEC,IVAR) ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR - ; - N ZR - D GETPA(.ZR,DFN,ISEC,IVAR) - I $D(ZR(0)) D PARY^C0CXPATH("ZR") - E W "NOTHING RETURNED",! - Q - ; -CAGET(RTN,IATTR) ; - ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR - ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE - ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC - Q - ; -PCLST(LSTRTN,IATTR) ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR - ; - I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES - N ZLST - S @LSTRTN@(0)=0 ; DEFAULT RETURN NONE - S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES - S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS - N ZNC ; ZNC IS NUMBER OF CATEGORIES - S ZNC=@ZCBASE@(0) - I ZNC=0 Q ; NO CATEGORIES TO SEARCH - N ZAP ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE - S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR) - N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT - F ZI=1:1:ZNC D ; FOR ALL CATEGORIES - . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT - . I $P(ZATBL,"^",ZAP)'="" D ; CAT HAS ATTR - . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL - . . M @LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT - S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS - S ZPAT=0 ; START AT FIRST PATIENT IN LIST - F S ZPAT=$O(@LSTRTN@(ZPAT)) Q:ZPAT="" D ; - . S ZCNT=ZCNT+1 - S @LSTRTN@(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY - Q - ; -DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR - ; - ;N ZR - D PCLST("ZR",CATTR) - I ZR(0)=0 D Q ; - . W "NO PATIENTS RETURNED",! - E D ; - . N ZI S ZI=0 - . F S ZI=$O(ZR(ZI)) Q:ZI="" D ; - . . W !,ZI - . ;D PARY^C0CXPATH("ZR") ; PRINT ARRAY - . W !,"COUNT=",ZR(0) - Q - ; -RPCGV(RTN,DFN,WHICH) ; RPC GET VARS - ; RETURNS IN RTN (PASSED BY REFERENCE) THE VARS AND VALUES - ; FOUND AT INARY RTN(X)="VAR^VALUE" RTN(0) IS THE COUNT - ; DFN IS THE PATIENT NUMBER. - ; WHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","IMMUNE" - ; OR OTHER SECTIONS AS THEY ARE ADDED - ; THIS IS MEANT TO BE AVAILABLE AS AN RPC - I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS - S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES - S RTN(0)=0 ; DEFAULT NOTHING IS RETURNED - N ZZGI - I WHICH="ALL" D ; VARIABLES FROM ALL SECTIONS - . F ZZGI="HEADER","PROBLEMS","VITALS","MEDS","ALERTS","RESULTS","IMMUNE","PROCEDURES" D ; - . . D ZGVWRK(ZZGI) ; DO EACH SECTION - . . I $G(DEBUG)'="" W "DID ",ZZGI,! - E D ZGVWRK(WHICH) ; ONLY ONE SECTION ASKED FOR - Q - ; -ZGVWRK(ZWHICH) ; DO ONE SECTION FOR RPCGV - ; - N ZZGN ; NAME FOR SECTION VARIABLES - S ZZGN=$NA(@ZVBASE@(DFN,ZWHICH)) ; BASE OF VARS FOR SECTION - ;I '$D(@ZZGN@(0)) Q ; NO VARS FOR THIS SECTION - I $O(@ZZGN@(""),-1)="" D ; - E D ; VARS EXIST - . N ZGVI,ZGVN - . S ZGVN=$O(@ZZGN@(""),-1) ;COUNT OF VARS - . F ZGVI=1:1:ZGVN D ; FOR EACH MULTIPLE IN SECTION - . . K ZZGA N ZZGA ; TEMP ARRAY FOR SECTION VARS - . . K ZZGN2 N ZZGN2 ; NAME FOR MULTIPLE - . . S ZZGN2=$NA(@ZZGN@(ZGVI)) - . . I $G(DEBUG)'="" W ZZGN2,!,$O(@ZZGN2@("")),! - . . D H2ARY^C0CXPATH("ZZGA",ZZGN2,ZGVI) ; CONVERT HASH TO ARRAY - . . ; D PARY^C0CXPATH("ZZGA") - . . D PUSHA^C0CXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN - Q - ; -DPATV(DFN,IWHICH) ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN C0CRIM - ; ALONG WITH SAMPLE VALUES. - ; IWHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","HEADER" - N GTMP - I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT - . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES - I '$D(IWHICH) S IWHICH="ALL" - D RPCGV(.GTMP,DFN,IWHICH) - D PARY^C0CXPATH("GTMP") - Q - ; -RIM2RNF(R2RTN,DFN,RWHICH) ; CONVERTS RIM VARIABLES TO RNF2 FORMAT - ; RETURN IN R2RTN, WHICH IS PASSED BY NAME - ; RWHICH IS RIM SECTION TO RETURN, DEFAULTS TO "ALL" - ; - I '$D(RWHICH) S RWHICH="ALL" - ;N R2TMP - I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT - . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES - D RPCGV(.R2TMP,DFN,RWHICH) ; RETRIEVE ALL THE VARIABLES I AN ARRAY - N R2I,R2J,R2X,R2X1,R2X2,R2Y,R2Z - F R2I=1:1:R2TMP(0) D ; FOR EVERY LINE OF THE ARRAY - . S R2X=$P(R2TMP(R2I),"^",1) ; OCCURANCE - . S R2Y=$P(R2TMP(R2I),"^",2) ; VARIABLE NAME - . I $L(R2Y)<4 Q ; SKIP SHORT VARIABLES (THEY ARE FOR DEBUGGING) - . S R2Z=$P(R2TMP(R2I),"^",3) ; VALUE - . I R2X[";" D ; THERES MULTIPLES - . . S R2X1=$P(R2X,";",1) ; FIRST INDEX - . . S R2X2=$P(R2X,";",2) ; SECOND INDEX - . . S R2J=R2Y_"["_R2X2_"]" ; BUILD THE VARIABLE NAME - . . S @R2RTN@("F",R2J,1)="" ; PUT VARIABLE NAME IN FIELD MAP - . . S @R2RTN@("V",R2X1,R2J,1)=R2Z ; PUT THE VALUE IN THE ARRAY - . E D ; NO SUB-MULTIPLES - . . S @R2RTN@("F",R2Y,1)="" ; PUT VARIABLE NAME IN FIELD MAP - . . S @R2RTN@("V",R2X,R2Y,1)=R2Z ; PUT THE VALUE IN THE ARRAY - Q - ; -RIM2CSV(DFN) ; WRITE THE RIM VARIABLES FOR A PATIENT TO A CSV FILE - ; - N R2CTMP,R2CARY - D RIM2RNF("R2CTMP",DFN) ; CONVERT VARIABLES TO RNF FORMAT - D RNF2CSV^C0CRNF("R2CARY","R2CTMP","NV") ; CONVERT RNF TO CSV FORMAT - D FILEOUT^C0CRNF("R2CARY","VARS-"_DFN_".csv") - Q - ; +C0CRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008,2009 George Lilly, University of Minnesota. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; THESE ROUTINES EXAMINE ONE OR MORE, UP TO ALL, OF THE PATIENTS ON THE + ; SYSTEM TO DETERMINE HOW COMPLETE THE RESULTING CCR OR CCD WOULD BE FOR + ; THESE PATIENTS. IT BEGINS TO MEASURE "HL7 RIM COHERENCE" WHICH IS HOW USEFUL + ; THE VARIABLES WILL BE TO A RIM-MODELED APPLICATION AFTER THEY ARE + ; CONVEYED VIA THE CCR OR CCD. + ; FACTORS THAT AFFECT RIM COHERENCE INCLUDE: + ; 1. THE PRESENSE OF CLINICAL DATA IN A SECTION + ; 2. ARE THE DATA ELEMENTS TIME-BOUND + ; 3. ARE THE DATA ELEMENTS CODED WITH SNOMED OR LOINC ETC + ; 4. ARE SOURCE ACTORS ASSOCIATED WITH THE DATA ELEMENTS + ; 5. ARE ACTORS IDENTIFIED REGARDING THEIR ROLE + ; .. AND OTHER FACTORS YET TO BE DETERMINED + ; + ; SINCE THESE MEASUREMENTS ARE DONE AT THE VARIABLE LEVEL, THEY + ; REFLECT ON RIM COHERENCE WHETHER THE CCR OR THE CCD IS USED FOR + ; CONVEYANCE TO THE RIM APPLICATION. + ; + ; +ANALYZE(BEGDFN,DFNCNT,APARMS) ; RIM COHERANCE ANALYSIS ROUTINE + ; BEGINS AT BEGDFN AND GOES FOR DFNCNT PATIENTS + ; TO RESUME AT NEXT PATIENT, USE BEGDFN="" + ; USE RESET^C0CRIMA TO RESET TO TOP OF PATIENT LIST + ; APARMS ARE PARAMETERS TO BE USED IN THE EXTRACTION + ; SEE C0CPARMS FOR SUPPORTED PARAMTERS + ; + N RIMARY,RIMTMP,RIMI,RIMDFN,RATTR + N CCRGLO + S C0CCHK=0 ; CHECKSUM FLAG + D ASETUP ; SET UP VARIABLES AND GLOBALS + D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE + I '$D(@RIMBASE@("RESUME")) S @RIMBASE@("RESUME")=$O(^DPT(0)) ; FIRST TIME + S RESUME=@RIMBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN + S RIMDFN=BEGDFN ; BEGIN WITH THE BEGDFN PATIENT + I RIMDFN="" S RIMDFN=RESUME + I +RIMDFN=0 D Q ; AT THE END OF THE PATIENTS + . W "END OF PATIENT LIST, CALL RESET^C0CRIMA",! + I '$D(APARMS) S APARMS="" ; DEFAULT NO OVERRIDE PARMS + F RIMI=1:1:DFNCNT D Q:+RIMDFN=0 ; FOR DFNCNT NUMBER OF PATIENTS OR END + . K @RIMBASE@("VARS",RIMDFN) ; CLEAR OUT OLD VARS + . D CCRRPC^C0CCCR(.CCRGLO,RIMDFN,APARMS,"CCR") ;PROCESS THE CCR + . W RIMDFN,! + . ; + . ; COPY ALL THE VARIABLES TO THE RIM MAP AREA INDEXED BY PATIENT + . ; + . I $D(^TMP("C0CCCR",$J,"PROBVALS",1)) D ; PROBLEM VARS EXISTS + . . M @RIMBASE@("VARS",RIMDFN,"PROBLEMS")=^TMP("C0CCCR",$J,"PROBVALS") + . . S @RIMBASE@("VARS",RIMDFN,"PROBLEMS",0)=$O(^TMP("C0CCCR",$J,"PROBVALS",""),-1) + . I $D(^TMP("C0CCCR",$J,"VITALS",1)) D ; VITALS VARS EXISTS + . . M @RIMBASE@("VARS",RIMDFN,"VITALS")=^TMP("C0CCCR",$J,"VITALS") + . I $D(^TMP("C0CCCR",$J,"MEDMAP",1)) D ; MEDS VARS EXISTS + . . M @RIMBASE@("VARS",RIMDFN,"MEDS")=^TMP("C0CCCR",$J,"MEDMAP") + . I $D(^TMP("C0CCCR",$J,"ALERTS",1,"ALERTOBJECTID")) D ; ALERTS EXIST + . . W "FOUND ALERT VARS",! + . . M @RIMBASE@("VARS",RIMDFN,"ALERTS")=^TMP("C0CCCR",$J,"ALERTS") + . I $D(^TMP("C0CCCR",$J,"RESULTS",0)) D ; RESULTS EXIST + . . W "FOUND RESULTS VARS",! + . . M @RIMBASE@("VARS",RIMDFN,"RESULTS")=^TMP("C0CCCR",$J,"RESULTS") + . S C0CCHK=0 + . I $$CHKSUM(RIMDFN) D ; CHECKSUM HAS CHANGED + . . W "CHECKSUM IS NEW OR HAS CHANGED",! + . . ;ZWR ^TMP("C0CRIM","CHKSUM",RIMDFN,*) + . . S C0CCHK=1 + . K ^TMP("C0CCCR",$J) ; KILL WORK AREA FOR CCR BUILDING + . ; + . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP + . ; + . S RATTR=$$SETATTR(RIMDFN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS + . S @RIMBASE@("ATTR",RIMDFN)=RATTR ; SAVE THE ATRIBUTES FOR THIS PAT + . ; + . ; INCREMENT THE COUNT OF PATIENTS WITH THESE ATTRIBUTES IN ATTRTBL + . ; + . ; I '$D(@RIMBASE@("ATTRTBL",RATTR)) D ; IF FIRST PAT WITH THESE ATTRS + . ; . S @RIMBASE@("ATTRTBL",RATTR)=0 ; DEFAULT VALUE TO BE INCREMENTED + . ; S @RIMBASE@("ATTRTBL",RATTR)=@RIMBASE@("ATTRTBL",RATTR)+1 ; INCREMENT + . ; + . N CATNAME,CATTBL + . ; S CATBASE=$NA(@RIMBASE@("ANALYSIS")) + . S CATNAME="" + . D CPUSH(.CATNAME,RIMBASE,"RIMTBL",RIMDFN,RATTR) ; ADD TO CATEGORY + . W "CATEGORY NAME: ",CATNAME,! + . ; + . F S RIMDFN=$O(^DPT(RIMDFN)) Q:'$$PTST^C0CSYS(RIMDFN) ; NEXT PATIENT + . ; PTST TESTS TO SEE IF PATIENT WAS MERGED + . ; IF CCRTEST=0, PTST WILL CHECK TO SEE IF THIS IS A TEST PATIENT + . ; AND WE SKIP IT + . S @RIMBASE@("RESUME")=RIMDFN ; WHERE WE ARE LEAVING OFF THIS RUN + ; D PARY^C0CXPATH(@RIMBASE@("ATTRTBL")) + Q + ; +SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS + N SBASE,SATTR + S SBASE=$NA(@RIMBASE@("VARS",SDFN)) + D APOST("SATTR","RIMTBL","HEADER") + I $D(@SBASE@("PROBLEMS",1)) D ; + . D APOST("SATTR","RIMTBL","PROBLEMS") + . ; W "POSTING PROBLEMS",! + I $D(@SBASE@("VITALS",1)) D APOST("SATTR","RIMTBL","VITALS") + I $D(@SBASE@("IMMUNE",1)) D ;IMMUNIZATIONS PRESENT + . D APOST("SATTR","RIMTBL","IMMUNE") + . N ZR,ZI + . D GETPA(.ZR,SDFN,"IMMUNE","IMMUNEPRODUCTCODE") + . I ZR(0)>0 D APOST("SATTR","RIMTBL","IMMUNECODE") ;IMMUNIZATION CODES + I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES + . D APOST("SATTR","RIMTBL","MEDS") + . N ZR,ZI + . D GETPA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES + . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN + . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS + . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","MEDSCODE") ;CODES + . ; D PATD^C0CRIMA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES + I $D(@SBASE@("ALERTS",1)) D ; IF THE PATIENT HAS ALERTS + . D APOST("SATTR","RIMTBL","ALERTS") + . N ZR,ZI + . D GETPA(.ZR,SDFN,"ALERTS","ALERTAGENTPRODUCTCODEVALUE") ;REACTANT CODES + . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN + . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS + . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","ALERTSCODE") ;CODES + I $D(@SBASE@("RESULTS",1)) D ; IF THE PATIENT HAS LABS VARIABLES + . D APOST("SATTR","RIMTBL","RESULTS") + . N ZR,ZI + . S ZR(0)=0 ; INITIALIZE TO NONE + . D RPCGV(.ZR,SDFN,"RESULTS") ;CHECK FOR LABS CODES + . ; D PARY^C0CXPATH("ZR") ; + . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN + . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS + . . . I $P(ZR(ZI),"^",2)="RESULTTESTCODINGSYSTEM" D ; LOINC CODE CHECK + . . . . I $P(ZR(ZI),"^",3)="LOINC" D APOST("SATTR","RIMTBL","RESULTSLN") ; + ; D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED + I $D(@SBASE@("PROCEDURES",1)) D ; + . D APOST("SATTR","RIMTBL","PROCEDURES") + W "ATTRIBUTES: ",SATTR,! + Q SATTR + ; +RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES + K ^TMP("C0CRIM","RESUME") + K ^TMP("C0CRIM") + Q + ; +CLIST ; LIST THE CATEGORIES + ; + I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS + N CLBASE,CLNUM,ZI,CLIDX + S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS")) + S CLNUM=@CLBASE@(0) + F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES + . S CLIDX=@CLBASE@(ZI) + . W "(",$P(@CLBASE@(CLIDX),"^",1) + . W ":",$P(@CLBASE@(CLIDX),"^",2),") " + . W CLIDX,! + ; D PARY^C0CXPATH(CLBASE) + Q + ; +CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES + ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT + ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE + ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME + ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, + ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" + ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES + ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY + ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING + ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY + ; NUMBER IE CTBL_X(CDFN)="" + ; + ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST + S CCTBL=$NA(@CBASE@(CTBL,"CATS")) + W "CBASE: ",CCTBL,! + ; + I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY + . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY + . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY + . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT + . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY + . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME + . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 + ; + S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY + S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT + S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK + ; + S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED + ; + S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT + W "PATS BASE: ",CPATLIST,! + S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST + ; + Q + ; +CHKSUM(CKDFN) ; DOES A CHECKSUM AND STORES IT IN MUMPS GLOBALS + ; + S C0CCKB=$NA(^TMP("C0CRIM","CHKSUM")) ;CHECKSUM BASE + S C0CGLB=$NA(^TMP("C0CRIM","VARS")) ;CCR VARIABLE BASE + S C0CI="" + F S C0CI=$O(@C0CGLB@(CKDFN,C0CI)) Q:C0CI="" D ;FOR EACH DOMAIN + . ;W "DFN:",CKDFN," DOMAIN:",C0CI,! + . S C0CJ=$NA(@C0CGLB@(CKDFN,C0CI)) + . I C0CI="HEADER" D ; HAVE TO TAKE OUT THE "DATE GENERATED" + . . S C0CDT=@C0CGLB@(CKDFN,C0CI,1,"DATETIME") + . . K @C0CGLB@(CKDFN,C0CI,1,"DATETIME") + . S C0CCK(C0CI)=$$CHKSUM^XUSESIG1(C0CJ) + . I C0CI="HEADER" D ; PUT IT BACK + . . S @C0CGLB@(CKDFN,C0CI,1,"DATETIME")=C0CDT + S C0CK="C0CCK" ; + S C0CALL=$$CHKSUM^XUSESIG1(C0CK) ;CHECKSUM OF ALL DOMAIN CHECKSUMS + S CHKR=0 ; RESULT DEFAULT + I $D(^TMP("C0CRIM","CHKSUM",CKDFN,"ALL")) D ; OLD CHECKSUM EXISTS + . I @C0CCKB@(CKDFN,"ALL")'=C0CALL S CHKR=1 + E S CHKR=1 ;CHECKSUM IS NEW + S @C0CCKB@(CKDFN,"ALL")=C0CALL + M @C0CCKB@(CKDFN,"DOMAIN")=C0CCK + ;ZWR ^TMP("C0CRIM","CHKSUM",CKDFN,*) + Q CHKR + ; +CCOUNT ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE + ; + I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS + N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT + S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES + S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS + S ZTOT=0 ; INITIALIZE OVERALL TOTAL + F ZI=1:1:@ZCBASE@(0) D ; FOR ALL CATS + . S ZCNT=0 + . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY + . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME + . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST + . ; F ZJ=0:0 D Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS + . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT + . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,! + . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX)) + . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT))) + . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD + . S ZTOT=ZTOT+ZCNT + W "TOTAL: ",ZTOT,! + Q + ; +CNTLST(INLST) ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST + ; INLST IS PASSED BY NAME + N ZI,ZDX,ZCOUNT + W INLST,! + S ZCOUNT=0 + S ZDX="" + F ZI=$O(@INLST@(ZDX)):0 D Q:$O(@INLST@(ZDX))="" ; LOOP UNTIL THE END + . S ZCOUNT=ZCOUNT+1 + . S ZDX=$O(@INLST@(ZDX)) + . W "ZDX:",ZDX," ZCNT:",ZCOUNT,! + Q ZCOUNT + ; +XCPAT(CPATCAT,CPATPARM) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT + ; + I '$D(CPATPARM) S CPATPARM="" + I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS + N ZI,ZJ,ZC,ZPATBASE + S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) + S ZI="" + F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END + . S ZI=$O(@ZPATBASE@(ZI)) + . D XPAT^C0CCCR(ZI,CPATPARM) ; EXPORT THE PATIENT TO A FILE + Q + ; +CPAT(CPATCAT) ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT + ; + I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS + N ZI,ZJ,ZC,ZPATBASE + S ZC=0 ; COUNT FOR SPACING THE PRINTOUT + S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) + S ZI="" + F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END + . S ZI=$O(@ZPATBASE@(ZI)) + . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT + . W ZI," " + . I ZC=10 D ; NEW LINE + . . S ZC=0 + . . W ! + Q + ; +PATC(DFN) ; DISPLAY THE CATEGORY FOR THIS PATIENT + ; + N ATTR S ATTR="" + I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT + . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT + S ATTR=^TMP("C0CRIM","ATTR",DFN) + I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q ;NO ATTRIBUTES FOUND + I $D(^TMP("C0CRIM","RIMTBL","CATS",ATTR)) D ; FOUND A CAT + . N CAT + . S CAT=$P(^TMP("C0CRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT + . W CAT,": ",ATTR,! + Q + ; +APUSH(AMAP,AVAL) ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME) + ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT + ; AND AMAP(N)=AVAL IS THE NTH AVAL + ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE + ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE + ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED + ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED + ; + I '$D(@AMAP) D ; IF THE MAP DOES NOT EXIST + . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS + S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT + S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY + S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF + Q + ; +ASETUP ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL + I '$D(RIMBASE) S RIMBASE=$NA(^TMP("C0CRIM")) + I '$D(@RIMBASE) S @RIMBASE="" + I '$D(RIMTBL) S RIMTBL=$NA(^TMP("C0CRIM","RIMTBL","TABLE")) ; ATTR TABLE + S ^TMP("C0CRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES + Q + ; +AINIT ; INITIALIZE ATTRIBUTE TABLE + I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS + K @RIMTBL + D APUSH(RIMTBL,"EXTRACTED") + D APUSH(RIMTBL,"NOTEXTRACTED") + D APUSH(RIMTBL,"HEADER") + D APUSH(RIMTBL,"NOPCP") + D APUSH(RIMTBL,"PCP") + D APUSH(RIMTBL,"PROBLEMS") + D APUSH(RIMTBL,"PROBCODE") + D APUSH(RIMTBL,"PROBNOCODE") + D APUSH(RIMTBL,"PROBDATE") + D APUSH(RIMTBL,"PROBNODATE") + D APUSH(RIMTBL,"VITALS") + D APUSH(RIMTBL,"VITALSCODE") + D APUSH(RIMTBL,"VITALSNOCODE") + D APUSH(RIMTBL,"VITALSDATE") + D APUSH(RIMTBL,"VITALSNODATE") + D APUSH(RIMTBL,"IMMUNE") + D APUSH(RIMTBL,"IMMUNECODE") + D APUSH(RIMTBL,"MEDS") + D APUSH(RIMTBL,"MEDSCODE") + D APUSH(RIMTBL,"MEDSNOCODE") + D APUSH(RIMTBL,"MEDSDATE") + D APUSH(RIMTBL,"MEDSNODATE") + D APUSH(RIMTBL,"ALERTS") + D APUSH(RIMTBL,"ALERTSCODE") + D APUSH(RIMTBL,"RESULTS") + D APUSH(RIMTBL,"RESULTSLN") + D APUSH(RIMTBL,"PROCEDURES") + D APUSH(RIMTBL,"ENCOUNTERS") + D APUSH(RIMTBL,"NOTES") + Q + ; +APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL + ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING + ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES + ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) + I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING + N USETBL + I '$D(@RIMBASE@("TABLES",PTBL)) D Q ; NO TABLE + . W "ERROR NO SUCH TABLE",! + S USETBL=@RIMBASE@("TABLES",PTBL) + S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL + Q +GETPA(RTN,DFN,ISEC,IVAR) ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN + ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT") + ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2 + ; IN SECTION "MEDS" + ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS + ; PENDING FOR MED 2 FOR PATIENT 2 + ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE + ; RETURNED. RTN IS PASSED BY REFERENCE + ; + S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE + I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES + S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES + I '$D(@ZVBASE@(DFN,ISEC,0)) D Q ; NO VARIABLES IN SECTION + . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,! + N ZZI,ZZS + S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT + ; ZWR @ZZS@(1) + S RTN(0)=@ZZS@(0) + F ZZI=1:1:RTN(0) D ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS) + . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE + . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE + Q + ; +PATD(DFN,ISEC,IVAR) ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR + ; + N ZR + D GETPA(.ZR,DFN,ISEC,IVAR) + I $D(ZR(0)) D PARY^C0CXPATH("ZR") + E W "NOTHING RETURNED",! + Q + ; +CAGET(RTN,IATTR) ; + ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR + ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE + ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC + Q + ; +PCLST(LSTRTN,IATTR) ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR + ; + I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES + N ZLST + S @LSTRTN@(0)=0 ; DEFAULT RETURN NONE + S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES + S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS + N ZNC ; ZNC IS NUMBER OF CATEGORIES + S ZNC=@ZCBASE@(0) + I ZNC=0 Q ; NO CATEGORIES TO SEARCH + N ZAP ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE + S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR) + N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT + F ZI=1:1:ZNC D ; FOR ALL CATEGORIES + . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT + . I $P(ZATBL,"^",ZAP)'="" D ; CAT HAS ATTR + . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL + . . M @LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT + S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS + S ZPAT=0 ; START AT FIRST PATIENT IN LIST + F S ZPAT=$O(@LSTRTN@(ZPAT)) Q:ZPAT="" D ; + . S ZCNT=ZCNT+1 + S @LSTRTN@(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY + Q + ; +DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR + ; + ;N ZR + D PCLST("ZR",CATTR) + I ZR(0)=0 D Q ; + . W "NO PATIENTS RETURNED",! + E D ; + . N ZI S ZI=0 + . F S ZI=$O(ZR(ZI)) Q:ZI="" D ; + . . W !,ZI + . ;D PARY^C0CXPATH("ZR") ; PRINT ARRAY + . W !,"COUNT=",ZR(0) + Q + ; +RPCGV(RTN,DFN,WHICH) ; RPC GET VARS + ; RETURNS IN RTN (PASSED BY REFERENCE) THE VARS AND VALUES + ; FOUND AT INARY RTN(X)="VAR^VALUE" RTN(0) IS THE COUNT + ; DFN IS THE PATIENT NUMBER. + ; WHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","IMMUNE" + ; OR OTHER SECTIONS AS THEY ARE ADDED + ; THIS IS MEANT TO BE AVAILABLE AS AN RPC + I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS + S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES + S RTN(0)=0 ; DEFAULT NOTHING IS RETURNED + N ZZGI + I WHICH="ALL" D ; VARIABLES FROM ALL SECTIONS + . F ZZGI="HEADER","PROBLEMS","VITALS","MEDS","ALERTS","RESULTS","IMMUNE","PROCEDURES" D ; + . . D ZGVWRK(ZZGI) ; DO EACH SECTION + . . I $G(DEBUG)'="" W "DID ",ZZGI,! + E D ZGVWRK(WHICH) ; ONLY ONE SECTION ASKED FOR + Q + ; +ZGVWRK(ZWHICH) ; DO ONE SECTION FOR RPCGV + ; + N ZZGN ; NAME FOR SECTION VARIABLES + S ZZGN=$NA(@ZVBASE@(DFN,ZWHICH)) ; BASE OF VARS FOR SECTION + ;I '$D(@ZZGN@(0)) Q ; NO VARS FOR THIS SECTION + I $O(@ZZGN@(""),-1)="" D ; + E D ; VARS EXIST + . N ZGVI,ZGVN + . S ZGVN=$O(@ZZGN@(""),-1) ;COUNT OF VARS + . F ZGVI=1:1:ZGVN D ; FOR EACH MULTIPLE IN SECTION + . . K ZZGA N ZZGA ; TEMP ARRAY FOR SECTION VARS + . . K ZZGN2 N ZZGN2 ; NAME FOR MULTIPLE + . . S ZZGN2=$NA(@ZZGN@(ZGVI)) + . . I $G(DEBUG)'="" W ZZGN2,!,$O(@ZZGN2@("")),! + . . D H2ARY^C0CXPATH("ZZGA",ZZGN2,ZGVI) ; CONVERT HASH TO ARRAY + . . ; D PARY^C0CXPATH("ZZGA") + . . D PUSHA^C0CXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN + Q + ; +DPATV(DFN,IWHICH) ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN C0CRIM + ; ALONG WITH SAMPLE VALUES. + ; IWHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","HEADER" + N GTMP + I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT + . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES + I '$D(IWHICH) S IWHICH="ALL" + D RPCGV(.GTMP,DFN,IWHICH) + D PARY^C0CXPATH("GTMP") + Q + ; +RIM2RNF(R2RTN,DFN,RWHICH) ; CONVERTS RIM VARIABLES TO RNF2 FORMAT + ; RETURN IN R2RTN, WHICH IS PASSED BY NAME + ; RWHICH IS RIM SECTION TO RETURN, DEFAULTS TO "ALL" + ; + I '$D(RWHICH) S RWHICH="ALL" + ;N R2TMP + I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT + . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES + D RPCGV(.R2TMP,DFN,RWHICH) ; RETRIEVE ALL THE VARIABLES I AN ARRAY + N R2I,R2J,R2X,R2X1,R2X2,R2Y,R2Z + F R2I=1:1:R2TMP(0) D ; FOR EVERY LINE OF THE ARRAY + . S R2X=$P(R2TMP(R2I),"^",1) ; OCCURANCE + . S R2Y=$P(R2TMP(R2I),"^",2) ; VARIABLE NAME + . I $L(R2Y)<4 Q ; SKIP SHORT VARIABLES (THEY ARE FOR DEBUGGING) + . S R2Z=$P(R2TMP(R2I),"^",3) ; VALUE + . I R2X[";" D ; THERES MULTIPLES + . . S R2X1=$P(R2X,";",1) ; FIRST INDEX + . . S R2X2=$P(R2X,";",2) ; SECOND INDEX + . . S R2J=R2Y_"["_R2X2_"]" ; BUILD THE VARIABLE NAME + . . S @R2RTN@("F",R2J,1)="" ; PUT VARIABLE NAME IN FIELD MAP + . . S @R2RTN@("V",R2X1,R2J,1)=R2Z ; PUT THE VALUE IN THE ARRAY + . E D ; NO SUB-MULTIPLES + . . S @R2RTN@("F",R2Y,1)="" ; PUT VARIABLE NAME IN FIELD MAP + . . S @R2RTN@("V",R2X,R2Y,1)=R2Z ; PUT THE VALUE IN THE ARRAY + Q + ; +RIM2CSV(DFN) ; WRITE THE RIM VARIABLES FOR A PATIENT TO A CSV FILE + ; + N R2CTMP,R2CARY + D RIM2RNF("R2CTMP",DFN) ; CONVERT VARIABLES TO RNF FORMAT + D RNF2CSV^C0CRNF("R2CARY","R2CTMP","NV") ; CONVERT RNF TO CSV FORMAT + D FILEOUT^C0CRNF("R2CARY","VARS-"_DFN_".csv") + Q + ; Index: ccr/branches/ohum/p/C0CRNF.m =================================================================== --- ccr/branches/ohum/p/C0CRNF.m (revision 1333) +++ ccr/branches/ohum/p/C0CRNF.m (revision 1337) @@ -1,462 +1,462 @@ -C0CRNF ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is the Reference Name Format (RNF) Utility Library ",! - W ! - Q - ; -FIELDS(C0CFRTN,C0CF) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF, - ; C0CFRTN IS PASSED BY NAME, C0CF IS PASSED BY VALUE - ; - N C0CFI,C0CFJ ;INNER LOOP, OUTER LOOP - N C0CFN ; FIELD NAME - S C0CFI=0 S C0CFJ=C0CF - K @C0CFRTN ; CLEAR THE RETURN ARRAY - F Q:C0CFJ'[C0CF D ; FOR THE C0CF FILE AND ALL SUBFILES INCLUSIVE - . ;W "1: "_C0CFJ," ",C0CFI,! - . F S C0CFI=$O(^DD(C0CFJ,C0CFI)) Q:+C0CFI=0 D ; EVERY FIELD - . . ;W "2: "_C0CFJ," ",C0CFI,! - . . S C0CFN=$P($G(^DD(C0CFJ,C0CFI,0)),"^",1) ;PULL FIELD NAME FROM ^DD - . . ;W "N: ",C0CFN,! - . . ;I C0CFN="STR" W C0CFN," ",C0CFJ,! - . . I $D(@C0CFRTN@(C0CFN)) D ; IS THIS A DUPLICATE? - . . . I $G(DEBUG) D ; - . . . . W "DUPLICATE FOUND! ",C0CFJ," ",C0CFI," ",C0CFN,!,@C0CFRTN@(C0CFN),! - . . . S @C0CFRTN@(C0CFN_"_"_C0CFJ)=C0CFJ_"^"_C0CFI - . . E S @C0CFRTN@(C0CFN)=C0CFJ_"^"_C0CFI - . S C0CFJ=$O(^DD(C0CFJ)) ; NEXT SUBFILE - Q - ; -TESTRNF ; TEST THE RNF1TO2 ROUTINE - S G1("ONE")=1 - S G1("TWO")=2 - S G1("THREE")=3 - D RNF1TO2("GPL","G1") - S G1("ONE")="NOT1" - S G1("TWO")="STILL2" - S G1("THREE")=3 - D RNF1TO2("GPL","G1") - ZWR GPL - Q - ; -RNF1TO2(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY - ; (ZOUT) BOTH ARE PASSED BY NAME - ; RNF1 IS OF THE FORM: - ; @ZIN@("VAR1")=VAL1 - ; @ZIN@("VAR2")=VAL2 - ; RNF2 IS OF THE FORM: - ; @ZOUT@("F","VAR1")="" - ; @ZOUT@("F","VAR2")="" - ; @ZOUT@("V",n,"VAR1")=VAL1 - ; @ZOUT@("V",n,"VAR2")=VAL2 - ; WHERE n IS THE "ROW" OF THE ARRAY - N ZI S ZI="" - N ZN - I '$D(@ZOUT@("V",1)) S ZN=1 - E S ZN=$O(@ZOUT@("V",""),-1)+1 - F S ZI=$O(@ZIN@(ZI)) Q:ZI="" D ; - . S @ZOUT@("F",ZI)="" - . S @ZOUT@("V",ZN,ZI)=@ZIN@(ZI) - Q - ; -RNF1TO2B(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY - ; THE "B" ROUTINE SUPPORTS WP FIELDS IN THE ARRAY - ; EVERY "V" VARIABLE IS FOLLOWED BY A "1" - ; FOR EXAMPLE @G@("V",n,"VAR1",1)="VALUE1" - ; USE THIS ROUTINE IF YOU WANT TO CONVERT THE RESULT TO A CSV - ; WITH RNF2CSV - ; (ZOUT) BOTH ARE PASSED BY NAME - ; RNF1 IS OF THE FORM: - ; @ZIN@("VAR1")=VAL1 - ; @ZIN@("VAR2")=VAL2 - ; RNF2 IS OF THE FORM: - ; @ZOUT@("F","VAR1")="" - ; @ZOUT@("F","VAR2")="" - ; @ZOUT@("V",n,"VAR1",1)=VAL1 - ; @ZOUT@("V",n,"VAR2",1)=VAL2 - ; WHERE n IS THE "ROW" OF THE ARRAY - N ZI S ZI="" - N ZN - I '$D(@ZOUT@("V",1)) S ZN=1 - E S ZN=$O(@ZOUT@("V",""),-1)+1 - F S ZI=$O(@ZIN@(ZI)) Q:ZI="" D ; - . S @ZOUT@("F",ZI)="" - . S @ZOUT@("V",ZN,ZI,1)=@ZIN@(ZI) - Q - ; -GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME - ; GRTN IS PASSED BY NAME - ; - N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME - I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) - E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) - S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE - D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP - D GETS^DIQ(GFILE,C0CREF,"**","I","C0CTMP") - D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE - S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J ; STRUCTURE SIGNATURE - S (C0CI,C0CJ)="" - F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES - . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE - . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS - . . ;W C0CJ," ",C0CI,! - . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME - . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI) ; - . . I C0CVALUE["C0CTMP" S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,1) ;1ST LINE OF WP - . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 - I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED - . S C0CI="" - . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY - . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES - Q - ; -GETN(GRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP - ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 - ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL - ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN - ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP - ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" - ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP - ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE - ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE - ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP - ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP - ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE - ; IF GREF IS "" THE FIRST RECORD IS OBTAINED - ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE - ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN - ; GREF IS THE VALUE FOR THE INDEX - ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED - ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN - ; - ; - N GIEN,GF - S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE - I ('$D(GNDX))!($G(GNDX)="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN - E D ; WE ARE USING AN INDEX - . ;N ZG - . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX - . I ZG'="" D ; - . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? - . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN - . . E S GIEN="" ; NOT FOUND IN INDEX - . E S GIEN="" ; - ;W "IEN: ",GIEN,! - ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME - I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) - E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) - S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE - D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP - K C0CTMP - D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") - D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE - S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE - S (C0CI,C0CJ)="" - F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES - . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE - . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS - . . ;W C0CJ," ",C0CI,! - . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME - . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; - . . I C0CVALUE["C0CTMP" D ; WP FIELD - . . . N ZT,ZWP S ZWP=0 ;ITERATOR - . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE - . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE - . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; - . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP - . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " - . . . . S C0CVALUE=C0CVALUE_ZT ; - . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 - . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) - I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED - . S C0CI="" - . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY - . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES - Q - ; -GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP - ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 - ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL - ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN - ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP - ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" - ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP - ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE - ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE - ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP - ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP - ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE - ; IF GREF IS "" THE FIRST RECORD IS OBTAINED - ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE - ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN - ; GREF IS THE VALUE FOR THE INDEX - ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED - ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN - ; - ; - N GIEN,GF - S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE - I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN - E D ; WE ARE USING AN INDEX - . ;N ZG - . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX - . I ZG'="" D ; - . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? - . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN - . . E S GIEN="" ; NOT FOUND IN INDEX - . E S GIEN="" ; - ;W "IEN: ",GIEN,! - ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME - I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) - E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) - S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE - D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP - K C0CTMP - D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") - D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE - S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE - S (C0CI,C0CJ)="" - F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES - . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE - . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS - . . ;W C0CJ," ",C0CI,! - . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME - . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; - . . I C0CVALUE["C0CTMP" D ; WP FIELD - . . . N ZT,ZWP S ZWP=0 ;ITERATOR - . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE - . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE - . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; - . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP - . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " - . . . . S C0CVALUE=C0CVALUE_ZT ; - . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 - . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) - I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED - . S C0CI="" - . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY - . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES - Q - ; -GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES - ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP - ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#" - ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP - ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE - ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES - ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE - ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP - ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP - ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE - ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE - ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN - ; .. OF THE FILE WILL BE USED - ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE - ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED - ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE - ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD - ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED - ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL - ;N GATMP,GAI,GAF - S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE - I '$D(GAIDX) S GAIDX="" ;DEFAULT - I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED - I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX - W GAF,! - W $O(@GAF@(0)) ; - S GAI=0 ;ITERATOR - F S GAI=$O(@GAF@(GAI)) Q:GAI="" D ; - . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD - . N GAX S GAX=0 - . F S GAX=$O(GATMP(GAX)) Q:GAX="" D ;PULL OUT THE FIELDS - . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN - Q - ; -ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX - ; - S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD# - S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE - Q - ; -RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT - ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES - ; RNSTY IS STYLE OF THE OUTPUT - - ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES - ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES - ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES - N RNR,RNC ;ROW ROOT,COL ROOT - N RNI,RNJ,RNX - I '$D(RNSTY) S RNSTY="NV" ;DEFAULT - I RNSTY="NV" D NV(RNRTN,RNIN) ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION - E D VN(RNRTN,RNIN) ; - Q - ; -NV(RNRTN,RNIN) ; - S RNR=$NA(@RNIN@("F")) - S RNC=$NA(@RNIN@("V")) - ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER - S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD" - S RNI="" - F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN - . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA - S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA - D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS - S RNI="" - F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW - . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD - . S RNJ="" - . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL - . . I $D(@RNC@(RNJ,RNI,1)) D ; THIS ROW HAS THIS COLUMN - . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA - . . E S RNX=RNX_"," ; NUL COLUMN - . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA - . D PUSH^C0CXPATH(RNRTN,RNX) - Q - ; -VN(RNRTN,RNIN) ; - S RNR=$NA(@RNIN@("V")) - S RNC=$NA(@RNIN@("F")) - ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER - S RNX="""ROW"""_"," ; FIRST COLUMN NAME IS "ROW" - S RNI="" - F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN - . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA - S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA - D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS - S RNI="" - F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW - . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD - . S RNJ="" - . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL - . . I $D(@RNR@(RNI,RNJ,1)) D ; THIS ROW HAS THIS COLUMN - . . . S RNV=$TR(@RNR@(RNI,RNJ,1),"""","") - . . . S RNV=$TR(RNV,",","") - . . . S RNX=RNX_""""_RNV_""""_"," ; ADD THE ELEMENT PLUS A COMMA - . . E S RNX=RNX_"," ; NUL COLUMN - . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA - . D PUSH^C0CXPATH(RNRTN,RNX) - Q - ; -READCSV(PATH,NAME,GLB) ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME - ; - Q $$FTG^%ZISH(PATH,NAME,GLB,1) - ; -FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV - ; - ;N G1,G2 - I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE - S G1=$NA(^TMP($J,"C0CCSV",1)) - S G2=$NA(^TMP($J,"C0CCSV",2)) - D GETN2(G1,FNUM) ; GET THE MATRIX - D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE - K @G1 - D FILEOUT(G2,"FILE_"_FNUM_".csv") - K @G2 - Q - ; -FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE - ; - W $$OUTPUT^C0CXPATH($NA(@FOARY@(1)),FONAM,^TMP("C0CCCR","ODIR")) - Q - ; -FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM - ; - N C0CF - S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE - S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT - I C0CF["()" S C0CF=$P(C0CF,"()",1) - Q C0CF - ; -SKIP ; - N TXT,DIERR - S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT") - I $D(DIERR) D CLEAN^DILF Q - W " report_text:",! ;Progress Note Text - N LN S LN=0 - F S LN=$O(TXT(LN)) Q:'LN D - . W " text"_LN_": "_TXT(LN),! - . Q - Q - ; -RNF2HNV(ZOUT,ZIN) ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME - ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT - ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END - ; THE TABLE WILL BE IN NV FORMAT, ROWS ARE NAMES COLUMNS ARE VALUES - D PUSH^C0CXPATH(ZOUT,"") - N ZI,ZJ,ZV,ZN S ZI="" S ZJ=0 - D PUSH^C0CXPATH(ZOUT,"") ;begin row and leave a blank col - F S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0 D ; FOR EACH OCCURANCE - . S ZV="" ; OCCURANCE AS COLUMNS HEADER - . D PUSH^C0CXPATH(ZOUT,ZV) - D PUSH^C0CXPATH(ZOUT,"") ;end of first row - S ZI="" - F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE - . S ZN="" ; 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="" - . . D PUSH^C0CXPATH(ZOUT,ZV) - . D PUSH^C0CXPATH(ZOUT,"") ;END OF ROW - D PUSH^C0CXPATH(ZOUT,"
"_ZJ_"
"_ZI_""_$G(@ZIN@("V",ZJ,ZI,1))_"
") ; 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,"") - N ZI,ZJ S ZI="" S ZJ=0 - D PUSH^C0CXPATH(ZOUT,"") ;new row for column headers - F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE - . S ZV="" - . D PUSH^C0CXPATH(ZOUT,ZV) ; name - D PUSH^C0CXPATH(ZOUT,"") ; 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,"") ;begin row - . F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE - . . S ZV="" ; value - . . D PUSH^C0CXPATH(ZOUT,ZV) ; value - . D PUSH^C0CXPATH(ZOUT,"") ; end header - D PUSH^C0CXPATH(ZOUT,"
"_ZI_"
"_$G(@ZIN@("V",ZJ,ZI,1))_"
") ;end of table - Q - ; -ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P(@ZTAB@(ZFN),"^",1) -ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P(@ZTAB@(ZFN),"^",2) -ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P($G(@ZTAB@(ZFN)),"^",3) - ; -ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P($G(@ZTAB@(ZFN,"I")),"^",3) - ; +C0CRNF ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is the Reference Name Format (RNF) Utility Library ",! + W ! + Q + ; +FIELDS(C0CFRTN,C0CF) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF, + ; C0CFRTN IS PASSED BY NAME, C0CF IS PASSED BY VALUE + ; + N C0CFI,C0CFJ ;INNER LOOP, OUTER LOOP + N C0CFN ; FIELD NAME + S C0CFI=0 S C0CFJ=C0CF + K @C0CFRTN ; CLEAR THE RETURN ARRAY + F Q:C0CFJ'[C0CF D ; FOR THE C0CF FILE AND ALL SUBFILES INCLUSIVE + . ;W "1: "_C0CFJ," ",C0CFI,! + . F S C0CFI=$O(^DD(C0CFJ,C0CFI)) Q:+C0CFI=0 D ; EVERY FIELD + . . ;W "2: "_C0CFJ," ",C0CFI,! + . . S C0CFN=$P($G(^DD(C0CFJ,C0CFI,0)),"^",1) ;PULL FIELD NAME FROM ^DD + . . ;W "N: ",C0CFN,! + . . ;I C0CFN="STR" W C0CFN," ",C0CFJ,! + . . I $D(@C0CFRTN@(C0CFN)) D ; IS THIS A DUPLICATE? + . . . I $G(DEBUG) D ; + . . . . W "DUPLICATE FOUND! ",C0CFJ," ",C0CFI," ",C0CFN,!,@C0CFRTN@(C0CFN),! + . . . S @C0CFRTN@(C0CFN_"_"_C0CFJ)=C0CFJ_"^"_C0CFI + . . E S @C0CFRTN@(C0CFN)=C0CFJ_"^"_C0CFI + . S C0CFJ=$O(^DD(C0CFJ)) ; NEXT SUBFILE + Q + ; +TESTRNF ; TEST THE RNF1TO2 ROUTINE + S G1("ONE")=1 + S G1("TWO")=2 + S G1("THREE")=3 + D RNF1TO2("GPL","G1") + S G1("ONE")="NOT1" + S G1("TWO")="STILL2" + S G1("THREE")=3 + D RNF1TO2("GPL","G1") + ZWR GPL + Q + ; +RNF1TO2(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY + ; (ZOUT) BOTH ARE PASSED BY NAME + ; RNF1 IS OF THE FORM: + ; @ZIN@("VAR1")=VAL1 + ; @ZIN@("VAR2")=VAL2 + ; RNF2 IS OF THE FORM: + ; @ZOUT@("F","VAR1")="" + ; @ZOUT@("F","VAR2")="" + ; @ZOUT@("V",n,"VAR1")=VAL1 + ; @ZOUT@("V",n,"VAR2")=VAL2 + ; WHERE n IS THE "ROW" OF THE ARRAY + N ZI S ZI="" + N ZN + I '$D(@ZOUT@("V",1)) S ZN=1 + E S ZN=$O(@ZOUT@("V",""),-1)+1 + F S ZI=$O(@ZIN@(ZI)) Q:ZI="" D ; + . S @ZOUT@("F",ZI)="" + . S @ZOUT@("V",ZN,ZI)=@ZIN@(ZI) + Q + ; +RNF1TO2B(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY + ; THE "B" ROUTINE SUPPORTS WP FIELDS IN THE ARRAY + ; EVERY "V" VARIABLE IS FOLLOWED BY A "1" + ; FOR EXAMPLE @G@("V",n,"VAR1",1)="VALUE1" + ; USE THIS ROUTINE IF YOU WANT TO CONVERT THE RESULT TO A CSV + ; WITH RNF2CSV + ; (ZOUT) BOTH ARE PASSED BY NAME + ; RNF1 IS OF THE FORM: + ; @ZIN@("VAR1")=VAL1 + ; @ZIN@("VAR2")=VAL2 + ; RNF2 IS OF THE FORM: + ; @ZOUT@("F","VAR1")="" + ; @ZOUT@("F","VAR2")="" + ; @ZOUT@("V",n,"VAR1",1)=VAL1 + ; @ZOUT@("V",n,"VAR2",1)=VAL2 + ; WHERE n IS THE "ROW" OF THE ARRAY + N ZI S ZI="" + N ZN + I '$D(@ZOUT@("V",1)) S ZN=1 + E S ZN=$O(@ZOUT@("V",""),-1)+1 + F S ZI=$O(@ZIN@(ZI)) Q:ZI="" D ; + . S @ZOUT@("F",ZI)="" + . S @ZOUT@("V",ZN,ZI,1)=@ZIN@(ZI) + Q + ; +GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME + ; GRTN IS PASSED BY NAME + ; + N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME + I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) + E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) + S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE + D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP + D GETS^DIQ(GFILE,C0CREF,"**","I","C0CTMP") + D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE + S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J ; STRUCTURE SIGNATURE + S (C0CI,C0CJ)="" + F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES + . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE + . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS + . . ;W C0CJ," ",C0CI,! + . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME + . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI) ; + . . I C0CVALUE["C0CTMP" S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,1) ;1ST LINE OF WP + . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 + I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED + . S C0CI="" + . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY + . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES + Q + ; +GETN(GRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP + ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 + ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL + ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN + ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP + ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" + ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP + ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE + ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE + ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP + ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP + ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE + ; IF GREF IS "" THE FIRST RECORD IS OBTAINED + ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE + ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN + ; GREF IS THE VALUE FOR THE INDEX + ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED + ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN + ; + ; + N GIEN,GF + S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE + I ('$D(GNDX))!($G(GNDX)="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN + E D ; WE ARE USING AN INDEX + . ;N ZG + . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX + . I ZG'="" D ; + . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? + . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN + . . E S GIEN="" ; NOT FOUND IN INDEX + . E S GIEN="" ; + ;W "IEN: ",GIEN,! + ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME + I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) + E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) + S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE + D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP + K C0CTMP + D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") + D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE + S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE + S (C0CI,C0CJ)="" + F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES + . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE + . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS + . . ;W C0CJ," ",C0CI,! + . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME + . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; + . . I C0CVALUE["C0CTMP" D ; WP FIELD + . . . N ZT,ZWP S ZWP=0 ;ITERATOR + . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE + . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE + . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; + . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP + . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " + . . . . S C0CVALUE=C0CVALUE_ZT ; + . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 + . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) + I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED + . S C0CI="" + . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY + . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES + Q + ; +GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP + ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 + ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL + ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN + ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP + ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" + ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP + ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE + ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE + ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP + ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP + ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE + ; IF GREF IS "" THE FIRST RECORD IS OBTAINED + ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE + ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN + ; GREF IS THE VALUE FOR THE INDEX + ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED + ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN + ; + ; + N GIEN,GF + S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE + I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN + E D ; WE ARE USING AN INDEX + . ;N ZG + . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX + . I ZG'="" D ; + . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? + . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN + . . E S GIEN="" ; NOT FOUND IN INDEX + . E S GIEN="" ; + ;W "IEN: ",GIEN,! + ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME + I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) + E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) + S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE + D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP + K C0CTMP + D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") + D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE + S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE + S (C0CI,C0CJ)="" + F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES + . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE + . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS + . . ;W C0CJ," ",C0CI,! + . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME + . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; + . . I C0CVALUE["C0CTMP" D ; WP FIELD + . . . N ZT,ZWP S ZWP=0 ;ITERATOR + . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE + . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE + . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; + . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP + . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " + . . . . S C0CVALUE=C0CVALUE_ZT ; + . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 + . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) + I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED + . S C0CI="" + . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY + . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES + Q + ; +GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES + ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP + ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#" + ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP + ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE + ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES + ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE + ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP + ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP + ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE + ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE + ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN + ; .. OF THE FILE WILL BE USED + ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE + ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED + ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE + ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD + ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED + ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL + ;N GATMP,GAI,GAF + S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE + I '$D(GAIDX) S GAIDX="" ;DEFAULT + I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED + I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX + W GAF,! + W $O(@GAF@(0)) ; + S GAI=0 ;ITERATOR + F S GAI=$O(@GAF@(GAI)) Q:GAI="" D ; + . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD + . N GAX S GAX=0 + . F S GAX=$O(GATMP(GAX)) Q:GAX="" D ;PULL OUT THE FIELDS + . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN + Q + ; +ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX + ; + S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD# + S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE + Q + ; +RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT + ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES + ; RNSTY IS STYLE OF THE OUTPUT - + ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES + ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES + ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES + N RNR,RNC ;ROW ROOT,COL ROOT + N RNI,RNJ,RNX + I '$D(RNSTY) S RNSTY="NV" ;DEFAULT + I RNSTY="NV" D NV(RNRTN,RNIN) ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION + E D VN(RNRTN,RNIN) ; + Q + ; +NV(RNRTN,RNIN) ; + S RNR=$NA(@RNIN@("F")) + S RNC=$NA(@RNIN@("V")) + ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER + S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD" + S RNI="" + F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN + . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA + S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA + D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS + S RNI="" + F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW + . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD + . S RNJ="" + . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL + . . I $D(@RNC@(RNJ,RNI,1)) D ; THIS ROW HAS THIS COLUMN + . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA + . . E S RNX=RNX_"," ; NUL COLUMN + . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA + . D PUSH^C0CXPATH(RNRTN,RNX) + Q + ; +VN(RNRTN,RNIN) ; + S RNR=$NA(@RNIN@("V")) + S RNC=$NA(@RNIN@("F")) + ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER + S RNX="""ROW"""_"," ; FIRST COLUMN NAME IS "ROW" + S RNI="" + F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN + . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA + S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA + D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS + S RNI="" + F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW + . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD + . S RNJ="" + . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL + . . I $D(@RNR@(RNI,RNJ,1)) D ; THIS ROW HAS THIS COLUMN + . . . S RNV=$TR(@RNR@(RNI,RNJ,1),"""","") + . . . S RNV=$TR(RNV,",","") + . . . S RNX=RNX_""""_RNV_""""_"," ; ADD THE ELEMENT PLUS A COMMA + . . E S RNX=RNX_"," ; NUL COLUMN + . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA + . D PUSH^C0CXPATH(RNRTN,RNX) + Q + ; +READCSV(PATH,NAME,GLB) ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME + ; + Q $$FTG^%ZISH(PATH,NAME,GLB,1) + ; +FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV + ; + ;N G1,G2 + I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE + S G1=$NA(^TMP($J,"C0CCSV",1)) + S G2=$NA(^TMP($J,"C0CCSV",2)) + D GETN2(G1,FNUM) ; GET THE MATRIX + D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE + K @G1 + D FILEOUT(G2,"FILE_"_FNUM_".csv") + K @G2 + Q + ; +FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE + ; + W $$OUTPUT^C0CXPATH($NA(@FOARY@(1)),FONAM,^TMP("C0CCCR","ODIR")) + Q + ; +FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM + ; + N C0CF + S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE + S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT + I C0CF["()" S C0CF=$P(C0CF,"()",1) + Q C0CF + ; +SKIP ; + N TXT,DIERR + S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT") + I $D(DIERR) D CLEAN^DILF Q + W " report_text:",! ;Progress Note Text + N LN S LN=0 + F S LN=$O(TXT(LN)) Q:'LN D + . W " text"_LN_": "_TXT(LN),! + . Q + Q + ; +RNF2HNV(ZOUT,ZIN) ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME + ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT + ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END + ; THE TABLE WILL BE IN NV FORMAT, ROWS ARE NAMES COLUMNS ARE VALUES + D PUSH^C0CXPATH(ZOUT,"") + N ZI,ZJ,ZV,ZN S ZI="" S ZJ=0 + D PUSH^C0CXPATH(ZOUT,"") ;begin row and leave a blank col + F S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0 D ; FOR EACH OCCURANCE + . S ZV="" ; OCCURANCE AS COLUMNS HEADER + . D PUSH^C0CXPATH(ZOUT,ZV) + D PUSH^C0CXPATH(ZOUT,"") ;end of first row + S ZI="" + F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE + . S ZN="" ; 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="" + . . D PUSH^C0CXPATH(ZOUT,ZV) + . D PUSH^C0CXPATH(ZOUT,"") ;END OF ROW + D PUSH^C0CXPATH(ZOUT,"
"_ZJ_"
"_ZI_""_$G(@ZIN@("V",ZJ,ZI,1))_"
") ; 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,"") + N ZI,ZJ S ZI="" S ZJ=0 + D PUSH^C0CXPATH(ZOUT,"") ;new row for column headers + F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE + . S ZV="" + . D PUSH^C0CXPATH(ZOUT,ZV) ; name + D PUSH^C0CXPATH(ZOUT,"") ; 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,"") ;begin row + . F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE + . . S ZV="" ; value + . . D PUSH^C0CXPATH(ZOUT,ZV) ; value + . D PUSH^C0CXPATH(ZOUT,"") ; end header + D PUSH^C0CXPATH(ZOUT,"
"_ZI_"
"_$G(@ZIN@("V",ZJ,ZI,1))_"
") ;end of table + Q + ; +ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P(@ZTAB@(ZFN),"^",1) +ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P(@ZTAB@(ZFN),"^",2) +ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P($G(@ZTAB@(ZFN)),"^",3) + ; +ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P($G(@ZTAB@(ZFN,"I")),"^",3) + ; Index: ccr/branches/ohum/p/C0CRNFRP.m =================================================================== --- ccr/branches/ohum/p/C0CRNFRP.m (revision 1333) +++ ccr/branches/ohum/p/C0CRNFRP.m (revision 1337) @@ -1,342 +1,342 @@ -C0CRNFRPC ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09 - ;;1.0;C0C;;Dec 9, 2009;Build 1 - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is the Reference Name Format (RNF) RPC Library ",! - W ! - Q - ; - ;This routine will be mirroring C0CRNF and transform the output - ;of the tags into an RPC friendly format - ;The tags will be exactly as they are in C0CRNF -FIELDS(C0CFRTN,C0CFILE) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF, - ;C0CFRTN IS PASSED BY REFERENCE, C0CF IS PASSED BY VALUE - ;RETURN FORMAT: - ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS - ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER" - ; - ;SAMPLE OUTPUT FROM FIELDS^C0CRNF: - ;C0CRNFFIELDS("*AMOUNT OF MILITARY RETIREMENT")="2^.3625" - ; - ;FORMAT APPEARS TO BE: - ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER" - ; - ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON - S DEBUG=0 - ;SET RETURN VALUE - S C0CFRTN=$NA(^TMP("C0CRNF",$J)) - K @C0CFRTN - ;RUN WRAPPED CALL - D FIELDS^C0CRNF("C0CRTN",C0CFILE) - S J="" - S I=1 - ;FORMAT RETURN - F S J=$O(C0CRTN(J)) Q:J="" D ; FOR EACH FIELD IN THE ARRAY - . S @C0CFRTN@(I)=J_"^"_C0CRTN(J) - . S I=I+1 - S @C0CFRTN@(0)=I-1 - ;CLEAN UP - K J,I - Q - ; -GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME - ; GRTN IS PASSED BY NAME - ; - ; OLD TAG DO NOT USE! - Q - ; -GETN(C0CGRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP - ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL - ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP - ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" - ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP - ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE - ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP - ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP - ; .. NULL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE - ; IF GREF IS "" THE FIRST RECORD IS OBTAINED - ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE - ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN - ; GREF IS THE VALUE FOR THE INDEX - ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED - ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN - ; - ; - ;RETURN FORMAT: - ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS^FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ_$C(30)" - ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER^VALUE^INTERNAL_VALUE_$C(30)" - ; - ;SAMPLE OUTPUT FROM FIELDS^C0CRNF: - ;C0CRNFGETN(0)="2^RNF1^5095^3091209^2908^3268" - ;C0CRNFGETN("1U4N")="2^.0905^H5369" - ;C0CRNFGETN("1U4N","I")="^^H5369" - ;C0CRNFGETN("ADDRESS CHANGE DT/TM")="2^.118^OCT 21,2009@08:03:26" - ;C0CRNFGETN("ADDRESS CHANGE DT/TM","I")="^^3091021.080326" - ; - ;FORMAT APPEARS TO BE: - ;VARIABLENAME(0)="FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ" - ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER^VALUE" - ;VARIABLENAME("FIELD_NAME","I")="^^INTERNAL_VALUE" - ; - ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON - S DEBUG=0 - ;SET RETURN VALUE - S C0CGRTN=$NA(^TMP("C0CRNF",$J)) - K @C0CGRTN - ;RUN WRAPPED CALL - D GETN^C0CRNF("C0CRTN",$G(GFILE),$G(GREF),$G(GNDX),$G(GNN)) - S J="" - S I=1 - ;FORMAT RETURN - F S J=$O(C0CRTN(J)) Q:J="" D ; FOR EACH FIELD IN THE ARRAY - . I J=0 S J=$O(C0CRTN(J)) ; SKIP THE 0 NODE - . S @C0CGRTN@(I)=J_"^"_C0CRTN(J)_"^" ; GETS THE FIRST LINE - . ;S J=$O(C0CRTN(J)) ; INCREMENT J SO WE CAN GET THE INTERNAL DATA - . ;TEST TO SEE IF INTERNAL DATA EXISTS - . I $D(C0CRTN(J,"I"))=1 D - . . S @C0CGRTN@(I)=@C0CGRTN@(I)_$P(C0CRTN(J,"I"),U,3) ; GETS THE INTERNAL VALUE PIECE 3 - . S I=I+1 - S @C0CGRTN@(0)=I-1_"^"_C0CRTN(0) - ;CLEAN UP - K J,I - Q - ; -GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP - ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 - ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL - ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN - ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP - ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" - ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP - ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE - ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE - ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP - ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP - ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE - ; IF GREF IS "" THE FIRST RECORD IS OBTAINED - ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE - ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN - ; GREF IS THE VALUE FOR THE INDEX - ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED - ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN - ; - ; - N GIEN,GF - S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE - I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN - E D ; WE ARE USING AN INDEX - . ;N ZG - . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX - . I ZG'="" D ; - . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? - . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN - . . E S GIEN="" ; NOT FOUND IN INDEX - . E S GIEN="" ; - ;W "IEN: ",GIEN,! - ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME - I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) - E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) - S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE - D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP - K C0CTMP - D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") - D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE - S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE - S (C0CI,C0CJ)="" - F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES - . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE - . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS - . . ;W C0CJ," ",C0CI,! - . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME - . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; - . . I C0CVALUE["C0CTMP" D ; WP FIELD - . . . N ZT,ZWP S ZWP=0 ;ITERATOR - . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE - . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE - . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; - . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP - . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " - . . . . S C0CVALUE=C0CVALUE_ZT ; - . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 - . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) - I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED - . S C0CI="" - . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY - . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES - Q - ; -GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES - ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP - ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#" - ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP - ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE - ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES - ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE - ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP - ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP - ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE - ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE - ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN - ; .. OF THE FILE WILL BE USED - ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE - ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED - ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE - ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD - ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED - ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL - ;N GATMP,GAI,GAF - S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE - I '$D(GAIDX) S GAIDX="" ;DEFAULT - I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED - I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX - W GAF,! - W $O(@GAF@(0)) ; - S GAI=0 ;ITERATOR - F S GAI=$O(@GAF@(GAI)) Q:GAI="" D ; - . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD - . N GAX S GAX=0 - . F S GAX=$O(GATMP(GAX)) Q:GAX="" D ;PULL OUT THE FIELDS - . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN - Q - ; -ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX - ; - S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD# - S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE - Q - ; -RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT - ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES - ; RNSTY IS STYLE OF THE OUTPUT - - ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES - ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES - ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES - N RNR,RNC ;ROW ROOT,COL ROOT - N RNI,RNJ,RNX - I '$D(RNSTY) S RNSTY="NV" ;DEFAULT - I RNSTY="NV" D NV(RNRTN,RNIN) ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION - E D VN(RNRTN,RNIN) ; - Q - ; -NV(RNRTN,RNIN) ; - S RNR=$NA(@RNIN@("F")) - S RNC=$NA(@RNIN@("V")) - ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER - S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD" - S RNI="" - F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN - . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA - S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA - D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS - S RNI="" - F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW - . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD - . S RNJ="" - . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL - . . I $D(@RNC@(RNJ,RNI,1)) D ; THIS ROW HAS THIS COLUMN - . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA - . . E S RNX=RNX_"," ; NUL COLUMN - . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA - . D PUSH^GPLXPATH(RNRTN,RNX) - Q - ; -VN(RNRTN,RNIN) ; - S RNR=$NA(@RNIN@("V")) - S RNC=$NA(@RNIN@("F")) - ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER - S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD" - S RNI="" - F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN - . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA - S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA - D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS - S RNI="" - F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW - . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD - . S RNJ="" - . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL - . . I $D(@RNR@(RNI,RNJ,1)) D ; THIS ROW HAS THIS COLUMN - . . . S RNX=RNX_""""_@RNR@(RNI,RNJ,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA - . . E S RNX=RNX_"," ; NUL COLUMN - . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA - . D PUSH^GPLXPATH(RNRTN,RNX) - Q - ; -READCSV(PATH,NAME,GLB) ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME - ; - Q $$FTG^%ZISH(PATH,NAME,GLB,1) - ; -FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV - ; - ;N G1,G2 - I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE - S G1=$NA(^TMP($J,"C0CCSV",1)) - S G2=$NA(^TMP($J,"C0CCSV",2)) - D GETN2(G1,FNUM) ; GET THE MATRIX - D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE - K @G1 - D FILEOUT(G2,"FILE_"_FNUM_".csv") - K @G2 - Q - ; -FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE - ; - W $$OUTPUT^GPLXPATH($NA(@FOARY@(1)),FONAM,^TMP("GPLCCR","ODIR")) - Q - ; -FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM - ; - N C0CF - S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE - S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT - I C0CF["()" S C0CF=$P(C0CF,"()",1) - Q C0CF - ; -SKIP ; - N TXT,DIERR - S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT") - I $D(DIERR) D CLEAN^DILF Q - W " report_text:",! ;Progress Note Text - N LN S LN=0 - F S LN=$O(TXT(LN)) Q:'LN D - . W " text"_LN_": "_TXT(LN),! - . Q - Q - ; -ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P(@ZTAB@(ZFN),"^",1) -ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P(@ZTAB@(ZFN),"^",2) -ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P($G(@ZTAB@(ZFN)),"^",3) - ; -ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P($G(@ZTAB@(ZFN,"I")),"^",3) - ; +C0CRNFRPC ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09 + ;;1.0;C0C;;Dec 9, 2009; + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is the Reference Name Format (RNF) RPC Library ",! + W ! + Q + ; + ;This routine will be mirroring C0CRNF and transform the output + ;of the tags into an RPC friendly format + ;The tags will be exactly as they are in C0CRNF +FIELDS(C0CFRTN,C0CFILE) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF, + ;C0CFRTN IS PASSED BY REFERENCE, C0CF IS PASSED BY VALUE + ;RETURN FORMAT: + ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS + ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER" + ; + ;SAMPLE OUTPUT FROM FIELDS^C0CRNF: + ;C0CRNFFIELDS("*AMOUNT OF MILITARY RETIREMENT")="2^.3625" + ; + ;FORMAT APPEARS TO BE: + ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER" + ; + ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON + S DEBUG=0 + ;SET RETURN VALUE + S C0CFRTN=$NA(^TMP("C0CRNF",$J)) + K @C0CFRTN + ;RUN WRAPPED CALL + D FIELDS^C0CRNF("C0CRTN",C0CFILE) + S J="" + S I=1 + ;FORMAT RETURN + F S J=$O(C0CRTN(J)) Q:J="" D ; FOR EACH FIELD IN THE ARRAY + . S @C0CFRTN@(I)=J_"^"_C0CRTN(J) + . S I=I+1 + S @C0CFRTN@(0)=I-1 + ;CLEAN UP + K J,I + Q + ; +GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME + ; GRTN IS PASSED BY NAME + ; + ; OLD TAG DO NOT USE! + Q + ; +GETN(C0CGRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP + ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL + ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP + ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" + ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP + ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE + ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP + ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP + ; .. NULL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE + ; IF GREF IS "" THE FIRST RECORD IS OBTAINED + ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE + ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN + ; GREF IS THE VALUE FOR THE INDEX + ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED + ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN + ; + ; + ;RETURN FORMAT: + ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS^FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ_$C(30)" + ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER^VALUE^INTERNAL_VALUE_$C(30)" + ; + ;SAMPLE OUTPUT FROM FIELDS^C0CRNF: + ;C0CRNFGETN(0)="2^RNF1^5095^3091209^2908^3268" + ;C0CRNFGETN("1U4N")="2^.0905^H5369" + ;C0CRNFGETN("1U4N","I")="^^H5369" + ;C0CRNFGETN("ADDRESS CHANGE DT/TM")="2^.118^OCT 21,2009@08:03:26" + ;C0CRNFGETN("ADDRESS CHANGE DT/TM","I")="^^3091021.080326" + ; + ;FORMAT APPEARS TO BE: + ;VARIABLENAME(0)="FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ" + ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER^VALUE" + ;VARIABLENAME("FIELD_NAME","I")="^^INTERNAL_VALUE" + ; + ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON + S DEBUG=0 + ;SET RETURN VALUE + S C0CGRTN=$NA(^TMP("C0CRNF",$J)) + K @C0CGRTN + ;RUN WRAPPED CALL + D GETN^C0CRNF("C0CRTN",$G(GFILE),$G(GREF),$G(GNDX),$G(GNN)) + S J="" + S I=1 + ;FORMAT RETURN + F S J=$O(C0CRTN(J)) Q:J="" D ; FOR EACH FIELD IN THE ARRAY + . I J=0 S J=$O(C0CRTN(J)) ; SKIP THE 0 NODE + . S @C0CGRTN@(I)=J_"^"_C0CRTN(J)_"^" ; GETS THE FIRST LINE + . ;S J=$O(C0CRTN(J)) ; INCREMENT J SO WE CAN GET THE INTERNAL DATA + . ;TEST TO SEE IF INTERNAL DATA EXISTS + . I $D(C0CRTN(J,"I"))=1 D + . . S @C0CGRTN@(I)=@C0CGRTN@(I)_$P(C0CRTN(J,"I"),U,3) ; GETS THE INTERNAL VALUE PIECE 3 + . S I=I+1 + S @C0CGRTN@(0)=I-1_"^"_C0CRTN(0) + ;CLEAN UP + K J,I + Q + ; +GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP + ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 + ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL + ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN + ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP + ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" + ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP + ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE + ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE + ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP + ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP + ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE + ; IF GREF IS "" THE FIRST RECORD IS OBTAINED + ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE + ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN + ; GREF IS THE VALUE FOR THE INDEX + ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED + ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN + ; + ; + N GIEN,GF + S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE + I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN + E D ; WE ARE USING AN INDEX + . ;N ZG + . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX + . I ZG'="" D ; + . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? + . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN + . . E S GIEN="" ; NOT FOUND IN INDEX + . E S GIEN="" ; + ;W "IEN: ",GIEN,! + ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME + I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) + E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) + S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE + D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP + K C0CTMP + D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") + D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE + S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE + S (C0CI,C0CJ)="" + F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES + . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE + . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS + . . ;W C0CJ," ",C0CI,! + . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME + . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; + . . I C0CVALUE["C0CTMP" D ; WP FIELD + . . . N ZT,ZWP S ZWP=0 ;ITERATOR + . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE + . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE + . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; + . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP + . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " + . . . . S C0CVALUE=C0CVALUE_ZT ; + . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 + . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) + I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED + . S C0CI="" + . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY + . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES + Q + ; +GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES + ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP + ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#" + ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP + ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE + ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES + ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE + ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP + ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP + ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE + ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE + ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN + ; .. OF THE FILE WILL BE USED + ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE + ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED + ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE + ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD + ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED + ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL + ;N GATMP,GAI,GAF + S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE + I '$D(GAIDX) S GAIDX="" ;DEFAULT + I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED + I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX + W GAF,! + W $O(@GAF@(0)) ; + S GAI=0 ;ITERATOR + F S GAI=$O(@GAF@(GAI)) Q:GAI="" D ; + . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD + . N GAX S GAX=0 + . F S GAX=$O(GATMP(GAX)) Q:GAX="" D ;PULL OUT THE FIELDS + . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN + Q + ; +ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX + ; + S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD# + S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE + Q + ; +RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT + ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES + ; RNSTY IS STYLE OF THE OUTPUT - + ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES + ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES + ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES + N RNR,RNC ;ROW ROOT,COL ROOT + N RNI,RNJ,RNX + I '$D(RNSTY) S RNSTY="NV" ;DEFAULT + I RNSTY="NV" D NV(RNRTN,RNIN) ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION + E D VN(RNRTN,RNIN) ; + Q + ; +NV(RNRTN,RNIN) ; + S RNR=$NA(@RNIN@("F")) + S RNC=$NA(@RNIN@("V")) + ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER + S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD" + S RNI="" + F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN + . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA + S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA + D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS + S RNI="" + F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW + . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD + . S RNJ="" + . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL + . . I $D(@RNC@(RNJ,RNI,1)) D ; THIS ROW HAS THIS COLUMN + . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA + . . E S RNX=RNX_"," ; NUL COLUMN + . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA + . D PUSH^GPLXPATH(RNRTN,RNX) + Q + ; +VN(RNRTN,RNIN) ; + S RNR=$NA(@RNIN@("V")) + S RNC=$NA(@RNIN@("F")) + ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER + S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD" + S RNI="" + F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN + . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA + S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA + D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS + S RNI="" + F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW + . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD + . S RNJ="" + . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL + . . I $D(@RNR@(RNI,RNJ,1)) D ; THIS ROW HAS THIS COLUMN + . . . S RNX=RNX_""""_@RNR@(RNI,RNJ,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA + . . E S RNX=RNX_"," ; NUL COLUMN + . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA + . D PUSH^GPLXPATH(RNRTN,RNX) + Q + ; +READCSV(PATH,NAME,GLB) ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME + ; + Q $$FTG^%ZISH(PATH,NAME,GLB,1) + ; +FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV + ; + ;N G1,G2 + I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE + S G1=$NA(^TMP($J,"C0CCSV",1)) + S G2=$NA(^TMP($J,"C0CCSV",2)) + D GETN2(G1,FNUM) ; GET THE MATRIX + D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE + K @G1 + D FILEOUT(G2,"FILE_"_FNUM_".csv") + K @G2 + Q + ; +FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE + ; + W $$OUTPUT^GPLXPATH($NA(@FOARY@(1)),FONAM,^TMP("GPLCCR","ODIR")) + Q + ; +FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM + ; + N C0CF + S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE + S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT + I C0CF["()" S C0CF=$P(C0CF,"()",1) + Q C0CF + ; +SKIP ; + N TXT,DIERR + S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT") + I $D(DIERR) D CLEAN^DILF Q + W " report_text:",! ;Progress Note Text + N LN S LN=0 + F S LN=$O(TXT(LN)) Q:'LN D + . W " text"_LN_": "_TXT(LN),! + . Q + Q + ; +ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P(@ZTAB@(ZFN),"^",1) +ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P(@ZTAB@(ZFN),"^",2) +ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P($G(@ZTAB@(ZFN)),"^",3) + ; +ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P($G(@ZTAB@(ZFN,"I")),"^",3) + ; Index: ccr/branches/ohum/p/C0CRPMS.m =================================================================== --- ccr/branches/ohum/p/C0CRPMS.m (revision 1333) +++ ccr/branches/ohum/p/C0CRPMS.m (revision 1337) @@ -1,133 +1,133 @@ -C0CRPMS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR RPMS ;1/14/09 14:33 - ;;0.1;CCDCCR;;JUL 16,2008;Build 1 - ;Copyright 2008 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -DISPLAY ; RUN THE PCC DISPLAY ROUTINE - D ^APCDDISP - Q - ; -VTYPES ; - D GETN2^C0CRNF("G1",9999999.07) - ZWR G1 - Q - ; -VISITS(C0CDFN,C0CCNT) ;LIST VISIT DATES FOR PATIENT DFN - ; C0CCNT IS A LIMIT ON HOW MANY VISITS TO DISPLAY ; DEFAULTS TO ALL - I '$D(C0CCNT) S C0CCNT=999999999 - N G,GN - S G="" S GN=0 - F S G=$O(^AUPNVSIT("AA",C0CDFN,G)) Q:(G="")!(GN>C0CCNT) D ; - . S GN=GN+1 - . W $$FMDTOUTC^C0CUTIL(9999999-G),! - Q - ; -VISITS2(C0CDFN,C0CCNT) ;SECOND VERSION USING NEXTV - ; - N C0CG,GN - S C0CG="" - S GN=0 - I '$D(C0CCNT) S C0CCNT=99999999 - F S C0CG=$$NEXTV(C0CDFN,C0CG) Q:(C0CG="")!(GN'C0CCNT) D ; + . S GN=GN+1 + . W $$FMDTOUTC^C0CUTIL(9999999-G),! + Q + ; +VISITS2(C0CDFN,C0CCNT) ;SECOND VERSION USING NEXTV + ; + N C0CG,GN + S C0CG="" + S GN=0 + I '$D(C0CCNT) S C0CCNT=99999999 + F S C0CG=$$NEXTV(C0CDFN,C0CG) Q:(C0CG="")!(GN'0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN - . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS - . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","SNOTBL","MEDSCODE") ;CODES - . ; D PATD^C0CSNOA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES - D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED - ; W "ATTRIBUTES: ",SATTR,! - Q SATTR - ; -RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES - K ^TMP("C0CSNO","RESUME") - K ^TMP("C0CSNO") - Q - ; -CLIST ; LIST THE CATEGORIES - ; - I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS - N CLBASE,CLNUM,ZI,CLIDX - S CLBASE=$NA(@SNOBASE@("SNOTBL","CATS")) - S CLNUM=@CLBASE@(0) - F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES - . S CLIDX=@CLBASE@(ZI) - . W "(",$P(@CLBASE@(CLIDX),"^",1) - . W ":",$P(@CLBASE@(CLIDX),"^",2),") " - . W CLIDX,! - ; D PARY^C0CXPATH(CLBASE) - Q - ; -CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES - ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT - ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE - ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME - ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, - ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" - ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES - ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY - ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING - ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY - ; NUMBER IE CTBL_X(CDFN)="" - ; - ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST - S CCTBL=$NA(@CBASE@(CTBL,"CATS")) - ; W "CBASE: ",CCTBL,! - ; - I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY - . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY - . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY - . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT - . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY - . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME - . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 - ; - S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY - S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT - S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK - ; - S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED - ; - S CPATLIST=$NA(@CBASE@(CTBL,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT - ; W "IENS BASE: ",CPATLIST,! - S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST - ; - Q - ; -REUSE ; GET SAVED VALUES FROM ^TMP("C0CSAV") AND PUT THEM IN A DATABASE - ; - D ASETUP - D AINIT - N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH - S SAVBASE=$NA(^TMP("C0CSAV","VARS")) - S SNOI="" - F D Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST - . S SNOI=$O(@SAVBASE@(SNOI)) - . S SNOJ=@SAVBASE@(SNOI) - . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1) - . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE - . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON - . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE - . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE - . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE - . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,! - . W SNOK,! - . W SNOJ,! - Q - ; +C0CSNOA ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;Copyright 2008,2009 George Lilly, University of Minnesota. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; THESE ROUTINES ANALYZE THE POTENTIAL RETRIEVAL OF SNOMED CT CODES + ; FOR PATIENT DRUG ALLERGIES FOR INCLUSION IN THE CCR OR CCD + ; USING THE VISTA LEXICON ^LEX + ; +ANALYZE(BEGIEN,IENCNT) ; SNOMED RETRIEVAL ANALYSIS ROUTINE + ; BEGINS AT BEGIEN AND GOES FOR IENCNT DRUGS IN GMRD + ; TO RESUME AT NEXT DRUG, USE BEGIEN="" + ; USE RESET^C0CSNOA TO RESET TO TOP OF DRUG LIST + ; + N SNOARY,SNOTMP,SNOI,SNOIEN,RATTR + N CCRGLO + D ASETUP ; SET UP VARIABLES AND GLOBALS + D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE + I '$D(@SNOBASE@("RESUME")) S @SNOBASE@("RESUME")=$O(@GMRBASE@(1)) ;1ST TME + S RESUME=@SNOBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN + S SNOIEN=BEGIEN ; BEGIN WITH THE BEGIEN RECORD + I SNOIEN="" S SNOIEN=RESUME + I +SNOIEN=0 D Q ; AT THE END OF THE ALLERGY LIST + . W "END OF DRUG LIST, CALL RESET^C0CSNOA",! + F SNOI=1:1:IENCNT D Q:+SNOIEN=0 ; FOR IENCNT NUMBER OF PATIENTS OR END + . ;D CCRRPC^C0CCCR(.CCRGLO,SNOIEN,"CCR","","","") ;PROCESS THE CCR + . W SNOIEN,@GMRBASE@(SNOIEN,0),! + . N SNORTN,TTERM ; RETURN ARRAY + . S TTERM=$P(@GMRBASE@(SNOIEN,0),"^",1)_" ALLERGY" + . D TEXTRPC(.SNORTN,TTERM) + . I $D(SNORTN) ZWR SNORTN + . K @SNOBASE@("VARS",SNOIEN) ; CLEAR OUT OLD VARS + . I $P(TTMP,"^",1)=1 S @SNOBASE@("VARS",SNOIEN)=TTERM_"^"_TTMP_"^"_SNORTN(0) + . ; + . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP + . ; + . S RATTR=$$SETATTR(SNOIEN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS + . S @SNOBASE@("ATTR",SNOIEN)=RATTR ; SAVE THE ATRIBUTES FOR THIS DRUG + . ; + . N CATNAME,CATTBL + . S CATNAME="" + . D CPUSH(.CATNAME,SNOBASE,"SNOTBL",SNOIEN,RATTR) ; ADD TO CATEGORY + . ; W "CATEGORY NAME: ",CATNAME,! + . ; + . S SNOIEN=$O(@GMRBASE@(SNOIEN)) ; NEXT RECORD + . S @SNOBASE@("RESUME")=SNOIEN ; WHERE WE ARE LEAVING OFF THIS RUN + ; D PARY^C0CXPATH(@SNOBASE@("ATTRTBL")) + Q + ; +TEXTRPC(ORTN,ITEXT) ; CALL THE LEXICON WITH ITEXT AND RETURN RESULTS IN ORTN + ; + ;N TTMP + W ITEXT,! + S TTMP=$$TEXT^LEXTRAN(ITEXT,"","","SCT","ORTN") + Q + ; +ASETUP ; SET UP GLOBALS AND VARS SNOBASE AND SNOTBL + I '$D(SNOBASE) S SNOBASE=$NA(^TMP("C0CSNO")) + I '$D(@SNOBASE) S @SNOBASE="" + I '$D(GMRBASE) S GMRBASE=$NA(^GMRD(120.82)) + I '$D(SNOTBL) S SNOTBL=$NA(^TMP("C0CSNO","SNOTBL","TABLE")) ; ATTR TABLE + S ^TMP("C0CSNO","TABLES","SNOTBL")=SNOTBL ; TABLE OF TABLES + Q + ; +AINIT ; INITIALIZE ATTRIBUTE TABLE + I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS + K @SNOTBL + D APUSH^C0CRIMA(SNOTBL,"CODE") + D APUSH^C0CRIMA(SNOTBL,"NOCODE") + D APUSH^C0CRIMA(SNOTBL,"MULTICODE") + D APUSH^C0CRIMA(SNOTBL,"SUBMULTI") + D APUSH^C0CRIMA(SNOTBL,"DONE") + Q +APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL + ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING + ; PTBL IS THE NAME OF A TABLE IN @SNOBASE@("TABLES") - "SNOTBL"=ALL VALUES + ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) + I '$D(SNOBASE) D ASETUP ; FOR COMMANDLINE PROCESSING + N USETBL + I '$D(@SNOBASE@("TABLES",PTBL)) D Q ; NO TABLE + . W "ERROR NO SUCH TABLE",! + S USETBL=@SNOBASE@("TABLES",PTBL) + S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL + Q +SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS + N SBASE,SATTR + S SBASE=$NA(@SNOBASE@("VARS",SDFN)) + D APOST("SATTR","SNOTBL","DONE") + I $P(TTMP,"^",1)=1 D APOST("SATTR","SNOTBL","CODE") + I $P(TTMP,"^",1)=-1 D APOST("SATTR","SNOTBL","NOCODE") + Q SATTR ; C0C + I $D(@SBASE@("PROBLEMS",1)) D ; + . D APOST("SATTR","SNOTBL","PROBLEMS") + . ; W "POSTING PROBLEMS",! + I $D(@SBASE@("VITALS",1)) D APOST("SATTR","SNOTBL","VITALS") + I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES + . D APOST("SATTR","SNOTBL","MEDS") + . N ZR,ZI + . D GETPA^C0CRIMA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES + . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN + . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS + . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","SNOTBL","MEDSCODE") ;CODES + . ; D PATD^C0CSNOA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES + D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED + ; W "ATTRIBUTES: ",SATTR,! + Q SATTR + ; +RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES + K ^TMP("C0CSNO","RESUME") + K ^TMP("C0CSNO") + Q + ; +CLIST ; LIST THE CATEGORIES + ; + I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS + N CLBASE,CLNUM,ZI,CLIDX + S CLBASE=$NA(@SNOBASE@("SNOTBL","CATS")) + S CLNUM=@CLBASE@(0) + F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES + . S CLIDX=@CLBASE@(ZI) + . W "(",$P(@CLBASE@(CLIDX),"^",1) + . W ":",$P(@CLBASE@(CLIDX),"^",2),") " + . W CLIDX,! + ; D PARY^C0CXPATH(CLBASE) + Q + ; +CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES + ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT + ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE + ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME + ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, + ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" + ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES + ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY + ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING + ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY + ; NUMBER IE CTBL_X(CDFN)="" + ; + ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST + S CCTBL=$NA(@CBASE@(CTBL,"CATS")) + ; W "CBASE: ",CCTBL,! + ; + I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY + . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY + . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY + . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT + . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY + . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME + . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 + ; + S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY + S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT + S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK + ; + S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED + ; + S CPATLIST=$NA(@CBASE@(CTBL,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT + ; W "IENS BASE: ",CPATLIST,! + S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST + ; + Q + ; +REUSE ; GET SAVED VALUES FROM ^TMP("C0CSAV") AND PUT THEM IN A DATABASE + ; + D ASETUP + D AINIT + N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH + S SAVBASE=$NA(^TMP("C0CSAV","VARS")) + S SNOI="" + F D Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST + . S SNOI=$O(@SAVBASE@(SNOI)) + . S SNOJ=@SAVBASE@(SNOI) + . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1) + . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE + . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON + . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE + . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE + . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE + . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,! + . W SNOK,! + . W SNOJ,! + Q + ; Index: ccr/branches/ohum/p/C0CSOAP.m =================================================================== --- ccr/branches/ohum/p/C0CSOAP.m (revision 1333) +++ ccr/branches/ohum/p/C0CSOAP.m (revision 1337) @@ -1,273 +1,273 @@ -C0CSOAP ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is an SOAP utility library",! - W ! - Q - ; -TEST1 - S url="https://ec2-75-101-247-83.compute-1.amazonaws.com:8181/ccr/CCRService?wsdl" - D GET1URL^C0CEWD2(url) - Q - ; -INITFARY(ARY) ;initialize the Fileman Field array for SOAP processing - ; ARY is passed by name - S @ARY@("XML FILE NUMBER")="178.301" - S @ARY@("BINDING SUBFILE NUMBER")="178.3014" - S @ARY@("MIME TYPE")="2.3" - S @ARY@("PROXY SERVER")="2.4" - S @ARY@("REPLY TEMPLATE")=".03" - S @ARY@("TEMPLATE NAME")=".01" - S @ARY@("TEMPLATE XML")="3" - S @ARY@("URL")="1" - S @ARY@("WSDL URL")="2" - S @ARY@("XML")="2.1" - S @ARY@("XML HEADER")="2.2" - S @ARY@("XPATH REDUCTION STRING")="2.5" - S @ARY@("CCR VARIABLE")="4" - S @ARY@("FILEMAN FIELD NAME")="1" - S @ARY@("FILEMAN FIELD NUMBER")="1.2" - S @ARY@("FILEMAN FILE POINTER")="1.1" - S @ARY@("INDEXED BY")=".05" - S @ARY@("SQLI FIELD NAME")="3" - S @ARY@("VARIABLE NAME")="2" - Q - ; -RESTID(INNAM,INFARY) ;EXTRINSIC TO RESOLVE TEMPLATE PASSED BY NAME - ; FILE IS IDENTIFIED IN FARY, PASSED BY NAME - I '$D(INFARY) D ; NO FILE ARRAY PASSED - . S INFARY="FARY" - . D INITFARY(INFARY) - N ZN,ZREF,ZR - S ZN=@INFARY@("XML FILE NUMBER") - S ZREF=$$FILEREF^C0CRNF(ZN) - S ZR=$O(@ZREF@("B",INNAM,"")) - Q ZR - ; -TESTSOAP ; - ; USING ICD9 WEB SERVICE TO TEST SOAP - S G("CODE")="E*" - S G("CODELN")=3 - D SOAP("GPL","ICD9","G") - Q - ; -SOAP(C0CRTN,C0CTID,C0CVA,C0CVOR,ALTXML,IFARY) ; MAKES A SOAP CALL FOR - ; TEMPLATE ID C0CTID - ; RETURNS THE XML RESULT IN C0CRTN, PASSED BY NAME - ; C0CVA IS PASSED BY NAME AND IS THE VARIABLE ARRAY TO PASS TO BIND - ; C0CVOR IS THE NAME OF A VARIABLE OVERRIDE ARRAY, WHICH IS APPLIED - ; BEFORE MAPPING - ; IF ALTXML IS PASSED, BIND AND MAP WILL BE SKIPPED AND - ; ALTXML WILL BE USED INSTEAD - ; - ; ARTIFACTS SECTION - ; THE FOLLOWING WILL SET UP DEBUGGING ARTIFACTS FOR A POSSIBLE FUTURE - ; ONLINE DEBUGGER. IF DEBUG=1, VARIABLES CONTAINING INTERMEDIATE RESULTS - ; WILL NOT BE NEWED. - I $G(WSDEBUG)="" N C0CV ; CATALOG OF ARTIFACT VARIABLES AND ARRAYS - S C0CV(100,"C0CXF","XML TEMPLATE FILE NUMBER")="" - S C0CV(200,"C0CHEAD","SOAP HEADER VARIABLE NAME")="" - S C0CV(300,"HEADER","SOAP HEADER")="" - S C0CV(400,"C0CMIME","MIME TYPE")="" - S C0CV(500,"C0CURL","WS URL")="" - S C0CV(550,"C0CPURL","PROXY URL")="" - S C0CV(600,"C0CXML","XML VARIABLE NAME")="" - S C0CV(700,"XML","OUTBOUND XML")="" - S C0CV(800,"C0CRSLT","RAW XML RESULT RETURNED FROM WEB SERVICE")="" - S C0CV(900,"C0CRHDR","RETURNED HEADER")="" - S C0CV(1000,"C0CRXML","XML RESULT NORMALIZED")="" - S C0CV(1100,"C0CR","REPLY TEMPLATE")="" - S C0CV(1200,"C0CREDUX","REDUX STRING")="" - S C0CV(1300,"C0CIDX","RESULT XPATH INDEX")="" - S C0CV(1400,"C0CARY","RESULT XPATH ARRAY")="" - S C0CV(1500,"C0CNOM","RESULT DOM DOCUMENT NAME")="" - S C0CV(1600,"C0CID","RESULT DOM ID")="" - I $G(DEBUG)'="" G NOTNEW ; SKIP NEWING THE VARIABLES IF IN DEBUG - N ZI,ZJ S ZI="" -NEW - S ZI=$O(C0CV(ZI)) - S ZJ=$O(C0CV(ZI,"")) ; SET UP NEW COMMAND - ;W ZJ,! - N @ZJ ; NEW THE VARIABLE - I $O(C0CV(ZI))'="" G NEW ;LOOP TO GET NEW IN CONTEXT -NOTNEW - ; END ARTIFACTS - ; - I '$D(IFARY) D INITFARY("C0CF") ; SET FILE NUMBER AND PARAMATERS - E D ; - . K C0CF - . M C0CF=@IFARY - S C0CXF=C0CF("XML FILE NUMBER") ; FILE NUMBER FOR THE XML TEMPLATE FILE - I +C0CTID=0 D ; A STRING WAS PASSED FOR THE TEMPLATE NAME - . S C0CUTID=$$RESTID(C0CTID,"C0CF") ;RESOLVE TEMPLATE IEN FROM NAME - E S C0CUTID=C0CTID ; AN IEN WAS PASSED - N XML,TEMPLATE,HEADER - N C0CFH S C0CFH=C0CF("XML HEADER") - S C0CHEAD=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFH,,"HEADER") - N C0CFM S C0CFM=C0CF("MIME TYPE") - S C0CMIME=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFM) - N C0CFP S C0CFP=C0CF("PROXY SERVER") - S C0CPURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFP) - N C0CFU S C0CFU=C0CF("URL") - S C0CURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFU) - N C0CFX S C0CFX=C0CF("XML") - S C0CXML=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFX,,"XML") - N C0CFT S C0CFT=C0CF("TEMPLATE XML") - S C0CTMPL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFT,,"TEMPLATE") - I C0CTMPL="TEMPLATE" D ; there is a template to process - . K XML ; going to replace the xml array - . N VARS - . I $D(C0CVOR) M @C0CVA=@C0CVOR ; merge in varible overrides - . I '$D(ALTXML) D ; if ALTXML is passed in, don't bind - . . D BIND("VARS",C0CVA,C0CUTID,"C0CF") - . . D MAP("XML","VARS",TPTR,"C0CF") - . . K XML(0) - . E M XML=@ALTXML ; use ALTXML instead - I $G(C0CPROXY) S C0CURL=C0CPURL - K C0CRSLT,C0CRHDR - B - S ok=$$httpPOST^%zewdGTM(C0CURL,.XML,C0CMIME,.C0CRSLT,.HEADER,"",.gpl5,.C0CRHDR) - K C0CRXML - D NORMAL("C0CRXML","C0CRSLT(1)") ;RETURN XML IN AN ARRAY - N C0CFR S C0CFR=$G(C0CF("REPLY TEMPLATE")) - S C0CR=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFR,"I") ; REPLY TEMPLATE - ; reply templates are optional and are specified by populating a - ; template pointer in field 2.5 of the request template - ; if specified, the reply template is the source of the REDUX string - ; used for XPath on the reply, and for UNBIND processing - ; if no reply template is specified, REDUX is obtained from the request - ; template and no UNBIND processing is performed. The XPath array is - ; returned without variable bindings - I C0CR'="" D ; REPLY TEMPLATE EXISTS - . I +$G(DEBUG)'=0 W "REPLY TEMPLATE:",C0CR,! - . S C0CTID=C0CR ; - N C0CFRDX S C0CFRDX=C0CF("XPATH REDUCTION STRING") - S C0CREDUX=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFRDX) ;XPATH REDUCTION STRING - K C0CIDX,C0CARY ; XPATH INDEX AND ARRAY VARS - S C0CNOM="C0CWS"_$J ; DOCUMENT NAME FOR THE DOM - S C0CID=$$PARSE^C0CXEWD("C0CRXML",C0CNOM) ;CALL THE PARSER - S C0CID=$$FIRST^C0CXEWD($$ID^C0CXEWD(C0CNOM)) ;ID OF FIRST NODE - D XPATH^C0CXEWD(C0CID,"/","C0CIDX","C0CARY","",C0CREDUX) ;XPATH GENERATOR - ; Next, call UNBIND to map the reply XPath array to variables - ; This is only done if a Reply Template is provided - D DEMUXARY(C0CRTN,"C0CARY") - ; M @C0CRTN=C0CARY - Q - ; -DEMUXARY(OARY,IARY) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO - ; FORMAT @OARY@(x,xpath) where x is the first multiple - N ZI,ZJ,ZK,ZL S ZI="" - F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; - . D DEMUX^C0CMXP("ZJ",ZI) - . S ZK=$P(ZJ,"^",3) - . S ZK=$RE($P($RE(ZK),"/",1)) - . S ZL=$P(ZJ,"^",1) - . I ZL="" S ZL=1 - . S @OARY@(ZL,ZK)=@IARY@(ZI) - Q - ; -NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML - ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME - ; - N ZI,ZN,ZTMP - S ZN=1 - S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">" - S ZN=ZN+1 - F S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)="" D ; - . S @OUTXML@(ZN)=@OUTXML@(ZN)_">" - . S ZN=ZN+1 - Q - ; -MAP(RARY,IVARS,TPTR,INFARY) ;RETURNS MAPPED XML IN RARY PASSED BY NAME - ; IVARS IS AN XPATH ARRAY PASSED BY NAME - ; TPTR IS A POINT TO THE C0C XML TEMPLATE FILE USED TO RETRIEVE THE TEMPLATE - ; - N ZT ;THE TEMPLATE - K ZT,@RARY - I '$D(INFARY) D ; - . S INFARY="FARY" - . D INITFARY(INFARY) - N ZF,ZFT - S ZF=@INFARY@("XML FILE NUMBER") - S ZFT=@INFARY@("TEMPLATE XML") - I $$GET1^DIQ(ZF,TPTR_",",ZFT,,"ZT")'="ZT" D Q ; ERROR GETTING TEMPLATE - . W "ERROR RETRIEVING TEMPLATE",! - D MAP^C0CXPATH("ZT",IVARS,RARY) ;DO THE MAPPING - Q - ; -TESTBIND ; - S G1("TESTONE")=1 - S G1("TESTTWO")=2 - D BIND("G","G1","TEST") - W ! - ZWR G - Q - ; -BIND(RARY,IVARS,INTPTR,INFARY) ;RETURNS AN XPATH ARRAY IN RARY FOR USE WITH MAP - ; TO BUILD AN INSTANTIATED TEMPLATE - ; TPTR IS THE IEN OF THE XML TEMPATE IN THE C0C XML TEMPLATE FILE - ; LOOPS THROUGHT THE BINDING SUBFILE TO PULL OUT XPATHS AND - ; EITHER ASSIGNS VARIABLES OR DOES A FILEMAN CALL TO GET VALUES - ; VARIABLES ARE IN IVARS WHICH IS PASSED BY NAME - I '$D(INFARY) D ; - . S INFARY="FARY" - . D INITFARY(INFARY) ;INITIALIZE FILE ARRAY IF NOT PASSED - I +INTPTR>0 S TPTR=INTPTR - E S TPTR=$$RESTID(INTPTR,INFARY) - N C0CFF,C0CBF,C0CXI,C0CFREF,C0CXREF - S C0CFF=@INFARY@("XML FILE NUMBER") ;fileman file number of XML file - S C0CFREF=$$FILEREF^C0CRNF(C0CFF) ; closed file reference to the file - S C0CBF=@INFARY@("BINDING SUBFILE NUMBER") ; BINDING SUBFILE NUMBER - S C0CXI=$G(@INFARY@("XPATH INDEX")) ; index to the XPath bindings - I C0CXI="" S C0CXI="XPATH" ; default is the XPATH index - ; this needs to be a whole file index on the XPath subfile with - ; the Template IEN perceding the XPath in the index - N ZI - S ZI="" - S C0CXREF=$NA(@C0CFREF@(C0CXI,TPTR)) ; where the xref is - ;F S ZI=$O(^C0CX(TPTR,5,"B",ZI)) Q:ZI="" D ; FOR EACH XPATH - F S ZI=$O(@C0CXREF@(ZI)) Q:ZI="" D ; for each XPath in this template - . ;W !,ZI," ",$O(@C0CXREF@(ZI,TPTR,"")) - . N ZIEN,ZFILE,ZFIELD,ZVAR,ZIDX,ZINDEX ; - . S ZIEN=$O(@C0CXREF@(ZI,TPTR,"")) ; IEN OF THE BINDING RECORD - . N ZFF S ZFF=@INFARY@("FILEMAN FILE POINTER") - . S ZFILE=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFF,"I") - . N ZFFLD S ZFFLD=@INFARY@("FILEMAN FIELD NUMBER") - . S ZFIELD=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFFLD,"I") - . N ZFV S ZFV=@INFARY@("VARIABLE NAME") - . S ZVAR=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFV,"E") - . N ZFX S ZFX=("INDEXED BY") - . S ZIDX=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFX,"I") - . S ZINDEX="" - . I ZIDX="DUZ" S ZINDEX=$G(DUZ) ; FILE IS INDEXED BY DUZ - . I ZIDX="DFN" S ZINDEX=$G(DFN) ; BY DFN - . E I ZIDX'="" S ZINDEX=$G(@ZIDX) ; index variable - . ;I ZIDX="ACCT" S ZINDEX=C0CACCT ; BY ACCOUNT RECORD POINT TO C0C WS ACCT - . ;I ZIDX="LOC" S ZINDEX=C0CLOC ; BY LOCATION - . I ZVAR'="" D ; VARIABLES TAKE PRESCIDENCE OVER FILEMAN FIELDS - . . S @RARY@(ZI)=@IVARS@(ZVAR) ; - . E D ; IF NO VARIABLE, TRY ACCESSING FROM FILEMAN - . . I (ZFILE="")!(ZFIELD="") Q ;QUIT IF FILE OR FIELD NOT THERE - . . D CLEAN^DILF - . . S @RARY@(ZI)=$$GET1^DIQ(ZFILE,ZINDEX_",",ZFIELD) ;GET THE VALUE - . . I $D(^TMP("DIERR",$J,1)) D B ; - . . . W "ERROR!",! - . . . ZWR ^TMP("DIERR",$J,*) - Q - ; +C0CSOAP ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is an SOAP utility library",! + W ! + Q + ; +TEST1 + S url="https://ec2-75-101-247-83.compute-1.amazonaws.com:8181/ccr/CCRService?wsdl" + D GET1URL^C0CEWD2(url) + Q + ; +INITFARY(ARY) ;initialize the Fileman Field array for SOAP processing + ; ARY is passed by name + S @ARY@("XML FILE NUMBER")="178.301" + S @ARY@("BINDING SUBFILE NUMBER")="178.3014" + S @ARY@("MIME TYPE")="2.3" + S @ARY@("PROXY SERVER")="2.4" + S @ARY@("REPLY TEMPLATE")=".03" + S @ARY@("TEMPLATE NAME")=".01" + S @ARY@("TEMPLATE XML")="3" + S @ARY@("URL")="1" + S @ARY@("WSDL URL")="2" + S @ARY@("XML")="2.1" + S @ARY@("XML HEADER")="2.2" + S @ARY@("XPATH REDUCTION STRING")="2.5" + S @ARY@("CCR VARIABLE")="4" + S @ARY@("FILEMAN FIELD NAME")="1" + S @ARY@("FILEMAN FIELD NUMBER")="1.2" + S @ARY@("FILEMAN FILE POINTER")="1.1" + S @ARY@("INDEXED BY")=".05" + S @ARY@("SQLI FIELD NAME")="3" + S @ARY@("VARIABLE NAME")="2" + Q + ; +RESTID(INNAM,INFARY) ;EXTRINSIC TO RESOLVE TEMPLATE PASSED BY NAME + ; FILE IS IDENTIFIED IN FARY, PASSED BY NAME + I '$D(INFARY) D ; NO FILE ARRAY PASSED + . S INFARY="FARY" + . D INITFARY(INFARY) + N ZN,ZREF,ZR + S ZN=@INFARY@("XML FILE NUMBER") + S ZREF=$$FILEREF^C0CRNF(ZN) + S ZR=$O(@ZREF@("B",INNAM,"")) + Q ZR + ; +TESTSOAP ; + ; USING ICD9 WEB SERVICE TO TEST SOAP + S G("CODE")="E*" + S G("CODELN")=3 + D SOAP("GPL","ICD9","G") + Q + ; +SOAP(C0CRTN,C0CTID,C0CVA,C0CVOR,ALTXML,IFARY) ; MAKES A SOAP CALL FOR + ; TEMPLATE ID C0CTID + ; RETURNS THE XML RESULT IN C0CRTN, PASSED BY NAME + ; C0CVA IS PASSED BY NAME AND IS THE VARIABLE ARRAY TO PASS TO BIND + ; C0CVOR IS THE NAME OF A VARIABLE OVERRIDE ARRAY, WHICH IS APPLIED + ; BEFORE MAPPING + ; IF ALTXML IS PASSED, BIND AND MAP WILL BE SKIPPED AND + ; ALTXML WILL BE USED INSTEAD + ; + ; ARTIFACTS SECTION + ; THE FOLLOWING WILL SET UP DEBUGGING ARTIFACTS FOR A POSSIBLE FUTURE + ; ONLINE DEBUGGER. IF DEBUG=1, VARIABLES CONTAINING INTERMEDIATE RESULTS + ; WILL NOT BE NEWED. + I $G(WSDEBUG)="" N C0CV ; CATALOG OF ARTIFACT VARIABLES AND ARRAYS + S C0CV(100,"C0CXF","XML TEMPLATE FILE NUMBER")="" + S C0CV(200,"C0CHEAD","SOAP HEADER VARIABLE NAME")="" + S C0CV(300,"HEADER","SOAP HEADER")="" + S C0CV(400,"C0CMIME","MIME TYPE")="" + S C0CV(500,"C0CURL","WS URL")="" + S C0CV(550,"C0CPURL","PROXY URL")="" + S C0CV(600,"C0CXML","XML VARIABLE NAME")="" + S C0CV(700,"XML","OUTBOUND XML")="" + S C0CV(800,"C0CRSLT","RAW XML RESULT RETURNED FROM WEB SERVICE")="" + S C0CV(900,"C0CRHDR","RETURNED HEADER")="" + S C0CV(1000,"C0CRXML","XML RESULT NORMALIZED")="" + S C0CV(1100,"C0CR","REPLY TEMPLATE")="" + S C0CV(1200,"C0CREDUX","REDUX STRING")="" + S C0CV(1300,"C0CIDX","RESULT XPATH INDEX")="" + S C0CV(1400,"C0CARY","RESULT XPATH ARRAY")="" + S C0CV(1500,"C0CNOM","RESULT DOM DOCUMENT NAME")="" + S C0CV(1600,"C0CID","RESULT DOM ID")="" + I $G(DEBUG)'="" G NOTNEW ; SKIP NEWING THE VARIABLES IF IN DEBUG + N ZI,ZJ S ZI="" +NEW + S ZI=$O(C0CV(ZI)) + S ZJ=$O(C0CV(ZI,"")) ; SET UP NEW COMMAND + ;W ZJ,! + N @ZJ ; NEW THE VARIABLE + I $O(C0CV(ZI))'="" G NEW ;LOOP TO GET NEW IN CONTEXT +NOTNEW + ; END ARTIFACTS + ; + I '$D(IFARY) D INITFARY("C0CF") ; SET FILE NUMBER AND PARAMATERS + E D ; + . K C0CF + . M C0CF=@IFARY + S C0CXF=C0CF("XML FILE NUMBER") ; FILE NUMBER FOR THE XML TEMPLATE FILE + I +C0CTID=0 D ; A STRING WAS PASSED FOR THE TEMPLATE NAME + . S C0CUTID=$$RESTID(C0CTID,"C0CF") ;RESOLVE TEMPLATE IEN FROM NAME + E S C0CUTID=C0CTID ; AN IEN WAS PASSED + N XML,TEMPLATE,HEADER + N C0CFH S C0CFH=C0CF("XML HEADER") + S C0CHEAD=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFH,,"HEADER") + N C0CFM S C0CFM=C0CF("MIME TYPE") + S C0CMIME=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFM) + N C0CFP S C0CFP=C0CF("PROXY SERVER") + S C0CPURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFP) + N C0CFU S C0CFU=C0CF("URL") + S C0CURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFU) + N C0CFX S C0CFX=C0CF("XML") + S C0CXML=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFX,,"XML") + N C0CFT S C0CFT=C0CF("TEMPLATE XML") + S C0CTMPL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFT,,"TEMPLATE") + I C0CTMPL="TEMPLATE" D ; there is a template to process + . K XML ; going to replace the xml array + . N VARS + . I $D(C0CVOR) M @C0CVA=@C0CVOR ; merge in varible overrides + . I '$D(ALTXML) D ; if ALTXML is passed in, don't bind + . . D BIND("VARS",C0CVA,C0CUTID,"C0CF") + . . D MAP("XML","VARS",TPTR,"C0CF") + . . K XML(0) + . E M XML=@ALTXML ; use ALTXML instead + I $G(C0CPROXY) S C0CURL=C0CPURL + K C0CRSLT,C0CRHDR + B + S ok=$$httpPOST^%zewdGTM(C0CURL,.XML,C0CMIME,.C0CRSLT,.HEADER,"",.gpl5,.C0CRHDR) + K C0CRXML + D NORMAL("C0CRXML","C0CRSLT(1)") ;RETURN XML IN AN ARRAY + N C0CFR S C0CFR=$G(C0CF("REPLY TEMPLATE")) + S C0CR=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFR,"I") ; REPLY TEMPLATE + ; reply templates are optional and are specified by populating a + ; template pointer in field 2.5 of the request template + ; if specified, the reply template is the source of the REDUX string + ; used for XPath on the reply, and for UNBIND processing + ; if no reply template is specified, REDUX is obtained from the request + ; template and no UNBIND processing is performed. The XPath array is + ; returned without variable bindings + I C0CR'="" D ; REPLY TEMPLATE EXISTS + . I +$G(DEBUG)'=0 W "REPLY TEMPLATE:",C0CR,! + . S C0CTID=C0CR ; + N C0CFRDX S C0CFRDX=C0CF("XPATH REDUCTION STRING") + S C0CREDUX=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFRDX) ;XPATH REDUCTION STRING + K C0CIDX,C0CARY ; XPATH INDEX AND ARRAY VARS + S C0CNOM="C0CWS"_$J ; DOCUMENT NAME FOR THE DOM + S C0CID=$$PARSE^C0CXEWD("C0CRXML",C0CNOM) ;CALL THE PARSER + S C0CID=$$FIRST^C0CXEWD($$ID^C0CXEWD(C0CNOM)) ;ID OF FIRST NODE + D XPATH^C0CXEWD(C0CID,"/","C0CIDX","C0CARY","",C0CREDUX) ;XPATH GENERATOR + ; Next, call UNBIND to map the reply XPath array to variables + ; This is only done if a Reply Template is provided + D DEMUXARY(C0CRTN,"C0CARY") + ; M @C0CRTN=C0CARY + Q + ; +DEMUXARY(OARY,IARY) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO + ; FORMAT @OARY@(x,xpath) where x is the first multiple + N ZI,ZJ,ZK,ZL S ZI="" + F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; + . D DEMUX^C0CMXP("ZJ",ZI) + . S ZK=$P(ZJ,"^",3) + . S ZK=$RE($P($RE(ZK),"/",1)) + . S ZL=$P(ZJ,"^",1) + . I ZL="" S ZL=1 + . S @OARY@(ZL,ZK)=@IARY@(ZI) + Q + ; +NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML + ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME + ; + N ZI,ZN,ZTMP + S ZN=1 + S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">" + S ZN=ZN+1 + F S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)="" D ; + . S @OUTXML@(ZN)=@OUTXML@(ZN)_">" + . S ZN=ZN+1 + Q + ; +MAP(RARY,IVARS,TPTR,INFARY) ;RETURNS MAPPED XML IN RARY PASSED BY NAME + ; IVARS IS AN XPATH ARRAY PASSED BY NAME + ; TPTR IS A POINT TO THE C0C XML TEMPLATE FILE USED TO RETRIEVE THE TEMPLATE + ; + N ZT ;THE TEMPLATE + K ZT,@RARY + I '$D(INFARY) D ; + . S INFARY="FARY" + . D INITFARY(INFARY) + N ZF,ZFT + S ZF=@INFARY@("XML FILE NUMBER") + S ZFT=@INFARY@("TEMPLATE XML") + I $$GET1^DIQ(ZF,TPTR_",",ZFT,,"ZT")'="ZT" D Q ; ERROR GETTING TEMPLATE + . W "ERROR RETRIEVING TEMPLATE",! + D MAP^C0CXPATH("ZT",IVARS,RARY) ;DO THE MAPPING + Q + ; +TESTBIND ; + S G1("TESTONE")=1 + S G1("TESTTWO")=2 + D BIND("G","G1","TEST") + W ! + ZWR G + Q + ; +BIND(RARY,IVARS,INTPTR,INFARY) ;RETURNS AN XPATH ARRAY IN RARY FOR USE WITH MAP + ; TO BUILD AN INSTANTIATED TEMPLATE + ; TPTR IS THE IEN OF THE XML TEMPATE IN THE C0C XML TEMPLATE FILE + ; LOOPS THROUGHT THE BINDING SUBFILE TO PULL OUT XPATHS AND + ; EITHER ASSIGNS VARIABLES OR DOES A FILEMAN CALL TO GET VALUES + ; VARIABLES ARE IN IVARS WHICH IS PASSED BY NAME + I '$D(INFARY) D ; + . S INFARY="FARY" + . D INITFARY(INFARY) ;INITIALIZE FILE ARRAY IF NOT PASSED + I +INTPTR>0 S TPTR=INTPTR + E S TPTR=$$RESTID(INTPTR,INFARY) + N C0CFF,C0CBF,C0CXI,C0CFREF,C0CXREF + S C0CFF=@INFARY@("XML FILE NUMBER") ;fileman file number of XML file + S C0CFREF=$$FILEREF^C0CRNF(C0CFF) ; closed file reference to the file + S C0CBF=@INFARY@("BINDING SUBFILE NUMBER") ; BINDING SUBFILE NUMBER + S C0CXI=$G(@INFARY@("XPATH INDEX")) ; index to the XPath bindings + I C0CXI="" S C0CXI="XPATH" ; default is the XPATH index + ; this needs to be a whole file index on the XPath subfile with + ; the Template IEN perceding the XPath in the index + N ZI + S ZI="" + S C0CXREF=$NA(@C0CFREF@(C0CXI,TPTR)) ; where the xref is + ;F S ZI=$O(^C0CX(TPTR,5,"B",ZI)) Q:ZI="" D ; FOR EACH XPATH + F S ZI=$O(@C0CXREF@(ZI)) Q:ZI="" D ; for each XPath in this template + . ;W !,ZI," ",$O(@C0CXREF@(ZI,TPTR,"")) + . N ZIEN,ZFILE,ZFIELD,ZVAR,ZIDX,ZINDEX ; + . S ZIEN=$O(@C0CXREF@(ZI,TPTR,"")) ; IEN OF THE BINDING RECORD + . N ZFF S ZFF=@INFARY@("FILEMAN FILE POINTER") + . S ZFILE=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFF,"I") + . N ZFFLD S ZFFLD=@INFARY@("FILEMAN FIELD NUMBER") + . S ZFIELD=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFFLD,"I") + . N ZFV S ZFV=@INFARY@("VARIABLE NAME") + . S ZVAR=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFV,"E") + . N ZFX S ZFX=("INDEXED BY") + . S ZIDX=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFX,"I") + . S ZINDEX="" + . I ZIDX="DUZ" S ZINDEX=$G(DUZ) ; FILE IS INDEXED BY DUZ + . I ZIDX="DFN" S ZINDEX=$G(DFN) ; BY DFN + . E I ZIDX'="" S ZINDEX=$G(@ZIDX) ; index variable + . ;I ZIDX="ACCT" S ZINDEX=C0CACCT ; BY ACCOUNT RECORD POINT TO C0C WS ACCT + . ;I ZIDX="LOC" S ZINDEX=C0CLOC ; BY LOCATION + . I ZVAR'="" D ; VARIABLES TAKE PRESCIDENCE OVER FILEMAN FIELDS + . . S @RARY@(ZI)=@IVARS@(ZVAR) ; + . E D ; IF NO VARIABLE, TRY ACCESSING FROM FILEMAN + . . I (ZFILE="")!(ZFIELD="") Q ;QUIT IF FILE OR FIELD NOT THERE + . . D CLEAN^DILF + . . S @RARY@(ZI)=$$GET1^DIQ(ZFILE,ZINDEX_",",ZFIELD) ;GET THE VALUE + . . I $D(^TMP("DIERR",$J,1)) D B ; + . . . W "ERROR!",! + . . . ZWR ^TMP("DIERR",$J,*) + Q + ; Index: ccr/branches/ohum/p/C0CSUB1.m =================================================================== --- ccr/branches/ohum/p/C0CSUB1.m (revision 1333) +++ ccr/branches/ohum/p/C0CSUB1.m (revision 1337) @@ -1,136 +1,136 @@ -C0CSUB1 ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is the CCR SUBSCRIPTIONN Utility Library ",! - Q - ; -CHK1(DFN) ; ADD THE CHECKSUM FOR ONE PATIENT - ; - S C0CCHK=$NA(^TMP("C0CRIM","CHKSUM")) - S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE - S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE - S C0CSFC=177.1012 ; FILE NUMBER FOR CHECKSUM SUBFILE - S C0CSFDC=177.10121 ; FILE NUMBER FOR DOMAIN CHECKSUMS - S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT - K C0CFDA - S C0CALL=$G(@C0CCHK@(DFN,"ALL")) - I C0CALL'="" S C0CFDA(C0CSFC,"?+1,"_C0CPAT_",",.01)=C0CALL - E Q ; NO CHECKSUMS FOR THISPATIENT - D UPDIE - N C0CJ S C0CJ="" - F S C0CJ=$O(@C0CCHK@(DFN,"DOMAIN",C0CJ)) Q:C0CJ="" D ; FOR EACH DOMAIN - . S C0CD=$O(^C0CDIC(170.101,"B",C0CJ,"")) - . W C0CJ," ",C0CD,! - . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",.01)=C0CD - . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",1)=@C0CCHK@(DFN,"DOMAIN",C0CJ) - . D UPDIE - Q - ; -SUBALL ; SUBSCRIBE ALL PATIENTS IN CCR GLOBALS TO SUBCRIBER 1 - ; - S C0CGLB=$NA(^TMP("C0CRIM","VARS")) - S C0CI="" - F S C0CI=$O(@C0CGLB@(C0CI)) Q:C0CI="" D ; FOR EACH PATIENT - . D SUB1(C0CI,1) ;SUBSCIRBE THEM TO EPCRN - Q - ; -SUB1(DFN,C0CSS) ; SUBSCRIBE ONE PATIENT TO SUBSCRIBER C0CSS - ; - S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE - S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE - S C0CSFC=177.10121 ; FILE NUMBER FOR CHECKSUMS - S C0CSSF=177.201 ; FILE NUMBER FOR SUBSCRIBER FILE - K C0CFDA - S C0CFDA(C0CSF,"+1,",.01)=DFN - D UPDIE ; ADD THE PATIENT - S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT - S C0CFDA(C0CSFS,"+1,"_C0CPAT_",",.01)=C0CSS ; C0CSS IS A POINTER - D UPDIE ; ADD THE SUBSCRIPTION - D CHK1(DFN) ; ADD THE CHECKSUMS - Q - ; -UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS - K ZERR - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","","ZERR") - I $D(ZERR) D ; - . W "ERROR",! - . ZWR ZERR - . B - K C0CFDA - Q - ; -VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE - ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO - ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO - ; - N ZCCRD,ZVARN,C0CFDA2 - S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY - S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE - I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT - . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE - . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! - . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE - . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE - . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN - . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY - . I $D(ZERR) D ; LAYGO ERROR - . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! - . E D ; - . . D CLEAN^DILF ; CLEAN UP - . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE - . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! - Q ZVARN - ; -SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN - ; TO SET TO VALUE C0CSV. - ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE - ; C0CSN,C0CSV ARE PASSED BY VALUE - ; - N C0CSI,C0CSJ - S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER - S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER - S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV - Q -ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) - E S ZR="" - Q ZR -ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) - E S ZR="" - Q ZR - ; -ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) - E S ZR="" - Q ZR - ; +C0CSUB1 ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is the CCR SUBSCRIPTIONN Utility Library ",! + Q + ; +CHK1(DFN) ; ADD THE CHECKSUM FOR ONE PATIENT + ; + S C0CCHK=$NA(^TMP("C0CRIM","CHKSUM")) + S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE + S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE + S C0CSFC=177.1012 ; FILE NUMBER FOR CHECKSUM SUBFILE + S C0CSFDC=177.10121 ; FILE NUMBER FOR DOMAIN CHECKSUMS + S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT + K C0CFDA + S C0CALL=$G(@C0CCHK@(DFN,"ALL")) + I C0CALL'="" S C0CFDA(C0CSFC,"?+1,"_C0CPAT_",",.01)=C0CALL + E Q ; NO CHECKSUMS FOR THISPATIENT + D UPDIE + N C0CJ S C0CJ="" + F S C0CJ=$O(@C0CCHK@(DFN,"DOMAIN",C0CJ)) Q:C0CJ="" D ; FOR EACH DOMAIN + . S C0CD=$O(^C0CDIC(170.101,"B",C0CJ,"")) + . W C0CJ," ",C0CD,! + . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",.01)=C0CD + . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",1)=@C0CCHK@(DFN,"DOMAIN",C0CJ) + . D UPDIE + Q + ; +SUBALL ; SUBSCRIBE ALL PATIENTS IN CCR GLOBALS TO SUBCRIBER 1 + ; + S C0CGLB=$NA(^TMP("C0CRIM","VARS")) + S C0CI="" + F S C0CI=$O(@C0CGLB@(C0CI)) Q:C0CI="" D ; FOR EACH PATIENT + . D SUB1(C0CI,1) ;SUBSCIRBE THEM TO EPCRN + Q + ; +SUB1(DFN,C0CSS) ; SUBSCRIBE ONE PATIENT TO SUBSCRIBER C0CSS + ; + S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE + S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE + S C0CSFC=177.10121 ; FILE NUMBER FOR CHECKSUMS + S C0CSSF=177.201 ; FILE NUMBER FOR SUBSCRIBER FILE + K C0CFDA + S C0CFDA(C0CSF,"+1,",.01)=DFN + D UPDIE ; ADD THE PATIENT + S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT + S C0CFDA(C0CSFS,"+1,"_C0CPAT_",",.01)=C0CSS ; C0CSS IS A POINTER + D UPDIE ; ADD THE SUBSCRIPTION + D CHK1(DFN) ; ADD THE CHECKSUMS + Q + ; +UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS + K ZERR + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","","ZERR") + I $D(ZERR) D ; + . W "ERROR",! + . ZWR ZERR + . B + K C0CFDA + Q + ; +VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE + ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO + ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO + ; + N ZCCRD,ZVARN,C0CFDA2 + S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY + S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE + I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT + . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE + . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! + . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE + . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE + . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN + . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY + . I $D(ZERR) D ; LAYGO ERROR + . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! + . E D ; + . . D CLEAN^DILF ; CLEAN UP + . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE + . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! + Q ZVARN + ; +SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN + ; TO SET TO VALUE C0CSV. + ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE + ; C0CSN,C0CSV ARE PASSED BY VALUE + ; + N C0CSI,C0CSJ + S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER + S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER + S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV + Q +ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) + E S ZR="" + Q ZR +ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) + E S ZR="" + Q ZR + ; +ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) + E S ZR="" + Q ZR + ; Index: ccr/branches/ohum/p/C0CSYS.m =================================================================== --- ccr/branches/ohum/p/C0CSYS.m (revision 1333) +++ ccr/branches/ohum/p/C0CSYS.m (revision 1337) @@ -1,59 +1,59 @@ -C0CSYS ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008 - ;;1.0;C0C;;May 19, 2009;Build 1 - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ; General Public License See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "Enter at appropriate points." Q - ; - ; Originally, I was going to use VEPERVER, but VEPERVER - ; actually kills ^TMP($J), outputs it to the screen in a user-friendly - ; manner (press any key to continue), - ; and is really a very half finished routine - ; - ; So for now, I am hard-coding the values. - ; -SYSNAME() ;Get EHR System Name; PUBLIC; Extrinsic - Q:$G(DUZ("AG"))="I" "RPMS" - Q "WorldVistA EHR/VOE" - ; -SYSVER() ;Get EHR System Version; PUBLIC; Extrinsic - Q "1.0" - ; -PTST(DFN) ;TEST TO SEE IF PATIENT MERGED OR A TEST PATIENT - ; DFN = IEN of the Patient to be tested - ; 1 = Merged or Test Patient - ; 0 = Non-test Patient - ; - I DFN="" Q 0 ; BAD DFN PASSED - I $D(^DPT(DFN,-9)) Q 1 ;This patient has been merged - I $G(^DPT(DFN,0))="" Q 1 ;Missing zeroth node <---add - ; - I '$D(CCRTEST) S CCRTEST=1 ; DEFAULT IS THAT WE ARE TESTING - I CCRTEST Q 0 ; IF WE ARE TESTING, DON'T REJECT TEST PATIENTS - N DIERR,DATA - I $$TESTPAT^VADPT(DFN) Q 1 ; QUIT IF IT'S A VA TEST PATIENT - S DATA=+$$GET1^DIQ(2,DFN_",",.6,"I") ;Test Patient Indicator - ; 1 = Test Patient - ; 0 = Non-test Patient - I DATA Q DATA - S DATA=$$GET1^DIQ(2,DFN_",",.09,"I") ;SSN test - D CLEAN^DILF - I "Pp"[$E(DATA,$L(DATA),$L(DATA)) Q 0 ;Allow Pseudo SSN - I $E(DATA,1,3)="000" Q 1 - I $E(DATA,1,3)="666" Q 1 - Q 0 - ; +C0CSYS ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008 + ;;1.0;C0C;;May 19, 2009;Build 38 + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "Enter at appropriate points." Q + ; + ; Originally, I was going to use VEPERVER, but VEPERVER + ; actually kills ^TMP($J), outputs it to the screen in a user-friendly + ; manner (press any key to continue), + ; and is really a very half finished routine + ; + ; So for now, I am hard-coding the values. + ; +SYSNAME() ;Get EHR System Name; PUBLIC; Extrinsic + Q:$G(DUZ("AG"))="I" "RPMS" + Q "WorldVistA EHR/VOE" + ; +SYSVER() ;Get EHR System Version; PUBLIC; Extrinsic + Q "1.0" + ; +PTST(DFN) ;TEST TO SEE IF PATIENT MERGED OR A TEST PATIENT + ; DFN = IEN of the Patient to be tested + ; 1 = Merged or Test Patient + ; 0 = Non-test Patient + ; + I DFN="" Q 0 ; BAD DFN PASSED + I $D(^DPT(DFN,-9)) Q 1 ;This patient has been merged + I $G(^DPT(DFN,0))="" Q 1 ;Missing zeroth node <---add + ; + I '$D(CCRTEST) S CCRTEST=1 ; DEFAULT IS THAT WE ARE TESTING + I CCRTEST Q 0 ; IF WE ARE TESTING, DON'T REJECT TEST PATIENTS + N DIERR,DATA + I $$TESTPAT^VADPT(DFN) Q 1 ; QUIT IF IT'S A VA TEST PATIENT + S DATA=+$$GET1^DIQ(2,DFN_",",.6,"I") ;Test Patient Indicator + ; 1 = Test Patient + ; 0 = Non-test Patient + I DATA Q DATA + S DATA=$$GET1^DIQ(2,DFN_",",.09,"I") ;SSN test + D CLEAN^DILF + I "Pp"[$E(DATA,$L(DATA),$L(DATA)) Q 0 ;Allow Pseudo SSN + I $E(DATA,1,3)="000" Q 1 + I $E(DATA,1,3)="666" Q 1 + Q 0 + ; Index: ccr/branches/ohum/p/C0CUNIT.m =================================================================== --- ccr/branches/ohum/p/C0CUNIT.m (revision 1333) +++ ccr/branches/ohum/p/C0CUNIT.m (revision 1337) @@ -1,186 +1,186 @@ -C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is a unit testing library",! - W ! - Q - ; -ZT(ZARY,BAT,TST) ; private routine to add a test case to the ZARY array - ; ZARY IS PASSED BY REFERENCE - ; BAT is a string identifying the test battery - ; TST is a test which will evaluate to true or false - ; I '$G(ZARY) D - ; . S ZARY(0)=0 ; initially there are no elements - ; W "GOT HERE LOADING "_TST,! - N CNT ; count of array elements - S CNT=ZARY(0) ; contains array count - S CNT=CNT+1 ; increment count - S ZARY(CNT)=TST ; put the test in the array - I $D(ZARY(BAT)) D ; NOT THE FIRST TEST IN BATTERY - . N II,TN ; TEMP FOR ENDING TEST IN BATTERY - . S II=$P(ZARY(BAT),"^",2) - . S $P(ZARY(BAT),"^",2)=II+1 - I '$D(ZARY(BAT)) D ; FIRST TEST IN THIS BATTERY - . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY - . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX - . ; S TN=$NA(ZARY("TESTS")) - . ; D PUSH^C0CXPATH(TN,BAT) - S ZARY(0)=CNT ; update the array counter - Q - ; -ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference - ; ZARY IS PASSED BY NAME - ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") - ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE - K @ZARY - S @ZARY@(0)=0 ; initialize array count - N LINE,LABEL,BODY - N INTEST S INTEST=0 ; switch for in the test case section - N SECTION S SECTION="[anonymous]" ; test case section - ; - N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D - . I LINE?." "1";;>".E S INTEST=1 ; entering test section - . I LINE?." "1";;>".E S INTEST=0 ; leaving TEMPLATE section - . I INTEST D ; within the testing section - . . I LINE?." "1";;><".E D ; section name found - . . . S SECTION=$P($P(LINE,";;><",2),">",1) ; pull out name - . . I LINE?." "1";;>>".E D ; test case found - . . . D ZT(.@ZARY,SECTION,$P(LINE,";;>>",2)) ; put the test in the array - S @ZARY@("ALL")="1"_"^"_@ZARY@(0) ; MAKE A BATTERY FOR ALL - Q - ; -ZTEST(ZARY,WHICH) ; try out the tests using a passed array ZTEST - N ZI,ZX,ZR,ZP - S DEBUG=0 - ; I WHICH="ALL" D Q ; RUN ALL THE TESTS - ; . W "DOING ALL",! - ; . N J,NT - ; . S NT=$NA(ZARY("TESTS")) - ; . W NT,@NT@(0),! - ; . F J=1:1:@NT@(0) D ; - ; . . W @NT@(J),! - ; . . D ZTEST^C0CUNIT(@ZARY,@NT@(J)) - I '$D(ZARY(WHICH)) D Q ; TEST SECTION DOESN'T EXIST - . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,! - N FIRST,LAST - S FIRST=$P(ZARY(WHICH),"^",1) - S LAST=$P(ZARY(WHICH),"^",2) - F ZI=FIRST:1:LAST D - . I ZARY(ZI)?1">"1.E D ; NOT A TEST, JUST RUN THE STATEMENT - . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) - . . ; W ZP,! - . . S ZX=ZP - . . W "RUNNING: "_ZP - . . X ZX - . . W "..SUCCESS: ",WHICH,! - . I ZARY(ZI)?1"?"1.E D ; THIS IS A TEST - . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) - . . S ZX="S ZR="_ZP - . . W "TRYING: "_ZP - . . X ZX - . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),! - . . I '$D(TPASSED) D ; NOT INITIALIZED YET - . . . S TPASSED=0 S TFAILED=0 - . . I ZR S TPASSED=TPASSED+1 - . . I 'ZR S TFAILED=TFAILED+1 - Q - ; -TEST ; RUN ALL THE TEST CASES - N ZTMP - D ZLOAD(.ZTMP) - D ZTEST(.ZTMP,"ALL") - W "PASSED: ",TPASSED,! - W "FAILED: ",TFAILED,! - W ! - W "THE TESTS!",! - ; I DEBUG ZWR ZTMP - Q - ; -GTSTS(GTZARY,RTN) ; return an array of test names - N I,J S I="" S I=$O(GTZARY("TESTS",I)) - F J=0:0 Q:I="" D - . D PUSH^C0CXPATH(RTN,I) - . S I=$O(GTZARY("TESTS",I)) - Q - ; -TESTALL(RNM) ; RUN ALL THE TESTS - N ZI,J,TZTMP,TSTS,TOTP,TOTF - S TOTP=0 S TOTF=0 - D ZLOAD^C0CUNIT("TZTMP",RNM) - D GTSTS(.TZTMP,"TSTS") - F ZI=1:1:TSTS(0) D ; - . S TPASSED=0 S TFAILED=0 - . D ZTEST^C0CUNIT(.TZTMP,TSTS(ZI)) - . S TOTP=TOTP+TPASSED - . S TOTF=TOTF+TFAILED - . S $P(TSTS(ZI),"^",2)=TPASSED - . S $P(TSTS(ZI),"^",3)=TFAILED - F ZI=1:1:TSTS(0) D ; - . W "TEST=> ",$P(TSTS(ZI),"^",1) - . W " PASSED=>",$P(TSTS(ZI),"^",2) - . W " FAILED=>",$P(TSTS(ZI),"^",3),! - W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,! - Q - ; -TLIST(ZARY) ; LIST ALL THE TESTS - ; THEY ARE MARKED AS ;;> IN THE TEST CASES - ; ZARY IS PASSED BY REFERENCE - N I,J,K S I="" S I=$O(ZARY("TESTS",I)) - S K=1 - F J=0:0 Q:I="" D - . ; W "I IS NOW=",I,! - . W I," " - . S I=$O(ZARY("TESTS",I)) - . S K=K+1 I K=6 D - . . W ! - . . S K=1 - Q - ; -MEDS - N DEBUG S DEBUG=0 - N DFN S DFN=5685 - K ^TMP($J) - W "Loading CCR Template into T using LOAD^GPLCCR0($NA(^TMP($J,""CCR"")))",!! - N T S T=$NA(^TMP($J,"CCR")) D LOAD^GPLCCR0(T) - N XPATH S XPATH="//ContinuityOfCareRecord/Body/Medications" - W "XPATH is: "_XPATH,! - W "Getting Med Template into INXML using",! - W "QUERY^GPLXPATH(T,XPATH,""INXML"")",!! - D QUERY^GPLXPATH(T,XPATH,"INXML") - W "Executing EXTRACT^C0CMED(INXML,DFN,OUTXML)",! - W "OUTXML will be ^TMP($J,""OUT"")",! - N OUTXML S OUTXML=$NA(^TMP($J,"OUT")) - D EXTRACT^C0CMED6("INXML",DFN,OUTXML) - D FILEOUT^C0CRNF(OUTXML,"TESTMEDS.xml") - Q -PAT - D ANALYZE^ARJTXRD("C0CDPT",.OUT) ; Analyze a routine in the directory - N X,Y - ; Select Patient - S DIC=2,DIC(0)="AEMQ" D ^DIC - ; - W "You have selected patient "_Y,!! - N I S I=89 F S I=$O(OUT(I)) Q:I="ALINE" D - . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" " - . W "valued at " - . W @("$$"_$P(OUT(I,0),"(DFN)")_"^"_"C0CDPT"_"("_$P(Y,"^")_")") - . W ! - Q +C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is a unit testing library",! + W ! + Q + ; +ZT(ZARY,BAT,TST) ; private routine to add a test case to the ZARY array + ; ZARY IS PASSED BY REFERENCE + ; BAT is a string identifying the test battery + ; TST is a test which will evaluate to true or false + ; I '$G(ZARY) D + ; . S ZARY(0)=0 ; initially there are no elements + ; W "GOT HERE LOADING "_TST,! + N CNT ; count of array elements + S CNT=ZARY(0) ; contains array count + S CNT=CNT+1 ; increment count + S ZARY(CNT)=TST ; put the test in the array + I $D(ZARY(BAT)) D ; NOT THE FIRST TEST IN BATTERY + . N II,TN ; TEMP FOR ENDING TEST IN BATTERY + . S II=$P(ZARY(BAT),"^",2) + . S $P(ZARY(BAT),"^",2)=II+1 + I '$D(ZARY(BAT)) D ; FIRST TEST IN THIS BATTERY + . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY + . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX + . ; S TN=$NA(ZARY("TESTS")) + . ; D PUSH^C0CXPATH(TN,BAT) + S ZARY(0)=CNT ; update the array counter + Q + ; +ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference + ; ZARY IS PASSED BY NAME + ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") + ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE + K @ZARY + S @ZARY@(0)=0 ; initialize array count + N LINE,LABEL,BODY + N INTEST S INTEST=0 ; switch for in the test case section + N SECTION S SECTION="[anonymous]" ; test case section + ; + N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D + . I LINE?." "1";;>".E S INTEST=1 ; entering test section + . I LINE?." "1";;>".E S INTEST=0 ; leaving TEMPLATE section + . I INTEST D ; within the testing section + . . I LINE?." "1";;><".E D ; section name found + . . . S SECTION=$P($P(LINE,";;><",2),">",1) ; pull out name + . . I LINE?." "1";;>>".E D ; test case found + . . . D ZT(.@ZARY,SECTION,$P(LINE,";;>>",2)) ; put the test in the array + S @ZARY@("ALL")="1"_"^"_@ZARY@(0) ; MAKE A BATTERY FOR ALL + Q + ; +ZTEST(ZARY,WHICH) ; try out the tests using a passed array ZTEST + N ZI,ZX,ZR,ZP + S DEBUG=0 + ; I WHICH="ALL" D Q ; RUN ALL THE TESTS + ; . W "DOING ALL",! + ; . N J,NT + ; . S NT=$NA(ZARY("TESTS")) + ; . W NT,@NT@(0),! + ; . F J=1:1:@NT@(0) D ; + ; . . W @NT@(J),! + ; . . D ZTEST^C0CUNIT(@ZARY,@NT@(J)) + I '$D(ZARY(WHICH)) D Q ; TEST SECTION DOESN'T EXIST + . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,! + N FIRST,LAST + S FIRST=$P(ZARY(WHICH),"^",1) + S LAST=$P(ZARY(WHICH),"^",2) + F ZI=FIRST:1:LAST D + . I ZARY(ZI)?1">"1.E D ; NOT A TEST, JUST RUN THE STATEMENT + . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) + . . ; W ZP,! + . . S ZX=ZP + . . W "RUNNING: "_ZP + . . X ZX + . . W "..SUCCESS: ",WHICH,! + . I ZARY(ZI)?1"?"1.E D ; THIS IS A TEST + . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) + . . S ZX="S ZR="_ZP + . . W "TRYING: "_ZP + . . X ZX + . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),! + . . I '$D(TPASSED) D ; NOT INITIALIZED YET + . . . S TPASSED=0 S TFAILED=0 + . . I ZR S TPASSED=TPASSED+1 + . . I 'ZR S TFAILED=TFAILED+1 + Q + ; +TEST ; RUN ALL THE TEST CASES + N ZTMP + D ZLOAD(.ZTMP) + D ZTEST(.ZTMP,"ALL") + W "PASSED: ",TPASSED,! + W "FAILED: ",TFAILED,! + W ! + W "THE TESTS!",! + ; I DEBUG ZWR ZTMP + Q + ; +GTSTS(GTZARY,RTN) ; return an array of test names + N I,J S I="" S I=$O(GTZARY("TESTS",I)) + F J=0:0 Q:I="" D + . D PUSH^C0CXPATH(RTN,I) + . S I=$O(GTZARY("TESTS",I)) + Q + ; +TESTALL(RNM) ; RUN ALL THE TESTS + N ZI,J,TZTMP,TSTS,TOTP,TOTF + S TOTP=0 S TOTF=0 + D ZLOAD^C0CUNIT("TZTMP",RNM) + D GTSTS(.TZTMP,"TSTS") + F ZI=1:1:TSTS(0) D ; + . S TPASSED=0 S TFAILED=0 + . D ZTEST^C0CUNIT(.TZTMP,TSTS(ZI)) + . S TOTP=TOTP+TPASSED + . S TOTF=TOTF+TFAILED + . S $P(TSTS(ZI),"^",2)=TPASSED + . S $P(TSTS(ZI),"^",3)=TFAILED + F ZI=1:1:TSTS(0) D ; + . W "TEST=> ",$P(TSTS(ZI),"^",1) + . W " PASSED=>",$P(TSTS(ZI),"^",2) + . W " FAILED=>",$P(TSTS(ZI),"^",3),! + W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,! + Q + ; +TLIST(ZARY) ; LIST ALL THE TESTS + ; THEY ARE MARKED AS ;;> IN THE TEST CASES + ; ZARY IS PASSED BY REFERENCE + N I,J,K S I="" S I=$O(ZARY("TESTS",I)) + S K=1 + F J=0:0 Q:I="" D + . ; W "I IS NOW=",I,! + . W I," " + . S I=$O(ZARY("TESTS",I)) + . S K=K+1 I K=6 D + . . W ! + . . S K=1 + Q + ; +MEDS + N DEBUG S DEBUG=0 + N DFN S DFN=5685 + K ^TMP($J) + W "Loading CCR Template into T using LOAD^GPLCCR0($NA(^TMP($J,""CCR"")))",!! + N T S T=$NA(^TMP($J,"CCR")) D LOAD^GPLCCR0(T) + N XPATH S XPATH="//ContinuityOfCareRecord/Body/Medications" + W "XPATH is: "_XPATH,! + W "Getting Med Template into INXML using",! + W "QUERY^GPLXPATH(T,XPATH,""INXML"")",!! + D QUERY^GPLXPATH(T,XPATH,"INXML") + W "Executing EXTRACT^C0CMED(INXML,DFN,OUTXML)",! + W "OUTXML will be ^TMP($J,""OUT"")",! + N OUTXML S OUTXML=$NA(^TMP($J,"OUT")) + D EXTRACT^C0CMED6("INXML",DFN,OUTXML) + D FILEOUT^C0CRNF(OUTXML,"TESTMEDS.xml") + Q +PAT + D ANALYZE^ARJTXRD("C0CDPT",.OUT) ; Analyze a routine in the directory + N X,Y + ; Select Patient + S DIC=2,DIC(0)="AEMQ" D ^DIC + ; + W "You have selected patient "_Y,!! + N I S I=89 F S I=$O(OUT(I)) Q:I="ALINE" D + . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" " + . W "valued at " + . W @("$$"_$P(OUT(I,0),"(DFN)")_"^"_"C0CDPT"_"("_$P(Y,"^")_")") + . W ! + Q Index: ccr/branches/ohum/p/C0CUTIL.m =================================================================== --- ccr/branches/ohum/p/C0CUTIL.m (revision 1333) +++ ccr/branches/ohum/p/C0CUTIL.m (revision 1337) @@ -1,175 +1,175 @@ -C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08 - ;;0.1;C0C;;Jun 15, 2008;Build 1 - ;Copyright 2008-2009 Sam Habiel & George Lilly. - ;Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "No Entry at Top!" - Q - ; -UUID() ; thanks to Wally for this. - N R,I,J,N - S N="",R="" F S N=N_$R(100000) Q:$L(N)>64 - F I=1:2:64 S R=R_$E("0123456789abcdef",($E(N,I,I+1)#16+1)) - Q $E(R,1,8)_"-"_$E(R,9,12)_"-4"_$E(R,14,16)_"-"_$E("89ab",$E(N,17)#4+1)_$E(R,18,20)_"-"_$E(R,21,32) - ; -OLDUUID() ; GENERATE A RANDOM UUID (Version 4) - N I,J,ZS - S ZS="0123456789abcdef" S J="" - F I=1:1:36 S J=J_$S((I=9)!(I=14)!(I=19)!(I=24):"-",I=15:4,I=20:"a",1:$E(ZS,$R(16)+1)) - Q J - ; -FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic - ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time) - ; If not passed, or passed incorrectly, it's assumed that it is D. - ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied. - ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC - ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters) - N UTC,Y,M,D,H,MM,S,OFF - S Y=1700+$E(DATE,1,3) - S M=$E(DATE,4,5) - S D=$E(DATE,6,7) - S H=$E(DATE,9,10) - I $L(H)=1 S H="0"_H - S MM=$E(DATE,11,12) - I $L(MM)=1 S MM="0"_MM - S S=$E(DATE,13,14) - I $L(S)=1 S S="0"_S - S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation. - S OFFS=$E(OFF,1,1) - S OFF0=$TR(OFF,"+-") - S OFF1=$E(OFF0+10000,2,3) - S OFF2=$E(OFF0+10000,4,5) - S OFF=OFFS_OFF1_":"_OFF2 - ;S OFF2=$E(OFF,1,2) ; - ;S OFF2=$E(100+OFF2,2,3) ; GPL 11/08 CHANGED TO -05:00 FORMAT - ;S OFF3=$E(OFF,3,4) ;MINUTES - ;S OFF=$S(OFF2="":"00",0:"00",1:OFF2)_"."_$S(OFF3="":"00",1:OFF3) - ; If H, MM and S are empty, it means that the FM date didn't supply the time. - ; In this case, set H, MM and S to "00" - ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING? - S:'$L(H) H="00" - S:'$L(MM) MM="00" - S:'$L(S) S="00" - S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds - I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time. - E Q $P(UTC,"T") - ; -SORTDT(V1,V2,ORDR) ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT - ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE - ; DATE AND TIME ORDER. DEFAULT IS FORWARD - ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT - ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER - ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER - ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC - ; BOTH V1 AND V2 ARE PASSED BY REFERENCE - N VSRT ; TEMP FOR HASHING DATES - N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2 - S ZCNT=V2(0) ; COUNTING NUMBER OF DATES - F ZI=1:1:ZCNT D ; FOR EACH DATE IN THE ARRAY - . I $D(V2(ZI)) D ; IF THE DATE EXISTS - . . S ZP1=$P(V2(ZI),".",1) ; THE DATE PIECE - . . S ZP2=$P(V2(ZI),".",2) ; THE TIME PIECE - . . ; W "DATE: ",ZP1," TIME: ",ZP2,! - . . S VSRT(ZP1,ZP2,ZI)=ZI ; INDEX OF DATE, TIME AND COUNT - N ZG - S ZG=$Q(VSRT("")) - F D Q:ZG="" ; - . ; W ZG,! - . D PUSH^C0CXPATH("V1",@ZG) - . S ZG=$Q(@ZG) - I ORDR=-1 D ; HAVE TO REVERSE ORDER - . N ZG2 - . F ZI=1:1:V1(0) D ; FOR EACH ELELMENT - . . S ZG2(V1(0)-ZI+1)=V1(ZI) ; SET IN REVERSE ORDER - . S ZG2(0)=V1(0) - . D CP^C0CXPATH("ZG2","V1") ; COPY OVER THE NEW ARRAY - Q ZCNT - ; -DA2SNO(RTN,DNAME) ; LOOK UP DRUG ALLERGY CODE IN ^LEX - ; RETURNS AN ARRAY RTN PASSED BY REFERENCE - ; THIS ROUTINE CAN BE USED AS AN RPC - ; RTN(0) IS THE NUMBER OF ELEMENTS IN THE ARRAY - ; RTN(1) IS THE SNOMED CODE FOR THE DRUG ALLERGY - ; - N LEXIEN - I $O(^LEX(757.21,"ADIS",DNAME,""))'="" D ; IEN FOUND FOR THIS DRUG - . S LEXIEN=$O(^LEX(757.21,"ADIS",DNAME,"")) ; GET THE IEN IN THE LEXICON - . W LEXIEN,! - . S RTN(1)=$P(^LEX(757.02,LEXIEN,0),"^",2) ; SNOMED CODE IN P2 - . S RTN(0)=1 ; ONE THING RETURNED - E S RTN(0)=0 ; NOT FOUND - Q - ; -DASNO(DANAME) ; PRINTS THE SNOMED CODE FOR ALLERGY TO DRUG DANAME - ; - N DARTN - D DA2SNO(.DARTN,DANAME) ; CALL THE LOOKUP ROUTINE - I DARTN(0)>0 D ; GOT RESULTS - . W !,DARTN(1) ;PRINT THE SNOMED CODE - E W !,"NOT FOUND",! - Q - ; -DASNALL(WHICH) ; ROUTINE TO EXAMINE THE ADIS INDEX IN LEX AND RETRIEVE ALL - ; ASSOCIATED SNOMED CODES - N DASTMP,DASIEN,DASNO - S DASTMP="" - F S DASTMP=$O(^LEX(757.21,WHICH,DASTMP)) Q:DASTMP="" D ; NAME OF MED - . S DASIEN=$O(^LEX(757.21,WHICH,DASTMP,"")) ; IEN OF MED - . S DASNO=$P(^LEX(757.02,DASIEN,0),"^",2) ; SNOMED CODE FOR ENTRY - . W DASTMP,"=",DASNO,! ; PRINT IT OUT - Q - ; -RXNFN() Q 1130590011.001 ; RxNorm Concepts file number - ; -CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF - ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR - N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT - I $G(ZVUID)="" Q "" - I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED - N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID") - S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES - N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01) - S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED - I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F" - Q ZRSLT - ; -NISTMAP(ZRXN) ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO - ; CONFORM TO NIST REQUIREMENTS - ;INPATIENT CERTIFICATION - I ZRXN=309362 S ZRXN=213169 - I ZRXN=855318 S ZRXN=855320 - I ZRXN=197361 S ZRXN=212549 - ;OUTPATIENT CERTIFICATION - I ZRXN=310534 S ZRXN=205875 - I ZRXN=617312 S ZRXN=617314 - I ZRXN=310429 S ZRXN=200801 - I ZRXN=628953 S ZRXN=628958 - I ZRXN=745679 S ZRXN=630208 - I ZRXN=311564 S ZRXN=979334 - I ZRXN=836343 S ZRXN=836370 - Q ZRXN - ; -RPMS() ; Are we running on an RPMS system rather than Vista? - Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service -VISTA() ; Are we running on Vanilla Vista? - Q $G(DUZ("AG"))="V" ; If User Agency is VA -WV() ; Are we running on WorldVista? - Q $G(DUZ("AG"))="E" ; Code for WV. -OV() ; Are we running on OpenVista? - Q $G(DUZ("AG"))="O" ; Code for OpenVista - +C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08 + ;;0.1;C0C;;Jun 15, 2008;Build 38 + ;Copyright 2008-2009 Sam Habiel & George Lilly. + ;Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "No Entry at Top!" + Q + ; +UUID() ; thanks to Wally for this. + N R,I,J,N + S N="",R="" F S N=N_$R(100000) Q:$L(N)>64 + F I=1:2:64 S R=R_$E("0123456789abcdef",($E(N,I,I+1)#16+1)) + Q $E(R,1,8)_"-"_$E(R,9,12)_"-4"_$E(R,14,16)_"-"_$E("89ab",$E(N,17)#4+1)_$E(R,18,20)_"-"_$E(R,21,32) + ; +OLDUUID() ; GENERATE A RANDOM UUID (Version 4) + N I,J,ZS + S ZS="0123456789abcdef" S J="" + F I=1:1:36 S J=J_$S((I=9)!(I=14)!(I=19)!(I=24):"-",I=15:4,I=20:"a",1:$E(ZS,$R(16)+1)) + Q J + ; +FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic + ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time) + ; If not passed, or passed incorrectly, it's assumed that it is D. + ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied. + ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC + ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters) + N UTC,Y,M,D,H,MM,S,OFF + S Y=1700+$E(DATE,1,3) + S M=$E(DATE,4,5) + S D=$E(DATE,6,7) + S H=$E(DATE,9,10) + I $L(H)=1 S H="0"_H + S MM=$E(DATE,11,12) + I $L(MM)=1 S MM="0"_MM + S S=$E(DATE,13,14) + I $L(S)=1 S S="0"_S + S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation. + S OFFS=$E(OFF,1,1) + S OFF0=$TR(OFF,"+-") + S OFF1=$E(OFF0+10000,2,3) + S OFF2=$E(OFF0+10000,4,5) + S OFF=OFFS_OFF1_":"_OFF2 + ;S OFF2=$E(OFF,1,2) ; + ;S OFF2=$E(100+OFF2,2,3) ; GPL 11/08 CHANGED TO -05:00 FORMAT + ;S OFF3=$E(OFF,3,4) ;MINUTES + ;S OFF=$S(OFF2="":"00",0:"00",1:OFF2)_"."_$S(OFF3="":"00",1:OFF3) + ; If H, MM and S are empty, it means that the FM date didn't supply the time. + ; In this case, set H, MM and S to "00" + ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING? + S:'$L(H) H="00" + S:'$L(MM) MM="00" + S:'$L(S) S="00" + S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds + I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time. + E Q $P(UTC,"T") + ; +SORTDT(V1,V2,ORDR) ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT + ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE + ; DATE AND TIME ORDER. DEFAULT IS FORWARD + ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT + ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER + ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER + ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC + ; BOTH V1 AND V2 ARE PASSED BY REFERENCE + N VSRT ; TEMP FOR HASHING DATES + N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2 + S ZCNT=V2(0) ; COUNTING NUMBER OF DATES + F ZI=1:1:ZCNT D ; FOR EACH DATE IN THE ARRAY + . I $D(V2(ZI)) D ; IF THE DATE EXISTS + . . S ZP1=$P(V2(ZI),".",1) ; THE DATE PIECE + . . S ZP2=$P(V2(ZI),".",2) ; THE TIME PIECE + . . ; W "DATE: ",ZP1," TIME: ",ZP2,! + . . S VSRT(ZP1,ZP2,ZI)=ZI ; INDEX OF DATE, TIME AND COUNT + N ZG + S ZG=$Q(VSRT("")) + F D Q:ZG="" ; + . ; W ZG,! + . D PUSH^C0CXPATH("V1",@ZG) + . S ZG=$Q(@ZG) + I ORDR=-1 D ; HAVE TO REVERSE ORDER + . N ZG2 + . F ZI=1:1:V1(0) D ; FOR EACH ELELMENT + . . S ZG2(V1(0)-ZI+1)=V1(ZI) ; SET IN REVERSE ORDER + . S ZG2(0)=V1(0) + . D CP^C0CXPATH("ZG2","V1") ; COPY OVER THE NEW ARRAY + Q ZCNT + ; +DA2SNO(RTN,DNAME) ; LOOK UP DRUG ALLERGY CODE IN ^LEX + ; RETURNS AN ARRAY RTN PASSED BY REFERENCE + ; THIS ROUTINE CAN BE USED AS AN RPC + ; RTN(0) IS THE NUMBER OF ELEMENTS IN THE ARRAY + ; RTN(1) IS THE SNOMED CODE FOR THE DRUG ALLERGY + ; + N LEXIEN + I $O(^LEX(757.21,"ADIS",DNAME,""))'="" D ; IEN FOUND FOR THIS DRUG + . S LEXIEN=$O(^LEX(757.21,"ADIS",DNAME,"")) ; GET THE IEN IN THE LEXICON + . W LEXIEN,! + . S RTN(1)=$P(^LEX(757.02,LEXIEN,0),"^",2) ; SNOMED CODE IN P2 + . S RTN(0)=1 ; ONE THING RETURNED + E S RTN(0)=0 ; NOT FOUND + Q + ; +DASNO(DANAME) ; PRINTS THE SNOMED CODE FOR ALLERGY TO DRUG DANAME + ; + N DARTN + D DA2SNO(.DARTN,DANAME) ; CALL THE LOOKUP ROUTINE + I DARTN(0)>0 D ; GOT RESULTS + . W !,DARTN(1) ;PRINT THE SNOMED CODE + E W !,"NOT FOUND",! + Q + ; +DASNALL(WHICH) ; ROUTINE TO EXAMINE THE ADIS INDEX IN LEX AND RETRIEVE ALL + ; ASSOCIATED SNOMED CODES + N DASTMP,DASIEN,DASNO + S DASTMP="" + F S DASTMP=$O(^LEX(757.21,WHICH,DASTMP)) Q:DASTMP="" D ; NAME OF MED + . S DASIEN=$O(^LEX(757.21,WHICH,DASTMP,"")) ; IEN OF MED + . S DASNO=$P(^LEX(757.02,DASIEN,0),"^",2) ; SNOMED CODE FOR ENTRY + . W DASTMP,"=",DASNO,! ; PRINT IT OUT + Q + ; +RXNFN() Q 1130590011.001 ; RxNorm Concepts file number + ; +CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF + ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR + N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT + I $G(ZVUID)="" Q "" + I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED + N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID") + S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES + N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01) + S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED + I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F" + Q ZRSLT + ; +NISTMAP(ZRXN) ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO + ; CONFORM TO NIST REQUIREMENTS + ;INPATIENT CERTIFICATION + I ZRXN=309362 S ZRXN=213169 + I ZRXN=855318 S ZRXN=855320 + I ZRXN=197361 S ZRXN=212549 + ;OUTPATIENT CERTIFICATION + I ZRXN=310534 S ZRXN=205875 + I ZRXN=617312 S ZRXN=617314 + I ZRXN=310429 S ZRXN=200801 + I ZRXN=628953 S ZRXN=628958 + I ZRXN=745679 S ZRXN=630208 + I ZRXN=311564 S ZRXN=979334 + I ZRXN=836343 S ZRXN=836370 + Q ZRXN + ; +RPMS() ; Are we running on an RPMS system rather than Vista? + Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service +VISTA() ; Are we running on Vanilla Vista? + Q $G(DUZ("AG"))="V" ; If User Agency is VA +WV() ; Are we running on WorldVista? + Q $G(DUZ("AG"))="E" ; Code for WV. +OV() ; Are we running on OpenVista? + Q $G(DUZ("AG"))="O" ; Code for OpenVista + Index: ccr/branches/ohum/p/C0CVA200.m =================================================================== --- ccr/branches/ohum/p/C0CVA200.m (revision 1333) +++ ccr/branches/ohum/p/C0CVA200.m (revision 1337) @@ -1,168 +1,168 @@ -C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008 Sam Habiel. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - Q - ; This routine uses Kernel APIs and Direct Global Access to get - ; Proivder Data from File 200. - ; - ; The Global is VA(200,*) - ; -FAMILY(DUZ) ; Get Family Name; PUBLIC; EXTRINSIC - ; INPUT: DUZ (i.e. File 200 IEN) ByVal - ; OUTPUT: String - N NAME S NAME=$P(^VA(200,DUZ,0),U) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("FAMILY") - ; -GIVEN(DUZ) ; Get Given Name; PUBLIC; EXTRINSIC - ; INPUT: DUZ ByVal - ; OUTPUT: String - N NAME S NAME=$P(^VA(200,DUZ,0),U) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("GIVEN") - ; -MIDDLE(DUZ) ; Get Middle Name, PUBLIC; EXTRINSIC - ; INPUT: DUZ ByVal - ; OUTPUT: String - N NAME S NAME=$P(^VA(200,DUZ,0),U) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("MIDDLE") - ; -SUFFIX(DUZ) ; Get Suffix Name, PUBLIC; EXTRINSIC - ; INPUT: DUZ ByVal - ; OUTPUT: String - N NAME S NAME=$P(^VA(200,DUZ,0),U) - D NAMECOMP^XLFNAME(.NAME) - Q NAME("SUFFIX") - ; -TITLE(DUZ) ; Get Title for Proivder, PUBLIC; EXTRINSIC - ; INPUT: DUZ ByVal - ; OUTPUT: String - ; Gets External Value of Title field in New Person File. - ; It's actually a pointer to file 3.1 - ; 200=New Person File; 8 is Title Field - Q $$GET1^DIQ(200,DUZ_",",8) - ; -NPI(DUZ) ; Get NPI Number, PUBLIC; EXTRINSIC - ; INPUT: DUZ ByVal - ; OUTPUT: Delimited String in format: - ; IDType^ID^IDDescription - ; If the NPI doesn't exist, "" is returned. - ; This routine uses a call documented in the Kernel dev guide - ; This call returns as "NPI^TimeEntered^ActiveInactive" - ; It returns -1 for NPI if NPI doesn't exist. - N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U) - Q:NPI=-1 "" - Q "NPI^"_NPI_"^HHS" - ; -SPEC(DUZ) ; Get Provider Specialty, PUBLIC; EXTRINSIC - ; INPUT: DUZ ByVal - ; OUTPUT: String: ProviderType/Specialty/Subspecialty OR "" - ; Uses a Kernel API. Returns -1 if a specialty is not specified - ; in file 200. - ; Otherwise, returns IEN^Profession^Specialty^Sub­specialty^Effect date^Expired date^VA code - N STR S STR=$$GET^XUA4A72(DUZ) - Q:+STR<0 "" - ; Sometimes we have 3 pieces, or 2. Deal with that. - Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4) - Q $P(STR,U,2)_"-"_$P(STR,U,3) - ; -ADDTYPE(DUZ) ; Get Address Type, PUBLIC; EXTRINSIC - ; INPUT: DUZ, but not needed really... here for future expansion - ; OUTPUT: At this point "Work" - Q "Work" - ; -ADDLINE1(ADUZ) ; Get Address associated with this instituation; PUBLIC; EXTRINSIC ; CHANGED PARAMETER TO ADUZ TO KEEP FROM CRASHING GPL 1/09 - ; INPUT: DUZ ByVal - ; Output: String. - ; - ; First, get site number from the institution file. - ; 1st piece returned by $$SITE^VASITE, which gets the system institution - N INST S INST=$P($$SITE^VASITE(),U) - ; - ; Second, get mailing address - ; There are two APIs to get the address, one for physical and one for - ; mailing. We will check if mailing exists first, since that's the - ; one we want to use; then check for physical. If neither exists, - ; then we return nothing. We check for the existence of an address - ; by the length of the returned string. - ; NOTE: API doesn't support Address 2, so I won't even include it - ; in the template. - N ADD - S ADD=$$MADD^XUAF4(INST) ; mailing address - Q:$L(ADD) $P(ADD,U) - S ADD=$$PADD^XUAF4(INST) ; physical address - Q:$L(ADD) $P(ADD,U) - Q "" - ; -CITY(ADUZ) ; Get City for Institution. PUBLIC; EXTRINSIC - ;GPL CHANGED PARAMETER TO ADUZ TO KEEP $$SITE^VASITE FROM CRASHING - ; INPUT: DUZ ByVal - ; Output: String. - ; See ADD1 for comments - N INST S INST=$P($$SITE^VASITE(),U) - N ADD - S ADD=$$MADD^XUAF4(INST) ; mailing address - Q:$L(ADD) $P(ADD,U,2) - S ADD=$$PADD^XUAF4(INST) ; physical address - Q:$L(ADD) $P(ADD,U,2) - Q "" - ; -STATE(ADUZ) ; Get State for Institution. PUBLIC; EXTRINSIC - ; INPUT: DUZ ByVal - ; Output: String. - ; See ADD1 for comments - N INST S INST=$P($$SITE^VASITE(),U) - N ADD - S ADD=$$MADD^XUAF4(INST) ; mailing address - Q:$L(ADD) $P(ADD,U,3) - S ADD=$$PADD^XUAF4(INST) ; physical address - Q:$L(ADD) $P(ADD,U,3) - Q "" - ; -POSTCODE(ADUZ) ; Get Postal Code for Institution. PUBLIC; EXTRINSIC - ; INPUT: DUZ ByVal - ; OUTPUT: String. - ; See ADD1 for comments - N INST S INST=$P($$SITE^VASITE(),U) - N ADD - S ADD=$$MADD^XUAF4(INST) ; mailing address - Q:$L(ADD) $P(ADD,U,4) - S ADD=$$PADD^XUAF4(INST) ; physical address - Q:$L(ADD) $P(ADD,U,4) - Q "" - ; -TEL(DUZ) ; Get Office Phone number. PUBLIC; EXTRINSIC - ; INPUT: DUZ ByVal - ; OUTPUT: String. - ; Direct global access - N TEL S TEL=$G(^VA(200,DUZ,.13)) - Q $P(TEL,U,2) - ; -TELTYPE(DUZ) ; Get Telephone Type. PUBLIC; EXTRINSIC - ; INPUT: DUZ ByVal - ; OUTPUT: String. - Q "Office" - ; -EMAIL(DUZ) ; Get Provider's Email. PUBLIC; EXTRINSIC - ; INPUT: DUZ ByVal - ; OUTPUT: String - ; Direct global access - N EMAIL S EMAIL=$G(^VA(200,DUZ,.15)) - Q $P(EMAIL,U) - ; +C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008 Sam Habiel. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + Q + ; This routine uses Kernel APIs and Direct Global Access to get + ; Proivder Data from File 200. + ; + ; The Global is VA(200,*) + ; +FAMILY(DUZ) ; Get Family Name; PUBLIC; EXTRINSIC + ; INPUT: DUZ (i.e. File 200 IEN) ByVal + ; OUTPUT: String + N NAME S NAME=$P(^VA(200,DUZ,0),U) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("FAMILY") + ; +GIVEN(DUZ) ; Get Given Name; PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String + N NAME S NAME=$P(^VA(200,DUZ,0),U) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("GIVEN") + ; +MIDDLE(DUZ) ; Get Middle Name, PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String + N NAME S NAME=$P(^VA(200,DUZ,0),U) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("MIDDLE") + ; +SUFFIX(DUZ) ; Get Suffix Name, PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String + N NAME S NAME=$P(^VA(200,DUZ,0),U) + D NAMECOMP^XLFNAME(.NAME) + Q NAME("SUFFIX") + ; +TITLE(DUZ) ; Get Title for Proivder, PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String + ; Gets External Value of Title field in New Person File. + ; It's actually a pointer to file 3.1 + ; 200=New Person File; 8 is Title Field + Q $$GET1^DIQ(200,DUZ_",",8) + ; +NPI(DUZ) ; Get NPI Number, PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: Delimited String in format: + ; IDType^ID^IDDescription + ; If the NPI doesn't exist, "" is returned. + ; This routine uses a call documented in the Kernel dev guide + ; This call returns as "NPI^TimeEntered^ActiveInactive" + ; It returns -1 for NPI if NPI doesn't exist. + N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U) + Q:NPI=-1 "" + Q "NPI^"_NPI_"^HHS" + ; +SPEC(DUZ) ; Get Provider Specialty, PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String: ProviderType/Specialty/Subspecialty OR "" + ; Uses a Kernel API. Returns -1 if a specialty is not specified + ; in file 200. + ; Otherwise, returns IEN^Profession^Specialty^Sub­specialty^Effect date^Expired date^VA code + N STR S STR=$$GET^XUA4A72(DUZ) + Q:+STR<0 "" + ; Sometimes we have 3 pieces, or 2. Deal with that. + Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4) + Q $P(STR,U,2)_"-"_$P(STR,U,3) + ; +ADDTYPE(DUZ) ; Get Address Type, PUBLIC; EXTRINSIC + ; INPUT: DUZ, but not needed really... here for future expansion + ; OUTPUT: At this point "Work" + Q "Work" + ; +ADDLINE1(ADUZ) ; Get Address associated with this instituation; PUBLIC; EXTRINSIC ; CHANGED PARAMETER TO ADUZ TO KEEP FROM CRASHING GPL 1/09 + ; INPUT: DUZ ByVal + ; Output: String. + ; + ; First, get site number from the institution file. + ; 1st piece returned by $$SITE^VASITE, which gets the system institution + N INST S INST=$P($$SITE^VASITE(),U) + ; + ; Second, get mailing address + ; There are two APIs to get the address, one for physical and one for + ; mailing. We will check if mailing exists first, since that's the + ; one we want to use; then check for physical. If neither exists, + ; then we return nothing. We check for the existence of an address + ; by the length of the returned string. + ; NOTE: API doesn't support Address 2, so I won't even include it + ; in the template. + N ADD + S ADD=$$MADD^XUAF4(INST) ; mailing address + Q:$L(ADD) $P(ADD,U) + S ADD=$$PADD^XUAF4(INST) ; physical address + Q:$L(ADD) $P(ADD,U) + Q "" + ; +CITY(ADUZ) ; Get City for Institution. PUBLIC; EXTRINSIC + ;GPL CHANGED PARAMETER TO ADUZ TO KEEP $$SITE^VASITE FROM CRASHING + ; INPUT: DUZ ByVal + ; Output: String. + ; See ADD1 for comments + N INST S INST=$P($$SITE^VASITE(),U) + N ADD + S ADD=$$MADD^XUAF4(INST) ; mailing address + Q:$L(ADD) $P(ADD,U,2) + S ADD=$$PADD^XUAF4(INST) ; physical address + Q:$L(ADD) $P(ADD,U,2) + Q "" + ; +STATE(ADUZ) ; Get State for Institution. PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; Output: String. + ; See ADD1 for comments + N INST S INST=$P($$SITE^VASITE(),U) + N ADD + S ADD=$$MADD^XUAF4(INST) ; mailing address + Q:$L(ADD) $P(ADD,U,3) + S ADD=$$PADD^XUAF4(INST) ; physical address + Q:$L(ADD) $P(ADD,U,3) + Q "" + ; +POSTCODE(ADUZ) ; Get Postal Code for Institution. PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String. + ; See ADD1 for comments + N INST S INST=$P($$SITE^VASITE(),U) + N ADD + S ADD=$$MADD^XUAF4(INST) ; mailing address + Q:$L(ADD) $P(ADD,U,4) + S ADD=$$PADD^XUAF4(INST) ; physical address + Q:$L(ADD) $P(ADD,U,4) + Q "" + ; +TEL(DUZ) ; Get Office Phone number. PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String. + ; Direct global access + N TEL S TEL=$G(^VA(200,DUZ,.13)) + Q $P(TEL,U,2) + ; +TELTYPE(DUZ) ; Get Telephone Type. PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String. + Q "Office" + ; +EMAIL(DUZ) ; Get Provider's Email. PUBLIC; EXTRINSIC + ; INPUT: DUZ ByVal + ; OUTPUT: String + ; Direct global access + N EMAIL S EMAIL=$G(^VA(200,DUZ,.15)) + Q $P(EMAIL,U) + ; Index: ccr/branches/ohum/p/C0CVIT2.m =================================================================== --- ccr/branches/ohum/p/C0CVIT2.m (revision 1333) +++ ccr/branches/ohum/p/C0CVIT2.m (revision 1337) @@ -1,478 +1,478 @@ -C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 - ;;1.0;C0C;;Feb 16, 2010;Build 1 - ;Copyright 2008,2009 George Lilly, University of Minnesota and others. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(VITXML,DFN,VITOUT) ; EXTRACT VITAL SIGNS INTO XML TEMPLATE - ; VITXML AND VITOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED - ; - ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS - ; THAT GET PASSED TO *GET ROUTINES - ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME)) - N C0CVIT - S C0CVIT=$NA(^TMP("C0CCCR",$J,DFN,"C0CVIT")) - ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS - ; THAT GET INSERTED INTO THE XML TEMPLATE - ; D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS - I $$RPMS^C0CUTIL() D GETRPMS(DFN,C0CVIT) ; GET VARS - I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D GETVISTA(DFN,C0CVIT) - ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE - ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES - D MAP(VITXML,C0CVIT,VITOUT) ;MAP RESULTS FOR PROCEDURES - Q - ; -GETVISTA(DFN,C0CVIT) ; CALLS VITALS^ORQQVI TO GET VITAL SIGNS. - ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME - ; C0CVIT: VITAL SIGNS - ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2 - ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY - ; EXIST. - ; - ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J)) - ; - ; SETUP RPC/API CALL HERE - ; USE START AND END DATES FROM PARAMETERS IF REQUIRED - ; - N VIT,DATA,START,END - ; RPC REQUIRES FM DATES NOT T-* DATES - D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM - D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM - ; RPC CALL (ORY,DFN,ORSDT,OREDT): - ;ORY: return variable - ;DFN: patient identifier from Patient File [#2] - ;ORSDT: start date/time in Fileman format - ;OREDT: end date/time in Fileman format - ; OUTPUT FORMAT: - ;vital measurement ien^vital type^rate^date/time taken - D VITALS^ORQQVI(.VIT,DFN,START,END) ; RUN QUERY VITALS CALL - I '$D(VIT) S @VITOUT@(0)=0 K VIT Q ; RETURN NOT FOUND, KILL ARRAY AND QUIT - I $P(VIT(1),U,2)="No vitals found." D Q ; signal no vitals and quit - . I $D(VITOUT) S @VITOUT@(0)=0 - . K VIT - ; - ; PREFORM SORT HERE IF NEEDED - ; - ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST - ; COPIED SORT LOGIC: - N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX - D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY - S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE - ; VSORT IS VITALS IN REVERSE ORDER - ; - ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY - ; RNF1 ARRAY FORMAT: - ; VAR("NAME_OF_RIM_VARIABLE")=VALUE - ; - ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS - ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD - ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS - N C0CVI,C0CC,ZRNF - ;S C0CVI="" ; INITIALIZE FOR $O - F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D ; FOR EACH VITAL SIGN IN THE LIST - . I DEBUG W VIT(C0CVI),! - . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER) - . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"in") - . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"lbs") - . D:$P(VIT(C0CVI),U,3)="BP" BP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") - . D:$P(VIT(C0CVI),U,3)="T" TMP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"F") - . D:$P(VIT(C0CVI),U,3)="R" RESP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") - . D:$P(VIT(C0CVI),U,3)="P" PULSE1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") - . D:$P(VIT(C0CVI),U,3)="PN" PAIN1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") - . D:'$D(ZRNF) OTHER1($$FMDTOUTC^C0CUTIL($P(C0CVI,U,4),"DT"),"OTHER VITAL",$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"UNKNOWN") ;IF THE VITAL ISN'T DEFINED IT IS OTHER - . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY - . K ZRNF - ; SAVE RIM VARIABLES SEE C0CRIMA - N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS")) - M @ZRIM=@C0CVIT@("V") - Q - ; -GETRPMS(DFN,C0CVIT) ; CALLS QUERY^BEHOVM TO GET VITAL SIGNS. - ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME - ; C0CVIT: VITAL SIGNS - ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2 - ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY - ; EXIST. - ; - ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J)) - ; - ; SETUP RPC/API CALL HERE - ; USE START AND END DATES FROM PARAMETERS IF REQUIRED - ; - ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE - ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE - N C0CEDT,C0CSDT,VIT,DATA,START,END - ; RPC REQUIRES FM DATES NOT T-* DATES - D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM - D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM - ; RPC OUTPUT FORMAT: - ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric) - D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL - I '$D(^TMP("CIAVMRPC",$J)) S @VITOUT@(0)=0 K ^TMP("CIAVMRPC",$J) Q ; RETURN NOT FOUND, KILL ARRAY AND QUIT - ; MOVE THE ARRAY TO LOCAL VARIABLE - M VIT=^TMP("CIAVMRPC",$J,0) - ; RPC CLEANUP - K ^TMP("CIAVMRPC",$J),VITS,RMAX,START,END,DATA,METRIC,VSTR,VUNT - ; - ; PREFORM SORT HERE IF NEEDED - ; - ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST - ; COPIED SORT LOGIC: - N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX - D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY - S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE - ; VSORT IS VITALS IN REVERSE ORDER - ; - ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY - ; RNF1 ARRAY FORMAT: - ; VAR("NAME_OF_RIM_VARIABLE")=VALUE - ; - ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS - ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD - ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS - N C0CVI,C0CC,ZRNF - ;S C0CVI="" ; INITIALIZE FOR $O - F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D ; FOR EACH VITAL SIGN IN THE LIST - . I DEBUG W VIT(C0CVI),! - . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER) - . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT - . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT - . D:$P(VIT(C0CVI),U,3)="BP" BP - . D:$P(VIT(C0CVI),U,3)="TMP" TMP - . D:$P(VIT(C0CVI),U,3)="RS" RESP - . D:$P(VIT(C0CVI),U,3)="PU" PULSE - . D:$P(VIT(C0CVI),U,3)="PA" PAIN - . D:'$D(ZRNF) OTHER ;IF THE VITAL ISN'T DEFINED IT IS OTHER - . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY - . K ZRNF - ; SAVE RIM VARIABLES SEE C0CRIMA - N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS")) - M @ZRIM=@C0CVIT@("V") - Q - ; -HEIGHT - I DEBUG W "IN VITAL: HEIGHT",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) - S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) - S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) - Q - ; -WEIGHT - I DEBUG W "IN VITAL: WEIGHT",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) - S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) - S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) - Q - ; -BP - I DEBUG W "IN VITAL: BLOOD PRESSURE",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) - S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) - S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) - Q - ; -TMP - I DEBUG W "IN VITAL: TEMPERATURE",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) - S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) - S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) - Q - ; -RESP - I DEBUG W "IN VITAL: RESPIRATION",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) - S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) - S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) - Q - ; -PULSE - I DEBUG W "IN VITAL: PULSE",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) - S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) - S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) - Q - ; -PAIN - I DEBUG W "IN VITAL: PAIN",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) - S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) - S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) - Q - ; -OTHER - I DEBUG W "IN VITAL: OTHER",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=$P(VIT(C0CVI),U,2) - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) - S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) - S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) - Q - ; - ;TEMPORARY, THINKING ON HOW TO REFACTOR (CJE) -HEIGHT1(DT,ACTOR,VALUE,UNIT) - I DEBUG W "IN VITAL: HEIGHT",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=DT - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR - S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE - S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT - Q - ; -WEIGHT1(DT,ACTOR,VALUE,UNIT) - I DEBUG W "IN VITAL: WEIGHT",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=DT - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR - S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE - S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT - Q - ; -BP1(DT,ACTOR,VALUE,UNIT) - I DEBUG W "IN VITAL: BLOOD PRESSURE",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=DT - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR - S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE - S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT - Q - ; -TMP1(DT,ACTOR,VALUE,UNIT) - I DEBUG W "IN VITAL: TEMPERATURE",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=DT - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR - S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE - S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT - Q - ; -RESP1(DT,ACTOR,VALUE,UNIT) - I DEBUG W "IN VITAL: RESPIRATION",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=DT - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR - S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE - S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT - Q - ; -PULSE1(DT,ACTOR,VALUE,UNIT) - I DEBUG W "IN VITAL: PULSE",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=DT - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR - S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE - S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT - Q - ; -PAIN1(DT,ACTOR,VALUE,UNIT) - I DEBUG W "IN VITAL: PAIN",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=DT - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN" - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR - S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE - S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT - Q - ; -OTHER1(DT,TEXT,ACTOR,VALUE,UNIT) - I DEBUG W "IN VITAL: OTHER",! - S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC - S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSEXACTDATETIME")=DT - S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=TEXT - S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC - S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" - S ZRNF("VITALSIGNSDESCCODEVALUE")="" - S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="" - S ZRNF("VITALSIGNSCODEVERSION")="" - S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR - S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE - S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT - Q - ; -VITSORT(VDT) ; RUN DATE SORTING ALGORITHM - ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY - ; OF DATES IN THE VITALS RESULTS - N VDTI,VDTJ,VTDCNT - S VTDCNT=0 ; COUNT TO BUILD ARRAY - S VDTJ="" ; USED TO VISIT THE RESULTS - F VDTI=0:0 D Q:$O(VIT(VDTJ))="" ; VISIT ALL RESULTS - . S VDTJ=$O(VIT(VDTJ)) ; NEXT RESULT - . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER - . S VDT(VTDCNT)=$P(VIT(VDTJ),U,4) ; PULL OUT THE DATE - S VDT(0)=VTDCNT - Q - ; -MAP(VITXML,C0CVIT,VITOUT) ; MAP VITAL SIGNS XML - ; - N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"VITTEMP")) ;WORK AREA FOR TEMPLATE - K @ZTEMP - N ZBLD - S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"VITBLD")) ; BUILD LIST AREA - D QUEUE^C0CXPATH(ZBLD,VITXML,1,1) ; FIRST LINE - N ZINNER - ; XPATH NEEDS TO MATCH YOUR SECTION - D QUERY^C0CXPATH(VITXML,"//VitalSigns/Result","ZINNER") ;ONE VITAL SIGN - N ZTMP,ZVAR,ZI - S ZI="" - F S ZI=$O(@C0CVIT@("V",ZI)) Q:ZI="" D ;FOR EACH VITAL SIGN - . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS VITAL SIGN XML - . S ZVAR=$NA(@C0CVIT@("V",ZI)) ;THIS VITAL SIGN VARIABLES - . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE VITAL SIGN - . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD - D QUEUE^C0CXPATH(ZBLD,VITXML,@VITXML@(0),@VITXML@(0)) - N ZZTMP ; IS THIS NEEDED? - D BUILD^C0CXPATH(ZBLD,VITOUT) ;BUILD FINAL XML - K @ZTEMP,@ZBLD - Q - ; +C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 + ;;1.0;C0C;;Feb 16, 2010;Build 38 + ;Copyright 2008,2009 George Lilly, University of Minnesota and others. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(VITXML,DFN,VITOUT) ; EXTRACT VITAL SIGNS INTO XML TEMPLATE + ; VITXML AND VITOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; + ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS + ; THAT GET PASSED TO *GET ROUTINES + ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME)) + N C0CVIT + S C0CVIT=$NA(^TMP("C0CCCR",$J,DFN,"C0CVIT")) + ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS + ; THAT GET INSERTED INTO THE XML TEMPLATE + ; D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS + I $$RPMS^C0CUTIL() D GETRPMS(DFN,C0CVIT) ; GET VARS + I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D GETVISTA(DFN,C0CVIT) + ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE + ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES + D MAP(VITXML,C0CVIT,VITOUT) ;MAP RESULTS FOR PROCEDURES + Q + ; +GETVISTA(DFN,C0CVIT) ; CALLS VITALS^ORQQVI TO GET VITAL SIGNS. + ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME + ; C0CVIT: VITAL SIGNS + ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2 + ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY + ; EXIST. + ; + ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J)) + ; + ; SETUP RPC/API CALL HERE + ; USE START AND END DATES FROM PARAMETERS IF REQUIRED + ; + N VIT,DATA,START,END + ; RPC REQUIRES FM DATES NOT T-* DATES + D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM + D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM + ; RPC CALL (ORY,DFN,ORSDT,OREDT): + ;ORY: return variable + ;DFN: patient identifier from Patient File [#2] + ;ORSDT: start date/time in Fileman format + ;OREDT: end date/time in Fileman format + ; OUTPUT FORMAT: + ;vital measurement ien^vital type^rate^date/time taken + D VITALS^ORQQVI(.VIT,DFN,START,END) ; RUN QUERY VITALS CALL + I '$D(VIT) S @VITOUT@(0)=0 K VIT Q ; RETURN NOT FOUND, KILL ARRAY AND QUIT + I $P(VIT(1),U,2)="No vitals found." D Q ; signal no vitals and quit + . I $D(VITOUT) S @VITOUT@(0)=0 + . K VIT + ; + ; PREFORM SORT HERE IF NEEDED + ; + ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST + ; COPIED SORT LOGIC: + N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX + D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY + S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE + ; VSORT IS VITALS IN REVERSE ORDER + ; + ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY + ; RNF1 ARRAY FORMAT: + ; VAR("NAME_OF_RIM_VARIABLE")=VALUE + ; + ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS + ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD + ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS + N C0CVI,C0CC,ZRNF + ;S C0CVI="" ; INITIALIZE FOR $O + F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D ; FOR EACH VITAL SIGN IN THE LIST + . I DEBUG W VIT(C0CVI),! + . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER) + . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"in") + . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"lbs") + . D:$P(VIT(C0CVI),U,3)="BP" BP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") + . D:$P(VIT(C0CVI),U,3)="T" TMP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"F") + . D:$P(VIT(C0CVI),U,3)="R" RESP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") + . D:$P(VIT(C0CVI),U,3)="P" PULSE1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") + . D:$P(VIT(C0CVI),U,3)="PN" PAIN1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") + . D:'$D(ZRNF) OTHER1($$FMDTOUTC^C0CUTIL($P(C0CVI,U,4),"DT"),"OTHER VITAL",$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"UNKNOWN") ;IF THE VITAL ISN'T DEFINED IT IS OTHER + . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY + . K ZRNF + ; SAVE RIM VARIABLES SEE C0CRIMA + N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS")) + M @ZRIM=@C0CVIT@("V") + Q + ; +GETRPMS(DFN,C0CVIT) ; CALLS QUERY^BEHOVM TO GET VITAL SIGNS. + ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME + ; C0CVIT: VITAL SIGNS + ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2 + ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY + ; EXIST. + ; + ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J)) + ; + ; SETUP RPC/API CALL HERE + ; USE START AND END DATES FROM PARAMETERS IF REQUIRED + ; + ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE + ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE + N C0CEDT,C0CSDT,VIT,DATA,START,END + ; RPC REQUIRES FM DATES NOT T-* DATES + D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM + D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM + ; RPC OUTPUT FORMAT: + ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric) + D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL + I '$D(^TMP("CIAVMRPC",$J)) S @VITOUT@(0)=0 K ^TMP("CIAVMRPC",$J) Q ; RETURN NOT FOUND, KILL ARRAY AND QUIT + ; MOVE THE ARRAY TO LOCAL VARIABLE + M VIT=^TMP("CIAVMRPC",$J,0) + ; RPC CLEANUP + K ^TMP("CIAVMRPC",$J),VITS,RMAX,START,END,DATA,METRIC,VSTR,VUNT + ; + ; PREFORM SORT HERE IF NEEDED + ; + ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST + ; COPIED SORT LOGIC: + N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX + D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY + S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE + ; VSORT IS VITALS IN REVERSE ORDER + ; + ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY + ; RNF1 ARRAY FORMAT: + ; VAR("NAME_OF_RIM_VARIABLE")=VALUE + ; + ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS + ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD + ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS + N C0CVI,C0CC,ZRNF + ;S C0CVI="" ; INITIALIZE FOR $O + F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D ; FOR EACH VITAL SIGN IN THE LIST + . I DEBUG W VIT(C0CVI),! + . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER) + . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT + . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT + . D:$P(VIT(C0CVI),U,3)="BP" BP + . D:$P(VIT(C0CVI),U,3)="TMP" TMP + . D:$P(VIT(C0CVI),U,3)="RS" RESP + . D:$P(VIT(C0CVI),U,3)="PU" PULSE + . D:$P(VIT(C0CVI),U,3)="PA" PAIN + . D:'$D(ZRNF) OTHER ;IF THE VITAL ISN'T DEFINED IT IS OTHER + . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY + . K ZRNF + ; SAVE RIM VARIABLES SEE C0CRIMA + N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS")) + M @ZRIM=@C0CVIT@("V") + Q + ; +HEIGHT + I DEBUG W "IN VITAL: HEIGHT",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) + S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) + S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) + Q + ; +WEIGHT + I DEBUG W "IN VITAL: WEIGHT",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) + S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) + S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) + Q + ; +BP + I DEBUG W "IN VITAL: BLOOD PRESSURE",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) + S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) + S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) + Q + ; +TMP + I DEBUG W "IN VITAL: TEMPERATURE",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) + S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) + S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) + Q + ; +RESP + I DEBUG W "IN VITAL: RESPIRATION",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) + S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) + S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) + Q + ; +PULSE + I DEBUG W "IN VITAL: PULSE",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) + S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) + S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) + Q + ; +PAIN + I DEBUG W "IN VITAL: PAIN",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) + S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) + S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) + Q + ; +OTHER + I DEBUG W "IN VITAL: OTHER",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=$P(VIT(C0CVI),U,2) + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) + S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) + S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) + Q + ; + ;TEMPORARY, THINKING ON HOW TO REFACTOR (CJE) +HEIGHT1(DT,ACTOR,VALUE,UNIT) + I DEBUG W "IN VITAL: HEIGHT",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=DT + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR + S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE + S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT + Q + ; +WEIGHT1(DT,ACTOR,VALUE,UNIT) + I DEBUG W "IN VITAL: WEIGHT",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=DT + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR + S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE + S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT + Q + ; +BP1(DT,ACTOR,VALUE,UNIT) + I DEBUG W "IN VITAL: BLOOD PRESSURE",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=DT + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR + S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE + S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT + Q + ; +TMP1(DT,ACTOR,VALUE,UNIT) + I DEBUG W "IN VITAL: TEMPERATURE",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=DT + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR + S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE + S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT + Q + ; +RESP1(DT,ACTOR,VALUE,UNIT) + I DEBUG W "IN VITAL: RESPIRATION",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=DT + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR + S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE + S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT + Q + ; +PULSE1(DT,ACTOR,VALUE,UNIT) + I DEBUG W "IN VITAL: PULSE",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=DT + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR + S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE + S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT + Q + ; +PAIN1(DT,ACTOR,VALUE,UNIT) + I DEBUG W "IN VITAL: PAIN",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=DT + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN" + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR + S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE + S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT + Q + ; +OTHER1(DT,TEXT,ACTOR,VALUE,UNIT) + I DEBUG W "IN VITAL: OTHER",! + S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC + S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSEXACTDATETIME")=DT + S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=TEXT + S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC + S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" + S ZRNF("VITALSIGNSDESCCODEVALUE")="" + S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="" + S ZRNF("VITALSIGNSCODEVERSION")="" + S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR + S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE + S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT + Q + ; +VITSORT(VDT) ; RUN DATE SORTING ALGORITHM + ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY + ; OF DATES IN THE VITALS RESULTS + N VDTI,VDTJ,VTDCNT + S VTDCNT=0 ; COUNT TO BUILD ARRAY + S VDTJ="" ; USED TO VISIT THE RESULTS + F VDTI=0:0 D Q:$O(VIT(VDTJ))="" ; VISIT ALL RESULTS + . S VDTJ=$O(VIT(VDTJ)) ; NEXT RESULT + . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER + . S VDT(VTDCNT)=$P(VIT(VDTJ),U,4) ; PULL OUT THE DATE + S VDT(0)=VTDCNT + Q + ; +MAP(VITXML,C0CVIT,VITOUT) ; MAP VITAL SIGNS XML + ; + N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"VITTEMP")) ;WORK AREA FOR TEMPLATE + K @ZTEMP + N ZBLD + S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"VITBLD")) ; BUILD LIST AREA + D QUEUE^C0CXPATH(ZBLD,VITXML,1,1) ; FIRST LINE + N ZINNER + ; XPATH NEEDS TO MATCH YOUR SECTION + D QUERY^C0CXPATH(VITXML,"//VitalSigns/Result","ZINNER") ;ONE VITAL SIGN + N ZTMP,ZVAR,ZI + S ZI="" + F S ZI=$O(@C0CVIT@("V",ZI)) Q:ZI="" D ;FOR EACH VITAL SIGN + . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS VITAL SIGN XML + . S ZVAR=$NA(@C0CVIT@("V",ZI)) ;THIS VITAL SIGN VARIABLES + . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE VITAL SIGN + . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD + D QUEUE^C0CXPATH(ZBLD,VITXML,@VITXML@(0),@VITXML@(0)) + N ZZTMP ; IS THIS NEEDED? + D BUILD^C0CXPATH(ZBLD,VITOUT) ;BUILD FINAL XML + K @ZTEMP,@ZBLD + Q + ; Index: ccr/branches/ohum/p/C0CVITAL.m =================================================================== --- ccr/branches/ohum/p/C0CVITAL.m (revision 1333) +++ ccr/branches/ohum/p/C0CVITAL.m (revision 1337) @@ -1,413 +1,413 @@ -C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008,2009 George Lilly, University of Minnesota and others. - ;Licensed under the terms of the GNU General Public License. - ;See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(VITXML,DFN,VITOUTXML) ; EXTRACT VITALS INTO PROVIDED XML TEMPLATE - ; - ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED - ; IVITXML CONTAINS ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE - ; - N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF,VORDR - S C0CVLMT=$$GET^C0CPARMS("VITLIMIT") ; GET THE LIMIT PARM - S C0CVSTRT=$$GET^C0CPARMS("VITSTART") ; GET START PARM - D DT^DILF(,C0CVLMT,.C0CEDT) ; - D DT^DILF(,C0CVSTRT,.C0CSDT) ; - ;D DT^DILF(,C0CVLMT,.C0CSDT) ; GPL TESTING - ;D DT^DILF(,C0CVSTRT,.C0CEDT) ; - W "VITALS START: ",C0CVSTRT," LIMIT: ",C0CVLMT,! - I $$RPMS^C0CUTIL() D VITRPMS QUIT - I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VITVISTA QUIT - ;I $$SYSNAME^C0CSYS()="RPMS" D VITRPMS - ;E D VITVISTA - Q - ; -VITVISTA ; EXTRACT VITALS FROM VISTA INTO PROVIDED XML TEMPLATE - D FASTVIT^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) ; GPL THIS ONE WORKS FOR AT - ; LEAST ONE SET OF VITALS - TO DO, CALL IT REPETIVELY TO GET EARLIER VITALS - ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) - ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CSDT,C0CEDT) - ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CVSTRT,C0CVLMT) ; GPL LET GMR HANDLE THE DATES - I '$D(VITRSLT(1)) S @VITOUTXML@(0)=0 Q ; RETURN NOT FOUND AND QUIT - I $P(VITRSLT(1),U,2)="No vitals found." D Q ; NULL RESULT FROM RPC - . I DEBUG W "NO VITALS FOUND FROM VITALS RPC",! - . S @VITOUTXML@(0)=0 - I $P(VITRSLT(1),U,2)="No vitals found." Q ; QUIT - ; ZWR RPCRSLT - S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS")) - S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP")) - K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES - N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX - D VITDVISTA(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY - I DEBUG ZWR VDATES ;DEBUG - S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE - ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY - S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS - F J=1:1:VCNT D ; FOR EACH VITAL IN THE LIST - . I $D(VITRSLT(VSORT(J))) D - . . S VITVMAP=$NA(@VITTVMAP@(J)) - . . K @VITVMAP - . . I DEBUG W "VMAP= ",VITVMAP,! - . . S VITPTMP=VITRSLT(VSORT(J)) ; DATE SORTED VITAL FROM RETURN ARRAY - . . I DEBUG W "VITAL ",VSORT(J),! - . . I DEBUG W VITRSLT(VSORT(J))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),! - . . I DEBUG W $P(VITPTMP,U,4),! - . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID - . . ;B ;gpl - . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6) - . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; - . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" - . . I $P(VITPTMP,U,2)="HT" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in" - . . E I $P(VITPTMP,U,2)="WT" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs" - . . E I $P(VITPTMP,U,2)="BP" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . ;S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" - . . E I $P(VITPTMP,U,2)="T" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F" - . . E I $P(VITPTMP,U,2)="R" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" - . . E I $P(VITPTMP,U,2)="P" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" - . . E I $P(VITPTMP,U,2)="PN" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" - . . E I $P(VITPTMP,U,2)="BMI" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="60621009" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" - . . E D - . . . ;W "IN VITAL: OTHER",! - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER VITAL" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="UNKNOWN" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER" - . . . ;S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="" - . . . ;S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="" - . . . ;S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN" - . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; - . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ; - . . S VITARYTMP=$NA(@VITTARYTMP@(J)) - . . K @VITARYTMP - . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP) - . . I J=1 D ; FIRST ONE IS JUST A COPY - . . . ; W "FIRST ONE",! - . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML) - . . . I DEBUG W "VITOUTXML ",VITOUTXML,! - . . I J>1 D ; AFTER THE FIRST, INSERT INNER XML - . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP) - ; ZWR ^TMP($J,"VITALS",*) - ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS - I DEBUG D PARY^C0CXPATH(VITOUTXML) - N VITTMP,I - D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS - I VITTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ - . W "VITALS MISSING ",! - . F I=1:1:VITTMP(0) W VITTMP(I),! - Q - ; -VITRPMS ; EXTRACT VITALS FROM RPMS INTO PROVIDED XML TEMPLATE - ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE - ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE - N END,START,DATA - D DT^DILF("",C0CVLMT,.END) - D DT^DILF("",C0CVSTRT,.START) - ; RPC OUTPUT FORMAT: - ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric) - D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL - I '$D(^TMP("CIAVMRPC",$J)) S @VITOUTXML@(0)=0 Q ; RETURN NOT FOUND AND QUIT - ;ZW ^TMP("CIAVMRPC",$J) - S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS")) - S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP")) - K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES - N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX - D VITDRPMS(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY - S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE - ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY - S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS - F J=1:1:VCNT D ; FOR EACH VITAL IN THE LIST - . I $D(^TMP("CIAVMRPC",$J,0,(VSORT(J)))) D - . . S VITVMAP=$NA(@VITTVMAP@(J)) - . . K @VITVMAP - . . I DEBUG W "VMAP= ",VITVMAP,! - . . S VITPTMP=^TMP("CIAVMRPC",$J,0,(VSORT(J))) ; DATE SORTED VITAL FROM RETURN ARRAY - . . I DEBUG W "VITAL ",VSORT(J),! - . . I DEBUG W ^TMP("CIAVMRPC",$J,0,(VSORT(J)))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),! - . . I DEBUG W $P(VITPTMP,U,4),! - . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID - . . I $P(VITPTMP,U,3)="HT" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) - . . E I $P(VITPTMP,U,3)="WT" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) - . . E I $P(VITPTMP,U,3)="BP" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) - . . E I $P(VITPTMP,U,3)="TMP" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) - . . E I $P(VITPTMP,U,3)="RS" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) - . . E I $P(VITPTMP,U,3)="PU" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) - . . E I $P(VITPTMP,U,3)="PA" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) - . . E D - . . . ;W "IN VITAL: OTHER",! - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2) - . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" - . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J - . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2) - . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="" - . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="" - . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" - . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) - . . S VITARYTMP=$NA(@VITTARYTMP@(J)) - . . K @VITARYTMP - . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP) - . . I J=1 D ; FIRST ONE IS JUST A COPY - . . . ; W "FIRST ONE",! - . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML) - . . . I DEBUG W "VITOUTXML ",VITOUTXML,! - . . I J>1 D ; AFTER THE FIRST, INSERT INNER XML - . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP) - ; ZWR ^TMP($J,"VITALS",*) - ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS - I DEBUG D PARY^C0CXPATH(VITOUTXML) - N VITTMP,I - D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS - I VITTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ - . W "VITALS MISSING ",! - . F I=1:1:VITTMP(0) W VITTMP(I),! - K ^TMP("CIAVMRPC",$J) - Q - ; -VITDRPMS(VDT) ; RUN DATE SORTING ALGORITHM FOR RPMS - ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY - ; OF DATES IN THE VITALS RESULTS - N VDTI,VDTJ,VTDCNT - S VTDCNT=0 ; COUNT TO BUILD ARRAY - S VDTJ="" ; USED TO VISIT THE RESULTS - F VDTI=0:0 D Q:$O(^TMP("CIAVMRPC",$J,0,VDTJ))="" ; VISIT ALL RESULTS - . S VDTJ=$O(^TMP("CIAVMRPC",$J,0,VDTJ)) ; NEXT RESULT - . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER - . S VDT(VTDCNT)=$P(^TMP("CIAVMRPC",$J,0,VDTJ),U,4) ; PULL OUT THE DATE - S VDT(0)=VTDCNT - Q - ; -VITDVISTA(VDT) ; RUN DATE SORTING ALGORITHM FOR VISTA - ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY - ; OF DATES IN THE VITALS RESULTS - N VDTI,VDTJ,VTDCNT - S VTDCNT=0 ; COUNT TO BUILD ARRAY - S VDTJ="" ; USED TO VISIT THE RESULTS - F VDTI=0:0 D Q:$O(VITRSLT(VDTJ))="" ; VISIT ALL RESULTS - . S VDTJ=$O(VITRSLT(VDTJ)) ; NEXT RESULT - . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER - . S VDT(VTDCNT)=$P(VITRSLT(VDTJ),U,4) ; PULL OUT THE DATE - S VDT(0)=VTDCNT - Q - ; +C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008,2009 George Lilly, University of Minnesota and others. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(VITXML,DFN,VITOUTXML) ; EXTRACT VITALS INTO PROVIDED XML TEMPLATE + ; + ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED + ; IVITXML CONTAINS ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE + ; + N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF,VORDR + S C0CVLMT=$$GET^C0CPARMS("VITLIMIT") ; GET THE LIMIT PARM + S C0CVSTRT=$$GET^C0CPARMS("VITSTART") ; GET START PARM + D DT^DILF(,C0CVLMT,.C0CEDT) ; + D DT^DILF(,C0CVSTRT,.C0CSDT) ; + ;D DT^DILF(,C0CVLMT,.C0CSDT) ; GPL TESTING + ;D DT^DILF(,C0CVSTRT,.C0CEDT) ; + W "VITALS START: ",C0CVSTRT," LIMIT: ",C0CVLMT,! + I $$RPMS^C0CUTIL() D VITRPMS QUIT + I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VITVISTA QUIT + ;I $$SYSNAME^C0CSYS()="RPMS" D VITRPMS + ;E D VITVISTA + Q + ; +VITVISTA ; EXTRACT VITALS FROM VISTA INTO PROVIDED XML TEMPLATE + D FASTVIT^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) ; GPL THIS ONE WORKS FOR AT + ; LEAST ONE SET OF VITALS - TO DO, CALL IT REPETIVELY TO GET EARLIER VITALS + ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) + ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CSDT,C0CEDT) + ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CVSTRT,C0CVLMT) ; GPL LET GMR HANDLE THE DATES + I '$D(VITRSLT(1)) S @VITOUTXML@(0)=0 Q ; RETURN NOT FOUND AND QUIT + I $P(VITRSLT(1),U,2)="No vitals found." D Q ; NULL RESULT FROM RPC + . I DEBUG W "NO VITALS FOUND FROM VITALS RPC",! + . S @VITOUTXML@(0)=0 + I $P(VITRSLT(1),U,2)="No vitals found." Q ; QUIT + ; ZWR RPCRSLT + S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS")) + S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP")) + K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES + N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX + D VITDVISTA(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY + I DEBUG ZWR VDATES ;DEBUG + S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE + ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY + S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS + F J=1:1:VCNT D ; FOR EACH VITAL IN THE LIST + . I $D(VITRSLT(VSORT(J))) D + . . S VITVMAP=$NA(@VITTVMAP@(J)) + . . K @VITVMAP + . . I DEBUG W "VMAP= ",VITVMAP,! + . . S VITPTMP=VITRSLT(VSORT(J)) ; DATE SORTED VITAL FROM RETURN ARRAY + . . I DEBUG W "VITAL ",VSORT(J),! + . . I DEBUG W VITRSLT(VSORT(J))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),! + . . I DEBUG W $P(VITPTMP,U,4),! + . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID + . . ;B ;gpl + . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6) + . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" + . . I $P(VITPTMP,U,2)="HT" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in" + . . E I $P(VITPTMP,U,2)="WT" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs" + . . E I $P(VITPTMP,U,2)="BP" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . ;S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" + . . E I $P(VITPTMP,U,2)="T" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F" + . . E I $P(VITPTMP,U,2)="R" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" + . . E I $P(VITPTMP,U,2)="P" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" + . . E I $P(VITPTMP,U,2)="PN" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" + . . E I $P(VITPTMP,U,2)="BMI" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="60621009" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" + . . E D + . . . ;W "IN VITAL: OTHER",! + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER VITAL" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="UNKNOWN" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER" + . . . ;S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="" + . . . ;S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="" + . . . ;S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN" + . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ; + . . S VITARYTMP=$NA(@VITTARYTMP@(J)) + . . K @VITARYTMP + . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP) + . . I J=1 D ; FIRST ONE IS JUST A COPY + . . . ; W "FIRST ONE",! + . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML) + . . . I DEBUG W "VITOUTXML ",VITOUTXML,! + . . I J>1 D ; AFTER THE FIRST, INSERT INNER XML + . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP) + ; ZWR ^TMP($J,"VITALS",*) + ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS + I DEBUG D PARY^C0CXPATH(VITOUTXML) + N VITTMP,I + D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS + I VITTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "VITALS MISSING ",! + . F I=1:1:VITTMP(0) W VITTMP(I),! + Q + ; +VITRPMS ; EXTRACT VITALS FROM RPMS INTO PROVIDED XML TEMPLATE + ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE + ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE + N END,START,DATA + D DT^DILF("",C0CVLMT,.END) + D DT^DILF("",C0CVSTRT,.START) + ; RPC OUTPUT FORMAT: + ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric) + D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL + I '$D(^TMP("CIAVMRPC",$J)) S @VITOUTXML@(0)=0 Q ; RETURN NOT FOUND AND QUIT + ;ZW ^TMP("CIAVMRPC",$J) + S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS")) + S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP")) + K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES + N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX + D VITDRPMS(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY + S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE + ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY + S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS + F J=1:1:VCNT D ; FOR EACH VITAL IN THE LIST + . I $D(^TMP("CIAVMRPC",$J,0,(VSORT(J)))) D + . . S VITVMAP=$NA(@VITTVMAP@(J)) + . . K @VITVMAP + . . I DEBUG W "VMAP= ",VITVMAP,! + . . S VITPTMP=^TMP("CIAVMRPC",$J,0,(VSORT(J))) ; DATE SORTED VITAL FROM RETURN ARRAY + . . I DEBUG W "VITAL ",VSORT(J),! + . . I DEBUG W ^TMP("CIAVMRPC",$J,0,(VSORT(J)))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),! + . . I DEBUG W $P(VITPTMP,U,4),! + . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID + . . I $P(VITPTMP,U,3)="HT" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) + . . E I $P(VITPTMP,U,3)="WT" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) + . . E I $P(VITPTMP,U,3)="BP" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) + . . E I $P(VITPTMP,U,3)="TMP" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) + . . E I $P(VITPTMP,U,3)="RS" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) + . . E I $P(VITPTMP,U,3)="PU" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) + . . E I $P(VITPTMP,U,3)="PA" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) + . . E D + . . . ;W "IN VITAL: OTHER",! + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2) + . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" + . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J + . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2) + . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="" + . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="" + . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) + . . S VITARYTMP=$NA(@VITTARYTMP@(J)) + . . K @VITARYTMP + . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP) + . . I J=1 D ; FIRST ONE IS JUST A COPY + . . . ; W "FIRST ONE",! + . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML) + . . . I DEBUG W "VITOUTXML ",VITOUTXML,! + . . I J>1 D ; AFTER THE FIRST, INSERT INNER XML + . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP) + ; ZWR ^TMP($J,"VITALS",*) + ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS + I DEBUG D PARY^C0CXPATH(VITOUTXML) + N VITTMP,I + D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS + I VITTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "VITALS MISSING ",! + . F I=1:1:VITTMP(0) W VITTMP(I),! + K ^TMP("CIAVMRPC",$J) + Q + ; +VITDRPMS(VDT) ; RUN DATE SORTING ALGORITHM FOR RPMS + ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY + ; OF DATES IN THE VITALS RESULTS + N VDTI,VDTJ,VTDCNT + S VTDCNT=0 ; COUNT TO BUILD ARRAY + S VDTJ="" ; USED TO VISIT THE RESULTS + F VDTI=0:0 D Q:$O(^TMP("CIAVMRPC",$J,0,VDTJ))="" ; VISIT ALL RESULTS + . S VDTJ=$O(^TMP("CIAVMRPC",$J,0,VDTJ)) ; NEXT RESULT + . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER + . S VDT(VTDCNT)=$P(^TMP("CIAVMRPC",$J,0,VDTJ),U,4) ; PULL OUT THE DATE + S VDT(0)=VTDCNT + Q + ; +VITDVISTA(VDT) ; RUN DATE SORTING ALGORITHM FOR VISTA + ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY + ; OF DATES IN THE VITALS RESULTS + N VDTI,VDTJ,VTDCNT + S VTDCNT=0 ; COUNT TO BUILD ARRAY + S VDTJ="" ; USED TO VISIT THE RESULTS + F VDTI=0:0 D Q:$O(VITRSLT(VDTJ))="" ; VISIT ALL RESULTS + . S VDTJ=$O(VITRSLT(VDTJ)) ; NEXT RESULT + . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER + . S VDT(VTDCNT)=$P(VITRSLT(VDTJ),U,4) ; PULL OUT THE DATE + S VDT(0)=VTDCNT + Q + ; Index: ccr/branches/ohum/p/C0CVOBX1.m =================================================================== --- ccr/branches/ohum/p/C0CVOBX1.m (revision 1333) +++ ccr/branches/ohum/p/C0CVOBX1.m (revision 1337) @@ -1,114 +1,114 @@ -LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09 - ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994;Build 1 - ; JMC - mods to check for IHS V LAB file - ; -CH ; Observation/Result segment for "CH" subscript results. - ; Called by LA7VOBX - ; - N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X - ; - ; "CH" subscript requires a dataname - I '$G(LRSB) Q - ; - ; get result node from LR global. - S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) - S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB)) - ; - ; Check if test is OK to send - (O)utput or (B)oth - S LA7X=$P(LA7VAL,"^",12) - I LA7X]"","BO"'[LA7X Q - I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q - ; - ; If no result NLT or LOINC try to determine from file #60 - S LA7X=$P(LA7VAL,"^",3) - ; WV check for IHS - NLT/LN codes from V LAB file - I $D(^AUPNVLAB) D TMPCHK^C0CLA7Q - ; - I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5)) - ; No result NLT code - log error - I $P($P(LA7VAL,"^",3),"!",2)="" D - . N LA7X - . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL") - . D CREATE^LA7LOG(36) - ; - ; something missing - No NLT code, etc. - I LA7VAL="" Q - ; - ; Check for missing units/reference ranges - S LA7X=$P(LA7VAL,"^",5) - ; - ; Results missing units, lookup in file #60 - I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3) - ; - ; If results missing reference ranges, use values from file #60. - I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D - . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)) - . S $P(LA7X,"!",2)=$P(LA7Y,"^") - . S $P(LA7X,"!",3)=$P(LA7Y,"^",2) - . S $P(LA7X,"!",11)=$P(LA7Y,"^",6) - . S $P(LA7X,"!",12)=$P(LA7Y,"^",7) - ; Use therapeutic low/high if low/high missing. - I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D - . S $P(LA7X,"!",2)=$P(LA7X,"!",11) - . S $P(LA7X,"!",3)=$P(LA7X,"!",12) - ; - ; Evaluate low/high reference ranges in case M code in these fields. - S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99 - F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D - . S @("X="_$P(LA7X,"!",LA7I)) - . S $P(LA7X,"!",LA7I)=X - ; - ; Put units/reference ranges back in variable LA7VAL - S $P(LA7VAL,"^",5)=LA7X - ; - ; Initialize OBX segment - S LA7OBX(0)="OBX" - S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN) - ; - ; Value type - S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB) - ; - ; Observation identifer - ; build alternate code based on dataname from file #63 in case it's needed - S LA7X=$P(LA7VAL,"^",3) - S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63" - S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH) - ; - ; Test value - S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH) - ; - ; Units - remove leading and trailing spaces - S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ") - S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH) - ; - ; Reference range - S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH) - ; - ; Abnormal flags - S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2)) - ; - ; "P"artial or "F"inal results - S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F")) - ; - ; Observation date/time - collection date/time per HL7 standard - I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^")) - ; - S LA7DIV=$P(LA7VAL,"^",9) - I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0)) - ; - ; Facility that performed the testing - S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH) - ; - ; Person that verified the test - S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH) - ; - ; Observation method - S LA7X=$P($P(LA7VAL,"^",3),"!",4) - I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH) - ; - ; Equipment entity identifier - I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH) - ; - D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS) - ; - Q +LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09 + ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994 + ; JMC - mods to check for IHS V LAB file + ; +CH ; Observation/Result segment for "CH" subscript results. + ; Called by LA7VOBX + ; + N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X + ; + ; "CH" subscript requires a dataname + I '$G(LRSB) Q + ; + ; get result node from LR global. + S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) + S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB)) + ; + ; Check if test is OK to send - (O)utput or (B)oth + S LA7X=$P(LA7VAL,"^",12) + I LA7X]"","BO"'[LA7X Q + I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q + ; + ; If no result NLT or LOINC try to determine from file #60 + S LA7X=$P(LA7VAL,"^",3) + ; WV check for IHS - NLT/LN codes from V LAB file + I $D(^AUPNVLAB) D TMPCHK^C0CLA7Q + ; + I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5)) + ; No result NLT code - log error + I $P($P(LA7VAL,"^",3),"!",2)="" D + . N LA7X + . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL") + . D CREATE^LA7LOG(36) + ; + ; something missing - No NLT code, etc. + I LA7VAL="" Q + ; + ; Check for missing units/reference ranges + S LA7X=$P(LA7VAL,"^",5) + ; + ; Results missing units, lookup in file #60 + I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3) + ; + ; If results missing reference ranges, use values from file #60. + I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D + . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)) + . S $P(LA7X,"!",2)=$P(LA7Y,"^") + . S $P(LA7X,"!",3)=$P(LA7Y,"^",2) + . S $P(LA7X,"!",11)=$P(LA7Y,"^",6) + . S $P(LA7X,"!",12)=$P(LA7Y,"^",7) + ; Use therapeutic low/high if low/high missing. + I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D + . S $P(LA7X,"!",2)=$P(LA7X,"!",11) + . S $P(LA7X,"!",3)=$P(LA7X,"!",12) + ; + ; Evaluate low/high reference ranges in case M code in these fields. + S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99 + F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D + . S @("X="_$P(LA7X,"!",LA7I)) + . S $P(LA7X,"!",LA7I)=X + ; + ; Put units/reference ranges back in variable LA7VAL + S $P(LA7VAL,"^",5)=LA7X + ; + ; Initialize OBX segment + S LA7OBX(0)="OBX" + S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN) + ; + ; Value type + S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB) + ; + ; Observation identifer + ; build alternate code based on dataname from file #63 in case it's needed + S LA7X=$P(LA7VAL,"^",3) + S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63" + S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH) + ; + ; Test value + S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH) + ; + ; Units - remove leading and trailing spaces + S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ") + S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH) + ; + ; Reference range + S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH) + ; + ; Abnormal flags + S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2)) + ; + ; "P"artial or "F"inal results + S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F")) + ; + ; Observation date/time - collection date/time per HL7 standard + I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^")) + ; + S LA7DIV=$P(LA7VAL,"^",9) + I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0)) + ; + ; Facility that performed the testing + S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH) + ; + ; Person that verified the test + S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH) + ; + ; Observation method + S LA7X=$P($P(LA7VAL,"^",3),"!",4) + I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH) + ; + ; Equipment entity identifier + I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH) + ; + D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS) + ; + Q Index: ccr/branches/ohum/p/C0CVORU.m =================================================================== --- ccr/branches/ohum/p/C0CVORU.m (revision 1333) +++ ccr/branches/ohum/p/C0CVORU.m (revision 1337) @@ -1,274 +1,274 @@ -C0C7VORU ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009 - ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994;Build 1 - ; -EN(LA) ; called from C0CVLAB - ; variables - ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68) - ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4) - ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68) - ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64) - ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64) - ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time) - ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60) - ; LA("LRDFN") - IEN in LAB DATA file (#63) - ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results. - ; LA("AUTO-INST") - Auto-Instrument - ; - N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY - ; - S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")="" - I $G(PRIMARY)'="" D - . S PRIMARY=$$SITE^VASITE(DT,PRIMARY) - . S PRIMARY=$P(PRIMARY,U,3) - . S LA("AUTO-INST")="LA7V HOST "_PRIMARY - ; - I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D Q - . ; need to add error logging when no entry in 63. - ; - ; Get zeroth node of entry in #63. - S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) - S LA7NLT=$G(LA("NLT")) - ; - S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE")) - S LA7NTESN=0 - D ORC - ; - I $G(LA("SUB"))="CH" D CH - ;I $G(LA("SUB"))="MI" D MI^LA7VORU1 - ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2 - Q - ; - ; -CH ; Build segments for "CH" subscript - ; - D OBR - D NTE - S LA7OBXSN=0 - D OBX - ; - Q - ; - ; -ORC ; Build ORC segment - ; - N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC - ; - S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) - ; - S ORC(0)="ORC" - ; - ; Order control - S ORC(1)=$$ORC1^LA7VORC("RE") - ; - ; Remote UID - S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH) - ; - ; Host UID - S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH) - ; - ; Return shipping manifest if found - S LA7SM="",LA7696=0 - I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0)) - I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14) - I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH) - ; - ; Order status - ; DoD/CHCS requires ORC-5 valued otherwise will not process message - I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH) - ; - ; Ordering provider - S (LA7X,LA7Y)="" - ; "CH" subscript stores requesting provider and requesting div/location. - I LA("SUB")="CH" D - . N LA7J - . S LA7J=$P(LA763(0),"^",13) - . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") - . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") - . S LA7X=$P(LA763(0),"^",10) - ; - ; Other subscripts only store requesting provider - I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) - ; Get default institution from MailMan Site Parameters file - I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") - S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) - ; - ; Entering organization - S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH) - ; - D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS) - D FILESEG^LA7VHLU(GBL,.LA7DATA) - ; - ; Check for flag to only build message but do not file - I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA) - ; - Q - ; - ; -OBR ;Observation Request segment for Lab Order - ; - N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR - ; - ; Retrieve placer's OBR information stored in #69.6 - D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR) - ; - ; Initialize OBR segment - S OBR(0)="OBR" - S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN) - ; - ; Remote UID - S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH) - ; - ; Host UID - S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH) - ; - ; Universal service ID, build from info stored in #69.6 - S LA7X="" - I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH) - E S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH) - ; - ; Collection D/T - S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U)) - ; - ; Specimen action code - ; If no OBR from PENDING ORDER file (#69.6) then assume added test. - I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A") - ; - ; Infection Warning - S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH) - ; - ; Lab Arrival Time - ; "CH" subscript does not store lab arrival time, use collection time. - ; Other subscripts do store lab arrival time (date/time received). - I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10)) - I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^")) - ; - ; Specimen source - S (LA761,LA762)="" - I "CHMI"[LA("SUB") D - . S LA761=$P(LA763(0),U,5) - . I LA761="" D CREATE^LA7LOG(27) - . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11) - S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH) - ; - ; Ordering provider - S (LA7X,LA7Y)="" - ; "CH" subscript stores requesting provider and requesting div/location. - I LA("SUB")="CH" D - . N LA7J - . S LA7J=$P(LA763(0),"^",13) - . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") - . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") - . S LA7X=$P(LA763(0),"^",10) - ; - ; Other subscripts only store requesting provider - I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) - ; Get default institution from MailMan Site Parameters file - I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") - S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) - ; - ; Placer Field #1 (remote auto-inst) - ; Build from info stored in #69.6 - I $G(LA7PLOBR("OBR-18"))'="" D - . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH) - ; Else build "auto instrument" if sending to VA facility - I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D - . N LA7X - . S LA7X(1)=LA("AUTO-INST") - . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH) - ; - ; Placer Field #2 - I $G(LA7PLOBR("OBR-19"))'="" D - . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH) - ; Else build collecting UID if sending to VA facility - I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D - . K LA7X - . S LA7X(7)=LA("RUID") - . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH) - ; - ; Filler Field #1 - ; Send file #63 ien info - used by HDR to track patient/specimen - K LA7X - S LA7X(1)=LA("LRDFN") - S LA7X(2)=LA("SUB") - S LA7X(3)=LA("LRIDT") - S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH) - ; - ; Date Report Completed - I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3)) - ; - ; Diagnostic service id - S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB)) - ; - ; Parent Result and Parent - I $D(LA7PARNT) D - . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH) - . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH) - ; - ; Principle result interpreter - ; Get default institution from MailMan Site Parameters file - I "CYEMMISP"[LA("SUB") D - . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4) - . E S LA7X=$P(LA763(0),"^",2) - . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") - . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) - ; - ; Assistant result interpreter - ; Get default institution from MailMan Site Parameters file - I "EMSP"[LA("SUB") D - . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") - . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) - ; - ; Technician - ; Get default institution from MailMan Site Parameters file - I "CYEM"[LA("SUB") D - . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") - . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) - ; - ; Typist - VistA stores as free text - ; Get default institution from MailMan Site Parameters file - I "CYEMSP"[LA("SUB") D - . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") - . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) - ; - D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS) - D FILESEG^LA7VHLU(GBL,.LA7DATA) - ; - ; Check for flag to only build message but do not file - I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) - ; - Q - ; - ; -OBX ;Observation/Result segment for Lab Results - ; - N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X - ; - S LA7VTIEN=0 - F S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN D - . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2) - . ; Build OBX segment - . K LA7DATA - . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF)) - . ; If OBX failed to build then don't store - . I '$D(LA7DATA) Q - . ; - . D FILESEG^LA7VHLU(GBL,.LA7DATA) - . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) - . ; - . ; Send performing lab comment and interpretation from file #60 - . S LA7NTESN=0 - . I LA7NVAF=1 D PLC^LA7VORUA - . D INTRP^LA7VORUA - . ; - . ; Mark result as sent - set to 1, if corrected results set to 2 - . I LA("SUB")="CH" D - . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q - . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1) - ; - Q - ; - ; -NTE ; Build NTE segment - ; - D NTE^LA7VORUA - Q +C0C7VORU ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009 + ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994 + ; +EN(LA) ; called from C0CVLAB + ; variables + ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68) + ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4) + ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68) + ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64) + ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64) + ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time) + ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60) + ; LA("LRDFN") - IEN in LAB DATA file (#63) + ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results. + ; LA("AUTO-INST") - Auto-Instrument + ; + N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY + ; + S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")="" + I $G(PRIMARY)'="" D + . S PRIMARY=$$SITE^VASITE(DT,PRIMARY) + . S PRIMARY=$P(PRIMARY,U,3) + . S LA("AUTO-INST")="LA7V HOST "_PRIMARY + ; + I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D Q + . ; need to add error logging when no entry in 63. + ; + ; Get zeroth node of entry in #63. + S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) + S LA7NLT=$G(LA("NLT")) + ; + S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE")) + S LA7NTESN=0 + D ORC + ; + I $G(LA("SUB"))="CH" D CH + ;I $G(LA("SUB"))="MI" D MI^LA7VORU1 + ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2 + Q + ; + ; +CH ; Build segments for "CH" subscript + ; + D OBR + D NTE + S LA7OBXSN=0 + D OBX + ; + Q + ; + ; +ORC ; Build ORC segment + ; + N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC + ; + S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) + ; + S ORC(0)="ORC" + ; + ; Order control + S ORC(1)=$$ORC1^LA7VORC("RE") + ; + ; Remote UID + S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH) + ; + ; Host UID + S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH) + ; + ; Return shipping manifest if found + S LA7SM="",LA7696=0 + I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0)) + I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14) + I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH) + ; + ; Order status + ; DoD/CHCS requires ORC-5 valued otherwise will not process message + I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH) + ; + ; Ordering provider + S (LA7X,LA7Y)="" + ; "CH" subscript stores requesting provider and requesting div/location. + I LA("SUB")="CH" D + . N LA7J + . S LA7J=$P(LA763(0),"^",13) + . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") + . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") + . S LA7X=$P(LA763(0),"^",10) + ; + ; Other subscripts only store requesting provider + I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) + ; Get default institution from MailMan Site Parameters file + I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") + S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) + ; + ; Entering organization + S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH) + ; + D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS) + D FILESEG^LA7VHLU(GBL,.LA7DATA) + ; + ; Check for flag to only build message but do not file + I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA) + ; + Q + ; + ; +OBR ;Observation Request segment for Lab Order + ; + N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR + ; + ; Retrieve placer's OBR information stored in #69.6 + D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR) + ; + ; Initialize OBR segment + S OBR(0)="OBR" + S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN) + ; + ; Remote UID + S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH) + ; + ; Host UID + S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH) + ; + ; Universal service ID, build from info stored in #69.6 + S LA7X="" + I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH) + E S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH) + ; + ; Collection D/T + S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U)) + ; + ; Specimen action code + ; If no OBR from PENDING ORDER file (#69.6) then assume added test. + I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A") + ; + ; Infection Warning + S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH) + ; + ; Lab Arrival Time + ; "CH" subscript does not store lab arrival time, use collection time. + ; Other subscripts do store lab arrival time (date/time received). + I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10)) + I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^")) + ; + ; Specimen source + S (LA761,LA762)="" + I "CHMI"[LA("SUB") D + . S LA761=$P(LA763(0),U,5) + . I LA761="" D CREATE^LA7LOG(27) + . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11) + S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH) + ; + ; Ordering provider + S (LA7X,LA7Y)="" + ; "CH" subscript stores requesting provider and requesting div/location. + I LA("SUB")="CH" D + . N LA7J + . S LA7J=$P(LA763(0),"^",13) + . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") + . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") + . S LA7X=$P(LA763(0),"^",10) + ; + ; Other subscripts only store requesting provider + I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) + ; Get default institution from MailMan Site Parameters file + I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") + S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) + ; + ; Placer Field #1 (remote auto-inst) + ; Build from info stored in #69.6 + I $G(LA7PLOBR("OBR-18"))'="" D + . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH) + ; Else build "auto instrument" if sending to VA facility + I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D + . N LA7X + . S LA7X(1)=LA("AUTO-INST") + . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH) + ; + ; Placer Field #2 + I $G(LA7PLOBR("OBR-19"))'="" D + . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH) + ; Else build collecting UID if sending to VA facility + I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D + . K LA7X + . S LA7X(7)=LA("RUID") + . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH) + ; + ; Filler Field #1 + ; Send file #63 ien info - used by HDR to track patient/specimen + K LA7X + S LA7X(1)=LA("LRDFN") + S LA7X(2)=LA("SUB") + S LA7X(3)=LA("LRIDT") + S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH) + ; + ; Date Report Completed + I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3)) + ; + ; Diagnostic service id + S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB)) + ; + ; Parent Result and Parent + I $D(LA7PARNT) D + . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH) + . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH) + ; + ; Principle result interpreter + ; Get default institution from MailMan Site Parameters file + I "CYEMMISP"[LA("SUB") D + . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4) + . E S LA7X=$P(LA763(0),"^",2) + . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") + . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) + ; + ; Assistant result interpreter + ; Get default institution from MailMan Site Parameters file + I "EMSP"[LA("SUB") D + . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") + . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) + ; + ; Technician + ; Get default institution from MailMan Site Parameters file + I "CYEM"[LA("SUB") D + . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") + . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) + ; + ; Typist - VistA stores as free text + ; Get default institution from MailMan Site Parameters file + I "CYEMSP"[LA("SUB") D + . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") + . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) + ; + D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS) + D FILESEG^LA7VHLU(GBL,.LA7DATA) + ; + ; Check for flag to only build message but do not file + I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) + ; + Q + ; + ; +OBX ;Observation/Result segment for Lab Results + ; + N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X + ; + S LA7VTIEN=0 + F S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN D + . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2) + . ; Build OBX segment + . K LA7DATA + . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF)) + . ; If OBX failed to build then don't store + . I '$D(LA7DATA) Q + . ; + . D FILESEG^LA7VHLU(GBL,.LA7DATA) + . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) + . ; + . ; Send performing lab comment and interpretation from file #60 + . S LA7NTESN=0 + . I LA7NVAF=1 D PLC^LA7VORUA + . D INTRP^LA7VORUA + . ; + . ; Mark result as sent - set to 1, if corrected results set to 2 + . I LA("SUB")="CH" D + . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q + . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1) + ; + Q + ; + ; +NTE ; Build NTE segment + ; + D NTE^LA7VORUA + Q Index: ccr/branches/ohum/p/C0CXEWD.m =================================================================== --- ccr/branches/ohum/p/C0CXEWD.m (revision 1333) +++ ccr/branches/ohum/p/C0CXEWD.m (revision 1337) @@ -1,126 +1,126 @@ -C0CXEWD ; C0C/GPL - EWD based XPath utilities; 10/11/09 - ;;0.1;C0C;nopatch;noreleasedate;Build 1 - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q - ; -TEST ; - D XPATH($$FIRST($$ID("CCR1")),"/","GIDX","GARY") - Q - ; -TEST2 ; - S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail" - D XPATH($$FIRST($$ID("gpl")),"/","GIDX","GARY","",REDUX) - Q - ; -XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE - ; THE XPATH INDEX ZXIDX, PASSED BY NAME - ; THE XPATH ARRAY XPARY, PASSED BY NAME - ; ZOID IS THE STARTING OID - ; ZPATH IS THE STARTING XPATH, USUALLY "/" - ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE - ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT - I '$D(ZREDUX) S ZREDUX="" - N NEWPATH - N NEWNUM S NEWNUM="" - I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" - S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE - I $G(ZREDUX)'="" D ; REDUX PROVIDED? - . N GT S GT=$P(NEWPATH,ZREDUX,2) - . I GT'="" S NEWPATH=GT - S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX - N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE - I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY - E I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY - I GD'="" S @ZXPARY@(NEWPATH)=GD ; IF YES, ADD IT TO THE XPATH ARRAY - N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD - I ZFRST'="" D ; THERE IS A CHILD - . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE - . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD - N GNXT S GNXT=$$NXTSIB(ZOID) - I GNXT'="" D ; MOVE ON TO THE NEXT SIBLING - . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB - Q - ; -PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME - ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD - ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD - N ZR - M ^CacheTempEWD($j)=@INXML ; - S ZR=$$parseDocument^%zewdHTMLParser(INDOC) - Q ZR - ; -ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE - N ZN - S ZN=$$NXTSIB(ZOID) - I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG - Q 0 - ; -DETAIL(ZRTN,ZOID) ; RETURNS DETAIL FOR NODE ZOID IN ZRTN, PASSED BY NAME - N DET - D getElementDetails^%zewdXPath(ZOID,.DET) - M @ZRTN=DET - Q - ; -ID(ZNAME) ;RETURNS THE docOID OF THE DOCUMENT NAMED ZNAME - Q $$getDocumentNode^%zewdDOM(ZNAME) - ; -NAME(ZOID) ;RETURNS THE NAME OF THE DOCUMENAT WITH docOID ZOID - Q $$getDocumentName^%zewdDOM(ZOID) - ; -FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID - N GOID - S GOID=ZOID - S GOID=$$getFirstChild^%zewdDOM(GOID) - I GOID="" Q "" - I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID) - Q GOID - ; -HASCHILD(ZOID) ; RETURNS TRUE IF ZOID HAS CHILD NODES - Q $$hasChildNodes^%zewdDOM(ZOID) - ; -CHILDREN(ZRTN,ZOID) ;RETURNS CHILDREN OF ZOID IN ARRAY ZRTN, PASSED BY NAME - N childArray - d getChildrenInOrder^%zewdDOM(ZOID,.childArray) - m @ZRTN=childArray - q - ; -TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE - Q $$getName^%zewdDOM(ZOID) - ; -NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING - Q $$getNextSibling^%zewdDOM(ZOID) - ; -NXTCHLD(ZOID) ; RETURNS THE NEXT CHILD IN PARENT ZPAR - N GOID - S GOID=$$getNextChild^%zewdDOM($$PARENT(ZOID),ZOID) - I GOID="" Q "" - I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID) - Q GOID - ; -PARENT(ZOID) ; RETURNS PARENT OF ZOID - Q $$getParentNode^%zewdDOM(ZOID) - ; -DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE - N ZT2 - S ZT2=$$getElementText^%zewdDOM(ZOID,.ZT2) - M @ZT=ZT2 - Q - ;Q $$getTextValue^%zewdXPath(ZOID) - ;Q $$getData^%zewdDOM(ZOID,.ZT) - ; +C0CXEWD ; C0C/GPL - EWD based XPath utilities; 10/11/09 + ;;0.1;C0C;nopatch;noreleasedate + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q + ; +TEST ; + D XPATH($$FIRST($$ID("CCR1")),"/","GIDX","GARY") + Q + ; +TEST2 ; + S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail" + D XPATH($$FIRST($$ID("gpl")),"/","GIDX","GARY","",REDUX) + Q + ; +XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE + ; THE XPATH INDEX ZXIDX, PASSED BY NAME + ; THE XPATH ARRAY XPARY, PASSED BY NAME + ; ZOID IS THE STARTING OID + ; ZPATH IS THE STARTING XPATH, USUALLY "/" + ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE + ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT + I '$D(ZREDUX) S ZREDUX="" + N NEWPATH + N NEWNUM S NEWNUM="" + I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" + S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE + I $G(ZREDUX)'="" D ; REDUX PROVIDED? + . N GT S GT=$P(NEWPATH,ZREDUX,2) + . I GT'="" S NEWPATH=GT + S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX + N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE + I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY + E I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY + I GD'="" S @ZXPARY@(NEWPATH)=GD ; IF YES, ADD IT TO THE XPATH ARRAY + N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD + I ZFRST'="" D ; THERE IS A CHILD + . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE + . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD + N GNXT S GNXT=$$NXTSIB(ZOID) + I GNXT'="" D ; MOVE ON TO THE NEXT SIBLING + . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB + Q + ; +PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME + ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD + ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD + N ZR + M ^CacheTempEWD($j)=@INXML ; + S ZR=$$parseDocument^%zewdHTMLParser(INDOC) + Q ZR + ; +ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE + N ZN + S ZN=$$NXTSIB(ZOID) + I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG + Q 0 + ; +DETAIL(ZRTN,ZOID) ; RETURNS DETAIL FOR NODE ZOID IN ZRTN, PASSED BY NAME + N DET + D getElementDetails^%zewdXPath(ZOID,.DET) + M @ZRTN=DET + Q + ; +ID(ZNAME) ;RETURNS THE docOID OF THE DOCUMENT NAMED ZNAME + Q $$getDocumentNode^%zewdDOM(ZNAME) + ; +NAME(ZOID) ;RETURNS THE NAME OF THE DOCUMENAT WITH docOID ZOID + Q $$getDocumentName^%zewdDOM(ZOID) + ; +FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID + N GOID + S GOID=ZOID + S GOID=$$getFirstChild^%zewdDOM(GOID) + I GOID="" Q "" + I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID) + Q GOID + ; +HASCHILD(ZOID) ; RETURNS TRUE IF ZOID HAS CHILD NODES + Q $$hasChildNodes^%zewdDOM(ZOID) + ; +CHILDREN(ZRTN,ZOID) ;RETURNS CHILDREN OF ZOID IN ARRAY ZRTN, PASSED BY NAME + N childArray + d getChildrenInOrder^%zewdDOM(ZOID,.childArray) + m @ZRTN=childArray + q + ; +TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE + Q $$getName^%zewdDOM(ZOID) + ; +NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING + Q $$getNextSibling^%zewdDOM(ZOID) + ; +NXTCHLD(ZOID) ; RETURNS THE NEXT CHILD IN PARENT ZPAR + N GOID + S GOID=$$getNextChild^%zewdDOM($$PARENT(ZOID),ZOID) + I GOID="" Q "" + I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID) + Q GOID + ; +PARENT(ZOID) ; RETURNS PARENT OF ZOID + Q $$getParentNode^%zewdDOM(ZOID) + ; +DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE + N ZT2 + S ZT2=$$getElementText^%zewdDOM(ZOID,.ZT2) + M @ZT=ZT2 + Q + ;Q $$getTextValue^%zewdXPath(ZOID) + ;Q $$getData^%zewdDOM(ZOID,.ZT) + ; Index: ccr/branches/ohum/p/C0CXPAT0.m =================================================================== --- ccr/branches/ohum/p/C0CXPAT0.m (revision 1333) +++ ccr/branches/ohum/p/C0CXPAT0.m (revision 1337) @@ -1,212 +1,212 @@ -C0CXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY",! - Q - ; - ;;> - ;;> - ;;>>>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 - ;;> - ;;>>>K GXML S GXML="" - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","@@DATA1@@") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","@@DATA2@@") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;> - ;;>>>K GXML S GXML="" - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","DATA1") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","DATA2") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","<_SECOND>") - ;;>>>D PUSH^C0CXPATH("GXML","DATA3") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;>>>D PUSH^C0CXPATH("GXML","") - ;;> - ;;>>>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" - ;;> - ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") - ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT") - ;;>>>S GX="" - ;;>>>D MKMDX^C0CXPATH("C0C",.GX) - ;;>>?GX="//FIRST/SECOND/THIRD/FOURTH" - ;;> - ;;>>?$$XNAME^C0CXPATH("DATA1")="FOURTH" - ;;>>?$$XNAME^C0CXPATH("")="SIXTH" - ;;>>?$$XNAME^C0CXPATH("")="THIRD" - ;;> - ;;>>>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" - ;;> - ;;>>>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" - ;;> - ;;>>>D ZTEST^C0CXPATH("INITXML") - ;;>>>S OUTARY="^TMP($J,""MISSINGTEST"")" - ;;>>>D MISSING^C0CXPATH("GXML",OUTARY) - ;;>>?@OUTARY@(1)="DATA1" - ;;>>?@OUTARY@(2)="DATA2" - ;;> - ;;>>>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" - ;;> - ;;>>>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)="@@DATA1@@ AND @@DATA3@@" - ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY) - ;;>>>D PARY^C0CXPATH(OUTARY) - ;;>>?@OUTARY@(4)="VALUE1 AND VALUE3" - ;;> - ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",2,3) - ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",4,5) - ;;>>?$P(BTLIST(2),";",2)=4 - ;;> - ;;>>>D ZTEST^C0CXPATH("INITXML") - ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FOURTH","G2") - ;;>>>D ZTEST^C0CXPATH("QUEUE") - ;;>>>D BUILD^C0CXPATH("BTLIST","G3") - ;;> - ;;>>>D ZTEST^C0CXPATH("INITXML") - ;;>>>D CP^C0CXPATH("GXML","G2") - ;;>>?G2(0)=13 - ;;> - ;;>>>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))="" - ;;> - ;;>>>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))="" - ;;> - ;;>>>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))="" - ;;> - ;;>>>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))="" - ;;>>?G2(1)="" - ;;> - ;;>>>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) - ;;> - ;;>>>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)="" - ;;> - ;;>>>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)="" - ;;> - ;;>>>K GXML,G2,GBL,G3 - ;;>>>D ZTEST^C0CXPATH("INITXML") - ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2") - ;;>>>D INSINNER^C0CXPATH("G2","G2") - ;;>>?G2(8)="" - ;;> - ;;>>>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 - ;;> - ;;>>>K GTMP,GTMP2 - ;;>>>S GTMP("TEST1")=1 - ;;>>>D H2ARY^C0CXPATH("GTMP2","GTMP") - ;;>>?GTMP2(0)=1 - ;;>>?GTMP2(1)="^TEST1^1" - ;;> - ;;>>>K GTMP,GTMP2 - ;;>>>D PUSH^C0CXPATH("GTMP","@@VAR1@@") - ;;>>>D XVARS^C0CXPATH("GTMP2","GTMP") - ;;>>?GTMP2(1)="^VAR1^1" - ;;> +C0CXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY",! + Q + ; + ;;> + ;;> + ;;>>>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 + ;;> + ;;>>>K GXML S GXML="" + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","@@DATA1@@") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","@@DATA2@@") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;> + ;;>>>K GXML S GXML="" + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","DATA1") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","DATA2") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","<_SECOND>") + ;;>>>D PUSH^C0CXPATH("GXML","DATA3") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;>>>D PUSH^C0CXPATH("GXML","") + ;;> + ;;>>>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" + ;;> + ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") + ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT") + ;;>>>S GX="" + ;;>>>D MKMDX^C0CXPATH("C0C",.GX) + ;;>>?GX="//FIRST/SECOND/THIRD/FOURTH" + ;;> + ;;>>?$$XNAME^C0CXPATH("DATA1")="FOURTH" + ;;>>?$$XNAME^C0CXPATH("")="SIXTH" + ;;>>?$$XNAME^C0CXPATH("")="THIRD" + ;;> + ;;>>>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" + ;;> + ;;>>>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" + ;;> + ;;>>>D ZTEST^C0CXPATH("INITXML") + ;;>>>S OUTARY="^TMP($J,""MISSINGTEST"")" + ;;>>>D MISSING^C0CXPATH("GXML",OUTARY) + ;;>>?@OUTARY@(1)="DATA1" + ;;>>?@OUTARY@(2)="DATA2" + ;;> + ;;>>>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" + ;;> + ;;>>>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)="@@DATA1@@ AND @@DATA3@@" + ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY) + ;;>>>D PARY^C0CXPATH(OUTARY) + ;;>>?@OUTARY@(4)="VALUE1 AND VALUE3" + ;;> + ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",2,3) + ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",4,5) + ;;>>?$P(BTLIST(2),";",2)=4 + ;;> + ;;>>>D ZTEST^C0CXPATH("INITXML") + ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FOURTH","G2") + ;;>>>D ZTEST^C0CXPATH("QUEUE") + ;;>>>D BUILD^C0CXPATH("BTLIST","G3") + ;;> + ;;>>>D ZTEST^C0CXPATH("INITXML") + ;;>>>D CP^C0CXPATH("GXML","G2") + ;;>>?G2(0)=13 + ;;> + ;;>>>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))="" + ;;> + ;;>>>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))="" + ;;> + ;;>>>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))="" + ;;> + ;;>>>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))="" + ;;>>?G2(1)="" + ;;> + ;;>>>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) + ;;> + ;;>>>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)="" + ;;> + ;;>>>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)="" + ;;> + ;;>>>K GXML,G2,GBL,G3 + ;;>>>D ZTEST^C0CXPATH("INITXML") + ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2") + ;;>>>D INSINNER^C0CXPATH("G2","G2") + ;;>>?G2(8)="" + ;;> + ;;>>>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 + ;;> + ;;>>>K GTMP,GTMP2 + ;;>>>S GTMP("TEST1")=1 + ;;>>>D H2ARY^C0CXPATH("GTMP2","GTMP") + ;;>>?GTMP2(0)=1 + ;;>>?GTMP2(1)="^TEST1^1" + ;;> + ;;>>>K GTMP,GTMP2 + ;;>>>D PUSH^C0CXPATH("GTMP","@@VAR1@@") + ;;>>>D XVARS^C0CXPATH("GTMP2","GTMP") + ;;>>?GTMP2(1)="^VAR1^1" + ;;> Index: ccr/branches/ohum/p/C0CXPATH.m =================================================================== --- ccr/branches/ohum/p/C0CXPATH.m (revision 1333) +++ ccr/branches/ohum/p/C0CXPATH.m (revision 1337) @@ -1,726 +1,726 @@ -C0CXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 - ;;1.0;C0C;;May 19, 2009;Build 1 - ;Copyright 2008 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is an XML XPATH utility library",! - W ! - Q - ; -OUTPUT(OUTARY,OUTNAME,OUTDIR) ; WRITE AN ARRAY TO A FILE - ; - N Y - S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME) - I Y Q 1_U_"WROTE FILE: "_OUTNAME_" TO "_OUTDIR - I 'Y Q 0_U_"ERROR WRITING FILE"_OUTNAME_" TO "_OUTDIR - Q - ; -PUSH(STK,VAL) ; pushs VAL onto STK and updates STK(0) - ; VAL IS A STRING AND STK IS PASSED BY NAME - ; - I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE - S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH - S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY - Q - ; -POP(STK,VAL) ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL - ; VAL AND STK ARE PASSED BY REFERENCE - ; - I @STK@(0)<1 D ; IF ARRAY IS EMPTY - . S VAL="" - . S @STK@(0)=0 - I @STK@(0)>0 D ; - . S VAL=@STK@(@STK@(0)) - . K @STK@(@STK@(0)) - . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY - Q - ; -PUSHA(ADEST,ASRC) ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME - ; - N ZGI - F ZGI=1:1:@ASRC@(0) D ; FOR ALL OF THE SOURCE ARRAY - . D PUSH(ADEST,@ASRC@(ZGI)) ; PUSH ONE ELEMENT - Q - ; -MKMDX(STK,RTN,INREDUX) ; MAKES A MUMPS INDEX FROM THE ARRAY STK - ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS - ; REDUX IS A STRING TO REMOVE FROM THE RESULT - S RTN="" - N I - ; W "STK= ",STK,! - I @STK@(0)>0 D ; IF THE ARRAY IS NOT EMPTY - . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON - . I @STK@(0)>1 D ; SUBSEQUENT ELEMENTS NEED A SEMICOLON - . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I) - I $G(INREDUX)'="" S RTN=$P(RTN,INREDUX,1)_$P(RTN,INREDUX,2) - Q - ; -XNAME(ISTR) ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG - ; AND WILL RETURN NAME - ; ISTR IS PASSED BY VALUE - N CUR,TMP - I ISTR?.E1"<".E D ; STRIP OFF LEFT BRACKET - . S TMP=$P(ISTR,"<",2) - I TMP?1"/".E D ; ALSO STRIP OFF SLASH IF PRESENT IE - . S TMP=$P(TMP,"/",2) - S CUR=$P(TMP,">",1) ; EXTRACT THE NAME - ; W "CUR= ",CUR,! - I CUR?.1"_"1.A1" ".E D ; CONTAINS A BLANK IE NAME ID=TEST> - . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER - ; W "CUR2= ",CUR,! - Q CUR - ; -XVAL(ISTR) ; EXTRACTS THE VALUE FROM A FRAGMENT OF XML - ; VALUE WILL RETURN VALUE - N G - S G=$P(ISTR,">",2) ;STRIP OFF - Q $P(G,"<",1) ; STRIP OFF LEAVING VALUE - ; -VDX2VDV(OUTVDV,INVDX) ; CONVERT AN VDX ARRAY TO VDV - ; VDX: @INVDX@(XPATH)=VALUE - ; VDV: @OUTVDV@(X1X2X3X4)=VALUE - ; THE VDV DATANAMES MIGHT BE MORE CONVENIENT FOR USE IN CODE - ; AN INDEX IS PROVIDED TO GO BACK TO VDX FOR CONVERSIONS - ; @VDV@("XPATH",X1X2X3X4)="XPATH" - N ZA,ZI,ZW - S ZI="" - F S ZI=$O(@INVDX@(ZI)) Q:ZI="" D ; - . S ZW=$TR(ZI,"/","") ; ELIMINATE ALL SLASHES - CAMEL CASE VARIABLE NAME - . W ZW,! - . S @OUTVDV@(ZW)=@INVDX@(ZI) - . S @OUTVDV@("XPATH",ZW)=ZI - Q - ; -VDX2XPG(OUTXPG,INVDX) ; CONVERT AN VDX ARRAY TO XPG - ; VDX: @VDX@(XPATH)=VALUE - ; XPG: @(VDX(X1,X2,X3,X4))@=VALUE - ; THIS IS A STEP TOWARD GENERATING XML FROM A VDX - N ZA,ZI,ZW - S ZI="" - F S ZI=$O(@INVDX@(ZI)) Q:ZI="" D ; - . S ZW=$E(ZI,3,$L(ZI)) ; STRIP OFF INITIAL // - . S ZW2=$P(ZW,"/",1) - . F ZK=1:1:$L(ZW,"/") D PUSH("ZA",$P(ZW,"/",ZK)) - . ;ZWR ZA - . S ZW2=ZA(1) - . F ZK=2:1:ZA(0) D ; - . . S ZW2=ZW2_""","""_ZA(ZK) - . K ZA - . S ZW2=""""_ZW2_"""" - . W ZW2,! - . S ZN=OUTXPG_"("_ZW2_")" - . S @ZN=@INVDX@(ZI) - Q - ; -XML2XPG(OUTXPG,INXML) ; CONVERT AN XML ARRAY, PASSED BY NAME TO AN XPG ARRAY - ; XPG MEANS XPATH GLOBAL AND HAS THE FORM @OUTXPG@("X1","X2","X3")=VALUE - ; - ;N G1 - D INDEX(INXML,"G1",1) ; PRODUCES A VDX ARRAY IN G1, NO INDEX IS PRODUCED - D VDX2XPG(OUTXPG,"G1") ; CONVERTS THE VDX ARRAY TO XPG FORM - Q - ; -DO - D XPG2XML("^GPL2B","^GPL2A") - Q - ; -T1 ; TEST OUT THESE ROUTINES - D XML2XPG("G2","^GPL") - D XPG2XML("G3","G2") - K ^GPLOUT - M ^GPLOUT=G3 - W $$OUTPUT^C0CXPATH("^GPLOUT(1)","GPLTEST.xml","/home/vademo2/EHR/p") - Q - ; -XPG2XML(OUTXML,INXPG) ; - N C0CN,FWD,ZA,G,GA,ZQ - S ZQ=0 ; QUIT FLAG - F Q:ZQ=1 D ; LOOP THROUGH EVERYTHING - . I '$D(C0CN) D ; FIRST TIME THROUGH - . . K @OUTXML ; MAKE SURE OUTPUT ARRAY IS CLEAR - . . S FWD=1 ; START OUT GOING FORWARD THROUGH SUBSCRIPTS - . . S G=$Q(@INXPG) ; THIS ONE - . . S GN=$Q(@G) ; NEXT ONE - . . S C0CN=1 ; SUBSCRIPT COUNT - . . S ZQ=0 ; QUIT FLAG - . . D ZXO("?xml version=""1.0"" encoding=""UTF-8""?") ;MAKE IT REAL XML - . . I $QS(G,1)="ContinuityOfCareRecord" D ; - . . . D ZXO("?xml-stylesheet type=""text/xsl"" href=""ccr.xsl""?") ; HACK TO MAKE THE CCR STYLESHEET WORK - . I FWD D ; GOING FORWARDS - . . I C0CN<$QL(G) D ; NOT A DATA NODE - . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT - . . . D ZXO(ZA) ; AND OPEN AN XML ELEMENT - . . . I @OUTXML@(@OUTXML@(0))="" D ; - . . . . S @OUTXML@(@OUTXML@(0))="" - . . . S C0CN=C0CN+1 ; MOVE TO THE NEXT ONE - . . E D ; AT THE DATA NODE - . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT - . . . D ZXVAL(ZA,@G) ; OUTPUT VAL FOR DATA NODE - . . . S FWD=0 ; GO BACKWARDS - . I 'FWD D ;GOING BACKWARDS - . . S GN=$Q(@G) ;NEXT XPATH - . . ;W "NEXT!",GN,! - . . S C0CN=C0CN-1 ; PREVIOUS SUBSCRIPT - . . I GN'="" D ; - . . . I $QS(G,C0CN)'=$QS(GN,C0CN) D ; NEED TO CLOSE OFF ELEMENT - . . . . D ZXC($QS(G,C0CN)) ; - . . . E I GN'="" D ; MORE ELEMENTS AT THIS LEVEL - . . . . S G=$Q(@G) ; ADVANCE TO NEW XPATH - . . . . S C0CN=C0CN+1 ; GET READY TO PROCESS NEXT SUBSCRIPT - . . . . S FWD=1 ; GOING FORWARD NOW - . I (GN="")&(C0CN=1) D Q ; WHEN WE ARE ALL DONE - . . D ZXC($QS(G,C0CN)) ; LAST ONE - . . S ZQ=1 ; QUIT NOW - Q - ; -ZXO(WHAT) - D PUSH("GA",WHAT) - D PUSH(OUTXML,"<"_WHAT_">") - Q - ; -ZXC(WHAT) - D POP("GA",.TMP) - D PUSH(OUTXML,"") - Q - ; -ZXVAL(WHAT,VAL) - D PUSH(OUTXML,"<"_WHAT_">"_VAL_"") - Q - ; -INDEX(IZXML,VDX,NOINX,TEMPLATE,REDUX) ; parse XML in IZXML and produce - ; an XPATH index; REDUX is a string to be removed from each xpath - ; GPL 7/14/09 OPTIONALLY GENERATE AN XML TEMPLATE IF PASSED BY NAME - ; TEMPLATE IS IDENTICAL TO THE PARSED XML LINE BY LINE - ; EXCEPT THAT DATA VALUES ARE REPLACED WITH @@XPATH@@ FOR THE XPATH OF THE TAG - ; GPL 5/24/09 AND OPTIONALLY PRODUCE THE VDX ARRAY PASSED BY NAME - ; @VDX@("XPATH")=VALUE - ; ex. @IZXML@("XPATH")=FIRSTLINE^LASTLINE - ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE - ; XML SECTION - ; IZXML IS PASSED BY NAME - ; IF NOINX IS SET TO 1, NO INDEX WILL BE GENERATED, BUT THE VDX WILL BE - N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND,CURVAL,DVDX,LCNT - N C0CSTK ; LEAVE OUT FOR DEBUGGING - I '$D(REDUX) S REDUX="" - I '$D(NOINX) S NOINX=0 ; IF NOT PASSED, GENERATE AN INDEX - N ZXML - I NOINX S ZXML=$NA(^TMP("C0CINDEX",$J)) ; TEMP PLACE FOR INDEX TO DISCARD - E S ZXML=IZXML ; PLACE FOR INDEX TO KEEP - I '$D(@IZXML@(0)) D ; IF COUNT NOT IN NODE 0 COUNT THEM - . S I="",LCNT=0 - . F S I=$O(@IZXML@(I)) Q:I="" S LCNT=LCNT+1 - E S LCNT=@IZXML@(0) ; LINE COUNT PASSED IN ARRAY - I LCNT=0 D Q ; NO XML PASSED - . W "ERROR IN XML FILE",! - S DVDX=0 ; DEFAULT DO NOT PRODUCE VDX INDEX - I $D(VDX) S DVDX=1 ; IF NAME PASSED, DO VDX - S C0CSTK(0)=0 ; INITIALIZE STACK - K LKASD ; KILL LOOKASIDE ARRAY - D MKLASD(.LKASD,IZXML) ;MAKE LOOK ASIDE BUFFER FOR MULTIPLES - F I=1:1:LCNT D ; PROCESS THE ENTIRE ARRAY - . S LINE=@IZXML@(I) - . I $D(TEMPLATE) D ;IF TEMPLATE IS REQUESTED - . . S @TEMPLATE@(I)=$$CLEAN(LINE) - . ;W LINE,! - . S FOUND=0 ; INTIALIZED FOUND FLAG - . I LINE?.E1"".E) D - . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS - . . . ; ON THE SAME LINE - . . . ; W "FOUND ",LINE,! - . . . S FOUND=1 ; SET FOUND FLAG - . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME - . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES - . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK - . . . D MKMDX("C0CSTK",.MDX,REDUX) ; GENERATE THE M INDEX - . . . ; W "MDX=",MDX,! - . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE - . . . . ;I '$D(ZDUP(MDX)) S ZDUP(MDX)=2 - . . . . ;E S ZDUP(MDX)=ZDUP(MDX)+1 - . . . . ;W "DUP:",MDX,! - . . . . ;I '$D(CURVAL) S CURVAL="" - . . . . ;I DVDX S @VDX@(MDX_"["_ZDUP(MDX)_"]")=CURVAL - . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER - . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE - . . . . S @ZXML@(MDX)=I_"^"_I ; ADD INDEX ENTRY-FIRST AND LAST - . . . . S CURVAL=$$XVAL(LINE) ; VALUE - . . . . S $P(@ZXML@(MDX),"^",3)=CURVAL ; THIRD PIECE - . . . . I DVDX S @VDX@(MDX)=CURVAL ; FILL IN VDX ARRAY IF REQUESTED - . . . . I $D(TEMPLATE) D ; IF TEMPLATE IS REQUESTED - . . . . . S LINE=$$CLEAN(LINE) ; CLEAN OUT CONTROL CHARACTERS - . . . . . S @TEMPLATE@(I)=$P(LINE,">",1)_">@@"_MDX_"@@") D ; BEGINNING OF A SECTION - . . . ; W "FOUND ",LINE,! - . . . S FOUND=1 ; SET FOUND FLAG - . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME - . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES - . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK - . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX - . . . ; W "MDX=",MDX,! - . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE - . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER - . . . . ;B - . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE - . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX - S @ZXML@("INDEXED")="" - S @ZXML@("//")="1^"_LCNT ; ROOT XPATH - I NOINX K @ZXML ; DELETE UNWANTED INDEX - Q - ; -MKLASD(OUTBUF,INARY) ; CREATE A LOOKASIDE BUFFER FOR MULTILPLES - ; - N ZI,ZN,ZA,ZLINE,ZLINE2,CUR,CUR2 - F ZI=1:1:LCNT-1 D ; PROCESS THE ENTIRE ARRAY - . S ZLINE=@IZXML@(ZI) - . I ZI") D ; BEGINNING OF A SECTION - . . . S CUR2=$$XNAME(ZLINE2) ; EXTRACT THE NAME - . . . I CUR=CUR2 D ; IF THIS IS A MULTIPLE - . . . . S OUTBUF(CUR,ZI+1)="" - ;ZWR OUTBUF - S ZI="" - F S ZI=$O(OUTBUF(ZI)) Q:ZI="" D ; FOR EACH KIND OF MULTIPLE - . S ZN=$O(OUTBUF(ZI,"")) ; LINE NUMBER OF SECOND MULTIPLE - . F S ZN=$O(@IZXML@(ZN),-1) Q:ZN="" I $E($P(@IZXML@(ZN),"<"_ZI,2),1,1)=">" Q ; - . S OUTBUF(ZI,ZN)="" - S ZA=1,ZI="",ZN="" - F S ZI=$O(OUTBUF(ZI)) Q:ZI="" D ; ADDING THE COUNT FOR THE MULIPLES [x] - . S ZN="",ZA=1 - . F S ZN=$O(OUTBUF(ZI,ZN)) Q:ZN="" D ; - . . S OUTBUF(ZI,ZN)="["_ZA_"]" - . . S ZA=ZA+1 - Q - ; -CLEAN(STR,TR) ; extrinsic function; returns string - ;; Removes all non printable characters from a string. - ;; STR by Value - ;; TR IS OPTIONAL TO IMPROVE PERFORMANCE - N TR,I - I '$D(TR) D ; - . F I=0:1:31 S TR=$G(TR)_$C(I) - . S TR=TR_$C(127) - QUIT $TR(STR,TR) - ; -QUERY(IARY,XPATH,OARY) ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION - ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD" - ; IARY AND OARY ARE PASSED BY NAME - I '$D(@IARY@("INDEXED")) D ; INDEX IS NOT PRESENT IN IARY - . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML - N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN - N TMP,I,J,QXPATH - S FIRST=1 - I '$D(@IARY@(0)) D ; LINE COUNT NOT IN ZERO NODE - . S @IARY@(0)=$O(@IARY@("//"),-1) ; THIS SHOULD USUALLY WORK - S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT - I XPATH'="//" D ; NOT A ROOT QUERY - . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES - . S FIRST=$P(TMP,"^",1) - . S LAST=$P(TMP,"^",2) - K @OARY - S @OARY@(0)=+LAST-FIRST+1 - S J=1 - FOR I=FIRST:1:LAST D - . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY - . S J=J+1 - ; ZWR OARY - Q - ; -XF(IDX,XPATH) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH - ; INDEX WITH TWO PIECES START^FINISH - ; IDX IS PASSED BY NAME - Q $P(@IDX@(XPATH),"^",1) - ; -XL(IDX,XPATH) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH - ; INDEX WITH TWO PIECES START^FINISH - ; IDX IS PASSED BY NAME - Q $P(@IDX@(XPATH),"^",2) - ; -START(ISTR) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX - ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH - ; COMPANION TO FINISH ; IDX IS PASSED BY NAME - Q $P(ISTR,";",2) - ; -FINISH(ISTR) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX - ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH - Q $P(ISTR,";",3) - ; -ARRAY(ISTR) ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX - ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH - Q $P(ISTR,";",1) - ; -BUILD(BLIST,BDEST) ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST - ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST - ; DEST IS CLEARED TO START - ; USES PUSH TO DO THE COPY - N I - K @BDEST - F I=1:1:@BLIST@(0) D ; FOR EACH INSTRUCTION IN BLIST - . N J,ATMP - . S ATMP=$$ARRAY(@BLIST@(I)) - . I $G(DEBUG) W "ATMP=",ATMP,! - . I $G(DEBUG) W @BLIST@(I),! - . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D ; - . . ; FOR EACH LINE IN THIS INSTR - . . I $G(DEBUG) W "BDEST= ",BDEST,! - . . I $G(DEBUG) W "ATMP= ",@ATMP@(J),! - . . D PUSH(BDEST,@ATMP@(J)) - Q - ; -QUEUE(BLST,ARRAY,FIRST,LAST) ; ADD AN ENTRY TO A BLIST - ; - I $G(DEBUG) W "QUEUEING ",BLST,! - D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST) - Q - ; -CP(CPSRC,CPDEST) ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME - ; KILLS CPDEST FIRST - N CPINSTR - I $G(DEBUG) W "MADE IT TO COPY",CPSRC,CPDEST,! - I @CPSRC@(0)<1 D ; BAD LENGTH - . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,! - . Q - ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT - D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY - D BUILD("CPINSTR",CPDEST) - Q - ; -QOPEN(QOBLIST,QOXML,QOXPATH) ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST - ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD - ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT - ; USED TO INSERT CHILDREN NODES - I @QOXML@(0)<1 D ; MALFORMED XML - . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,! - . Q - I $G(DEBUG) W "DOING QOPEN",! - N S1,E1,QOT,QOTMP - S S1=1 ; OPEN FROM THE BEGINNING OF THE XML - I $D(QOXPATH) D ; XPATH PROVIDED - . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX - . S E1=$P(@QOXML@(QOXPATH),"^",2)-1 - I '$D(QOXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT - . S E1=@QOXML@(0)-1 - D QUEUE(QOBLIST,QOXML,S1,E1) - ; S QOTMP=QOXML_"^"_S1_"^"_E1 - ; D PUSH(QOBLIST,QOTMP) - Q - ; -QCLOSE(QCBLIST,QCXML,QCXPATH) ; CLOSE XML AFTER A QOPEN - ; ADDS THE LIST LINE OF QCXML TO QCBLIST - ; USED TO FINISH INSERTING CHILDERN NODES - ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END - ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO - I @QCXML@(0)<1 D ; MALFORMED XML - . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,! - I $G(DEBUG) W "GOING TO CLOSE",! - N S1,E1,QCT,QCTMP - S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML - I $D(QCXPATH) D ; XPATH PROVIDED - . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX - . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML - I '$D(QCXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT - . S S1=@QCXML@(0) - D QUEUE(QCBLIST,QCXML,S1,E1) - ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1) - Q - ; -INSERT(INSXML,INSNEW,INSXPATH) ; INSERT INSNEW INTO INSXML AT THE - ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS - ; OMITTED, INSERTION WILL BE AT THE ROOT - ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW - ; XML AT THE END OF THE XPATH POINT - ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE - N INSBLD,INSTMP - I $G(DEBUG) W "DOING INSERT ",INSXML,INSNEW,INSXPATH,! - I $G(DEBUG) F G1=1:1:@INSXML@(0) W @INSXML@(G1),! - I '$D(@INSXML@(1)) D ; INSERT INTO AN EMPTY ARRAY - . D CP^C0CXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT - I $D(@INSXML@(1)) D ; IF ORIGINAL ARRAY IS NOT EMPTY - . I '$D(@INSXML@(0)) S @INSXML@(0)=$O(@INSXML@(""),-1) ;SET LENGTH - . I $D(INSXPATH) D ; XPATH PROVIDED - . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE - . . I $G(DEBUG) D PARY^C0CXPATH("INSBLD") - . I '$D(INSXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT - . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH - . I '$D(@INSNEW@(0)) S @INSNEW@(0)=$O(@INSNEW@(""),-1) ;SIZE OF XML - . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML - . I $D(INSXPATH) D ; XPATH PROVIDED - . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH - . I '$D(INSXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT - . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH - . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST - . D CP^C0CXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE - Q - ; -INSINNER(INNXML,INNNEW,INNXPATH) ; INSERT THE INNER XML OF INNNEW - ; INTO INNXML AT THE INNXPATH XPATH POINT - ; - N INNBLD,UXPATH - N INNTBUF - S INNTBUF=$NA(^TMP($J,"INNTBUF")) - I '$D(INNXPATH) D ; XPATH NOT PASSED - . S UXPATH="//" ; USE ROOT XPATH - I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED - I '$D(@INNXML@(0)) D ; INNXML IS EMPTY - . D QUEUE^C0CXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER - . D BUILD("INNBLD",INNXML) - I @INNXML@(0)>0 D ; NOT EMPTY - . D QOPEN("INNBLD",INNXML,UXPATH) ; - . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML - . D QCLOSE("INNBLD",INNXML,UXPATH) - . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER - . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST - Q - ; -INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST - ; BUT XDEST AN XNEW ARE PASSED BY NAME - N XBLD,XTMP - D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT - D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST - D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION - D BUILD("XBLD","XTMP") ; BUILD THE RESULT - D CP("XTMP",XDEST) ; COPY TO THE DESTINATION - I $G(DEBUG) D PARY("XDEST") - Q - ; -REPLACE(REXML,RENEW,REXPATH) ; REPLACE THE XML AT THE XPATH POINT - ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE - ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE - ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD") - N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP - S OLD=$NA(^TMP($J,"REPLACE_OLD")) - D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD - S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS - S XFIRST=$P(XNODE,"^",1) - S XLAST=$P(XNODE,"^",2) - I RENEW="" D ; WE ARE DELETING A SECTION, MUST SAVE THE TAG - . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE - . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST - I RENEW'="" D ; NEW XML IS NOT NULL - . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE - . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW - . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST - I $G(DEBUG) W "REPLACE PREBUILD",! - I $G(DEBUG) D PARY("REBLD") - D BUILD("REBLD","RTMP") - K @REXML ; KILL WHAT WAS THERE - D CP("RTMP",REXML) ; COPY IN THE RESULT - Q - ; -DELETE(REXML,REXPATH) ; DELETE THE XML AT THE XPATH POINT - ; REXML IS PASSED BY NAME XPATH IS A VALUE - N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP - S OLD=$NA(^TMP($J,"REPLACE_OLD")) - D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD - S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS - S XFIRST=$P(XNODE,"^",1) - S XLAST=$P(XNODE,"^",2) - D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE - D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST - I $G(DEBUG) D PARY("REBLD") - D BUILD("REBLD","RTMP") - K @REXML ; KILL WHAT WAS THERE - D CP("RTMP",REXML) ; COPY IN THE RESULT - Q - ; -MISSING(IXML,OARY) ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY - ; W "Reporting on the missing",! - ; W OARY - I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q - N I - S @OARY@(0)=0 ; INITIALIZED MISSING COUNT - F I=1:1:@IXML@(0) D ; LOOP THROUGH WHOLE ARRAY - . I @IXML@(I)?.E1"@@".E D ; MISSING VARIABLE HERE - . . D PUSH^C0CXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY - . . Q - Q - ; -MAP(IXML,INARY,OXML) ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY - ; AND PUT THE RESULTS IN OXML - N XCNT - I '$D(DEBUG) S DEBUG=0 - I '$D(IXML) W "MALFORMED XML PASSED TO MAP",! Q - I '$D(@IXML@(0)) D ; INITIALIZE COUNT - . S XCNT=$O(@IXML@(""),-1) - E S XCNT=@IXML@(0) ;COUNT - I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q - N I,J,TNAM,TVAL,TSTR - S @OXML@(0)=XCNT ; TOTAL LINES IN OUTPUT - F I=1:1:XCNT D ; LOOP THROUGH WHOLE ARRAY - . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT - . I @OXML@(I)?.E1"@@".E D ; IS THERE A VARIABLE HERE? - . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS - . . F J=2:2:10 D Q:$P(@IXML@(I),"@@",J+2)="" ; QUIT IF NO MORE VARS - . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,! - . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME - . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED - . . . I $D(@INARY@(TNAM)) D ; IS THE VARIABLE IN THE MAP? - . . . . I '$D(@INARY@(TNAM,"F")) D ; NOT A SPECIAL FIELD - . . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE - . . . . E D DOFLD ; PROCESS A FIELD - . . . S TVAL=$$SYMENC^MXMLUTL(TVAL) ;MAKE SURE THE VALUE IS XML SAFE - . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER - . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES - . . I DEBUG W TSTR - I DEBUG W "MAPPED",! - Q - ; -DOFLD ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE - ; - Q - ; -TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS - ; THEXML IS PASSED BY NAME - N I,J,TMPXML,DEL,FOUND,INTXT - S FOUND=0 - S INTXT=0 - I $G(DEBUG) W "DELETING EMPTY ELEMENTS",! - F I=1:1:(@THEXML@(0)-1) D ; LOOP THROUGH ENTIRE ARRAY - . S J=@THEXML@(I) - . I J["" D - . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM - . . I $G(DEBUG) W "IN HTML SECTION",! - . N JM,JP,JPX ; JMINUS AND JPLUS - . S JM=@THEXML@(I-1) ; LINE BEFORE - . I JM["" S INTXT=0 ; LEFT HTML SECTION,START TRIM - . S JP=@THEXML@(I+1) ; LINE AFTER - . I INTXT=0 D ; IF NOT IN AN HTML SECTION - . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH - . . I J=JPX D ; AN EMPTY ELEMENT ON TWO LINES - . . . I $G(DEBUG) W I,J,JP,! - . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED - . . . S DEL(I)="" ; SET LINE TO DELETE - . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE - . . I J["><" D ; AN EMPTY ELEMENT ON ONE LINE - . . . I $G(DEBUG) W I,J,! - . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED - . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED - . . . I JM=JPX D ; - . . . . I $G(DEBUG) W I,JM_J_JPX,! - . . . . S DEL(I-1)="" - . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL - ; . I J'["><" D PUSH("TMPXML",J) - I FOUND D ; NEED TO DELETE THINGS - . F I=1:1:@THEXML@(0) D ; COPY ARRAY LEAVING OUT DELELTED LINES - . . I '$D(DEL(I)) D ; IF THE LINE IS NOT DELETED - . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY - . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY - Q FOUND - ; -UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML - ; XSEC IS A SECTION PASSED BY NAME - N XBLD,XTMP - D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML - D BUILD("XBLD","XTMP") ; BUILD THE RESULT - D CP("XTMP",XSEC) ; REPLACE PASSED XML - Q - ; -PARY(GLO,ZN) ;PRINT AN ARRAY - ; IF ZN=-1 NO LINE NUMBERS - N I - F I=1:1:@GLO@(0) D ; - . I $G(ZN)=-1 W @GLO@(I),! - . E W I_" "_@GLO@(I),! - Q - ; -H2ARY(IARYRTN,IHASH,IPRE) ; CONVERT IHASH TO RETURN ARRAY - ; IPRE IS OPTIONAL PREFIX FOR THE ELEMENTS. USED FOR MUPTIPLES 1^"VAR"^VALUE - I '$D(IPRE) S IPRE="" - N H2I S H2I="" - ; W $O(@IHASH@(H2I)),! - F S H2I=$O(@IHASH@(H2I)) Q:H2I="" D ; FOR EACH ELEMENT OF THE HASH - . I $QS(H2I,$QL(H2I))="M" D Q ; SPECIAL CASE FOR MULTIPLES - . . ;W H2I_"^"_@IHASH@(H2I),! - . . N IH,IHI - . . S IH=$NA(@IHASH@(H2I)) ; - . . S IH2A=$O(@IH@("")) ; SKIP OVER MULTIPLE DISCRIPTOR - . . S IH2=$NA(@IH@(IH2A)) ; PAST THE "M","DIRETIONS" FOR EXAMPLE - . . S IHI="" ; INDEX INTO "M" MULTIPLES - . . F S IHI=$O(@IH2@(IHI)) Q:IHI="" D ; FOR EACH SUB-MULTIPLE - . . . ; W @IH@(IHI) - . . . S IH3=$NA(@IH2@(IHI)) - . . . ; W "HEY",IH3,! - . . . D H2ARY(.IARYRTN,IH3,IPRE_";"_IHI) ; RECURSIVE CALL - INDENTED ELEMENTS - . . ; W IH,! - . . ; W "C0CZZ",! - . . ; W $NA(@IHASH@(H2I)),! - . . Q ; - . D PUSH(IARYRTN,IPRE_"^"_H2I_"^"_@IHASH@(H2I)) - . ; W @IARYRTN@(0),! - Q - ; -XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES - ; DEFINED IN INPUT XML XVIXML BY @@VAR@@ - ; XVRTN AND XVIXML ARE PASSED BY NAME - ; - N XVI,XVTMP,XVT - F XVI=1:1:@XVIXML@(0) D ; FOR ALL LINES OF THE XML - . S XVT=@XVIXML@(XVI) - . I XVT["@@" S XVTMP($P(XVT,"@@",2))=XVI - D H2ARY(XVRTN,"XVTMP") - Q - ; -DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE - ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE - ; - N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED - I DXIN="CCR" D ; NEED TO GO GET CCR TEMPLATE - . D LOAD^C0CCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP - . S DXUSE="DTMP" ; DXUSE IS NAME - E I DXIN="CCD" D ; NEED TO GO GET CCD TEMPLATE - . D LOAD^C0CCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP - . S DXUSE="DTMP" ; DXUSE IS NAME - E S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE - N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE - D XVARS("DVARS",DXUSE) ; PULL OUT VARS - D PARY^C0CXPATH("DVARS") ;AND DISPLAY THEM - Q - ; -TEST ; Run all the test cases - D TESTALL^C0CUNIT("C0CXPAT0") - Q - ; -ZTEST(WHICH) ; RUN ONE SET OF TESTS - N ZTMP - S DEBUG=1 - D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") - D ZTEST^C0CUNIT(.ZTMP,WHICH) - Q - ; -TLIST ; LIST THE TESTS - N ZTMP - D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") - D TLIST^C0CUNIT(.ZTMP) - Q - ; +C0CXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 + ;;1.0;C0C;;May 19, 2009;Build 38 + ;Copyright 2008 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is an XML XPATH utility library",! + W ! + Q + ; +OUTPUT(OUTARY,OUTNAME,OUTDIR) ; WRITE AN ARRAY TO A FILE + ; + N Y + S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME) + I Y Q 1_U_"WROTE FILE: "_OUTNAME_" TO "_OUTDIR + I 'Y Q 0_U_"ERROR WRITING FILE"_OUTNAME_" TO "_OUTDIR + Q + ; +PUSH(STK,VAL) ; pushs VAL onto STK and updates STK(0) + ; VAL IS A STRING AND STK IS PASSED BY NAME + ; + I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE + S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH + S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY + Q + ; +POP(STK,VAL) ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL + ; VAL AND STK ARE PASSED BY REFERENCE + ; + I @STK@(0)<1 D ; IF ARRAY IS EMPTY + . S VAL="" + . S @STK@(0)=0 + I @STK@(0)>0 D ; + . S VAL=@STK@(@STK@(0)) + . K @STK@(@STK@(0)) + . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY + Q + ; +PUSHA(ADEST,ASRC) ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME + ; + N ZGI + F ZGI=1:1:@ASRC@(0) D ; FOR ALL OF THE SOURCE ARRAY + . D PUSH(ADEST,@ASRC@(ZGI)) ; PUSH ONE ELEMENT + Q + ; +MKMDX(STK,RTN,INREDUX) ; MAKES A MUMPS INDEX FROM THE ARRAY STK + ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS + ; REDUX IS A STRING TO REMOVE FROM THE RESULT + S RTN="" + N I + ; W "STK= ",STK,! + I @STK@(0)>0 D ; IF THE ARRAY IS NOT EMPTY + . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON + . I @STK@(0)>1 D ; SUBSEQUENT ELEMENTS NEED A SEMICOLON + . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I) + I $G(INREDUX)'="" S RTN=$P(RTN,INREDUX,1)_$P(RTN,INREDUX,2) + Q + ; +XNAME(ISTR) ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG + ; AND WILL RETURN NAME + ; ISTR IS PASSED BY VALUE + N CUR,TMP + I ISTR?.E1"<".E D ; STRIP OFF LEFT BRACKET + . S TMP=$P(ISTR,"<",2) + I TMP?1"/".E D ; ALSO STRIP OFF SLASH IF PRESENT IE + . S TMP=$P(TMP,"/",2) + S CUR=$P(TMP,">",1) ; EXTRACT THE NAME + ; W "CUR= ",CUR,! + I CUR?.1"_"1.A1" ".E D ; CONTAINS A BLANK IE NAME ID=TEST> + . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER + ; W "CUR2= ",CUR,! + Q CUR + ; +XVAL(ISTR) ; EXTRACTS THE VALUE FROM A FRAGMENT OF XML + ; VALUE WILL RETURN VALUE + N G + S G=$P(ISTR,">",2) ;STRIP OFF + Q $P(G,"<",1) ; STRIP OFF LEAVING VALUE + ; +VDX2VDV(OUTVDV,INVDX) ; CONVERT AN VDX ARRAY TO VDV + ; VDX: @INVDX@(XPATH)=VALUE + ; VDV: @OUTVDV@(X1X2X3X4)=VALUE + ; THE VDV DATANAMES MIGHT BE MORE CONVENIENT FOR USE IN CODE + ; AN INDEX IS PROVIDED TO GO BACK TO VDX FOR CONVERSIONS + ; @VDV@("XPATH",X1X2X3X4)="XPATH" + N ZA,ZI,ZW + S ZI="" + F S ZI=$O(@INVDX@(ZI)) Q:ZI="" D ; + . S ZW=$TR(ZI,"/","") ; ELIMINATE ALL SLASHES - CAMEL CASE VARIABLE NAME + . W ZW,! + . S @OUTVDV@(ZW)=@INVDX@(ZI) + . S @OUTVDV@("XPATH",ZW)=ZI + Q + ; +VDX2XPG(OUTXPG,INVDX) ; CONVERT AN VDX ARRAY TO XPG + ; VDX: @VDX@(XPATH)=VALUE + ; XPG: @(VDX(X1,X2,X3,X4))@=VALUE + ; THIS IS A STEP TOWARD GENERATING XML FROM A VDX + N ZA,ZI,ZW + S ZI="" + F S ZI=$O(@INVDX@(ZI)) Q:ZI="" D ; + . S ZW=$E(ZI,3,$L(ZI)) ; STRIP OFF INITIAL // + . S ZW2=$P(ZW,"/",1) + . F ZK=1:1:$L(ZW,"/") D PUSH("ZA",$P(ZW,"/",ZK)) + . ;ZWR ZA + . S ZW2=ZA(1) + . F ZK=2:1:ZA(0) D ; + . . S ZW2=ZW2_""","""_ZA(ZK) + . K ZA + . S ZW2=""""_ZW2_"""" + . W ZW2,! + . S ZN=OUTXPG_"("_ZW2_")" + . S @ZN=@INVDX@(ZI) + Q + ; +XML2XPG(OUTXPG,INXML) ; CONVERT AN XML ARRAY, PASSED BY NAME TO AN XPG ARRAY + ; XPG MEANS XPATH GLOBAL AND HAS THE FORM @OUTXPG@("X1","X2","X3")=VALUE + ; + ;N G1 + D INDEX(INXML,"G1",1) ; PRODUCES A VDX ARRAY IN G1, NO INDEX IS PRODUCED + D VDX2XPG(OUTXPG,"G1") ; CONVERTS THE VDX ARRAY TO XPG FORM + Q + ; +DO + D XPG2XML("^GPL2B","^GPL2A") + Q + ; +T1 ; TEST OUT THESE ROUTINES + D XML2XPG("G2","^GPL") + D XPG2XML("G3","G2") + K ^GPLOUT + M ^GPLOUT=G3 + W $$OUTPUT^C0CXPATH("^GPLOUT(1)","GPLTEST.xml","/home/vademo2/EHR/p") + Q + ; +XPG2XML(OUTXML,INXPG) ; + N C0CN,FWD,ZA,G,GA,ZQ + S ZQ=0 ; QUIT FLAG + F Q:ZQ=1 D ; LOOP THROUGH EVERYTHING + . I '$D(C0CN) D ; FIRST TIME THROUGH + . . K @OUTXML ; MAKE SURE OUTPUT ARRAY IS CLEAR + . . S FWD=1 ; START OUT GOING FORWARD THROUGH SUBSCRIPTS + . . S G=$Q(@INXPG) ; THIS ONE + . . S GN=$Q(@G) ; NEXT ONE + . . S C0CN=1 ; SUBSCRIPT COUNT + . . S ZQ=0 ; QUIT FLAG + . . D ZXO("?xml version=""1.0"" encoding=""UTF-8""?") ;MAKE IT REAL XML + . . I $QS(G,1)="ContinuityOfCareRecord" D ; + . . . D ZXO("?xml-stylesheet type=""text/xsl"" href=""ccr.xsl""?") ; HACK TO MAKE THE CCR STYLESHEET WORK + . I FWD D ; GOING FORWARDS + . . I C0CN<$QL(G) D ; NOT A DATA NODE + . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT + . . . D ZXO(ZA) ; AND OPEN AN XML ELEMENT + . . . I @OUTXML@(@OUTXML@(0))="" D ; + . . . . S @OUTXML@(@OUTXML@(0))="" + . . . S C0CN=C0CN+1 ; MOVE TO THE NEXT ONE + . . E D ; AT THE DATA NODE + . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT + . . . D ZXVAL(ZA,@G) ; OUTPUT VAL FOR DATA NODE + . . . S FWD=0 ; GO BACKWARDS + . I 'FWD D ;GOING BACKWARDS + . . S GN=$Q(@G) ;NEXT XPATH + . . ;W "NEXT!",GN,! + . . S C0CN=C0CN-1 ; PREVIOUS SUBSCRIPT + . . I GN'="" D ; + . . . I $QS(G,C0CN)'=$QS(GN,C0CN) D ; NEED TO CLOSE OFF ELEMENT + . . . . D ZXC($QS(G,C0CN)) ; + . . . E I GN'="" D ; MORE ELEMENTS AT THIS LEVEL + . . . . S G=$Q(@G) ; ADVANCE TO NEW XPATH + . . . . S C0CN=C0CN+1 ; GET READY TO PROCESS NEXT SUBSCRIPT + . . . . S FWD=1 ; GOING FORWARD NOW + . I (GN="")&(C0CN=1) D Q ; WHEN WE ARE ALL DONE + . . D ZXC($QS(G,C0CN)) ; LAST ONE + . . S ZQ=1 ; QUIT NOW + Q + ; +ZXO(WHAT) + D PUSH("GA",WHAT) + D PUSH(OUTXML,"<"_WHAT_">") + Q + ; +ZXC(WHAT) + D POP("GA",.TMP) + D PUSH(OUTXML,"") + Q + ; +ZXVAL(WHAT,VAL) + D PUSH(OUTXML,"<"_WHAT_">"_VAL_"") + Q + ; +INDEX(IZXML,VDX,NOINX,TEMPLATE,REDUX) ; parse XML in IZXML and produce + ; an XPATH index; REDUX is a string to be removed from each xpath + ; GPL 7/14/09 OPTIONALLY GENERATE AN XML TEMPLATE IF PASSED BY NAME + ; TEMPLATE IS IDENTICAL TO THE PARSED XML LINE BY LINE + ; EXCEPT THAT DATA VALUES ARE REPLACED WITH @@XPATH@@ FOR THE XPATH OF THE TAG + ; GPL 5/24/09 AND OPTIONALLY PRODUCE THE VDX ARRAY PASSED BY NAME + ; @VDX@("XPATH")=VALUE + ; ex. @IZXML@("XPATH")=FIRSTLINE^LASTLINE + ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE + ; XML SECTION + ; IZXML IS PASSED BY NAME + ; IF NOINX IS SET TO 1, NO INDEX WILL BE GENERATED, BUT THE VDX WILL BE + N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND,CURVAL,DVDX,LCNT + N C0CSTK ; LEAVE OUT FOR DEBUGGING + I '$D(REDUX) S REDUX="" + I '$D(NOINX) S NOINX=0 ; IF NOT PASSED, GENERATE AN INDEX + N ZXML + I NOINX S ZXML=$NA(^TMP("C0CINDEX",$J)) ; TEMP PLACE FOR INDEX TO DISCARD + E S ZXML=IZXML ; PLACE FOR INDEX TO KEEP + I '$D(@IZXML@(0)) D ; IF COUNT NOT IN NODE 0 COUNT THEM + . S I="",LCNT=0 + . F S I=$O(@IZXML@(I)) Q:I="" S LCNT=LCNT+1 + E S LCNT=@IZXML@(0) ; LINE COUNT PASSED IN ARRAY + I LCNT=0 D Q ; NO XML PASSED + . W "ERROR IN XML FILE",! + S DVDX=0 ; DEFAULT DO NOT PRODUCE VDX INDEX + I $D(VDX) S DVDX=1 ; IF NAME PASSED, DO VDX + S C0CSTK(0)=0 ; INITIALIZE STACK + K LKASD ; KILL LOOKASIDE ARRAY + D MKLASD(.LKASD,IZXML) ;MAKE LOOK ASIDE BUFFER FOR MULTIPLES + F I=1:1:LCNT D ; PROCESS THE ENTIRE ARRAY + . S LINE=@IZXML@(I) + . I $D(TEMPLATE) D ;IF TEMPLATE IS REQUESTED + . . S @TEMPLATE@(I)=$$CLEAN(LINE) + . ;W LINE,! + . S FOUND=0 ; INTIALIZED FOUND FLAG + . I LINE?.E1"".E) D + . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS + . . . ; ON THE SAME LINE + . . . ; W "FOUND ",LINE,! + . . . S FOUND=1 ; SET FOUND FLAG + . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME + . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES + . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK + . . . D MKMDX("C0CSTK",.MDX,REDUX) ; GENERATE THE M INDEX + . . . ; W "MDX=",MDX,! + . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE + . . . . ;I '$D(ZDUP(MDX)) S ZDUP(MDX)=2 + . . . . ;E S ZDUP(MDX)=ZDUP(MDX)+1 + . . . . ;W "DUP:",MDX,! + . . . . ;I '$D(CURVAL) S CURVAL="" + . . . . ;I DVDX S @VDX@(MDX_"["_ZDUP(MDX)_"]")=CURVAL + . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER + . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE + . . . . S @ZXML@(MDX)=I_"^"_I ; ADD INDEX ENTRY-FIRST AND LAST + . . . . S CURVAL=$$XVAL(LINE) ; VALUE + . . . . S $P(@ZXML@(MDX),"^",3)=CURVAL ; THIRD PIECE + . . . . I DVDX S @VDX@(MDX)=CURVAL ; FILL IN VDX ARRAY IF REQUESTED + . . . . I $D(TEMPLATE) D ; IF TEMPLATE IS REQUESTED + . . . . . S LINE=$$CLEAN(LINE) ; CLEAN OUT CONTROL CHARACTERS + . . . . . S @TEMPLATE@(I)=$P(LINE,">",1)_">@@"_MDX_"@@") D ; BEGINNING OF A SECTION + . . . ; W "FOUND ",LINE,! + . . . S FOUND=1 ; SET FOUND FLAG + . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME + . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES + . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK + . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX + . . . ; W "MDX=",MDX,! + . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE + . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER + . . . . ;B + . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE + . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX + S @ZXML@("INDEXED")="" + S @ZXML@("//")="1^"_LCNT ; ROOT XPATH + I NOINX K @ZXML ; DELETE UNWANTED INDEX + Q + ; +MKLASD(OUTBUF,INARY) ; CREATE A LOOKASIDE BUFFER FOR MULTILPLES + ; + N ZI,ZN,ZA,ZLINE,ZLINE2,CUR,CUR2 + F ZI=1:1:LCNT-1 D ; PROCESS THE ENTIRE ARRAY + . S ZLINE=@IZXML@(ZI) + . I ZI") D ; BEGINNING OF A SECTION + . . . S CUR2=$$XNAME(ZLINE2) ; EXTRACT THE NAME + . . . I CUR=CUR2 D ; IF THIS IS A MULTIPLE + . . . . S OUTBUF(CUR,ZI+1)="" + ;ZWR OUTBUF + S ZI="" + F S ZI=$O(OUTBUF(ZI)) Q:ZI="" D ; FOR EACH KIND OF MULTIPLE + . S ZN=$O(OUTBUF(ZI,"")) ; LINE NUMBER OF SECOND MULTIPLE + . F S ZN=$O(@IZXML@(ZN),-1) Q:ZN="" I $E($P(@IZXML@(ZN),"<"_ZI,2),1,1)=">" Q ; + . S OUTBUF(ZI,ZN)="" + S ZA=1,ZI="",ZN="" + F S ZI=$O(OUTBUF(ZI)) Q:ZI="" D ; ADDING THE COUNT FOR THE MULIPLES [x] + . S ZN="",ZA=1 + . F S ZN=$O(OUTBUF(ZI,ZN)) Q:ZN="" D ; + . . S OUTBUF(ZI,ZN)="["_ZA_"]" + . . S ZA=ZA+1 + Q + ; +CLEAN(STR,TR) ; extrinsic function; returns string + ;; Removes all non printable characters from a string. + ;; STR by Value + ;; TR IS OPTIONAL TO IMPROVE PERFORMANCE + N TR,I + I '$D(TR) D ; + . F I=0:1:31 S TR=$G(TR)_$C(I) + . S TR=TR_$C(127) + QUIT $TR(STR,TR) + ; +QUERY(IARY,XPATH,OARY) ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION + ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD" + ; IARY AND OARY ARE PASSED BY NAME + I '$D(@IARY@("INDEXED")) D ; INDEX IS NOT PRESENT IN IARY + . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML + N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN + N TMP,I,J,QXPATH + S FIRST=1 + I '$D(@IARY@(0)) D ; LINE COUNT NOT IN ZERO NODE + . S @IARY@(0)=$O(@IARY@("//"),-1) ; THIS SHOULD USUALLY WORK + S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT + I XPATH'="//" D ; NOT A ROOT QUERY + . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES + . S FIRST=$P(TMP,"^",1) + . S LAST=$P(TMP,"^",2) + K @OARY + S @OARY@(0)=+LAST-FIRST+1 + S J=1 + FOR I=FIRST:1:LAST D + . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY + . S J=J+1 + ; ZWR OARY + Q + ; +XF(IDX,XPATH) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH + ; INDEX WITH TWO PIECES START^FINISH + ; IDX IS PASSED BY NAME + Q $P(@IDX@(XPATH),"^",1) + ; +XL(IDX,XPATH) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH + ; INDEX WITH TWO PIECES START^FINISH + ; IDX IS PASSED BY NAME + Q $P(@IDX@(XPATH),"^",2) + ; +START(ISTR) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX + ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH + ; COMPANION TO FINISH ; IDX IS PASSED BY NAME + Q $P(ISTR,";",2) + ; +FINISH(ISTR) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX + ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH + Q $P(ISTR,";",3) + ; +ARRAY(ISTR) ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX + ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH + Q $P(ISTR,";",1) + ; +BUILD(BLIST,BDEST) ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST + ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST + ; DEST IS CLEARED TO START + ; USES PUSH TO DO THE COPY + N I + K @BDEST + F I=1:1:@BLIST@(0) D ; FOR EACH INSTRUCTION IN BLIST + . N J,ATMP + . S ATMP=$$ARRAY(@BLIST@(I)) + . I $G(DEBUG) W "ATMP=",ATMP,! + . I $G(DEBUG) W @BLIST@(I),! + . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D ; + . . ; FOR EACH LINE IN THIS INSTR + . . I $G(DEBUG) W "BDEST= ",BDEST,! + . . I $G(DEBUG) W "ATMP= ",@ATMP@(J),! + . . D PUSH(BDEST,@ATMP@(J)) + Q + ; +QUEUE(BLST,ARRAY,FIRST,LAST) ; ADD AN ENTRY TO A BLIST + ; + I $G(DEBUG) W "QUEUEING ",BLST,! + D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST) + Q + ; +CP(CPSRC,CPDEST) ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME + ; KILLS CPDEST FIRST + N CPINSTR + I $G(DEBUG) W "MADE IT TO COPY",CPSRC,CPDEST,! + I @CPSRC@(0)<1 D ; BAD LENGTH + . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,! + . Q + ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT + D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY + D BUILD("CPINSTR",CPDEST) + Q + ; +QOPEN(QOBLIST,QOXML,QOXPATH) ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST + ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD + ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT + ; USED TO INSERT CHILDREN NODES + I @QOXML@(0)<1 D ; MALFORMED XML + . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,! + . Q + I $G(DEBUG) W "DOING QOPEN",! + N S1,E1,QOT,QOTMP + S S1=1 ; OPEN FROM THE BEGINNING OF THE XML + I $D(QOXPATH) D ; XPATH PROVIDED + . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX + . S E1=$P(@QOXML@(QOXPATH),"^",2)-1 + I '$D(QOXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT + . S E1=@QOXML@(0)-1 + D QUEUE(QOBLIST,QOXML,S1,E1) + ; S QOTMP=QOXML_"^"_S1_"^"_E1 + ; D PUSH(QOBLIST,QOTMP) + Q + ; +QCLOSE(QCBLIST,QCXML,QCXPATH) ; CLOSE XML AFTER A QOPEN + ; ADDS THE LIST LINE OF QCXML TO QCBLIST + ; USED TO FINISH INSERTING CHILDERN NODES + ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END + ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO + I @QCXML@(0)<1 D ; MALFORMED XML + . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,! + I $G(DEBUG) W "GOING TO CLOSE",! + N S1,E1,QCT,QCTMP + S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML + I $D(QCXPATH) D ; XPATH PROVIDED + . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX + . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML + I '$D(QCXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT + . S S1=@QCXML@(0) + D QUEUE(QCBLIST,QCXML,S1,E1) + ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1) + Q + ; +INSERT(INSXML,INSNEW,INSXPATH) ; INSERT INSNEW INTO INSXML AT THE + ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS + ; OMITTED, INSERTION WILL BE AT THE ROOT + ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW + ; XML AT THE END OF THE XPATH POINT + ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE + N INSBLD,INSTMP + I $G(DEBUG) W "DOING INSERT ",INSXML,INSNEW,INSXPATH,! + I $G(DEBUG) F G1=1:1:@INSXML@(0) W @INSXML@(G1),! + I '$D(@INSXML@(1)) D ; INSERT INTO AN EMPTY ARRAY + . D CP^C0CXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT + I $D(@INSXML@(1)) D ; IF ORIGINAL ARRAY IS NOT EMPTY + . I '$D(@INSXML@(0)) S @INSXML@(0)=$O(@INSXML@(""),-1) ;SET LENGTH + . I $D(INSXPATH) D ; XPATH PROVIDED + . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE + . . I $G(DEBUG) D PARY^C0CXPATH("INSBLD") + . I '$D(INSXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT + . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH + . I '$D(@INSNEW@(0)) S @INSNEW@(0)=$O(@INSNEW@(""),-1) ;SIZE OF XML + . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML + . I $D(INSXPATH) D ; XPATH PROVIDED + . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH + . I '$D(INSXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT + . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH + . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST + . D CP^C0CXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE + Q + ; +INSINNER(INNXML,INNNEW,INNXPATH) ; INSERT THE INNER XML OF INNNEW + ; INTO INNXML AT THE INNXPATH XPATH POINT + ; + N INNBLD,UXPATH + N INNTBUF + S INNTBUF=$NA(^TMP($J,"INNTBUF")) + I '$D(INNXPATH) D ; XPATH NOT PASSED + . S UXPATH="//" ; USE ROOT XPATH + I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED + I '$D(@INNXML@(0)) D ; INNXML IS EMPTY + . D QUEUE^C0CXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER + . D BUILD("INNBLD",INNXML) + I @INNXML@(0)>0 D ; NOT EMPTY + . D QOPEN("INNBLD",INNXML,UXPATH) ; + . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML + . D QCLOSE("INNBLD",INNXML,UXPATH) + . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER + . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST + Q + ; +INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST + ; BUT XDEST AN XNEW ARE PASSED BY NAME + N XBLD,XTMP + D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT + D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST + D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION + D BUILD("XBLD","XTMP") ; BUILD THE RESULT + D CP("XTMP",XDEST) ; COPY TO THE DESTINATION + I $G(DEBUG) D PARY("XDEST") + Q + ; +REPLACE(REXML,RENEW,REXPATH) ; REPLACE THE XML AT THE XPATH POINT + ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE + ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE + ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD") + N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP + S OLD=$NA(^TMP($J,"REPLACE_OLD")) + D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD + S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS + S XFIRST=$P(XNODE,"^",1) + S XLAST=$P(XNODE,"^",2) + I RENEW="" D ; WE ARE DELETING A SECTION, MUST SAVE THE TAG + . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE + . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST + I RENEW'="" D ; NEW XML IS NOT NULL + . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE + . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW + . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST + I $G(DEBUG) W "REPLACE PREBUILD",! + I $G(DEBUG) D PARY("REBLD") + D BUILD("REBLD","RTMP") + K @REXML ; KILL WHAT WAS THERE + D CP("RTMP",REXML) ; COPY IN THE RESULT + Q + ; +DELETE(REXML,REXPATH) ; DELETE THE XML AT THE XPATH POINT + ; REXML IS PASSED BY NAME XPATH IS A VALUE + N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP + S OLD=$NA(^TMP($J,"REPLACE_OLD")) + D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD + S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS + S XFIRST=$P(XNODE,"^",1) + S XLAST=$P(XNODE,"^",2) + D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE + D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST + I $G(DEBUG) D PARY("REBLD") + D BUILD("REBLD","RTMP") + K @REXML ; KILL WHAT WAS THERE + D CP("RTMP",REXML) ; COPY IN THE RESULT + Q + ; +MISSING(IXML,OARY) ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY + ; W "Reporting on the missing",! + ; W OARY + I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q + N I + S @OARY@(0)=0 ; INITIALIZED MISSING COUNT + F I=1:1:@IXML@(0) D ; LOOP THROUGH WHOLE ARRAY + . I @IXML@(I)?.E1"@@".E D ; MISSING VARIABLE HERE + . . D PUSH^C0CXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY + . . Q + Q + ; +MAP(IXML,INARY,OXML) ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY + ; AND PUT THE RESULTS IN OXML + N XCNT + I '$D(DEBUG) S DEBUG=0 + I '$D(IXML) W "MALFORMED XML PASSED TO MAP",! Q + I '$D(@IXML@(0)) D ; INITIALIZE COUNT + . S XCNT=$O(@IXML@(""),-1) + E S XCNT=@IXML@(0) ;COUNT + I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q + N I,J,TNAM,TVAL,TSTR + S @OXML@(0)=XCNT ; TOTAL LINES IN OUTPUT + F I=1:1:XCNT D ; LOOP THROUGH WHOLE ARRAY + . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT + . I @OXML@(I)?.E1"@@".E D ; IS THERE A VARIABLE HERE? + . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS + . . F J=2:2:10 D Q:$P(@IXML@(I),"@@",J+2)="" ; QUIT IF NO MORE VARS + . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,! + . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME + . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED + . . . I $D(@INARY@(TNAM)) D ; IS THE VARIABLE IN THE MAP? + . . . . I '$D(@INARY@(TNAM,"F")) D ; NOT A SPECIAL FIELD + . . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE + . . . . E D DOFLD ; PROCESS A FIELD + . . . S TVAL=$$SYMENC^MXMLUTL(TVAL) ;MAKE SURE THE VALUE IS XML SAFE + . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER + . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES + . . I DEBUG W TSTR + I DEBUG W "MAPPED",! + Q + ; +DOFLD ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE + ; + Q + ; +TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS + ; THEXML IS PASSED BY NAME + N I,J,TMPXML,DEL,FOUND,INTXT + S FOUND=0 + S INTXT=0 + I $G(DEBUG) W "DELETING EMPTY ELEMENTS",! + F I=1:1:(@THEXML@(0)-1) D ; LOOP THROUGH ENTIRE ARRAY + . S J=@THEXML@(I) + . I J["" D + . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM + . . I $G(DEBUG) W "IN HTML SECTION",! + . N JM,JP,JPX ; JMINUS AND JPLUS + . S JM=@THEXML@(I-1) ; LINE BEFORE + . I JM["" S INTXT=0 ; LEFT HTML SECTION,START TRIM + . S JP=@THEXML@(I+1) ; LINE AFTER + . I INTXT=0 D ; IF NOT IN AN HTML SECTION + . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH + . . I J=JPX D ; AN EMPTY ELEMENT ON TWO LINES + . . . I $G(DEBUG) W I,J,JP,! + . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED + . . . S DEL(I)="" ; SET LINE TO DELETE + . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE + . . I J["><" D ; AN EMPTY ELEMENT ON ONE LINE + . . . I $G(DEBUG) W I,J,! + . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED + . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED + . . . I JM=JPX D ; + . . . . I $G(DEBUG) W I,JM_J_JPX,! + . . . . S DEL(I-1)="" + . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL + ; . I J'["><" D PUSH("TMPXML",J) + I FOUND D ; NEED TO DELETE THINGS + . F I=1:1:@THEXML@(0) D ; COPY ARRAY LEAVING OUT DELELTED LINES + . . I '$D(DEL(I)) D ; IF THE LINE IS NOT DELETED + . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY + . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY + Q FOUND + ; +UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML + ; XSEC IS A SECTION PASSED BY NAME + N XBLD,XTMP + D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML + D BUILD("XBLD","XTMP") ; BUILD THE RESULT + D CP("XTMP",XSEC) ; REPLACE PASSED XML + Q + ; +PARY(GLO,ZN) ;PRINT AN ARRAY + ; IF ZN=-1 NO LINE NUMBERS + N I + F I=1:1:@GLO@(0) D ; + . I $G(ZN)=-1 W @GLO@(I),! + . E W I_" "_@GLO@(I),! + Q + ; +H2ARY(IARYRTN,IHASH,IPRE) ; CONVERT IHASH TO RETURN ARRAY + ; IPRE IS OPTIONAL PREFIX FOR THE ELEMENTS. USED FOR MUPTIPLES 1^"VAR"^VALUE + I '$D(IPRE) S IPRE="" + N H2I S H2I="" + ; W $O(@IHASH@(H2I)),! + F S H2I=$O(@IHASH@(H2I)) Q:H2I="" D ; FOR EACH ELEMENT OF THE HASH + . I $QS(H2I,$QL(H2I))="M" D Q ; SPECIAL CASE FOR MULTIPLES + . . ;W H2I_"^"_@IHASH@(H2I),! + . . N IH,IHI + . . S IH=$NA(@IHASH@(H2I)) ; + . . S IH2A=$O(@IH@("")) ; SKIP OVER MULTIPLE DISCRIPTOR + . . S IH2=$NA(@IH@(IH2A)) ; PAST THE "M","DIRETIONS" FOR EXAMPLE + . . S IHI="" ; INDEX INTO "M" MULTIPLES + . . F S IHI=$O(@IH2@(IHI)) Q:IHI="" D ; FOR EACH SUB-MULTIPLE + . . . ; W @IH@(IHI) + . . . S IH3=$NA(@IH2@(IHI)) + . . . ; W "HEY",IH3,! + . . . D H2ARY(.IARYRTN,IH3,IPRE_";"_IHI) ; RECURSIVE CALL - INDENTED ELEMENTS + . . ; W IH,! + . . ; W "C0CZZ",! + . . ; W $NA(@IHASH@(H2I)),! + . . Q ; + . D PUSH(IARYRTN,IPRE_"^"_H2I_"^"_@IHASH@(H2I)) + . ; W @IARYRTN@(0),! + Q + ; +XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES + ; DEFINED IN INPUT XML XVIXML BY @@VAR@@ + ; XVRTN AND XVIXML ARE PASSED BY NAME + ; + N XVI,XVTMP,XVT + F XVI=1:1:@XVIXML@(0) D ; FOR ALL LINES OF THE XML + . S XVT=@XVIXML@(XVI) + . I XVT["@@" S XVTMP($P(XVT,"@@",2))=XVI + D H2ARY(XVRTN,"XVTMP") + Q + ; +DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE + ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE + ; + N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED + I DXIN="CCR" D ; NEED TO GO GET CCR TEMPLATE + . D LOAD^C0CCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP + . S DXUSE="DTMP" ; DXUSE IS NAME + E I DXIN="CCD" D ; NEED TO GO GET CCD TEMPLATE + . D LOAD^C0CCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP + . S DXUSE="DTMP" ; DXUSE IS NAME + E S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE + N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE + D XVARS("DVARS",DXUSE) ; PULL OUT VARS + D PARY^C0CXPATH("DVARS") ;AND DISPLAY THEM + Q + ; +TEST ; Run all the test cases + D TESTALL^C0CUNIT("C0CXPAT0") + Q + ; +ZTEST(WHICH) ; RUN ONE SET OF TESTS + N ZTMP + S DEBUG=1 + D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") + D ZTEST^C0CUNIT(.ZTMP,WHICH) + Q + ; +TLIST ; LIST THE TESTS + N ZTMP + D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") + D TLIST^C0CUNIT(.ZTMP) + Q + ;