Index: ccr/trunk/p/C0CACTOR.m =================================================================== --- ccr/trunk/p/C0CACTOR.m (revision 391) +++ ccr/trunk/p/C0CACTOR.m (revision 391) @@ -0,0 +1,213 @@ +C0CACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 + ;;0.4;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. + ; + ; 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,! + N AMAP,ZX + S AMAP=$NA(^TMP($J,"AMAP")) + K @AMAP + S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID + S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRDPT(AIEN) + S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRDPT(AIEN) + S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRDPT(AIEN) + S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^CCRDPT(AIEN) + S @AMAP@("ACTORGENDER")=$$GENDER^CCRDPT(AIEN) + 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 $D(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^CCRDPT(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^CCRDPT(AIEN) + S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^CCRDPT(AIEN) + S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^CCRDPT(AIEN) + S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRDPT(AIEN) + S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRDPT(AIEN) + S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^CCRDPT(AIEN) + S @AMAP@("ACTORRESTEL")="" + S @AMAP@("ACTORRESTELTEXT")="" + S ZX=$$RESTEL^CCRDPT(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^CCRDPT(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^CCRDPT(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^CCRDPT(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 + 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^CCRSYS + S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^CCRSYS + 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 + S AMAP=$NA(^TMP($J,"AMAP")) + K @AMAP + S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID + S @AMAP@("ORGANIZATIONNAME")=$P($$SITE^VASITE,U,2) + S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" + D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE + 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^CCRVA200(AIEN) + S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRVA200(AIEN) + S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRVA200(AIEN) + S @AMAP@("ACTORTITLE")=$$TITLE^CCRVA200(AIEN) + S @AMAP@("IDTYPE")=$P($$NPI^CCRVA200(AIEN),U,1) + S @AMAP@("ID")=$P($$NPI^CCRVA200(AIEN),U,2) + S @AMAP@("IDDESC")=$P($$NPI^CCRVA200(AIEN),U,3) + S @AMAP@("ACTORSPECIALITY")=$$SPEC^CCRVA200(AIEN) + S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^CCRVA200(AIEN) + S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^CCRVA200(AIEN) + S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRVA200(AIEN) + S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRVA200(AIEN) + S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^CCRVA200(AIEN) + S @AMAP@("ACTORTELEPHONE")="" + S @AMAP@("ACTORTELEPHONETYPE")="" + S ZX=$$TEL^CCRVA200(AIEN) + I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE + . S @AMAP@("ACTORTELEPHONE")=ZX + . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^CCRVA200(AIEN) + S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRVA200(AIEN) + S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1" + S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE + D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE + Q + ; Index: ccr/trunk/p/C0CALERT.m =================================================================== --- ccr/trunk/p/C0CALERT.m (revision 391) +++ ccr/trunk/p/C0CALERT.m (revision 391) @@ -0,0 +1,123 @@ +C0CALERT ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 + ;;0.1;CCDCCR;;SEP 11,2008; + ;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) ; EXTRACT ALERTS INTO PROVIDED XML TEMPLATE + ; + ; 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 + . N A2 S A2=$$GET1^DIQ(120.8,ALTTMP,"MECHANISM","I") ; MECHANISM + . N A3 S A3=$P(A1,U,5) ; ADVERSE FLAG + . N ADT S ADT="Patient has an " ; X $ZINT H 5 + . S ADT=ADT_$S(A2="P":"ADVERSE",A2="A":"ALLERGIC",1:"UNKNOWN") + . S ADT=ADT_" reaction to "_$P(@ALTG@(ALTTMP),U,2)_"." + . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT + . N ADTY S ADTY=$S(A2="P":"Adverse Reaction",A2="A":"Allergy",1:"") ; + . S @ALTVMAP@("ALERTTYPE")=ADTY ; type of allergy + . N ALTCDE ; SNOMED CODE THE THE ALERT + . S ALTCDE=$S(A2="P":"282100009",A2="A":"418634005",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC + . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ; + . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE + . ; AND 282100009 FOR ADVERSE REACTION TO A SUBSTANCE + . I ALTCDE'="" D ; IF THERE IS A CODE + . . S @ALTVMAP@("ALERTCODESYSTEM")="SNOMED CT" + . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="2008" + . E D ; SET TO NULL + . . S @ALTVMAP@("ALERTCODESYSTEM")="" + . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="" + . S @ALTVMAP@("ALERTSTATUSTEXT")="" ; WHERE DO WE GET THIS? + . N ALTPROV S ALTPROV=$P(^GMR(120.8,ALTTMP,0),U,5) ; SOURCE PROVIDER IEN + . I ALTPROV'="" D ; PROVIDER PROVIDEED + . . S @ALTVMAP@("ALERTSOURCEID")="ACTORPROVIDER_"_ALTPROV + . E S @ALTVMAP@("ALERTSOURCEID")="" ; SOURCE NULL - SHOULD NOT HAPPEN + . W "RUNNING ALERTS, PROVIDER: ",@ALTVMAP@("ALERTSOURCEID"),! + . N ACGL1,ACGFI,ACIEN,ACVUID,ACNM,ACTMP + . S ACGL1=$P(@ALTG@(ALTTMP),U,9) ; ADDRESS OF THE REACTANT XX;GLB(YY.Z, + . S ACGFI=$$PRSGLB($P(ACGL1,";",2)) ; FILE NUMBER + . S ACIEN=$P(ACGL1,";",1) ; IEN OF REACTANT + . S ACVUID=$$GET1^DIQ(ACGFI,ACIEN,"VUID") ; VUID OF THE REACTANT + . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="PRODUCT_"_ACIEN ; IE OF REACTANT + . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="" ; WHERE DO WE GET THIS? + . S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT + . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM + . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ACVUID + . I ACVUID'="" D ; IF VUID IS NOT NULL + . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="VUID" + . E D ; IF REACTANT CODE VALUE IS NULL + . . I $G(DUZ("AG"))="I" D ; IF WE ARE RUNNING ON RPMS + . . . S ACTMP=$O(^C0CCODES(176.112,"C",ACNM,0)) ; + . . . W "RPMS NAME FOUND",ACNM," ",ACTMP,! + . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="" + . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="" + . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW + . N ARTMP,ARIEN,ARDES,ARVUID + . S (ARTMP,ARDES,ARVUID)="" + . I $D(@ALTG@(ALTTMP,"S",1)) D ; IF REACTION EXISTS + . . S ARTMP=@ALTG@(ALTTMP,"S",1) + . . W "REACTION:",ARTMP,! + . . S ARIEN=$P(ARTMP,";",2) + . . S ARDES=$P(ARTMP,";",1) + . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID") + . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES + . I ARVUID'="" D ; IF REACTION VUID IS NOT NULL + . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID + . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID" + . E D ; IF IT IS NULL DON'T SET CODE SYSTEM + . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")="" + . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="" + . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) + . ; NOW GO TO THE GLOBAL TO GET THE DATE/TIME AND BETTER DESCRIPTION + . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL + . D GETN1^C0CRNF("C0CG1",120.8,DFN,"B") ;GET VALUES BY NAME + . S C0CT=$$ZVALUEI^C0CRNF("ORIGINATION DATE/TIME","C0CG1") + . S @ALTVMAP@("ALERTDATETIME")=$$FMDTOUTC^CCRUTIL(C0CT) + . 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/trunk/p/C0CCCD1.m =================================================================== --- ccr/trunk/p/C0CCCD1.m (revision 391) +++ ccr/trunk/p/C0CCCD1.m (revision 391) @@ -0,0 +1,268 @@ +C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/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. + ; + 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/trunk/p/C0CCCR.m =================================================================== --- ccr/trunk/p/C0CCCR.m (revision 391) +++ ccr/trunk/p/C0CCCR.m (revision 391) @@ -0,0 +1,239 @@ +C0CCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/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. + ; + ; 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 + I '$D(DIR) S UDIR="" + E S UDIR=DIR + I '$D(FN) S UFN="" + E S UFN=FN + I '$D(XPARMS) S XPARMS="" + D CCRRPC(.CCRGLO,DFN,XPARMS,"CCR") + S OARY=$NA(^TMP("C0CCCR",$J,DFN,"CCR",1)) + S ONAM=UFN + I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_19.xml" + S ODIRGLB=$NA(^TMP("C0CCCR","ODIR")) + 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("C0CCCR",$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 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 + ; 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 + I '$D(DEBUG) S DEBUG=0 + S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD + D SET^C0CPARMS(CCRPARMS) ;SET PARAMETERS WITH CCRPARMS AS OVERRIDES + 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 CCRMEDS SECTION + S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE + S CCRGLO=$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 + D LOAD^C0CCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE + D CP^C0CXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL + ; + ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL + ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES + D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body") + D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") + D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") + I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! + ; + D HDRMAP(CCRGLO,DFN) ; MAP HEADER VARIABLES + ; + K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT + S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS + D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS + N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD + F PROCI=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS + . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE + . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL + . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL + . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE + . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS + . S IXML="INXML" + . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES + . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY + . ; W OXML,! + . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL + . W "RUNNING ",CALL,! + . X CALL + . ; NOW INSERT THE RESULTS IN THE CCR BUFFER + . I @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") + 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 + 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"")") + D PUSH^C0CXPATH(TAB,"EXTRACT;CCRMEDS;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")") + 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,"MAP;C0CIMMU;//ContinuityOfCareRecord/Body/Immunizations;^TMP(""C0CCCR"",$J,DFN,""IMMUNE"")") + I TESTALERT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""C0CCCR"",$J,DFN,""ALERTS"")") + 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^CCRUTIL($$NOW^XLFDT,"DT") + ; I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS + D ; ALWAYS MAP THESE VARIABLES + . 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) + 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 ; SCAN ALL LINES + . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE + . . S J=$P($P(@AXML@(I),"",2),"",1) + . . I DEBUG 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/trunk/p/C0CIMMU.m =================================================================== --- ccr/trunk/p/C0CIMMU.m (revision 391) +++ ccr/trunk/p/C0CIMMU.m (revision 391) @@ -0,0 +1,107 @@ +C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09 + ;;0.1;CCDCCR;nopatch;noreleasedate;Build 7 + ;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^CCRUTIL(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/trunk/p/C0CLABS.m =================================================================== --- ccr/trunk/p/C0CLABS.m (revision 391) +++ ccr/trunk/p/C0CLABS.m (revision 391) @@ -0,0 +1,387 @@ +C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 + ;;0.3;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. + ; +;MAP(DFN,MOXML,MIVAR,MIXML) ; MAP RESULTS VARIABLES TO XML - GPL -TBD +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 + 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^CCRDPT(DFN) ; GET THE SSN FOR THIS PATIENT + I C0CPTID="" D Q ; NO SSN, COMPLAIN AND QUIT + . W "LAB LOOKUP FAILED, NO SSN",! + . S C0CNSSN=1 ; SET NO SSN FLAG + S C0CSPC="*" ; LOOKING FOR ALL LABS + ;I $D(^TMP("C0CCCR","RPMS")) D ; RUNNING RPMS + ;. D DT^DILF(,"T-365",.C0CSDT) ; START DATE ONE YEAR AGO TO LIMIT VOLUME + ;E D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING + ;D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY + S C0CLLMT=$$GET^C0CPARMS("LABLIMIT") ; GET THE LIMIT PARM + S C0CLSTRT=$$GET^C0CPARMS("LABSTART") ; GET START PARM + D DT^DILF(,C0CLLMT,.C0CSDT) ; + W "LAB LIMIT: ",C0CLLMT,! + D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM + S C0CR=$$GCPR^LA7QRY(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP + Q + ; +LIST ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB + ; + ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR + I '$D(C0CLB) S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS + I '$D(C0CQT) S C0CQT=0 + I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT + I '$D(^TMP("C0CCCR","LABTBL",0)) D SETTBL ;INITIALIZE LAB TABLE + I ^TMP("C0CCCR","LABTBL",0)'="V3" D SETTBL ;NEED NEWEST VERSION + I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE + S C0CTAB=$NA(^TMP("C0CCCR","LABTBL")) ; BASE OF OBX TABLE + S C0CHB=$NA(^TMP("HLS",$J)) + S C0CI="" + S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT + F S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI="" D ; FOR ALL RECORDS IN HL7 MSG + . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES + . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) + . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT) + . M XV=C0CVAR ; + . I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION + . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT + . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT + . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS + . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI + . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR + . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1) + . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT + . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL + . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^CCRUTIL(C0CX2,"DT") ;UTC TIME + . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS + . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION + . I C0CTYP="OBX" D ; SPECIAL CASE FOR OBX3 + . . ; RESULTTESTCODEVALUE + . . ; RESULTTESTDESCRIPTIONTEXT + . . I C0CVAR("C3")="LN" D ; PRIMARY CODE IS LOINC + . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE + . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC + . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESCRIPTION TEXT + . . E I C0CVAR("C6")="LN" D ; SECONDARY CODE IS LOINC + . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE + . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC + . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT + . . E I C0CVAR("C6")'="" D ; NO LOINC CODES, USE SECONDARY IF PRESENT + . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE + . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME + . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT + . . E D ; NO SECONDARY, USE PRIMARY + . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE + . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME + . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT + . . N C0CZG S C0CZG=XV("RESULTTESTNORMALDESCTEXT") ; + . . S XV("RESULTTESTNORMALDESCTEXT")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE + . . S C0CZG=XV("RESULTTESTVALUE") + . . S XV("RESULTTESTVALUE")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE + . 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^CCRUTIL(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/trunk/p/C0CPROBS.m =================================================================== --- ccr/trunk/p/C0CPROBS.m (revision 391) +++ ccr/trunk/p/C0CPROBS.m (revision 391) @@ -0,0 +1,115 @@ +C0CPROBS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08 + ;;0.1;CCDCCR;nopatch;noreleasedate;Build 7 + ;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 '$T(GET^BGOPRB) D ; IF BGOPRB ROUTINE IS MISSING (IE RPMS) + . D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC + E D GET^BGOPROB(.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",1:"") + . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3) + . S @VMAP@("PROBLEMCODINGVERSION")="" + . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4) + . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^CCRUTIL($P(PTMP,U,5),"DT") + . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^CCRUTIL($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^CCRUTIL($P(PTMP,U,15),"DT") + . S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^CCRUTIL($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 ; IF THIS IS FOR A 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 + 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/trunk/p/C0CRIMA.m =================================================================== --- ccr/trunk/p/C0CRIMA.m (revision 391) +++ ccr/trunk/p/C0CRIMA.m (revision 391) @@ -0,0 +1,491 @@ +C0CRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/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 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 + 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)=^TMP("C0CCCR",$J,"PROBVALS",0) + . 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") + . 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^CCRSYS(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 + 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 + ; +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) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT + ; + 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,"","") ; 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") + 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 ; + . 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" D ; + . . D ZGVWRK(ZZGI) ; DO EACH SECTION + . . 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 + E D ; VARS EXIST + . N ZGVI + . F ZGVI=1:1:@ZZGN@(0) 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)) + . . 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/trunk/p/C0CSNOA.m =================================================================== --- ccr/trunk/p/C0CSNOA.m (revision 391) +++ ccr/trunk/p/C0CSNOA.m (revision 391) @@ -0,0 +1,198 @@ +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/trunk/p/C0CUNIT.m =================================================================== --- ccr/trunk/p/C0CUNIT.m (revision 391) +++ ccr/trunk/p/C0CUNIT.m (revision 391) @@ -0,0 +1,156 @@ +C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 + ;;0.1;CCDCCR;nopatch;noreleasedate + ;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 + ; Index: ccr/trunk/p/C0CVITAL.m =================================================================== --- ccr/trunk/p/C0CVITAL.m (revision 391) +++ ccr/trunk/p/C0CVITAL.m (revision 391) @@ -0,0 +1,204 @@ +C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 + ;;0.1;CCDCCR;;JUL 16,2008; + ;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,.C0CSDT) ; + W "VITALS START: ",C0CVSTRT," LIMIT: ",C0CVLMT,! + D DT^DILF(,C0CVSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM + D VITALS^ORQQVI(.VITRSLT,DFN,C0CSDT,C0CEDT) + 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 VITDATES(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY + ; I DEBUG ZWR VDATES ;DEBUG + S VCNT=$$SORTDT^CCRUTIL(.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^CCRUTIL($P(VITPTMP,U,4),"DT"),! + . . I DEBUG W $P(VITPTMP,U,4),! + . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID + . . I $P(VITPTMP,U,2)="HT" D + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($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^CCRUTIL($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^CCRUTIL($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^CCRUTIL($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^CCRUTIL($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^CCRUTIL($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^CCRUTIL($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 D + . . . ;W "IN VITAL: OTHER",! + . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" + . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($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(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) + . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN" + . . 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 + ; +VITDATES(VDT) ; 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/trunk/p/C0CXPAT0.m =================================================================== --- ccr/trunk/p/C0CXPAT0.m (revision 391) +++ ccr/trunk/p/C0CXPAT0.m (revision 391) @@ -0,0 +1,212 @@ +C0CXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 + ;;0.2;CCDCCR;nopatch;noreleasedate + ;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" + ;;>>?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" + ;;>>?GXML("//FIRST/SECOND/THIRD")="3^8" + ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^7" + ;;>>?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/trunk/p/C0CXPATH.m =================================================================== --- ccr/trunk/p/C0CXPATH.m (revision 391) +++ ccr/trunk/p/C0CXPATH.m (revision 391) @@ -0,0 +1,505 @@ +C0CXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 + ;;0.2;CCDCCR;nopatch;noreleasedate + ;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) ; MAKES A MUMPS INDEX FROM THE ARRAY STK + ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS + 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) + 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 + ; +INDEX(ZXML) ; parse the XML in ZXML and produce an XPATH index + ; ex. ZXML(FIRST,SECOND,THIRD,FOURTH)=FIRSTLINE^LASTLINE + ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE + ; XML SECTION + ; ZXML IS PASSED BY NAME + N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND + N C0CSTK ; LEAVE OUT FOR DEBUGGING + I '$D(@ZXML@(0)) D ; NO XML PASSED + . W "ERROR IN XML FILE",! + S C0CSTK(0)=0 ; INITIALIZE STACK + F I=1:1:@ZXML@(0) D ; PROCESS THE ENTIRE ARRAY + . S LINE=@ZXML@(I) + . ;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 + . . . 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 + . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE + . . . . S @ZXML@(MDX)=I_"^"_I ; ADD INDEX ENTRY-FIRST AND LAST + . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK + . I FOUND'=1 D ; THE LINE DOESN'T CONTAIN THE START AND END + . . I LINE?.E1"") D ; BEGINNING OF A SECTION + . . . ; W "FOUND ",LINE,! + . . . S FOUND=1 ; SET FOUND FLAG + . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME + . . . 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 + . . . 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^"_@ZXML@(0) ; ROOT XPATH + Q + ; +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 + 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 DEBUG W "ATMP=",ATMP,! + . I DEBUG W @BLIST@(I),! + . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D ; + . . ; FOR EACH LINE IN THIS INSTR + . . I DEBUG W "BDEST= ",BDEST,! + . . I DEBUG W "ATMP= ",@ATMP@(J),! + . . D PUSH(BDEST,@ATMP@(J)) + Q + ; +QUEUE(BLST,ARRAY,FIRST,LAST) ; ADD AN ENTRY TO A BLIST + ; + I 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 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 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 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 DEBUG W "DOING INSERT ",INSXML,INSNEW,INSXPATH,! + I DEBUG F G1=1:1:@INSXML@(0) W @INSXML@(G1),! + I '$D(@INSXML@(0)) D ; INSERT INTO AN EMPTY ARRAY + . D CP^C0CXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT + I $D(@INSXML@(0)) D ; IF ORIGINAL ARRAY IS NOT EMPTY + . I $D(INSXPATH) D ; XPATH PROVIDED + . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE + . . I DEBUG D PARY^C0CXPATH("INSBLD") + . I '$D(INSXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT + . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH + . 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 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 DEBUG W "REPLACE PREBUILD",! + I 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 + I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MAP",! Q + I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q + N I,J,TNAM,TVAL,TSTR + S @OXML@(0)=@IXML@(0) ; TOTAL LINES IN OUTPUT + F I=1:1:@OXML@(0) 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 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 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 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 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 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) ;PRINT AN ARRAY + N I + F I=1:1:@GLO@(0) 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 + ; Index: ccr/trunk/p/GPLACTOR.m =================================================================== --- ccr/trunk/p/GPLACTOR.m (revision 389) +++ (revision ) @@ -1,212 +1,0 @@ -GPLACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 - ;;0.4;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. - ; - ; 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^GPLCCR 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^GPLXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML - D REPLACE^GPLXPATH(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^GPLXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP") - . . D PATIENT("ATMP",AIEN,AOID,"ATMP2") - . ; - . I ATYP="SYSTEM" D ; SYSTEM ACTOR TYPE - . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP") - . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2") - . ; - . I ATYP="NOK" D ; NOK ACTOR TYPE - . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP") - . . D NOK("ATMP",AIEN,AOID,"ATMP2") - . ; - . I ATYP="PROVIDER" D ; PROVIDER ACTOR TYPE - . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP") - . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2") - . ; - . I ATYP="ORGANIZATION" D ; PROVIDER ACTOR TYPE - . . D QUERY^GPLXPATH(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^GPLXPATH(AXML,"ATMP2") ; INSERT INTO ROOT - . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE - ; - N ACTTMP - D MISSING^GPLXPATH(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,! - N AMAP,ZX - S AMAP=$NA(^TMP($J,"AMAP")) - K @AMAP - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID - S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRDPT(AIEN) - S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRDPT(AIEN) - S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRDPT(AIEN) - S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^CCRDPT(AIEN) - S @AMAP@("ACTORGENDER")=$$GENDER^CCRDPT(AIEN) - 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 $D(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^CCRDPT(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^CCRDPT(AIEN) - S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^CCRDPT(AIEN) - S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^CCRDPT(AIEN) - S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRDPT(AIEN) - S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRDPT(AIEN) - S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^CCRDPT(AIEN) - S @AMAP@("ACTORRESTEL")="" - S @AMAP@("ACTORRESTELTEXT")="" - S ZX=$$RESTEL^CCRDPT(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^CCRDPT(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^CCRDPT(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^CCRDPT(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 - D MAP^GPLXPATH(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^CCRSYS - S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^CCRSYS - S @AMAP@("ACTORINFOSYSSOURCEID")=AOID - D MAP^GPLXPATH(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^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE - Q - ; -ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR - ; - ; N AMAP - S AMAP=$NA(^TMP($J,"AMAP")) - K @AMAP - S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID - S @AMAP@("ORGANIZATIONNAME")=$P($$SITE^VASITE,U,2) - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" - D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE - 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^CCRVA200(AIEN) - S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRVA200(AIEN) - S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRVA200(AIEN) - S @AMAP@("ACTORTITLE")=$$TITLE^CCRVA200(AIEN) - S @AMAP@("IDTYPE")=$P($$NPI^CCRVA200(AIEN),U,1) - S @AMAP@("ID")=$P($$NPI^CCRVA200(AIEN),U,2) - S @AMAP@("IDDESC")=$P($$NPI^CCRVA200(AIEN),U,3) - S @AMAP@("ACTORSPECIALITY")=$$SPEC^CCRVA200(AIEN) - S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^CCRVA200(AIEN) - S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^CCRVA200(AIEN) - S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRVA200(AIEN) - S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRVA200(AIEN) - S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^CCRVA200(AIEN) - S @AMAP@("ACTORTELEPHONE")="" - S @AMAP@("ACTORTELEPHONETYPE")="" - S ZX=$$TEL^CCRVA200(AIEN) - I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE - . S @AMAP@("ACTORTELEPHONE")=ZX - . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^CCRVA200(AIEN) - S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRVA200(AIEN) - S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1" - S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE - D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE - Q - ; Index: ccr/trunk/p/GPLALERT.m =================================================================== --- ccr/trunk/p/GPLALERT.m (revision 389) +++ (revision ) @@ -1,122 +1,0 @@ -GPLALERT ; CCDCCR/CKU - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 - ;;0.1;CCDCCR;;SEP 11,2008; - ;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(ALTXML,DFN,ALTOUTXML) ; EXTRACT ALERTS INTO PROVIDED XML TEMPLATE - ; - ; 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("GPLCCR",$J,"ALERTS")) - S ALTTARYTMP=$NA(^TMP("GPLCCR",$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 - . N A2 S A2=$$GET1^DIQ(120.8,ALTTMP,"MECHANISM","I") ; MECHANISM - . N A3 S A3=$P(A1,U,5) ; ADVERSE FLAG - . N ADT S ADT="Patient has an " ; X $ZINT H 5 - . S ADT=ADT_$S(A2="P":"ADVERSE",A2="A":"ALLERGIC",1:"UNKNOWN") - . S ADT=ADT_" reaction to "_$P(@ALTG@(ALTTMP),U,2)_"." - . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT - . N ADTY S ADTY=$S(A2="P":"Adverse Reaction",A2="A":"Allergy",1:"") ; - . S @ALTVMAP@("ALERTTYPE")=ADTY ; type of allergy - . N ALTCDE ; SNOMED CODE THE THE ALERT - . S ALTCDE=$S(A2="P":"282100009",A2="A":"418634005",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC - . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ; - . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE - . ; AND 282100009 FOR ADVERSE REACTION TO A SUBSTANCE - . I ALTCDE'="" D ; IF THERE IS A CODE - . . S @ALTVMAP@("ALERTCODESYSTEM")="SNOMED CT" - . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="2008" - . E D ; SET TO NULL - . . S @ALTVMAP@("ALERTCODESYSTEM")="" - . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="" - . S @ALTVMAP@("ALERTSTATUSTEXT")="" ; WHERE DO WE GET THIS? - . N ALTPROV S ALTPROV=$P(^GMR(120.8,ALTTMP,0),U,5) ; SOURCE PROVIDER IEN - . I ALTPROV'="" D ; PROVIDER PROVIDEED - . . S @ALTVMAP@("ALERTSOURCEID")="ACTORPROVIDER_"_ALTPROV - . E S @ALTVMAP@("ALERTSOURCEID")="" ; SOURCE NULL - SHOULD NOT HAPPEN - . W "RUNNING ALERTS, PROVIDER: ",@ALTVMAP@("ALERTSOURCEID"),! - . N ACGL1,ACGFI,ACIEN,ACVUID,ACNM,ACTMP - . S ACGL1=$P(@ALTG@(ALTTMP),U,9) ; ADDRESS OF THE REACTANT XX;GLB(YY.Z, - . S ACGFI=$$PRSGLB($P(ACGL1,";",2)) ; FILE NUMBER - . S ACIEN=$P(ACGL1,";",1) ; IEN OF REACTANT - . S ACVUID=$$GET1^DIQ(ACGFI,ACIEN,"VUID") ; VUID OF THE REACTANT - . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="PRODUCT_"_ACIEN ; IE OF REACTANT - . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="" ; WHERE DO WE GET THIS? - . S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT - . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM - . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ACVUID - . I ACVUID'="" D ; IF VUID IS NOT NULL - . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="VUID" - . E D ; IF REACTANT CODE VALUE IS NULL - . . I $G(DUZ("AG"))="I" D ; IF WE ARE RUNNING ON RPMS - . . . S ACTMP=$O(^C0CCODES(176.112,"C",ACNM,0)) ; - . . . W "RPMS NAME FOUND",ACNM," ",ACTMP,! - . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="" - . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="" - . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW - . N ARTMP,ARIEN,ARDES,ARVUID - . S (ARTMP,ARDES,ARVUID)="" - . I $D(@ALTG@(ALTTMP,"S",1)) D ; IF REACTION EXISTS - . . S ARTMP=@ALTG@(ALTTMP,"S",1) - . . W "REACTION:",ARTMP,! - . . S ARIEN=$P(ARTMP,";",2) - . . S ARDES=$P(ARTMP,";",1) - . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID") - . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES - . I ARVUID'="" D ; IF REACTION VUID IS NOT NULL - . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID - . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID" - . E D ; IF IT IS NULL DON'T SET CODE SYSTEM - . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")="" - . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="" - . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) - . ; NOW GO TO THE GLOBAL TO GET THE DATE/TIME AND BETTER DESCRIPTION - . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL - . D GETN1^C0CRNF("C0CG1",120.8,DFN,"B") ;GET VALUES BY NAME - . S C0CT=$$ZVALUEI^C0CRNF("ORIGINATION DATE/TIME","C0CG1") - . S @ALTVMAP@("ALERTDATETIME")=$$FMDTOUTC^CCRUTIL(C0CT) - . K @ALTARYTMP - . D MAP^GPLXPATH(ALTXML,ALTVMAP,ALTARYTMP) - . I ALTCNT=1 D CP^GPLXPATH(ALTARYTMP,ALTOUTXML) - . I ALTCNT>1 D INSINNER^GPLXPATH(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/trunk/p/GPLCCD.m =================================================================== --- ccr/trunk/p/GPLCCD.m (revision 389) +++ ccr/trunk/p/GPLCCD.m (revision 391) @@ -1,6 +1,7 @@ -GPLCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 +C0CCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/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. + ;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 @@ -29,12 +30,12 @@ ; XPAT(DFN,DIR,FN) ; EXPORT ONE PATIENT TO A FILE - ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("GPLCCR","ODIR") + ; 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("GPLCCR",$J,DFN,"CCD",1)) + 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("GPLCCR","ODIR")) + S ODIRGLB=$NA(^TMP("C0CCCR","ODIR")) I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET . S @ODIRGLB="/home/glilly/CCROUT" @@ -44,5 +45,5 @@ I DIR="" S ODIR=@ODIRGLB N ZY - S ZY=$$OUTPUT^GPLXPATH(OARY,ONAM,ODIR) + S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR) W $P(ZY,U,2) Q @@ -62,13 +63,13 @@ 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("GPLCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE - I CCD S CCDGLO=$NA(^TMP("GPLCCR",$J,DFN,"CCD")) ; GLOBAL FOR THE CCD - E S CCDGLO=$NA(^TMP("GPLCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR - S ACTGLO=$NA(^TMP("GPLCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS + 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("GPLCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL - I CCD D LOAD^GPLCCD1(TGLOBAL) ; LOAD THE CCR TEMPLATE - E D LOAD^GPLCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE - D CP^GPLXPATH(TGLOBAL,CCDGLO) ; COPY THE TEMPLATE TO CCR GLOBAL + 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 @@ -81,7 +82,7 @@ ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES - D REPLACE^GPLXPATH(CCDGLO,"","//ContinuityOfCareRecord/Body") - D REPLACE^GPLXPATH(CCDGLO,"","//ContinuityOfCareRecord/Actors") - I 'CCD D REPLACE^GPLXPATH(CCDGLO,"","//ContinuityOfCareRecord/Signatures") + 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),! ; @@ -89,17 +90,17 @@ ; MAPPING THE PATIENT PORTION OF THE CDA HEADER S ZZX="//ContinuityOfCareRecord/recordTarget/patientRole/patient" - D QUERY^GPLXPATH(CCDGLO,ZZX,"ACTT1") - D PATIENT^GPLACTOR("ACTT1",DFN,"ACTORPATIENT_"_DFN,"ACTT2") ; MAP PATIENT - I DEBUG D PARY^GPLXPATH("ACTT2") - D REPLACE^GPLXPATH(CCDGLO,"ACTT2",ZZX) - I DEBUG D PARY^GPLXPATH(CCDGLO) + 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^GPLACTOR(CCDGLO,DFN,"ACTORPATIENTORGANIZATION","ACTT2") ; MAP ORG - D CP^GPLXPATH("ACTT2",CCDGLO) - ; - K ^TMP("GPLCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT - S CCRXTAB=$NA(^TMP("GPLCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS + 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 @@ -109,5 +110,5 @@ . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE - . D QUERY^GPLXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS + . 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 @@ -118,18 +119,18 @@ . X CALL . I @OXML@(0)'=0 D ; THERE IS A RESULT - . . I CCD D QUERY^GPLXPATH(TGLOBAL,XPATH,"ITMP") ; XML TO UNSHAVE WITH + . . I CCD D QUERY^C0CXPATH(TGLOBAL,XPATH,"ITMP") ; XML TO UNSHAVE WITH . . I CCD D UNSHAVE("ITMP",OXML) - . . I CCD D UNMARK^GPLXPATH(OXML) ; REMOVE THE CCR MARKUP FROM SECTION + . . I CCD D UNMARK^C0CXPATH(OXML) ; REMOVE THE CCR MARKUP FROM SECTION . ; NOW INSERT THE RESULTS IN THE CCR BUFFER - . D INSERT^GPLXPATH(CCDGLO,OXML,"//ContinuityOfCareRecord/Body") - . I DEBUG F GPLI=1:1:@OXML@(0) W @OXML@(GPLI),! + . 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^GPLCCR(CCDGLO,ACTGLO) ; GEN THE ACTOR LIST - ; D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") - ; D EXTRACT^GPLACTOR("ACTT",ACTGLO,"ACTT2") - ; D INSINNER^GPLXPATH(CCDGLO,"ACTT2","//ContinuityOfCareRecord/Actors") + ; 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^GPLXPATH(CCDGLO) ; DELETE EMPTY ELEMENTS + . S J=$$TRIM^C0CXPATH(CCDGLO) ; DELETE EMPTY ELEMENTS . W "TRIMMED",J,! . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE @@ -149,7 +150,7 @@ W "TAB= ",TAB,! ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS - D PUSH^GPLXPATH(TAB,"EXTRACT;GPLPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""GPLCCR"",$J,DFN,""PROBLEMS"")") - ;D PUSH^GPLXPATH(TAB,"EXTRACT;GPLMEDS;//ContinuityOfCareRecord/Body/Medications;^TMP(""GPLCCR"",$J,DFN,""MEDICATIONS"")") - I 'CCD D PUSH^GPLXPATH(TAB,"EXTRACT;GPLVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""GPLCCR"",$J,DFN,""VITALS"")") + D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")") + ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMEDS;//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 ; @@ -159,10 +160,10 @@ W SHXML,! W @SHXML@(1),! - D QUEUE^GPLXPATH("SHBLD",SHXML,1,1) ; THE FIRST LINE IS NEEDED - D QUEUE^GPLXPATH("SHBLD",SHXML,7,@SHXML@(0)-3) ; REPEATING PART - D QUEUE^GPLXPATH("SHBLD",SHXML,@SHXML@(0),@SHXML@(0)) ; LAST LINE - D PARY^GPLXPATH("SHBLD") ; PRINT BUILD LIST - D BUILD^GPLXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION - D CP^GPLXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY + 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 ; @@ -172,14 +173,14 @@ W SHXML,! W @SHXML@(1),! - D QUEUE^GPLXPATH("SHBLD",ORIGXML,1,6) ; FIRST 6 LINES OF TEMPLATE - D QUEUE^GPLXPATH("SHBLD",SHXML,2,@SHXML@(0)-1) ; INS ALL BUT FIRST/LAST - D QUEUE^GPLXPATH("SHBLD",ORIGXML,@ORIGXML@(0)-2,@ORIGXML@(0)) ; FROM TEMP - D PARY^GPLXPATH("SHBLD") ; PRINT BUILD LIST - D BUILD^GPLXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION - D CP^GPLXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY + 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("GPLCCR",$J,DFN,"HEADER")) + N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER")) ; K @VMAP S @VMAP@("DATETIME")=$$FMDTOUTC^CCRUTIL($$NOW^XLFDT,"DT") @@ -193,8 +194,8 @@ . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT I IHDR'="" D ; HEADER VALUES ARE PROVIDED - . D CP^GPLXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY + . D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY N CTMP - D MAP^GPLXPATH(CXML,VMAP,"CTMP") - D CP^GPLXPATH("CTMP",CXML) + D MAP^C0CXPATH(CXML,VMAP,"CTMP") + D CP^C0CXPATH("CTMP",CXML) Q ; @@ -221,51 +222,51 @@ . 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^GPLXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY + . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY Q ; TEST ; RUN ALL THE TEST CASES - D TESTALL^GPLUNIT("GPLCCR") + D TESTALL^C0CUNIT("C0CCCR") Q ; ZTEST(WHICH) ; RUN ONE SET OF TESTS N ZTMP - D ZLOAD^GPLUNIT("ZTMP","GPLCCR") - D ZTEST^GPLUNIT(.ZTMP,WHICH) + D ZLOAD^C0CUNIT("ZTMP","C0CCCR") + D ZTEST^C0CUNIT(.ZTMP,WHICH) Q ; TLIST ; LIST THE TESTS N ZTMP - D ZLOAD^GPLUNIT("ZTMP","GPLCCR") - D TLIST^GPLUNIT(.ZTMP) + D ZLOAD^C0CUNIT("ZTMP","C0CCCR") + D TLIST^C0CUNIT(.ZTMP) Q ; ;;> ;;> - ;;>>>K GPL S GPL="" - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","PROBLEMS","","","") - ;;>>?@GPL@(@GPL@(0))["" + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","","","") + ;;>>?@C0C@(@C0C@(0))["" ;;> - ;;>>>K GPL S GPL="" - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","VITALS","","","") - ;;>>?@GPL@(@GPL@(0))["" + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","","","") + ;;>>?@C0C@(@C0C@(0))["" ;;> - ;;>>>K GPL S GPL="" - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") - ;;>>?@GPL@(@GPL@(0))["" + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","") + ;;>>?@C0C@(@C0C@(0))["" ;;> - ;;>>>K GPL S GPL="" - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") - ;;>>>D ACTLST^GPLCCR(GPL,"ACTTEST") + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","") + ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST") ;;> - ;;>>>D ZTEST^GPLCCR("ACTLST") - ;;>>>D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") - ;;>>>D EXTRACT^GPLACTOR("G2","ACTTEST","G3") + ;;>>>D ZTEST^C0CCCR("ACTLST") + ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") + ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3") ;;>>?G3(G3(0))["" ;;> - ;;>>>D ZTEST^GPLCCR("CCR") - ;;>>>W $$TRIM^GPLXPATH(CCDGLO) + ;;>>>D ZTEST^C0CCCR("CCR") + ;;>>>W $$TRIM^C0CXPATH(CCDGLO) ;;> - ;;>>>K GPL S GPL="" - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCD","","","") - ;;>>?@GPL@(@GPL@(0))["" + ;;>>>K C0C S C0C="" + ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCD","","","") + ;;>>?@C0C@(@C0C@(0))["" ;;> Index: ccr/trunk/p/GPLCCD1.m =================================================================== --- ccr/trunk/p/GPLCCD1.m (revision 389) +++ (revision ) @@ -1,267 +1,0 @@ -GPLCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/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 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,"GPLCCD1") - ; ZWR @ARY - Q - ; -TRMCCD ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD - Q -MARKUP ; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ;; - ; - ;; - ;; - Q - ; - ; Index: ccr/trunk/p/GPLCCR.m =================================================================== --- ccr/trunk/p/GPLCCR.m (revision 389) +++ (revision ) @@ -1,236 +1,0 @@ -GPLCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/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. - ; - ; 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("GPLCCR","ODIR") - ; FN IS FILE NAME, DEFAULTS IF NULL - N CCRGLO,UDIR,UFN - I '$D(DIR) S UDIR="" - E S UDIR=DIR - I '$D(FN) S UFN="" - E S UFN=FN - I '$D(XPARMS) S XPARMS="" - D CCRRPC(.CCRGLO,DFN,XPARMS,"CCR") - S OARY=$NA(^TMP("GPLCCR",$J,DFN,"CCR",1)) - S ONAM=UFN - I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_18.xml" - S ODIRGLB=$NA(^TMP("GPLCCR","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=UDIR - I UDIR="" S ODIR=@ODIRGLB - N ZY - S ZY=$$OUTPUT^GPLXPATH(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("GPLCCR",$J,DFN,"CCR")) - I $D(@G1@(0)) D ; CCR EXISTS - . D PARY^GPLXPATH(G1) - E W "CCR NOT CREATED, RUN D XPAT^GPLCCR(DFN,"""","""") FIRST",! - Q - ; -CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART) ;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 - ; 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 - I '$D(DEBUG) S DEBUG=0 - S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD - D SET^C0CPARMS(CCRPARMS) ;SET PARAMETERS WITH CCRPARMS AS OVERRIDES - 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 CCRMEDS SECTION - S TGLOBAL=$NA(^TMP("GPLCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE - S CCRGLO=$NA(^TMP("GPLCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR - S ACTGLO=$NA(^TMP("GPLCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS - ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC - S CCRGRTN=$NA(^TMP("GPLCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL - D LOAD^GPLCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE - D CP^GPLXPATH(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^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body") - D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") - D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") - I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! - ; - D HDRMAP(CCRGLO,DFN) ; MAP HEADER VARIABLES - ; - K ^TMP("GPLCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT - S CCRXTAB=$NA(^TMP("GPLCCR",$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^GPLXPATH(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 @OXML@(0)'=0 D ; THERE IS A RESULT - . . D INSERT^GPLXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body") - . . I DEBUG F GPLI=1:1:@OXML@(0) W @OXML@(GPLI),! - N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING - D ACTLST^GPLCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST - D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") - D EXTRACT^GPLACTOR("ACTT",ACTGLO,"ACTT2") - D INSINNER^GPLXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors") - N TRIMI,J,DONE S DONE=0 - F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE - . S J=$$TRIM^GPLXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS - . I DEBUG W "TRIMMED",J,! - . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE - 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^GPLXPATH(TAB,"EXTRACT;GPLPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""GPLCCR"",$J,DFN,""PROBLEMS"")") - D PUSH^GPLXPATH(TAB,"EXTRACT;CCRMEDS;//ContinuityOfCareRecord/Body/Medications;^TMP(""GPLCCR"",$J,DFN,""MEDICATIONS"")") - D PUSH^GPLXPATH(TAB,"EXTRACT;GPLVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""GPLCCR"",$J,DFN,""VITALS"")") - D PUSH^GPLXPATH(TAB,"MAP;GPLLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""GPLCCR"",$J,DFN,""RESULTS"")") - D PUSH^GPLXPATH(TAB,"MAP;GPLIMMU;//ContinuityOfCareRecord/Body/Immunizations;^TMP(""GPLCCR"",$J,DFN,""IMMUNE"")") - I TESTALERT D PUSH^GPLXPATH(TAB,"EXTRACT;GPLALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""GPLCCR"",$J,DFN,""ALERTS"")") - Q - ; -HDRMAP(CXML,DFN) ; MAP HEADER VARIABLES: FROM, TO ECT - N VMAP S VMAP=$NA(^TMP("GPLCCR",$J,DFN,"HEADER")) - ; K @VMAP - S @VMAP@("DATETIME")=$$FMDTOUTC^CCRUTIL($$NOW^XLFDT,"DT") - ; I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS - D ; ALWAYS MAP THESE VARIABLES - . 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^GPLXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY - N CTMP - D MAP^GPLXPATH(CXML,VMAP,"CTMP") - D CP^GPLXPATH("CTMP",CXML) - N HRIMVARS ; - S HRIMVARS=$NA(^TMP("GPLRIM","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 ; SCAN ALL LINES - . I @AXML@(I)?.E1"".E D ; THERE IS AN ACTOR THIS LINE - . . S J=$P($P(@AXML@(I),"",2),"",1) - . . I DEBUG 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^GPLXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY - Q - ; -TEST ; RUN ALL THE TEST CASES - D TESTALL^GPLUNIT("GPLCCR") - Q - ; -ZTEST(WHICH) ; RUN ONE SET OF TESTS - N ZTMP - D ZLOAD^GPLUNIT("ZTMP","GPLCCR") - D ZTEST^GPLUNIT(.ZTMP,WHICH) - Q - ; -TLIST ; LIST THE TESTS - N ZTMP - D ZLOAD^GPLUNIT("ZTMP","GPLCCR") - D TLIST^GPLUNIT(.ZTMP) - Q - ; - ;;> - ;;> - ;;>>>K GPL S GPL="" - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","PROBLEMS","","","") - ;;>>?@GPL@(@GPL@(0))["" - ;;> - ;;>>>K GPL S GPL="" - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","VITALS","","","") - ;;>>?@GPL@(@GPL@(0))["" - ;;> - ;;>>>K GPL S GPL="" - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") - ;;>>?@GPL@(@GPL@(0))["" - ;;> - ;;>>>K GPL S GPL="" - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","") - ;;>>>D ACTLST^GPLCCR(GPL,"ACTTEST") - ;;> - ;;>>>D ZTEST^GPLCCR("ACTLST") - ;;>>>D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") - ;;>>>D EXTRACT^GPLACTOR("G2","ACTTEST","G3") - ;;>>?G3(G3(0))["" - ;;> - ;;>>>D ZTEST^GPLCCR("CCR") - ;;>>>W $$TRIM^GPLXPATH(CCRGLO) - ;;> - ;;>>>S TESTALERT=1 - ;;>>>K GPL S GPL="" - ;;>>>D CCRRPC^GPLCCR(.GPL,"2","ALERTS","","","") - ;;>>?@GPL@(@GPL@(0))["" - Index: ccr/trunk/p/GPLIMMU.m =================================================================== --- ccr/trunk/p/GPLIMMU.m (revision 389) +++ (revision ) @@ -1,106 +1,0 @@ -GPLIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09 - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 7 - ;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. - ; - ; - ; 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("GPLCCR",$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^GPLXPATH(IPXML,C0CZVI,"C0CZT") ;MAP THE VARIABLES TO XML - . . I C0CZI=1 D ; FIRST ONE - . . . D CP^GPLXPATH("C0CZT",OUTXML) ;JUST COPY RESULTS - . . E D ;NOT THE FIRST - . . . D INSINNER^GPLXPATH(OUTXML,"C0CZT") - E S @OUTXML@(0)=0 ; SIGNAL NO IMMUNIZATIONS - N IMMUTMP,I - D MISSING^GPLXPATH(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^GPLXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT - ; - N RPCRSLT,J,K,PTMP,X,VMAP,TBU - S TVMAP=$NA(^TMP("GPLCCR",$J,"IMMUNE")) - S TARYTMP=$NA(^TMP("GPLCCR",$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^CCRUTIL(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("GPLRIM","VARS",DFN,"IMMUNE")) - M @C0CIRIM=@TVMAP ; PERSIST RIM VARIABLES - Q - ; Index: ccr/trunk/p/GPLLABS.m =================================================================== --- ccr/trunk/p/GPLLABS.m (revision 389) +++ (revision ) @@ -1,386 +1,0 @@ -GPLALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 - ;;0.3;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. - ; -;MAP(DFN,MOXML,MIVAR,MIXML) ; MAP RESULTS VARIABLES TO XML - GPL -TBD -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("GPLCCR",$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^GPLCCR0("C0CT0") ; LOAD ENTIRE CCR TEMPLATE - . D QUERY^GPLXPATH("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("GPLCCR",$J,"RESULTS")) ;DEFAULT VARIABLE LOCATION - E S C0CV=RMIVAR ; PASSED LOCATIONS OF VARS - D CP^GPLXPATH(C0CT,"C0CRT") ; START MAKING TEST REQUEST TEMPLATE - D REPLACE^GPLXPATH("C0CRT","","//Results/Result/Test") ; DELETE TEST FROM REQ - D QUERY^GPLXPATH(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^GPLXPATH("C0CT") ; SECTION TEMPLATE - . ;D PARY^GPLXPATH("C0CRT") ;REQUEST TEMPLATE (OCR) - . ;D PARY^GPLXPATH("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("GPLRIM","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^GPLXPATH("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^GPLXPATH("C0CRT",C0CMAP,C0CRTMP) ; MAP OBR DATA - . ;D QOPEN^GPLXPATH("C0CRBLD",C0CRTMP,C0CIS) ;1ST PART OF XML - . D QUEUE^GPLXPATH("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^GPLXPATH("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^GPLXPATH("C0CRBLD",C0CTMP,C0CJS,C0CJE) ; ADD TO BUILD LIST - . . . ;I C0CJ=1 D ; FIRST TIME, JUST COPY - . . . ;. D CP^GPLXPATH("C0CTMP","C0CTO") ; START BUILDING TEST XML - . . . ;E D INSINNER^GPLXPATH("C0CTO","C0CTMP") - . . . ; - . . . ;D PUSHA^GPLXPATH("C0CTO",C0CTMP) ;ADD THE TEST TO BUFFER - . . ; I 'C0CQT D PARY^GPLXPATH("C0CTO") - . . ;D INSINNER^GPLXPATH(C0CRTMP,"C0CTO","//Results/Result/Test") ;INSERT TST - . ;D QCLOSE^GPLXPATH("C0CRBLD",C0CRTMP,"//Results/Result/Test") ;END OF XML - . D QUEUE^GPLXPATH("C0CRBLD","C0CRT",C0CRT(0)-1,C0CRT(0)-1) ; - . ;I C0CI=1 D ; FIRST TIME, COPY INSTEAD OF INSERT - . . ;D CP^GPLXPATH(C0CRTMP,"RTN") ; - . ;E D INSINNER^GPLXPATH("RTN",C0CRTMP) ; INSERT THIS TEST REQUEST - D QUEUE^GPLXPATH("C0CRBLD","C0CRT",C0CRT(0),C0CRT(0)) ; - D BUILD^GPLXPATH("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("GPLCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS - D GHL7 ; GET HL7 MESSAGE FOR THIS PATIENT - I C0CNSSN=1 D Q ; NO SSN, CAN'T GET HL7 FOR THIS PATIENT - . S @C0CLB@(0)=0 - K @C0CLB ; CLEAR OUT OLD VARS IF ANY - N QTSAV S QTSAV=C0CQT ;SAVE QUIET FLAG - S C0CQT=1 ; SURPRESS LISTING - D LIST ; EXTRACT THE VARIABLES - S C0CQT=QTSAV ; RESET SILENT FLAG - K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT - I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^GPLLABS - 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^CCRDPT(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("GPLCCR","RPMS")) D ; RUNNING RPMS - ;. D DT^DILF(,"T-365",.C0CSDT) ; START DATE ONE YEAR AGO TO LIMIT VOLUME - ;E D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING - ;D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY - S C0CLLMT=$$GET^C0CPARMS("LABLIMIT") ; GET THE LIMIT PARM - S C0CLSTRT=$$GET^C0CPARMS("LABSTART") ; GET START PARM - D DT^DILF(,C0CLLMT,.C0CSDT) ; - W "LAB LIMIT: ",C0CLLMT,! - D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM - S C0CR=$$GCPR^LA7QRY(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("GPLCCR",$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("GPLCCR","LABTBL",0)) D SETTBL ;INITIALIZE LAB TABLE - I ^TMP("GPLCCR","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("GPLCCR","LABTBL")) ; BASE OF OBX TABLE - S C0CHB=$NA(^TMP("HLS",$J)) - S C0CI="" - S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT - F S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI="" D ; FOR ALL RECORDS IN HL7 MSG - . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES - . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) - . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT) - . M XV=C0CVAR ; - . I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION - . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT - . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT - . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS - . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI - . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR - . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1) - . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT - . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL - . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^CCRUTIL(C0CX2,"DT") ;UTC TIME - . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS - . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION - . I C0CTYP="OBX" D ; SPECIAL CASE FOR OBX3 - . . ; RESULTTESTCODEVALUE - . . ; RESULTTESTDESCRIPTIONTEXT - . . I C0CVAR("C3")="LN" D ; PRIMARY CODE IS LOINC - . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE - . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC - . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESCRIPTION TEXT - . . E I C0CVAR("C6")="LN" D ; SECONDARY CODE IS LOINC - . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE - . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC - . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT - . . E I C0CVAR("C6")'="" D ; NO LOINC CODES, USE SECONDARY IF PRESENT - . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE - . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME - . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT - . . E D ; NO SECONDARY, USE PRIMARY - . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE - . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME - . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT - . . N C0CZG S C0CZG=XV("RESULTTESTNORMALDESCTEXT") ; - . . S XV("RESULTTESTNORMALDESCTEXT")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE - . . S C0CZG=XV("RESULTTESTVALUE") - . . S XV("RESULTTESTVALUE")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE - . 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^CCRUTIL(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("GPLRIM","VARS",DFN,"RESULTS") - ;M ^TMP("GPLRIM","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("GPLCCR",$J,DFN,"CCR",1)) - S GF="RPMS_CCR_"_DFN_"_"_DT_".xml" - S GD=^TMP("GPLCCR","ODIR") - W $$OUTPUT^GPLXPATH(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("GPLCCR","LABTBL") - M ^TMP("GPLCCR","LABTBL")=X ; SET VALUES IN LAB TBL - S ^TMP("GPLCCR","LABTBL",0)="V3" - Q - ; Index: ccr/trunk/p/GPLPROBS.m =================================================================== --- ccr/trunk/p/GPLPROBS.m (revision 389) +++ (revision ) @@ -1,114 +1,0 @@ -GPLPROBS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08 - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 7 - ;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. - ; - ; - ; 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^GPLXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT - ; - N RPCRSLT,J,K,PTMP,X,VMAP,TBU - S TVMAP=$NA(^TMP("GPLCCR",$J,"PROBVALS")) - S TARYTMP=$NA(^TMP("GPLCCR",$J,"PROBARYTMP")) - K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES - I '$T(GET^BGOPRB) D ; IF BGOPRB ROUTINE IS MISSING (IE RPMS) - . D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC - E D GET^BGOPROB(.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",1:"") - . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3) - . S @VMAP@("PROBLEMCODINGVERSION")="" - . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4) - . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^CCRUTIL($P(PTMP,U,5),"DT") - . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^CCRUTIL($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^CCRUTIL($P(PTMP,U,15),"DT") - . S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^CCRUTIL($P(PTMP,U,16),"DT") - . S ARYTMP=$NA(@TARYTMP@(J)) - . ; W "ARYTMP= ",ARYTMP,! - . K @ARYTMP - . D MAP^GPLXPATH(IPXML,VMAP,ARYTMP) ; - . I J=1 D ; FIRST ONE IS JUST A COPY - . . ; W "FIRST ONE",! - . . D CP^GPLXPATH(ARYTMP,OUTXML) - . . ; W "OUTXML ",OUTXML,! - . I J>1 D ; AFTER THE FIRST, INSERT INNER XML - . . D INSINNER^GPLXPATH(OUTXML,ARYTMP) - ; ZWR ^TMP("GPLCCR",$J,"PROBVALS",*) - ; ZWR ^TMP("GPLCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS - ; ZWR @OUTXML - ; $$HTML^DILF( - ; GENERATE THE NARITIVE HTML FOR THE CCD - I CCD D ; IF THIS IS FOR A CCD - . N HTMP,HOUT,HTMLO,GPLPROBI,ZX - . F GPLPROBI=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM - . . S VMAP=$NA(@TVMAP@(GPLPROBI)) - . . I DEBUG W "VMAP =",VMAP,! - . . D QUERY^GPLXPATH(TGLOBAL,"//ContinuityOfCareRecord/Body/PROBLEMS-HTML","HTMP") ; GET THE HTML FROM THE TEMPLATE - . . D UNMARK^GPLXPATH("HTMP") ; REMOVE MARKUP - . . ; D PARY^GPLXPATH("HTMP") ; PRINT IT - . . D MAP^GPLXPATH("HTMP",VMAP,"HOUT") ; MAP THE VARIABLES - . . ; D PARY^GPLXPATH("HOUT") ; PRINT IT AGAIN - . . I GPLPROBI=1 D ; FIRST ONE IS JUST A COPY - . . . D CP^GPLXPATH("HOUT","HTMLO") - . . I GPLPROBI>1 D ; AFTER THE FIRST, INSERT INNER HTML - . . . I DEBUG W "DOING INNER",! - . . . N HTMLBLD,HTMLTMP - . . . D QUEUE^GPLXPATH("HTMLBLD","HTMLO",1,HTMLO(0)-1) - . . . D QUEUE^GPLXPATH("HTMLBLD","HOUT",2,HOUT(0)-1) - . . . D QUEUE^GPLXPATH("HTMLBLD","HTMLO",HTMLO(0),HTMLO(0)) - . . . D BUILD^GPLXPATH("HTMLBLD","HTMLTMP") - . . . D CP^GPLXPATH("HTMLTMP","HTMLO") - . . . ; D INSINNER^GPLXPATH("HOUT","HTMLO","//") - . I DEBUG D PARY^GPLXPATH("HTMLO") - . D INSB4^GPLXPATH(OUTXML,"HTMLO") ; INSERT AT TOP OF SECTION - N PROBSTMP,I - D MISSING^GPLXPATH(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/trunk/p/GPLRIMA.m =================================================================== --- ccr/trunk/p/GPLRIMA.m (revision 389) +++ (revision ) @@ -1,490 +1,0 @@ -GPLRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/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. - ; - ; 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^GPLRIMA 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 - 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^GPLRIMA",! - 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^GPLCCR(.CCRGLO,RIMDFN,APARMS,"CCR") ;PROCESS THE CCR - . W RIMDFN,! - . ; - . ; COPY ALL THE VARIABLES TO THE RIM MAP AREA INDEXED BY PATIENT - . ; - . I $D(^TMP("GPLCCR",$J,"PROBVALS",1)) D ; PROBLEM VARS EXISTS - . . M @RIMBASE@("VARS",RIMDFN,"PROBLEMS")=^TMP("GPLCCR",$J,"PROBVALS") - . . S @RIMBASE@("VARS",RIMDFN,"PROBLEMS",0)=^TMP("GPLCCR",$J,"PROBVALS",0) - . I $D(^TMP("GPLCCR",$J,"VITALS",1)) D ; VITALS VARS EXISTS - . . M @RIMBASE@("VARS",RIMDFN,"VITALS")=^TMP("GPLCCR",$J,"VITALS") - . I $D(^TMP("GPLCCR",$J,"MEDMAP",1)) D ; MEDS VARS EXISTS - . . M @RIMBASE@("VARS",RIMDFN,"MEDS")=^TMP("GPLCCR",$J,"MEDMAP") - . I $D(^TMP("GPLCCR",$J,"ALERTS",1,"ALERTOBJECTID")) D ; ALERTS EXIST - . . W "FOUND ALERT VARS",! - . . M @RIMBASE@("VARS",RIMDFN,"ALERTS")=^TMP("GPLCCR",$J,"ALERTS") - . I $D(^TMP("GPLCCR",$J,"RESULTS",0)) D ; RESULTS EXIST - . . W "FOUND RESULTS VARS",! - . . M @RIMBASE@("VARS",RIMDFN,"RESULTS")=^TMP("GPLCCR",$J,"RESULTS") - . K ^TMP("GPLCCR",$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^CCRSYS(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^GPLXPATH(@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^GPLRIMA(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^GPLXPATH("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 - W "ATTRIBUTES: ",SATTR,! - Q SATTR - ; -RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES - K ^TMP("GPLRIM","RESUME") - K ^TMP("GPLRIM") - 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^GPLXPATH(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^GPLXPATH(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 - ; -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) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT - ; - 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^GPLCCR(ZI,"","") ; 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("GPLRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT - . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT - S ATTR=^TMP("GPLRIM","ATTR",DFN) - I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q ;NO ATTRIBUTES FOUND - I $D(^TMP("GPLRIM","RIMTBL","CATS",ATTR)) D ; FOUND A CAT - . N CAT - . S CAT=$P(^TMP("GPLRIM","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("GPLRIM")) - I '$D(@RIMBASE) S @RIMBASE="" - I '$D(RIMTBL) S RIMTBL=$NA(^TMP("GPLRIM","RIMTBL","TABLE")) ; ATTR TABLE - S ^TMP("GPLRIM","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") - 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^GPLXPATH("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 ; - . D PARY^GPLXPATH("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" D ; - . . D ZGVWRK(ZZGI) ; DO EACH SECTION - . . 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 - E D ; VARS EXIST - . N ZGVI - . F ZGVI=1:1:@ZZGN@(0) 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)) - . . W ZZGN2,!,$O(@ZZGN2@("")),! - . . D H2ARY^GPLXPATH("ZZGA",ZZGN2,ZGVI) ; CONVERT HASH TO ARRAY - . . ; D PARY^GPLXPATH("ZZGA") - . . D PUSHA^GPLXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN - Q - ; -DPATV(DFN,IWHICH) ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN GPLRIM - ; ALONG WITH SAMPLE VALUES. - ; IWHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","HEADER" - N GTMP - I '$D(^TMP("GPLRIM","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^GPLXPATH("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("GPLRIM","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/trunk/p/GPLSNOA.m =================================================================== --- ccr/trunk/p/GPLSNOA.m (revision 389) +++ (revision ) @@ -1,197 +1,0 @@ -GPLSNOA ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/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. - ; - ; 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^GPLSNOA 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^GPLSNOA",! - F SNOI=1:1:IENCNT D Q:+SNOIEN=0 ; FOR IENCNT NUMBER OF PATIENTS OR END - . ;D CCRRPC^GPLCCR(.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^GPLXPATH(@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("GPLSNO")) - I '$D(@SNOBASE) S @SNOBASE="" - I '$D(GMRBASE) S GMRBASE=$NA(^GMRD(120.82)) - I '$D(SNOTBL) S SNOTBL=$NA(^TMP("GPLSNO","SNOTBL","TABLE")) ; ATTR TABLE - S ^TMP("GPLSNO","TABLES","SNOTBL")=SNOTBL ; TABLE OF TABLES - Q - ; -AINIT ; INITIALIZE ATTRIBUTE TABLE - I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS - K @SNOTBL - D APUSH^GPLRIMA(SNOTBL,"CODE") - D APUSH^GPLRIMA(SNOTBL,"NOCODE") - D APUSH^GPLRIMA(SNOTBL,"MULTICODE") - D APUSH^GPLRIMA(SNOTBL,"SUBMULTI") - D APUSH^GPLRIMA(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 ; GPL - 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^GPLRIMA(.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^GPLSNOA(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("GPLSNO","RESUME") - K ^TMP("GPLSNO") - 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^GPLXPATH(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^GPLXPATH(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("GPLSAV") AND PUT THEM IN A DATABASE - ; - D ASETUP - D AINIT - N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH - S SAVBASE=$NA(^TMP("GPLSAV","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/trunk/p/GPLUNIT.m =================================================================== --- ccr/trunk/p/GPLUNIT.m (revision 389) +++ (revision ) @@ -1,156 +1,0 @@ -GPLUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/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 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^GPLXPATH(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^GPLUNIT(@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^GPLXPATH(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^GPLUNIT("TZTMP",RNM) - D GTSTS(.TZTMP,"TSTS") - F ZI=1:1:TSTS(0) D ; - . S TPASSED=0 S TFAILED=0 - . D ZTEST^GPLUNIT(.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 - ; Index: ccr/trunk/p/GPLVITAL.m =================================================================== --- ccr/trunk/p/GPLVITAL.m (revision 389) +++ (revision ) @@ -1,203 +1,0 @@ -GPLVITAL ; CCDCCR/CJE - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 - ;;0.1;CCDCCR;;JUL 16,2008; - ;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(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,.C0CSDT) ; - W "VITALS START: ",C0CVSTRT," LIMIT: ",C0CVLMT,! - D DT^DILF(,C0CVSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM - D VITALS^ORQQVI(.VITRSLT,DFN,C0CSDT,C0CEDT) - 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("GPLCCR",$J,"VITALS")) - S VITTARYTMP=$NA(^TMP("GPLCCR",$J,"VITALARYTMP")) - K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES - N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX - D VITDATES(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY - ; I DEBUG ZWR VDATES ;DEBUG - S VCNT=$$SORTDT^CCRUTIL(.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^CCRUTIL($P(VITPTMP,U,4),"DT"),! - . . I DEBUG W $P(VITPTMP,U,4),! - . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID - . . I $P(VITPTMP,U,2)="HT" D - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($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^CCRUTIL($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^CCRUTIL($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^CCRUTIL($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^CCRUTIL($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^CCRUTIL($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^CCRUTIL($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 D - . . . ;W "IN VITAL: OTHER",! - . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" - . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($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(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) - . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN" - . . S VITARYTMP=$NA(@VITTARYTMP@(J)) - . . K @VITARYTMP - . . D MAP^GPLXPATH(VITXML,VITVMAP,VITARYTMP) - . . I J=1 D ; FIRST ONE IS JUST A COPY - . . . ; W "FIRST ONE",! - . . . D CP^GPLXPATH(VITARYTMP,VITOUTXML) - . . . I DEBUG W "VITOUTXML ",VITOUTXML,! - . . I J>1 D ; AFTER THE FIRST, INSERT INNER XML - . . . D INSINNER^GPLXPATH(VITOUTXML,VITARYTMP) - ; ZWR ^TMP($J,"VITALS",*) - ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS - I DEBUG D PARY^GPLXPATH(VITOUTXML) - N VITTMP,I - D MISSING^GPLXPATH(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 - ; -VITDATES(VDT) ; 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/trunk/p/GPLXPAT0.m =================================================================== --- ccr/trunk/p/GPLXPAT0.m (revision 389) +++ (revision ) @@ -1,212 +1,0 @@ -GPLXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 - ;;0.2;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 "NO ENTRY",! - Q - ; - ;;> - ;;> - ;;>>>K GPL S GPL="" - ;;>>>D PUSH^GPLXPATH("GPL","FIRST") - ;;>>>D PUSH^GPLXPATH("GPL","SECOND") - ;;>>>D PUSH^GPLXPATH("GPL","THIRD") - ;;>>>D PUSH^GPLXPATH("GPL","FOURTH") - ;;>>?GPL(0)=4 - ;;> - ;;>>>K GXML S GXML="" - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","@@DATA1@@") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","@@DATA2@@") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;> - ;;>>>K GXML S GXML="" - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","DATA1") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","DATA2") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","<_SECOND>") - ;;>>>D PUSH^GPLXPATH("GXML","DATA3") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;>>>D PUSH^GPLXPATH("GXML","") - ;;> - ;;>>>D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") - ;;>>>D ZTEST^GPLUNIT(.ZTMP,"INIT") - ;;>>?GPL(GPL(0))="FOURTH" - ;;>>>D POP^GPLXPATH("GPL",.GX) - ;;>>?GX="FOURTH" - ;;>>?GPL(GPL(0))="THIRD" - ;;>>>D POP^GPLXPATH("GPL",.GX) - ;;>>?GX="THIRD" - ;;>>?GPL(GPL(0))="SECOND" - ;;> - ;;>>>D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") - ;;>>>D ZTEST^GPLUNIT(.ZTMP,"INIT") - ;;>>>S GX="" - ;;>>>D MKMDX^GPLXPATH("GPL",.GX) - ;;>>?GX="//FIRST/SECOND/THIRD/FOURTH" - ;;> - ;;>>?$$XNAME^GPLXPATH("DATA1")="FOURTH" - ;;>>?$$XNAME^GPLXPATH("")="SIXTH" - ;;>>?$$XNAME^GPLXPATH("")="THIRD" - ;;> - ;;>>>D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") - ;;>>>D ZTEST^GPLUNIT(.ZTMP,"INITXML") - ;;>>>D INDEX^GPLXPATH("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" - ;;>>?GXML("//FIRST/SECOND/THIRD/SIXTH")="8^8" - ;;>>?GXML("//FIRST/SECOND")="2^12" - ;;>>?GXML("//FIRST")="1^13" - ;;> - ;;>>>D ZTEST^GPLXPATH("INITXML2") - ;;>>>D INDEX^GPLXPATH("GXML") - ;;>>?GXML("//FIRST/SECOND")="2^12" - ;;>>?GXML("//FIRST/SECOND/_SECOND")="9^11" - ;;>>?GXML("//FIRST/SECOND/_SECOND/FOURTH")="10^10" - ;;>>?GXML("//FIRST/SECOND/THIRD")="3^8" - ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^7" - ;;>>?GXML("//FIRST")="1^13" - ;;> - ;;>>>D ZTEST^GPLXPATH("INITXML") - ;;>>>S OUTARY="^TMP($J,""MISSINGTEST"")" - ;;>>>D MISSING^GPLXPATH("GXML",OUTARY) - ;;>>?@OUTARY@(1)="DATA1" - ;;>>?@OUTARY@(2)="DATA2" - ;;> - ;;>>>D ZTEST^GPLXPATH("INITXML") - ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")" - ;;>>>S OUTARY="^TMP($J,""MAPTEST"")" - ;;>>>S @MAPARY@("DATA2")="VALUE2" - ;;>>>D MAP^GPLXPATH("GXML",MAPARY,OUTARY) - ;;>>?@OUTARY@(6)="VALUE2" - ;;> - ;;>>>D ZTEST^GPLXPATH("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^GPLXPATH("GXML",MAPARY,OUTARY) - ;;>>>D PARY^GPLXPATH(OUTARY) - ;;>>?@OUTARY@(4)="VALUE1 AND VALUE3" - ;;> - ;;>>>D QUEUE^GPLXPATH("BTLIST","GXML",2,3) - ;;>>>D QUEUE^GPLXPATH("BTLIST","GXML",4,5) - ;;>>?$P(BTLIST(2),";",2)=4 - ;;> - ;;>>>D ZTEST^GPLXPATH("INITXML") - ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FOURTH","G2") - ;;>>>D ZTEST^GPLXPATH("QUEUE") - ;;>>>D BUILD^GPLXPATH("BTLIST","G3") - ;;> - ;;>>>D ZTEST^GPLXPATH("INITXML") - ;;>>>D CP^GPLXPATH("GXML","G2") - ;;>>?G2(0)=13 - ;;> - ;;>>>K G2,GBL - ;;>>>D ZTEST^GPLXPATH("INITXML") - ;;>>>D QOPEN^GPLXPATH("GBL","GXML") - ;;>>?$P(GBL(1),";",3)=12 - ;;>>>D BUILD^GPLXPATH("GBL","G2") - ;;>>?G2(G2(0))="" - ;;> - ;;>>>K G2,GBL - ;;>>>D ZTEST^GPLXPATH("INITXML") - ;;>>>D QOPEN^GPLXPATH("GBL","GXML","//FIRST/SECOND") - ;;>>?$P(GBL(1),";",3)=11 - ;;>>>D BUILD^GPLXPATH("GBL","G2") - ;;>>?G2(G2(0))="" - ;;> - ;;>>>K G2,GBL - ;;>>>D ZTEST^GPLXPATH("INITXML") - ;;>>>D QCLOSE^GPLXPATH("GBL","GXML") - ;;>>?$P(GBL(1),";",3)=13 - ;;>>>D BUILD^GPLXPATH("GBL","G2") - ;;>>?G2(G2(0))="" - ;;> - ;;>>>K G2,GBL - ;;>>>D ZTEST^GPLXPATH("INITXML") - ;;>>>D QCLOSE^GPLXPATH("GBL","GXML","//FIRST/SECOND/THIRD") - ;;>>?$P(GBL(1),";",3)=13 - ;;>>>D BUILD^GPLXPATH("GBL","G2") - ;;>>?G2(G2(0))="" - ;;>>?G2(1)="" - ;;> - ;;>>>K G2,GBL,G3,G4 - ;;>>>D ZTEST^GPLXPATH("INITXML") - ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2") - ;;>>>D INSERT^GPLXPATH("GXML","G2","//FIRST/SECOND/THIRD") - ;;>>>D INSERT^GPLXPATH("G3","G2","//") - ;;>>?G2(1)=GXML(9) - ;;> - ;;>>>K G2,GBL,G3 - ;;>>>D ZTEST^GPLXPATH("INITXML") - ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2") - ;;>>>D REPLACE^GPLXPATH("GXML","G2","//FIRST/SECOND") - ;;>>?GXML(2)="" - ;;> - ;;>>>K GXML,G2,GBL,G3 - ;;>>>D ZTEST^GPLXPATH("INITXML") - ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD","G2") - ;;>>>D INSINNER^GPLXPATH("GXML","G2","//FIRST/SECOND/THIRD") - ;;>>?GXML(10)="" - ;;> - ;;>>>K GXML,G2,GBL,G3 - ;;>>>D ZTEST^GPLXPATH("INITXML") - ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD","G2") - ;;>>>D INSINNER^GPLXPATH("G2","G2") - ;;>>?G2(8)="" - ;;> - ;;>>>K GTMP,GTMP2 - ;;>>>N GTMP,GTMP2 - ;;>>>D PUSH^GPLXPATH("GTMP","A") - ;;>>>D PUSH^GPLXPATH("GTMP2","B") - ;;>>>D PUSH^GPLXPATH("GTMP2","C") - ;;>>>D PUSHA^GPLXPATH("GTMP","GTMP2") - ;;>>?GTMP(3)="C" - ;;>>?GTMP(0)=3 - ;;> - ;;>>>K GTMP,GTMP2 - ;;>>>S GTMP("TEST1")=1 - ;;>>>D H2ARY^GPLXPATH("GTMP2","GTMP") - ;;>>?GTMP2(0)=1 - ;;>>?GTMP2(1)="^TEST1^1" - ;;> - ;;>>>K GTMP,GTMP2 - ;;>>>D PUSH^GPLXPATH("GTMP","@@VAR1@@") - ;;>>>D XVARS^GPLXPATH("GTMP2","GTMP") - ;;>>?GTMP2(1)="^VAR1^1" - ;;> Index: ccr/trunk/p/GPLXPATH.m =================================================================== --- ccr/trunk/p/GPLXPATH.m (revision 389) +++ (revision ) @@ -1,505 +1,0 @@ -GPLXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 - ;;0.2;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 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) ; MAKES A MUMPS INDEX FROM THE ARRAY STK - ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS - 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) - 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 - ; -INDEX(ZXML) ; parse the XML in ZXML and produce an XPATH index - ; ex. ZXML(FIRST,SECOND,THIRD,FOURTH)=FIRSTLINE^LASTLINE - ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE - ; XML SECTION - ; ZXML IS PASSED BY NAME - N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND - N GPLSTK ; LEAVE OUT FOR DEBUGGING - I '$D(@ZXML@(0)) D ; NO XML PASSED - . W "ERROR IN XML FILE",! - S GPLSTK(0)=0 ; INITIALIZE STACK - F I=1:1:@ZXML@(0) D ; PROCESS THE ENTIRE ARRAY - . S LINE=@ZXML@(I) - . ;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 - . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK - . . . D MKMDX("GPLSTK",.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 - . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE - . . . . S @ZXML@(MDX)=I_"^"_I ; ADD INDEX ENTRY-FIRST AND LAST - . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK - . I FOUND'=1 D ; THE LINE DOESN'T CONTAIN THE START AND END - . . I LINE?.E1"") D ; BEGINNING OF A SECTION - . . . ; W "FOUND ",LINE,! - . . . S FOUND=1 ; SET FOUND FLAG - . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME - . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK - . . . D MKMDX("GPLSTK",.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 - . . . 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^"_@ZXML@(0) ; ROOT XPATH - Q - ; -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 - 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 DEBUG W "ATMP=",ATMP,! - . I DEBUG W @BLIST@(I),! - . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D ; - . . ; FOR EACH LINE IN THIS INSTR - . . I DEBUG W "BDEST= ",BDEST,! - . . I DEBUG W "ATMP= ",@ATMP@(J),! - . . D PUSH(BDEST,@ATMP@(J)) - Q - ; -QUEUE(BLST,ARRAY,FIRST,LAST) ; ADD AN ENTRY TO A BLIST - ; - I 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 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 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 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 DEBUG W "DOING INSERT ",INSXML,INSNEW,INSXPATH,! - I DEBUG F G1=1:1:@INSXML@(0) W @INSXML@(G1),! - I '$D(@INSXML@(0)) D ; INSERT INTO AN EMPTY ARRAY - . D CP^GPLXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT - I $D(@INSXML@(0)) D ; IF ORIGINAL ARRAY IS NOT EMPTY - . I $D(INSXPATH) D ; XPATH PROVIDED - . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE - . . I DEBUG D PARY^GPLXPATH("INSBLD") - . I '$D(INSXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT - . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH - . 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^GPLXPATH("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^GPLXPATH("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 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 DEBUG W "REPLACE PREBUILD",! - I 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^GPLXPATH(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 - I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MAP",! Q - I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q - N I,J,TNAM,TVAL,TSTR - S @OXML@(0)=@IXML@(0) ; TOTAL LINES IN OUTPUT - F I=1:1:@OXML@(0) 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 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 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 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 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 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) ;PRINT AN ARRAY - N I - F I=1:1:@GLO@(0) 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 "GPLZZ",! - . . ; 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^GPLCCR0("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^GPLCCD1("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^GPLXPATH("DVARS") ;AND DISPLAY THEM - Q - ; -TEST ; Run all the test cases - D TESTALL^GPLUNIT("GPLXPAT0") - Q - ; -ZTEST(WHICH) ; RUN ONE SET OF TESTS - N ZTMP - S DEBUG=1 - D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") - D ZTEST^GPLUNIT(.ZTMP,WHICH) - Q - ; -TLIST ; LIST THE TESTS - N ZTMP - D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") - D TLIST^GPLUNIT(.ZTMP) - Q - ;