diff --git a/p/GPLALERT.m b/p/GPLALERT.m index 458fd66..a4cc532 100644 --- a/p/GPLALERT.m +++ b/p/GPLALERT.m @@ -1,65 +1,67 @@ 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 - ; + ;;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 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("GPLALERT",$J,"ALERTS")) - S ALTTARYTMP=$NA(^TMP("GPLALERT",$J,"ALERTSARYTMP")) - K @ALTTVMAP,@ALTTARYTMP - N ALTTMP,ALTCNT S ALTTMP=$NA(GMRAL),ALTCNT=1 - F S ALTTMP=$Q(@ALTTMP) Q:ALTTMP="" D - . I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q - . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT)) - . K @ALTVMAP - . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT - . N ALERTDESCRIPTIONTEXT S ALERTDESCRIPTIONTEXT="Patient has an " ; X $ZINT H 5 - . S ALERTDESCRIPTIONTEXT=ALERTDESCRIPTIONTEXT_$S($P(@ALTTMP,U,4)=1:"ADVERSE",$P(@ALTTMP,U,5)=1:"ALLERGIC",1:"UNKNOWN") - . S ALERTDESCRIPTIONTEXT=ALERTDESCRIPTIONTEXT_" reaction to "_$P(@ALTTMP,U,2)_"." - . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ALERTDESCRIPTIONTEXT - . S @ALTVMAP@("ALERTCODEVALUE")="ALERT CODE VALUE" - . S @ALTVMAP@("ALERTCODESYSTEM")="ALERT CODE SYSTEM" - . S @ALTVMAP@("ALERTSTATUSTEXT")="ALERT STATUS TEXT" - . S @ALTVMAP@("ALERTSOURCEID")="ALERT SOURCE ID" - . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="ALERT AGENT PRODUCT OBJECT ID" - . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="A" - . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")="B" - . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="C" - . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="D" - . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) - . 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 - - Q + ; + ; 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("GPLALERT",$J,"ALERTS")) + S ALTTARYTMP=$NA(^TMP("GPLALERT",$J,"ALERTSARYTMP")) + K @ALTTVMAP,@ALTTARYTMP + N ALTTMP,ALTCNT S ALTTMP=$NA(GMRAL),ALTCNT=1 + F S ALTTMP=$Q(@ALTTMP) Q:ALTTMP="" D + . I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q + . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT)) + . K @ALTVMAP + . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT + . N ADT S ADT="Patient has an " ; X $ZINT H 5 + . S ADT=ADT_$S($P(@ALTTMP,U,4)=1:"ADVERSE",$P(@ALTTMP,U,5)=1:"ALLERGIC",1:"UNKNOWN") + . S ADT=ADT_" reaction to "_$P(@ALTTMP,U,2)_"." + . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT + . S @ALTVMAP@("ALERTCODEVALUE")="ALERT CODE VALUE" + . S @ALTVMAP@("ALERTCODESYSTEM")="ALERT CODE SYSTEM" + . S @ALTVMAP@("ALERTSTATUSTEXT")="ALERT STATUS TEXT" + . S @ALTVMAP@("ALERTSOURCEID")="ALERT SOURCE ID" + . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="ALERT AGENT PRODUCT OBJECT ID" + . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="A" + . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")="B" + . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="C" + . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="D" + . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")="E" + . S @ALTVMAP@("ALERTREACTIONCODEVALUE")="F" + . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="G" + . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) + . 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 + Q diff --git a/p/GPLSNOA.m b/p/GPLSNOA.m index 73609d7..e2654d3 100644 --- a/p/GPLSNOA.m +++ b/p/GPLSNOA.m @@ -174,3 +174,24 @@ CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES ; 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 + ; \ No newline at end of file