Index: ccr/branches/ohum/p/C0CACTOR.m =================================================================== --- ccr/branches/ohum/p/C0CACTOR.m (revision 1332) +++ ccr/branches/ohum/p/C0CACTOR.m (revision 1333) @@ -1,4 +1,4 @@ C0CACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008,2009 George Lilly, University of Minnesota. ;Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CALERT.m =================================================================== --- ccr/branches/ohum/p/C0CALERT.m (revision 1332) +++ ccr/branches/ohum/p/C0CALERT.m (revision 1333) @@ -1,4 +1,4 @@ C0CALERT ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008,2009 George Lilly, University of Minnesota and others. ;Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CBAT.m =================================================================== --- ccr/branches/ohum/p/C0CBAT.m (revision 1332) +++ ccr/branches/ohum/p/C0CBAT.m (revision 1333) @@ -1,4 +1,4 @@ C0CBAT ; CCDCCR/GPL - CCR Batch utilities; 4/21/09 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU ;General Public License See attached copy of the License. Index: ccr/branches/ohum/p/C0CCCD.m =================================================================== --- ccr/branches/ohum/p/C0CCCD.m (revision 1332) +++ ccr/branches/ohum/p/C0CCCD.m (revision 1333) @@ -1,4 +1,4 @@ C0CCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008,2009 George Lilly, University of Minnesota. ;Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CCCD1.m =================================================================== --- ccr/branches/ohum/p/C0CCCD1.m (revision 1332) +++ ccr/branches/ohum/p/C0CCCD1.m (revision 1333) @@ -1,4 +1,4 @@ C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008,2009 George Lilly, University of Minnesota. ;Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CCCR.m =================================================================== --- ccr/branches/ohum/p/C0CCCR.m (revision 1332) +++ ccr/branches/ohum/p/C0CCCR.m (revision 1333) @@ -1,4 +1,4 @@ C0CCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008,2009 George Lilly, University of Minnesota. ;Licensed under the terms of the GNU General Public License. @@ -26,4 +26,7 @@ I Y<1 Q ; EXIT S DFN=$P(Y,U,1) ; SET THE PATIENT + ;OHUM/RUT 3120102 To take inputs from user for date limits and notes + D ^C0CVALID + ;OHUM/RUT D XPAT(DFN) ; EXPORT TO A FILE Q @@ -168,4 +171,7 @@ ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") ; gpl - turned off Encounters for Certification + ;OHUM/RUT 3111228 Condition for Notes ; It should be included or not + I ^TMP("C0CCCR","TIULIMIT")'="" D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") + ;OHUM/RUT Q ; Index: ccr/branches/ohum/p/C0CCCR0.m =================================================================== --- ccr/branches/ohum/p/C0CCCR0.m (revision 1332) +++ ccr/branches/ohum/p/C0CCCR0.m (revision 1333) @@ -1,4 +1,4 @@ C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008,2009 George Lilly, University of Minnesota. ;Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CCMT.m =================================================================== --- ccr/branches/ohum/p/C0CCMT.m (revision 1332) +++ ccr/branches/ohum/p/C0CCMT.m (revision 1333) @@ -1,4 +1,4 @@ C0CCMT ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10 - ;;1.0;C0C;;May 21, 2010;Build 38 + ;;1.0;C0C;;May 21, 2010;Build 1 ;Copyright 2010 George Lilly, University of Minnesota and others. ;Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CCPT.m =================================================================== --- ccr/branches/ohum/p/C0CCPT.m (revision 1332) +++ ccr/branches/ohum/p/C0CCPT.m (revision 1333) @@ -1,4 +1,4 @@ C0CCPT ;;BSL;RETURN CPT DATA; - ;Sequence Managers Software GPL;;;;;Build 38 + ;Sequence Managers Software GPL;;;;;Build 1 ;Copied into C0C namespace from SQMCPT with permission from ;Brian Lord - and with our thanks. gpl 01/20/2010 @@ -19,4 +19,7 @@ ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE ;GET DATE OF NOTE + ;OHUM/RUT 3111228 Date Range for Notes + S STDT=^TMP("C0CCCR","TIULIMIT") D NOW^%DTC S ENDDT=X + ;OHUM/RUT S Z="" F S Z=$O(NOTE(Z)) Q:Z="" D Index: ccr/branches/ohum/p/C0CDIC.m =================================================================== --- ccr/branches/ohum/p/C0CDIC.m (revision 1332) +++ ccr/branches/ohum/p/C0CDIC.m (revision 1333) @@ -1,207 +1,207 @@ -C0CDIC ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08 - ;;0.1;CCDCCR;nopatch;noreleasedate - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is the CCR Dictionary Utility Library ",! - W ! - Q - ; -DIC2CSV ;OUTPUT THE CCR DICTIONARY TO A CSV FILE - ; - N ZI - S ZI="" - S G1=$NA(^TMP($J,"C0CCSV",1)) - S G1A=$NA(@G1@("V")) - S G2=$NA(^TMP($J,"C0CCSV",2)) - D GETN2^C0CRNF(G1,170) ; GET THE MATRIX - F S ZI=$O(@G1A@(ZI)) Q:ZI="" D ;FOR EACH ROW IN THE MATRIX - . I $G(@G1A@(ZI,"MAPPING METHOD",1))'="" D ; - . . W @G1A@(ZI,"MAPPING METHOD",1),! - . . ;K @G1A@(ZI,"MAPPING METHOD") - . ;W !,ZI,$G(@G1A@(ZI,"MAPPING METHOD",1)) - D RNF2CSV^C0CRNF(G2,G1,"VN") ; PREPARE THE CVS FILE - K @G1 - D FILEOUT^C0CRNF(G2,"FILE_"_170_".csv") - K @G2 - Q - ; -GVARS(C0CVARS,C0CT) ; Get the CCR variables from the CCR template - ; and return them in C0CVARS, which is passed by name - ; FIRST PIECE OF C0CVARS(x) IS THE VARIABLE NAME, SECOND PIECE - ; IS THE LINE NUMBER OF THE VARIABLE IN THE TEMPLATE - ; C0CT IS RETURNED AS THE CCR TEMPLATE - N C0CTVARS ; ARRAY FOR THE TEMPLATE AND ARRAY FOR THE VARS - D LOAD^GPLCCR0(C0CT) ; LOAD THE CCR TEMPLATE - D XVARS^GPLXPATH("C0CTVARS",C0CT) ; PULL OUT THE VARS - N C0CI,C0CX - S @C0CVARS@(0)=C0CTVARS(0) ; SAME COUNT - F C0CI=1:1:C0CTVARS(0) D ; FOR EVERY LINE IN THE ARRAY - . S C0CX=C0CTVARS(C0CI) ; THE VARIABLE - 3 PIECES, FIRST ONE NULL - . S @C0CVARS@(C0CI)=$P(C0CX,"^",2)_"^"_$P(C0CX,"^",3) ; VAR NAME^LINE NUMBER - ;D PARY^GPLXPATH("C0CVARS") - Q - ; -GXPATH(C0CPVARS,C0CPT) ; LOAD THE CCR TEMPLATE INTO C0CPT, PULL OUT VARIABLES - ; AND THE XPATH TO THE VARIABLES INTO C0CPVARS - ; BY INDEXING THE TEMPLATE C0CT AND MATCHING THE XPATH TO THE VARIABLE - ; BOTH ARE PASSED BY NAME - ; C0CPVARS(x) IS VAR^LINENUM^XPATH SORTED BY LINENUM - ; C0CPVARS(0) IS NUMBER OF VARIABLES - ; C0CPT(0) IS NUMBER OF LINES IN THE TEMPLATE - D GVARS(C0CPVARS,C0CPT) ; GET THE VARIABLES AND LINE NUMBERS - ;N C0CTVARS ; HASH TABLE FOR VARIABLE BY LINE NUMBER - D HASHV ; PUT THE VARIABLES IN A LINE NUMBER HASH FOR MATCHING TO XPATHS - ; NOW GO GET THE XPATH INDEXES - D INDEX^GPLXPATH(C0CPT) ; ADD THE XPATH INDEXES TO THE TEMPLATE ARRAY - S C0CI="" ; GOING TO LOOP THROUGH THE WHOLE ARRAY LOOKING AT XPATHS - F S C0CI=$O(@C0CPT@(C0CI)) Q:C0CI="" D ; VISIT EVERY LINE - . I +C0CI'=0 Q ; SKIP EVERYTHING BUT THE XPATH INDEX - . I C0CI=0 Q ; SKIP THE ZERO NODE - . S C0CX=@C0CPT@(C0CI) ; PULL OUT THE LINE NUMBERS X^Y - . S C0CY=$P(C0CX,"^",1) ; STARTING LINE NUMBER - . S C0CZ=$P(C0CX,"^",2) ; ENDING LINE NUMBER - . I C0CY=C0CZ D ; THIS IS AN XPATH END NODE, HAS A VARIABLE (WE HOPE) - . . ; W "FOUND ",C0CI,! - . . I $D(C0CTVARS(C0CY)) D ; IF THERE IS A VARIABLE THERE - . . . S $P(C0CTVARS(C0CY),"^",3)=C0CI ; INSERT THE XPATH FOR THE VAR - D SORTV ; SORT THE ARRAY BY LINE NUMBER - Q - ; -HASHV ; INTERNAL ROUTINE TO PUT VARIABLE NAMES IN A LINE NUMBER HASH - ;N C0CI,C0CTVARS,C0CX,C0CY - F C0CI=1:1:@C0CPVARS@(0) D ; FOR THE ENTIRE ARRAY - . S C0CX=$P(@C0CPVARS@(C0CI),"^",2) ; LINE NUMBER - . S C0CY=$P(@C0CPVARS@(C0CI),"^",1) ; VARIABLE NAME - . S C0CTVARS(C0CX)=C0CY ; BUILD HASH OF VARIABLES BY LINE NUMBER - Q - ; -SORTV ; INTERNAL ROUTINE TO OUTPUT VARIABLES (AND XPATHS) IN LINE NUMBER ORDER - ;N C0CV2 ; SCRACTH SPACE FOR BUILDING SORTED ARRAY - S C0CI="" ; - F S C0CI=$O(C0CTVARS(C0CI)) Q:C0CI="" D ; BY LINE NUMBER - . S C0CX=C0CTVARS(C0CI) ;VARIABLE NAME - . S $P(C0CX,"^",2)=C0CI ; LINE NUMBER IS SECOND PIECE - . D PUSH^GPLXPATH("C0C2",C0CX) ; PUT ONTO ARRAY - K @C0CPVARS - M @C0CPVARS=C0C2 - Q - ; -LOAD ; LOAD VARIABLE NAMES AND XPATH IN ^C0CDIC(170 - ; INITIAL LOAD OF THE CCR DICTIONARY - ; - N C0CDIC,C0CARY,C0CXML,C0CFDA,C0CI - S C0CDIC="^C0CDIC(170," ; ROOT OF THE CCR DICTIONARY - D GXPATH("C0CARY","C0CXML") ; FETCH THE VARIABLES AND XPATH INTO C0CARY - ; C0CXML WILL CONTAIN THE TEMPLATE - NOT NEEDED FOR LOAD - D PARY^GPLXPATH("C0CARY") ;TEST - F C0CI=1:1:C0CARY(0) D ; LOAD EACH VARIABLE - . S C0CFDA(170,"+"_C0CI_",",.01)=$P(C0CARY(C0CI),"^",1) ; VAR NAME - . S C0CFDA(170,"+"_C0CI_",",2)=$P(C0CARY(C0CI),"^",3) ; XPATH - . D UPDATE^DIE("","C0CFDA") - . I $D(^TMP("DIERR",$J)) U $P BREAK - . W "LOADING:",C0CI," ",C0CARY(C0CI),! - Q - ; -INIT ; INITIALIZE CCR DICTIONARY BASED ON VARIABLE NAMES - ; - ; CHEAT SHEET FOR VARIABLE NAMES IN ^C0CDIC(170.xx, - ; THIS IS WHAT WILL BE IN C0CA FOR EACH DICTIONARY ENTRY - ;G1("CODING")="170^8" - ;G1("DATA ELEMENT")="170^7" - ;G1("DESCRIPTION")="170^3" - ;G1("ID")="170^1" - ;G1("M","170^8","CODING")="170.08^.01" - ;G1("MAPPING METHOD")="170.08^1" - ;G1("SECTION")="170^10" - ;G1("SOURCE")="170^4" - ;G1("STATUS")="170^9" - ;G1("TYPE")="170^6" - ;G1("VARIABLE")="170^.01" - ;G1("XPATH")="170^2" - ; - N C0CZA,C0CZX,C0CN,C0CSTAT - S C0CZX=0 - S C0CSTAT=0 ; INIT STATUS SET FLAG - F S C0CZX=$O(^C0CDIC(170,C0CZX)) Q:+C0CZX=0 D ; FOR EACH DICT ENTRY - . ;W C0CZX,! - . K C0CA,C0CN ; CLEAR OUT THE LAST ONE - . D GETN1^C0CRNF("C0CA",170,C0CZX,"","ALL") ; GET VARIABLE HASH - . ;ZWR C0CA B ; - . S C0CN=$$ZVALUE("VARIABLE") ;NAME OF THE VARIABLE - . W "VARIABLE: ",C0CN,! - . I $E(C0CN,1,5)="ACTOR" D SETFDA("SECTION","ACTORS") ; - . I $E(C0CN,1,6)="SOCIAL" D ; - . . D SETFDA("SECTION","SOC") ; - . . D SETFDA("STATUS","X") ;SOCIAL HISTORY NOT IMPLEMENTED - . . S C0CSTAT=1 - . I $E(C0CN,1,6)="FAMILY" D ; - . . D SETFDA("SECTION","FAM") ; - . . D SETFDA("STATUS","X") ;FAMILY HISTORY NOT IMPLEMENTED - . . S C0CSTAT=1 - . ;D SETFDA("TYPE","") ;CORRECT FOR TYPE ERRORS - . I $E(C0CN,1,5)="ALERT" D SETFDA("SECTION","ALERTS") - . I $E(C0CN,1,5)="VITAL" D SETFDA("SECTION","VITALS") - . I $E(C0CN,1,7)="PROBLEM" D SETFDA("SECTION","PROBLEMS") - . I $E(C0CN,1,10)="RESULTTEST" D SETFDA("SECTION","TEST") - . E I $E(C0CN,1,6)="RESULT" D SETFDA("SECTION","LABS") - . I C0CN["CODEVALUE" D SETFDA("TYPE","CD") ;CODES - . I C0CN["CODEVERSION" D SETFDA("TYPE","CV") ; CODE VERSION - . I C0CN["CODINGSYSTEM" D SETFDA("TYPE","CS") ;CODING SYSTEM - . I $$ZVALUE("STATUS")=""!'C0CSTAT D SETFDA("STATUS","N") ;BLANK STATUS TO N - . I $$ZVALUE("XPATH")["/Medication/Directions/" D ; MEDS DIRECTIONS VAR - . . D SETFDA("SECTION","DIR") ; SPECIAL SECTION FOR DIRECTIONS - . E I $$ZVALUE("XPATH")["/Medications/Medication/" D ; ALL OTHER MEDS - . . D SETFDA("SECTION","MEDS") ; A MEDS VAR - . I $E(C0CN,($L(C0CN)-1),$L(C0CN))="ID" D SETFDA("TYPE","ID") ;CATCH THE IDS - . I C0CN["DATETIME" D SETFDA("TYPE","DT") ; DATE/TIME VARIABLE - . W "VARIABLE: ",C0CZX," ",C0CA("VARIABLE"),! - . ;ZWR C0CFDA - . I $D(C0CFDA) D ; WE HAVE CHANGES ON THIS VARIABLE - . . ;ZWR C0CFDA - . . D UPDATE^DIE("","C0CFDA(C0CZX)") - . . I $D(^TMP("DIERR",$J)) U $P BREAK - . . D CLEAN^DILF ; CLEAN UP - . ;ZWR C0CFDA - Q - ; -SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN - ; TO SET TO VALUE C0CSV. - ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE - ; C0CSN,C0CSV ARE PASSED BY VALUE - ; - N C0CSI,C0CSJ - S C0CSI=$$ZFILE(C0CSN,"C0CA") ; FILE NUMBER - S C0CSJ=$$ZFIELD(C0CSN,"C0CA") ; FIELD NUMBER - S C0CFDA(C0CZX,C0CSI,C0CZX_",",C0CSJ)=C0CSV - Q -ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P(@ZTAB@(ZFN),"^",1) -ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P(@ZTAB@(ZFN),"^",2) -ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - Q $P(@ZTAB@(ZFN),"^",3) - ; +C0CDIC ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08 + ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 + ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is the CCR Dictionary Utility Library ",! + W ! + Q + ; +DIC2CSV ;OUTPUT THE CCR DICTIONARY TO A CSV FILE + ; + N ZI + S ZI="" + S G1=$NA(^TMP($J,"C0CCSV",1)) + S G1A=$NA(@G1@("V")) + S G2=$NA(^TMP($J,"C0CCSV",2)) + D GETN2^C0CRNF(G1,170) ; GET THE MATRIX + F S ZI=$O(@G1A@(ZI)) Q:ZI="" D ;FOR EACH ROW IN THE MATRIX + . I $G(@G1A@(ZI,"MAPPING METHOD",1))'="" D ; + . . W @G1A@(ZI,"MAPPING METHOD",1),! + . . ;K @G1A@(ZI,"MAPPING METHOD") + . ;W !,ZI,$G(@G1A@(ZI,"MAPPING METHOD",1)) + D RNF2CSV^C0CRNF(G2,G1,"VN") ; PREPARE THE CVS FILE + K @G1 + D FILEOUT^C0CRNF(G2,"FILE_"_170_".csv") + K @G2 + Q + ; +GVARS(C0CVARS,C0CT) ; Get the CCR variables from the CCR template + ; and return them in C0CVARS, which is passed by name + ; FIRST PIECE OF C0CVARS(x) IS THE VARIABLE NAME, SECOND PIECE + ; IS THE LINE NUMBER OF THE VARIABLE IN THE TEMPLATE + ; C0CT IS RETURNED AS THE CCR TEMPLATE + N C0CTVARS ; ARRAY FOR THE TEMPLATE AND ARRAY FOR THE VARS + D LOAD^GPLCCR0(C0CT) ; LOAD THE CCR TEMPLATE + D XVARS^GPLXPATH("C0CTVARS",C0CT) ; PULL OUT THE VARS + N C0CI,C0CX + S @C0CVARS@(0)=C0CTVARS(0) ; SAME COUNT + F C0CI=1:1:C0CTVARS(0) D ; FOR EVERY LINE IN THE ARRAY + . S C0CX=C0CTVARS(C0CI) ; THE VARIABLE - 3 PIECES, FIRST ONE NULL + . S @C0CVARS@(C0CI)=$P(C0CX,"^",2)_"^"_$P(C0CX,"^",3) ; VAR NAME^LINE NUMBER + ;D PARY^GPLXPATH("C0CVARS") + Q + ; +GXPATH(C0CPVARS,C0CPT) ; LOAD THE CCR TEMPLATE INTO C0CPT, PULL OUT VARIABLES + ; AND THE XPATH TO THE VARIABLES INTO C0CPVARS + ; BY INDEXING THE TEMPLATE C0CT AND MATCHING THE XPATH TO THE VARIABLE + ; BOTH ARE PASSED BY NAME + ; C0CPVARS(x) IS VAR^LINENUM^XPATH SORTED BY LINENUM + ; C0CPVARS(0) IS NUMBER OF VARIABLES + ; C0CPT(0) IS NUMBER OF LINES IN THE TEMPLATE + D GVARS(C0CPVARS,C0CPT) ; GET THE VARIABLES AND LINE NUMBERS + ;N C0CTVARS ; HASH TABLE FOR VARIABLE BY LINE NUMBER + D HASHV ; PUT THE VARIABLES IN A LINE NUMBER HASH FOR MATCHING TO XPATHS + ; NOW GO GET THE XPATH INDEXES + D INDEX^GPLXPATH(C0CPT) ; ADD THE XPATH INDEXES TO THE TEMPLATE ARRAY + S C0CI="" ; GOING TO LOOP THROUGH THE WHOLE ARRAY LOOKING AT XPATHS + F S C0CI=$O(@C0CPT@(C0CI)) Q:C0CI="" D ; VISIT EVERY LINE + . I +C0CI'=0 Q ; SKIP EVERYTHING BUT THE XPATH INDEX + . I C0CI=0 Q ; SKIP THE ZERO NODE + . S C0CX=@C0CPT@(C0CI) ; PULL OUT THE LINE NUMBERS X^Y + . S C0CY=$P(C0CX,"^",1) ; STARTING LINE NUMBER + . S C0CZ=$P(C0CX,"^",2) ; ENDING LINE NUMBER + . I C0CY=C0CZ D ; THIS IS AN XPATH END NODE, HAS A VARIABLE (WE HOPE) + . . ; W "FOUND ",C0CI,! + . . I $D(C0CTVARS(C0CY)) D ; IF THERE IS A VARIABLE THERE + . . . S $P(C0CTVARS(C0CY),"^",3)=C0CI ; INSERT THE XPATH FOR THE VAR + D SORTV ; SORT THE ARRAY BY LINE NUMBER + Q + ; +HASHV ; INTERNAL ROUTINE TO PUT VARIABLE NAMES IN A LINE NUMBER HASH + ;N C0CI,C0CTVARS,C0CX,C0CY + F C0CI=1:1:@C0CPVARS@(0) D ; FOR THE ENTIRE ARRAY + . S C0CX=$P(@C0CPVARS@(C0CI),"^",2) ; LINE NUMBER + . S C0CY=$P(@C0CPVARS@(C0CI),"^",1) ; VARIABLE NAME + . S C0CTVARS(C0CX)=C0CY ; BUILD HASH OF VARIABLES BY LINE NUMBER + Q + ; +SORTV ; INTERNAL ROUTINE TO OUTPUT VARIABLES (AND XPATHS) IN LINE NUMBER ORDER + ;N C0CV2 ; SCRACTH SPACE FOR BUILDING SORTED ARRAY + S C0CI="" ; + F S C0CI=$O(C0CTVARS(C0CI)) Q:C0CI="" D ; BY LINE NUMBER + . S C0CX=C0CTVARS(C0CI) ;VARIABLE NAME + . S $P(C0CX,"^",2)=C0CI ; LINE NUMBER IS SECOND PIECE + . D PUSH^GPLXPATH("C0C2",C0CX) ; PUT ONTO ARRAY + K @C0CPVARS + M @C0CPVARS=C0C2 + Q + ; +LOAD ; LOAD VARIABLE NAMES AND XPATH IN ^C0CDIC(170 + ; INITIAL LOAD OF THE CCR DICTIONARY + ; + N C0CDIC,C0CARY,C0CXML,C0CFDA,C0CI + S C0CDIC="^C0CDIC(170," ; ROOT OF THE CCR DICTIONARY + D GXPATH("C0CARY","C0CXML") ; FETCH THE VARIABLES AND XPATH INTO C0CARY + ; C0CXML WILL CONTAIN THE TEMPLATE - NOT NEEDED FOR LOAD + D PARY^GPLXPATH("C0CARY") ;TEST + F C0CI=1:1:C0CARY(0) D ; LOAD EACH VARIABLE + . S C0CFDA(170,"+"_C0CI_",",.01)=$P(C0CARY(C0CI),"^",1) ; VAR NAME + . S C0CFDA(170,"+"_C0CI_",",2)=$P(C0CARY(C0CI),"^",3) ; XPATH + . D UPDATE^DIE("","C0CFDA") + . I $D(^TMP("DIERR",$J)) U $P BREAK + . W "LOADING:",C0CI," ",C0CARY(C0CI),! + Q + ; +INIT ; INITIALIZE CCR DICTIONARY BASED ON VARIABLE NAMES + ; + ; CHEAT SHEET FOR VARIABLE NAMES IN ^C0CDIC(170.xx, + ; THIS IS WHAT WILL BE IN C0CA FOR EACH DICTIONARY ENTRY + ;G1("CODING")="170^8" + ;G1("DATA ELEMENT")="170^7" + ;G1("DESCRIPTION")="170^3" + ;G1("ID")="170^1" + ;G1("M","170^8","CODING")="170.08^.01" + ;G1("MAPPING METHOD")="170.08^1" + ;G1("SECTION")="170^10" + ;G1("SOURCE")="170^4" + ;G1("STATUS")="170^9" + ;G1("TYPE")="170^6" + ;G1("VARIABLE")="170^.01" + ;G1("XPATH")="170^2" + ; + N C0CZA,C0CZX,C0CN,C0CSTAT + S C0CZX=0 + S C0CSTAT=0 ; INIT STATUS SET FLAG + F S C0CZX=$O(^C0CDIC(170,C0CZX)) Q:+C0CZX=0 D ; FOR EACH DICT ENTRY + . ;W C0CZX,! + . K C0CA,C0CN ; CLEAR OUT THE LAST ONE + . D GETN1^C0CRNF("C0CA",170,C0CZX,"","ALL") ; GET VARIABLE HASH + . ;ZWR C0CA B ; + . S C0CN=$$ZVALUE("VARIABLE") ;NAME OF THE VARIABLE + . W "VARIABLE: ",C0CN,! + . I $E(C0CN,1,5)="ACTOR" D SETFDA("SECTION","ACTORS") ; + . I $E(C0CN,1,6)="SOCIAL" D ; + . . D SETFDA("SECTION","SOC") ; + . . D SETFDA("STATUS","X") ;SOCIAL HISTORY NOT IMPLEMENTED + . . S C0CSTAT=1 + . I $E(C0CN,1,6)="FAMILY" D ; + . . D SETFDA("SECTION","FAM") ; + . . D SETFDA("STATUS","X") ;FAMILY HISTORY NOT IMPLEMENTED + . . S C0CSTAT=1 + . ;D SETFDA("TYPE","") ;CORRECT FOR TYPE ERRORS + . I $E(C0CN,1,5)="ALERT" D SETFDA("SECTION","ALERTS") + . I $E(C0CN,1,5)="VITAL" D SETFDA("SECTION","VITALS") + . I $E(C0CN,1,7)="PROBLEM" D SETFDA("SECTION","PROBLEMS") + . I $E(C0CN,1,10)="RESULTTEST" D SETFDA("SECTION","TEST") + . E I $E(C0CN,1,6)="RESULT" D SETFDA("SECTION","LABS") + . I C0CN["CODEVALUE" D SETFDA("TYPE","CD") ;CODES + . I C0CN["CODEVERSION" D SETFDA("TYPE","CV") ; CODE VERSION + . I C0CN["CODINGSYSTEM" D SETFDA("TYPE","CS") ;CODING SYSTEM + . I $$ZVALUE("STATUS")=""!'C0CSTAT D SETFDA("STATUS","N") ;BLANK STATUS TO N + . I $$ZVALUE("XPATH")["/Medication/Directions/" D ; MEDS DIRECTIONS VAR + . . D SETFDA("SECTION","DIR") ; SPECIAL SECTION FOR DIRECTIONS + . E I $$ZVALUE("XPATH")["/Medications/Medication/" D ; ALL OTHER MEDS + . . D SETFDA("SECTION","MEDS") ; A MEDS VAR + . I $E(C0CN,($L(C0CN)-1),$L(C0CN))="ID" D SETFDA("TYPE","ID") ;CATCH THE IDS + . I C0CN["DATETIME" D SETFDA("TYPE","DT") ; DATE/TIME VARIABLE + . W "VARIABLE: ",C0CZX," ",C0CA("VARIABLE"),! + . ;ZWR C0CFDA + . I $D(C0CFDA) D ; WE HAVE CHANGES ON THIS VARIABLE + . . ;ZWR C0CFDA + . . D UPDATE^DIE("","C0CFDA(C0CZX)") + . . I $D(^TMP("DIERR",$J)) U $P BREAK + . . D CLEAN^DILF ; CLEAN UP + . ;ZWR C0CFDA + Q + ; +SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN + ; TO SET TO VALUE C0CSV. + ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE + ; C0CSN,C0CSV ARE PASSED BY VALUE + ; + N C0CSI,C0CSJ + S C0CSI=$$ZFILE(C0CSN,"C0CA") ; FILE NUMBER + S C0CSJ=$$ZFIELD(C0CSN,"C0CA") ; FIELD NUMBER + S C0CFDA(C0CZX,C0CSI,C0CZX_",",C0CSJ)=C0CSV + Q +ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P(@ZTAB@(ZFN),"^",1) +ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P(@ZTAB@(ZFN),"^",2) +ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + Q $P(@ZTAB@(ZFN),"^",3) + ; Index: ccr/branches/ohum/p/C0CDOM.m =================================================================== --- ccr/branches/ohum/p/C0CDOM.m (revision 1332) +++ ccr/branches/ohum/p/C0CDOM.m (revision 1333) @@ -1,319 +1,319 @@ C0CDOM ; GPL - DOM PROCESSING ROUTINES ;6/6/11 17:05 - ;;0.1;C0C;nopatch;noreleasedate;Build 38 - ;Copyright 2011 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q - ; + ;;0.1;C0C;nopatch;noreleasedate;Build 1 + ;Copyright 2011 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q + ; DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE - ; THE XPATH INDEX ZXIDX, PASSED BY NAME - ; THE XPATH ARRAY XPARY, PASSED BY NAME - ; ZOID IS THE STARTING OID - ; ZPATH IS THE STARTING XPATH, USUALLY "/" - ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE - ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT - I $G(ZREDUX)="" S ZREDUX="" - N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY - N NEWNUM S NEWNUM="" - I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" - S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE - I $G(ZREDUX)'="" D ; REDUX PROVIDED? - . N GT S GT=$P(NEWPATH,ZREDUX,2) - . I GT'="" S NEWPATH=GT - S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX - N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE - I $D(GA) D ; PROCESS THE ATTRIBUTES - . N ZI S ZI="" - . F S ZI=$O(GA(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE - . . N ZP S ZP=NEWPATH_"@"_ZI ; PATH FOR ATTRIBUTE - . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY - . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE - N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE - I $D(GD(2)) D ; - . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY - E I $D(GD(1)) D ; - . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY - . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY - N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD - I ZFRST'=0 D ; THERE IS A CHILD - . N ZNUM - . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE - . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD - N GNXT S GNXT=$$NXTSIB(ZOID) - I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES - I GNXT'=0 D ; - . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? - . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES - . . N ZNUM S ZNUM=1 ; - . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB - . E D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB - Q - ; -ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY - ; - ; IF ZATT=1 THE ARRAY IS ADDED AS ATTRIBUTES - ; - N ZZI,ZZJ,ZZN - S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY - I ZZI="" Q ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE - S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY - S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH . - I ZZI'["]" D ; A SINGLETON - . S ZZN=1 - E D ; THERE IS AN [x] OCCURANCE - . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE - . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X] - I ZZJ'="" D ; TIME TO ADD THE VALUE - . S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE - Q - ; + ; THE XPATH INDEX ZXIDX, PASSED BY NAME + ; THE XPATH ARRAY XPARY, PASSED BY NAME + ; ZOID IS THE STARTING OID + ; ZPATH IS THE STARTING XPATH, USUALLY "/" + ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE + ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT + I $G(ZREDUX)="" S ZREDUX="" + N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY + N NEWNUM S NEWNUM="" + I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" + S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE + I $G(ZREDUX)'="" D ; REDUX PROVIDED? + . N GT S GT=$P(NEWPATH,ZREDUX,2) + . I GT'="" S NEWPATH=GT + S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX + N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE + I $D(GA) D ; PROCESS THE ATTRIBUTES + . N ZI S ZI="" + . F S ZI=$O(GA(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE + . . N ZP S ZP=NEWPATH_"@"_ZI ; PATH FOR ATTRIBUTE + . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY + . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE + N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE + I $D(GD(2)) D ; + . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY + E I $D(GD(1)) D ; + . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY + . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY + N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD + I ZFRST'=0 D ; THERE IS A CHILD + . N ZNUM + . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE + . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD + N GNXT S GNXT=$$NXTSIB(ZOID) + I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES + I GNXT'=0 D ; + . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? + . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES + . . N ZNUM S ZNUM=1 ; + . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB + . E D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB + Q + ; +ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY + ; + ; IF ZATT=1 THE ARRAY IS ADDED AS ATTRIBUTES + ; + N ZZI,ZZJ,ZZN + S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY + I ZZI="" Q ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE + S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY + S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH . + I ZZI'["]" D ; A SINGLETON + . S ZZN=1 + E D ; THERE IS AN [x] OCCURANCE + . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE + . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X] + I ZZJ'="" D ; TIME TO ADD THE VALUE + . S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE + Q + ; PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME - ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW - ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML - ;Q $$EN^MXMLDOM(INXML) - Q $$EN^MXMLDOM(INXML,"W") - ; + ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW + ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML + ;Q $$EN^MXMLDOM(INXML) + Q $$EN^MXMLDOM(INXML,"W") + ; ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE - N ZN - ;I $$TAG(ZOID)["entry" B - S ZN=$$NXTSIB(ZOID) - I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG - Q 0 - ; + N ZN + ;I $$TAG(ZOID)["entry" B + S ZN=$$NXTSIB(ZOID) + I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG + Q 0 + ; FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID - Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) - ; + Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) + ; PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID - Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) - ; + Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) + ; ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID - S HANDLE=C0CDOCID - K @RTN - D GETTXT^MXMLDOM("A") - Q - ; + S HANDLE=C0CDOCID + K @RTN + D GETTXT^MXMLDOM("A") + Q + ; TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE - ;I ZOID=149 B ;GPLTEST - N X,Y - S Y="" - S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE - I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y - I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) - Q Y - ; + ;I ZOID=149 B ;GPLTEST + N X,Y + S Y="" + S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE + I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y + I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) + Q Y + ; NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING - Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) - ; + Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) + ; DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE - ;N ZT,ZN S ZT="" - ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) - ;Q $G(@C0CDOM@(ZOID,"T",1)) - S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) - Q - ; + ;N ZT,ZN S ZT="" + ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) + ;Q $G(@C0CDOM@(ZOID,"T",1)) + S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) + Q + ; OUTXML(ZRTN,INID,NO1ST) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM - ; - S C0CDOCID=INID - I '$D(NO1ST) S NO1ST=0 ; DO NOT SURPRESS THE 0 S ZPARNODE=PARENT ; WE HAVE BEEN PASSED A PARENT NODE ID - E I $L($G(PARENT))>0 D ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL - . D STARTELE^MXMLDOM(PARENT) ; INSERT THE PARENT NODE - . S ZPARNODE=1 ; - ; WE NOW HAVE A HANDLE AND A PARENT NODE AND LEVEL HAS BEEN SET - N ZEXARY - D EXPAND("ZEXARY",INARY) ; EXPAND THE NHIN ARRAY - D MAJOR("ZEXARY") ; PROCESS ALL THE NODES TO BE ADDED - I $L($G(PARENT))>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE - Q HANDLE ; SUCCESS - ; -MAJOR(ZARY) ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES - N ZI S ZI="" - N ZTAG - F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH SECTION - . N ZELEADD S ZELEADD=0 - . I ZI["@" D ; END NODE HAS NO VALUE, ONLY ATTRIBUTES - . . S ZTAG=$P(ZI,"@",1) ; PULL OUT THE TAG - . . K ZATT ; CLEAR OUT LAST ONE - . . M ZATT=@ZARY@(ZI,1) ; GET ATTRIBUTE ARRAY - . . D STARTELE^MXMLDOM(ZTAG,.ZATT) ; ADD THE NODE - . . S ZELEADD=1 ; FLAG TO NOT ADD THE ELEMENT TWICE - . I $O(@ZARY@(ZI,""))="" D ;END NODE - . . S ZTAG=ZI ; USE ZI FOR THE TAG - . . I 'ZELEADD D STARTELE^MXMLDOM(ZTAG) ; ADD ELEMENT IF NOT THERE - . . S ZELEADD=1 ; ADDED AN ELEMENT - . . D CHAR^MXMLDOM($G(@ZARY@(ZI))) ; INSERT THE VALUE - . I ZELEADD D Q ; NO MORE TO DO ON THIS LEVEL - . . D ENDELE^MXMLDOM(ZTAG) ; CLOSE THE ELEMENT BEFORE LEAVING - . N NEWARY ; INDENTED ARRAY - . N ZN S ZN=0 - . F S ZN=$O(@ZARY@(ZI,ZN)) Q:ZN="" D ; FOR EACH MULTIPLE - . . D STARTELE^MXMLDOM(ZI) ; ADD THE INTERMEDIATE TAG - . . S NEWARY=$NA(@ZARY@(ZI,ZN)) ; INDENT THE ARRAY - . . D MAJOR(NEWARY) ; RECURSE FOR INDENTED ARRAY - . . D ENDELE^MXMLDOM(ZI) ; END THE INTERMEDIATE TAG - Q - ; -EXPAND(ZZOUT,ZZIN) ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED - ; CONSISTENT FORMAT - ; GNARY("patient",1,"facilities[2].facility@code")="050" - ; becomes G2ARY("patient",1,"facilities",2,"facility@",1,"code")="050" - ; for easier processing (this is fileman format genius) - ; basically removes the dot notation from the strings - ; - N ZZI - S ZZI="" - F S ZZI=$O(@ZZIN@(ZZI)) Q:ZZI="" D ; - . N ZZN S ZZN=0 - . F S ZZN=$O(@ZZIN@(ZZI,ZZN)) Q:ZZN="" D ; - . . N ZZS S ZZS="" - . . N GA ;PUSH STACK - . . F S ZZS=$O(@ZZIN@(ZZI,ZZN,ZZS)) Q:ZZS="" D ; - . . . K GA ; NEW STACK - . . . D PUSH^C0CXPATH("GA",ZZI_"^"_ZZN) ; PUSH PARENT - . . . N ZZV ; PLACE TO STASH THE VALUE - . . . S ZZV=@ZZIN@(ZZI,ZZN,ZZS) ; VALUE - . . . W !,"VALUE:",ZZV - . . . N GK ; COUNTER - . . . F GK=1:1:$L(ZZS,".") D ; FOR EACH INTERMEDIATE NODE - . . . . N ZZN2 S ZZN2=1 ; DEFAULT IF NO [X] - . . . . N GM S GM=$P(ZZS,".",GK) ; TAG - . . . . I GM["[" D ; IT'S A MULTIPLE - . . . . . S ZZN2=$P($P(GM,"[",2),"]",1) ; PULL OUT THE NUMBER - . . . . . S GM=$P(GM,"[",1) ; PULL OUT THE TAG - . . . . I GM["@" D ; IT'S GOT ATTRIBUTES - . . . . . N GM2 S GM2=$P(GM,"@",2) ; PULLOUT THE ATTRIBUTE NAME - . . . . . D PUSH^C0CXPATH("GA",$P(GM,"@",1)_"@"_"^"_ZZN2) ; PUSH THE TAG - . . . . . D PUSH^C0CXPATH("GA",GM2_"^"_ZZN2) - . . . . E D PUSH^C0CXPATH("GA",GM_"^"_ZZN2) ; - . . . S GA(GA(0))=$P(GA(GA(0)),"^",1)_"^" ; GET RID OF THE LAST "1" - . . . N GZI S GZI="" ; STRING FOR THE INDEX - . . . F GK=1:1:GA(0) D ; TIME TO REVERSE POP THE TAGS - . . . . S GM=$P(GA(GK),"^",1) ; THE TAG - . . . . S ZZN2=$P(GA(GK),"^",2) ; THE NUMBER IF ANY - . . . . I ZZN2="" S GZI=GZI_""""_GM_"""" ; FOR THE LAST ONE - . . . . E S GZI=GZI_""""_GM_""""_","_ZZN2_"," ; FOR THE REST - . . . S GZI2=ZZOUT_"("_GZI_")" ; INCLUDE THE ARRAY NAME - . . . W !,GZI - . . . S @GZI2=ZZV ; REMEMBER THE VALUE? - Q - ; -NEWDOM() ; extrinsic which creates a new DOM and returns the HANDLE - N CBK,SUCCESS,LEVEL,NODE,HANDLE - K ^TMP("MXMLERR",$J) - L +^TMP("MXMLDOM",$J):5 - E Q 0 - S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)="" - L -^TMP("MXMLDOM",$J) - Q HANDLE - ; + N ZI S ZI=$$FIRST(ZOID) + I ZI'=0 D ; THERE IS A CHILD + . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT + . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN + E D ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT + . ;W "DOING",ZOID,! + . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA + . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES + . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN + I $$NXTSIB(ZOID)'=0 D ; THERE IS A SIBLING + . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS + Q + ; +WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE + ; + N GN,GN2 + D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML + S GN2=$NA(@GN@(1)) + W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/") + Q + ; +NARY2XML(ZGOUT,ZGIN) ; CREATE XML FROM AN NHIN ARRAY + ; ZGOUT AND ZGIN ARE PASSED BY NAME + N C0CDOCID + W !,ZGOUT," ",ZGIN + S C0CDOCID=$$DOMI(ZGIN) ; PUT IT INTO THE DOM + D OUTXML(ZGOUT,C0CDOCID) + Q + ; + ; EXAMPLE OF NHIN ARRAY FORMAT - THIS IS AN OUTPUT OF DOMO ABOVE WHEN RUN + ; AGAINST THE OUTPUT OF THE GET^NHINV ROUTINE. (THIS IS NOT REAL PATIENT DATA) + ; + ;GNARY("med",1,"doses.dose@dose")=10 + ;GNARY("med",1,"doses.dose@noun")="TABLET" + ;GNARY("med",1,"doses.dose@route")="PO" + ;GNARY("med",1,"doses.dose@schedule")="QD" + ;GNARY("med",1,"doses.dose@units")="MG" + ;GNARY("med",1,"doses.dose@unitsPerDose")=1 + ;GNARY("med",1,"facility@code")=100 + ;GNARY("med",1,"facility@name")="VOE OFFICE INSTITUTION" + ;GNARY("med",1,"form@value")="TAB" + ;GNARY("med",1,"id@value")="1N;O" + ;GNARY("med",1,"location@code")=5 + ;GNARY("med",1,"location@name")="3 WEST" + ;GNARY("med",1,"name@value")="LISINOPRIL TAB" + ;GNARY("med",1,"orderID@value")=294 + ;GNARY("med",1,"ordered@value")=3110531.001233 + ;GNARY("med",1,"orderingProvider@code")=63 + ;GNARY("med",1,"orderingProvider@name")="KING,MATTHEW MICHAEL" + ;GNARY("med",1,"products.product.class@code")="ACE INHIBITORS" + ;GNARY("med",1,"products.product.vaGeneric@code")=1990 + ;GNARY("med",1,"products.product.vaGeneric@name")="LISINOPRIL" + ;GNARY("med",1,"products.product.vaGeneric@vuid")=4019380 + ;GNARY("med",1,"products.product.vaProduct@code")=8118 + ;GNARY("med",1,"products.product.vaProduct@name")="LISINOPRIL 10MG TAB" + ;GNARY("med",1,"products.product.vaProduct@vuid")=4008593 + ;GNARY("med",1,"products.product@code")=6174 + ;GNARY("med",1,"products.product@name")="LISINOPRIL 10MG U/D" + ;GNARY("med",1,"products.product@role")="D" + ;GNARY("med",1,"sig")="10MG BY MOUTH EVERY DAY" + ;GNARY("med",1,"sig@xml:space")="preserve" + ;GNARY("med",1,"status@value")="active" + ;GNARY("med",1,"type@value")="OTC" + ;GNARY("med",1,"vaType@value")="N" + ; + ; DOMI is an extrinsic to insert NHIN ARRAY FORMAT arrays into the DOM + ; it returns 0 or 1 based on success. + ; + ; INARY is passed by name and has the format shown above + ; HANDLE is the document number in the DOM (both MXML and EWD DOMs will + ; be supported eventually - initial implementation is for MXML + ; + ; PARENT is the node id or tag of the parent under which the DOM will + ; be populated. If it is numeric, it is a node. If it is a string, the DOM + ; will be searched to find the tag. If not found and there is no root, + ; it will be inserted as the root. If not found and there is a root, it + ; will be inserted under the root. + ; + ; For the above example the call would be OK=$$DOMI("GNARY",0,"results") + ; because "results" is the root tag. Use OUTXML to render the xml from + ; the DOM. + ; +DOMI(INARY,HANDLE,PARENT) ; EXTRINSIC TO INSERT NHIN ARRAYS TO A DOM + ; + N ZPARNODE + S (SUCCESS,LEVEL,LEVEL(0),NODE)=0 + I '$D(INARY) Q 0 ; NO ARRAY PASSED + I '$D(HANDLE) S HANDLE=$$NEWDOM() ; MAKE A NEW DOM + ;I PARENT="" S PARENT="root" + I +$G(PARENT)>0 S ZPARNODE=PARENT ; WE HAVE BEEN PASSED A PARENT NODE ID + E I $L($G(PARENT))>0 D ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL + . D STARTELE^MXMLDOM(PARENT) ; INSERT THE PARENT NODE + . S ZPARNODE=1 ; + ; WE NOW HAVE A HANDLE AND A PARENT NODE AND LEVEL HAS BEEN SET + N ZEXARY + D EXPAND("ZEXARY",INARY) ; EXPAND THE NHIN ARRAY + D MAJOR("ZEXARY") ; PROCESS ALL THE NODES TO BE ADDED + I $L($G(PARENT))>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE + Q HANDLE ; SUCCESS + ; +MAJOR(ZARY) ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES + N ZI S ZI="" + N ZTAG + F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH SECTION + . N ZELEADD S ZELEADD=0 + . I ZI["@" D ; END NODE HAS NO VALUE, ONLY ATTRIBUTES + . . S ZTAG=$P(ZI,"@",1) ; PULL OUT THE TAG + . . K ZATT ; CLEAR OUT LAST ONE + . . M ZATT=@ZARY@(ZI,1) ; GET ATTRIBUTE ARRAY + . . D STARTELE^MXMLDOM(ZTAG,.ZATT) ; ADD THE NODE + . . S ZELEADD=1 ; FLAG TO NOT ADD THE ELEMENT TWICE + . I $O(@ZARY@(ZI,""))="" D ;END NODE + . . S ZTAG=ZI ; USE ZI FOR THE TAG + . . I 'ZELEADD D STARTELE^MXMLDOM(ZTAG) ; ADD ELEMENT IF NOT THERE + . . S ZELEADD=1 ; ADDED AN ELEMENT + . . D CHAR^MXMLDOM($G(@ZARY@(ZI))) ; INSERT THE VALUE + . I ZELEADD D Q ; NO MORE TO DO ON THIS LEVEL + . . D ENDELE^MXMLDOM(ZTAG) ; CLOSE THE ELEMENT BEFORE LEAVING + . N NEWARY ; INDENTED ARRAY + . N ZN S ZN=0 + . F S ZN=$O(@ZARY@(ZI,ZN)) Q:ZN="" D ; FOR EACH MULTIPLE + . . D STARTELE^MXMLDOM(ZI) ; ADD THE INTERMEDIATE TAG + . . S NEWARY=$NA(@ZARY@(ZI,ZN)) ; INDENT THE ARRAY + . . D MAJOR(NEWARY) ; RECURSE FOR INDENTED ARRAY + . . D ENDELE^MXMLDOM(ZI) ; END THE INTERMEDIATE TAG + Q + ; +EXPAND(ZZOUT,ZZIN) ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED + ; CONSISTENT FORMAT + ; GNARY("patient",1,"facilities[2].facility@code")="050" + ; becomes G2ARY("patient",1,"facilities",2,"facility@",1,"code")="050" + ; for easier processing (this is fileman format genius) + ; basically removes the dot notation from the strings + ; + N ZZI + S ZZI="" + F S ZZI=$O(@ZZIN@(ZZI)) Q:ZZI="" D ; + . N ZZN S ZZN=0 + . F S ZZN=$O(@ZZIN@(ZZI,ZZN)) Q:ZZN="" D ; + . . N ZZS S ZZS="" + . . N GA ;PUSH STACK + . . F S ZZS=$O(@ZZIN@(ZZI,ZZN,ZZS)) Q:ZZS="" D ; + . . . K GA ; NEW STACK + . . . D PUSH^C0CXPATH("GA",ZZI_"^"_ZZN) ; PUSH PARENT + . . . N ZZV ; PLACE TO STASH THE VALUE + . . . S ZZV=@ZZIN@(ZZI,ZZN,ZZS) ; VALUE + . . . W !,"VALUE:",ZZV + . . . N GK ; COUNTER + . . . F GK=1:1:$L(ZZS,".") D ; FOR EACH INTERMEDIATE NODE + . . . . N ZZN2 S ZZN2=1 ; DEFAULT IF NO [X] + . . . . N GM S GM=$P(ZZS,".",GK) ; TAG + . . . . I GM["[" D ; IT'S A MULTIPLE + . . . . . S ZZN2=$P($P(GM,"[",2),"]",1) ; PULL OUT THE NUMBER + . . . . . S GM=$P(GM,"[",1) ; PULL OUT THE TAG + . . . . I GM["@" D ; IT'S GOT ATTRIBUTES + . . . . . N GM2 S GM2=$P(GM,"@",2) ; PULLOUT THE ATTRIBUTE NAME + . . . . . D PUSH^C0CXPATH("GA",$P(GM,"@",1)_"@"_"^"_ZZN2) ; PUSH THE TAG + . . . . . D PUSH^C0CXPATH("GA",GM2_"^"_ZZN2) + . . . . E D PUSH^C0CXPATH("GA",GM_"^"_ZZN2) ; + . . . S GA(GA(0))=$P(GA(GA(0)),"^",1)_"^" ; GET RID OF THE LAST "1" + . . . N GZI S GZI="" ; STRING FOR THE INDEX + . . . F GK=1:1:GA(0) D ; TIME TO REVERSE POP THE TAGS + . . . . S GM=$P(GA(GK),"^",1) ; THE TAG + . . . . S ZZN2=$P(GA(GK),"^",2) ; THE NUMBER IF ANY + . . . . I ZZN2="" S GZI=GZI_""""_GM_"""" ; FOR THE LAST ONE + . . . . E S GZI=GZI_""""_GM_""""_","_ZZN2_"," ; FOR THE REST + . . . S GZI2=ZZOUT_"("_GZI_")" ; INCLUDE THE ARRAY NAME + . . . W !,GZI + . . . S @GZI2=ZZV ; REMEMBER THE VALUE? + Q + ; +NEWDOM() ; extrinsic which creates a new DOM and returns the HANDLE + N CBK,SUCCESS,LEVEL,NODE,HANDLE + K ^TMP("MXMLERR",$J) + L +^TMP("MXMLDOM",$J):5 + E Q 0 + S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)="" + L -^TMP("MXMLDOM",$J) + Q HANDLE + ; Index: ccr/branches/ohum/p/C0CDPT.m =================================================================== --- ccr/branches/ohum/p/C0CDPT.m (revision 1332) +++ ccr/branches/ohum/p/C0CDPT.m (revision 1333) @@ -1,4 +1,4 @@ C0CDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ; ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU Index: ccr/branches/ohum/p/C0CENC.m =================================================================== --- ccr/branches/ohum/p/C0CENC.m (revision 1332) +++ ccr/branches/ohum/p/C0CENC.m (revision 1333) @@ -1,4 +1,4 @@ C0CENC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10 - ;;1.0;C0C;;May 21, 2010;Build 38 + ;;1.0;C0C;;May 21, 2010;Build 1 ;Copyright 2010 George Lilly, University of Minnesota and others. ;Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CENV.m =================================================================== --- ccr/branches/ohum/p/C0CENV.m (revision 1332) +++ ccr/branches/ohum/p/C0CENV.m (revision 1333) @@ -1,50 +1,50 @@ -C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009 - ;;1.0;C0C;;May 19, 2009; - ; - ; -ENV ; Does not prevent loading of the transport global. - ; Environment check is done only during the install. - ; - N XQA,XQAMSG - ; - ; - ; Make sure the patch name exist - ; - I '$D(XPDNM) D Q - . D BMES("No valid patch name exist") - . S XPDQUIT=2 - . D EXIT - ; - D CHECK - D EXIT - Q - ; - ; -CHECK ; Perform environment check +C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009 + ;;1.0;C0C;;May 19, 2009;Build 1 ; - I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D - . D BMES("Terminal Device is not defined") - . S XPDQUIT=2 - ; - I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D - . D BMES("Please log in to set local DUZ... variables") - . S XPDQUIT=2 - ; - I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D - . D BMES("You are not a valid user on this system") - . S XPDQUIT=2 + ; +ENV ; Does not prevent loading of the transport global. + ; Environment check is done only during the install. + ; + N XQA,XQAMSG + ; + ; + ; Make sure the patch name exist + ; + I '$D(XPDNM) D Q + . D BMES("No valid patch name exist") + . S XPDQUIT=2 + . D EXIT + ; + D CHECK + D EXIT Q ; ; -EXIT ; +CHECK ; Perform environment check + ; + I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D + . D BMES("Terminal Device is not defined") + . S XPDQUIT=2 + ; + I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D + . D BMES("Please log in to set local DUZ... variables") + . S XPDQUIT=2 + ; + I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D + . D BMES("You are not a valid user on this system") + . S XPDQUIT=2 + Q ; ; - I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q - D BMES("--- Environment Check is Ok ---") - ; - Q +EXIT ; ; ; -PRE ;Pre-install entry point + I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q + D BMES("--- Environment Check is Ok ---") + ; + Q + ; + ; +PRE ;Pre-install entry point ; ; No action needed in pre-install @@ -54,5 +54,5 @@ ; ; -POST ;Post install +POST ;Post install ; ; Check for RPMS system with V LAB file. @@ -131,5 +131,5 @@ ; ; -POST6 ; Checkpoint call back entry point. +POST6 ; Checkpoint call back entry point. ; Check for RPMS system and determine LAB patch level ; and need to load in C0C version of LA7 routines. @@ -174,5 +174,5 @@ ; ; -BMES(STR) ; Write BMES^XPDUTL statements +BMES(STR) ; Write BMES^XPDUTL statements ; D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM)) Index: ccr/branches/ohum/p/C0CEVC.m =================================================================== --- ccr/branches/ohum/p/C0CEVC.m (revision 1332) +++ ccr/branches/ohum/p/C0CEVC.m (revision 1333) @@ -1,177 +1,177 @@ C0CEVC ; CCDCCR/GPL - SUPPORT FOR EWD VISTCOM PAGES ; 3/1/2010 - ;;1.0;C0C;;Mar 1, 2010; -gpltest2 ; experiment with sending a CCR to an ewd page - N ZI - S ZI="" - D PSEUDO - N ZIO - S ZIO=IO - S IO="/dev/null" - OPEN IO - U IO - N G - S G=$$URLTOKEN^C0CEWD - D CCRRPC^C0CCCR(.GPL,2) - S IO=ZIO - OPEN IO - U IO - K GPL(0) - F S ZI=$O(GPL(ZI)) Q:ZI="" W GPL(ZI),! - Q - ; -gpltest ; experiment with sending a CCR to an ewd page - N ZI - S ZI="" - K ^GPL(0) - S ^GPL(2)="" - F S ZI=$O(^GPL(ZI)) Q:ZI="" W ^GPL(ZI),! - Q - ; -TEST(sessid); - d setSessionValue^%zewdAPI("person.Name","Rob",sessid) - d setSessionValue^%zewdAPI("person.DateOfBirth","13/06/55",sessid) - d setSessionValue^%zewdAPI("person.Address.PostCode","SW1 3QA",sessid) - d setSessionValue^%zewdAPI("person.Address.Line1","1 The Street",sessid) - d setSessionValue^%zewdAPI("person.Address.2.hello","world",sessid) - d setJSONValue^%zewdAPI("json","person",sessid) - Q "" - -PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME - ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD - ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD - N ZR - M ^CacheTempEWD($j)=@INXML ; - S ZR=$$parseDocument^%zewdHTMLParser(INDOC) - Q ZR - ; -TEST2(sessid) ; try to put a ccr in the session - S U="^" - D PSEUDO ; FAKE LOGIN - S ZIO=$IO - S DEV="/dev/null" - O DEV U DEV - N G - N ZDFN - S ZDFN=$$getSessionValue^%zewdAPI("vista.dfn",sessid) - I ZDFN="" S ZDFN=2 - ;K ^TMP("GPL") - ;M ^TMP("GPL")=^%zewdSession("session",sessid) - D CCRRPC^C0CCCR(.GPL,ZDFN) - K GPL(0) - S GPL(2)="" - C DEV U ZIO - ;M ^CacheTempEWD($j)=GPL - S DOCNAME="CCR" - ;ZWR GPL - ;S ZR=$$parseDocument^%zewdHTMLParser(DOCNAME) - ;d setSessionValues^%zewdAPI(DOCNAME,GPL,sessid) - d mergeArrayToSession^%zewdAPI(.GPL,DOCNAME,sessid) - Q "" - ; -INITSES(sessid) ;initialize an EWD/CPRS session - K ^TMP("GPL") - ;M ^TMP("GPL")=^%zewdSession("session",sessid) - N ZT,ZDFN - S ZT=$$URLTOKEN^C0CEWD(sessid) - ;S ^TMP("GPL")=ZT - d trace^%zewdAPI("*********************ZT="_ZT) - S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN - S ^TMP("GPL","DFN")=ZDFN - I ZDFN=0 S DFN=2 ; DEFAULT TEST PATIENT - D setSessionValue^%zewdAPI("vista.dfn",ZDFN,sessid) - ;M ^TMP("GPL","request")=requestArray - ;D PSEUDO - ;D ^%ZTER - q "" - ; -PRSEORTK(ZTOKEN) ;PARSES THE TOKEN SENT BY CPRS AND RETURNS THE DFN - ; OF THE PATIENT ; HERE'S WHAT THE TOKEN LOOKS LIKE: - ; ^TMP('ORWCHART',6547,'192.168.169.8',002E0FE6) - N ZX,ZN1,ZIP,ZN2,ZDFN,ZG - S ZDFN=0 ; DEFAULT RETURN - S ZN1=$P(ZTOKEN,",",2) ; FIRST NUMBER - S ZIP=$P(ZTOKEN,",",3) ; IP NUMBER - S ZIP=$P(ZIP,"'",2) ; GET RID OF ' - S ZN2=$P(ZTOKEN,",",4) ; SECOND NUMBER - S ZN2=$P(ZN2,")",1) ; GET RID OF ) - S ZG=$NA(^TMP("ORWCHART",ZN1,ZIP,ZN2)) ; BUILD THE GLOBAL NAME - I $G(@ZG)'="" S ZDFN=@ZG ; ACCESS THE GLOBAL - S ^TMP("GPL","FIRSTDFN")=ZDFN - S ^TMP("GPL","FIRSTGLB")=ZG - Q ZDFN - ; -GETPATIENTLIST(sessid) ; - D PSEUDO - D LISTALL^ORWPT(.RTN,"NAME","1") - N ZI - S ZI="" - F S ZI=$O(RTN(ZI)) Q:ZI="" D ; - . S data(ZI,"DFN")=$P(RTN(ZI),"^",1) - . S data(ZI,"Name")=$P(RTN(ZI),"^",2) - ; ZWR data - ;S data(1,"DFN")=$P(RTN(1),"^",1) - ;S data(1,"Name")=$P(RTN(1),"^",2) - d deleteFromSession^%zewdAPI("patients",sessid) - d createDataTableStore^%zewdYUIRuntime(.data,"patients",sessid) - ;d mergeArrayToSession^%zewdAPI(.data,"patients",sessid) - Q "" - ; -PSEUDO - S U="^" - S DILOCKTM=3 - S DISYS=19 - S DT=3100219 - S DTIME=999 - S DUZ=10 - S DUZ(0)="@" - S DUZ(1)="" - S DUZ(2)=1 - S DUZ("AG")="V" - S DUZ("BUF")=1 - S DUZ("LANG")="" - ;S IO="/dev/pts/2" - ;S IO(0)="/dev/pts/2" - ;S IO(1,"/dev/pts/2")="" - ;S IO("ERROR")="" - ;S IO("HOME")="41^/dev/pts/2" - ;S IO("ZIO")="/dev/pts/2" - ;S IOBS="$C(8)" - ;S IOF="#,$C(27,91,50,74,27,91,72)" - ;S SIOM=80 - Q - ; -PSEUDO2 ; FAKE LOGIN SETS SOME LOCAL VARIABLE TO FOOL FILEMAN - S DILOCKTM=3 - S DISYS=19 - S DT=3100112 - S DTIME=9999 - S DUZ=10000000020 - S DUZ(0)="@" - S DUZ(1)="" - S DUZ(2)=67 - S DUZ("AG")="E" - S DUZ("BUF")=1 - S DUZ("LANG")=1 - S IO="/dev/pts/0" - ;S IO(0)="/dev/pts/0" - ;S IO(1,"/dev/pts/0")="" - ;S IO("ERROR")="" - ;S IO("HOME")="50^/dev/pts/0" - ;S IO("ZIO")="/dev/pts/0" - ;S IOBS="$C(8)" - ;S IOF="!!!!!!!!!!!!!!!!!!!!!!!!,#,$C(27,91,50,74,27,91,72)" - ;S IOM=80 - ;S ION="GTM/UNIX TELNET" - ;S IOS=50 - ;S IOSL=24 - ;S IOST="C-VT100" - ;S IOST(0)=9 - ;S IOT="VTRM" - ;S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)" - S U="^" - S X="1;DIC(4.2," - S XPARSYS="1;DIC(4.2," - S XQXFLG="^^XUP" - S Y="DEV^VISTA^hollywood^VISTA:hollywood" - Q - ; + ;;1.0;C0C;;Mar 1, 2010;Build 1 +gpltest2 ; experiment with sending a CCR to an ewd page + N ZI + S ZI="" + D PSEUDO + N ZIO + S ZIO=IO + S IO="/dev/null" + OPEN IO + U IO + N G + S G=$$URLTOKEN^C0CEWD + D CCRRPC^C0CCCR(.GPL,2) + S IO=ZIO + OPEN IO + U IO + K GPL(0) + F S ZI=$O(GPL(ZI)) Q:ZI="" W GPL(ZI),! + Q + ; +gpltest ; experiment with sending a CCR to an ewd page + N ZI + S ZI="" + K ^GPL(0) + S ^GPL(2)="" + F S ZI=$O(^GPL(ZI)) Q:ZI="" W ^GPL(ZI),! + Q + ; +TEST(sessid); + d setSessionValue^%zewdAPI("person.Name","Rob",sessid) + d setSessionValue^%zewdAPI("person.DateOfBirth","13/06/55",sessid) + d setSessionValue^%zewdAPI("person.Address.PostCode","SW1 3QA",sessid) + d setSessionValue^%zewdAPI("person.Address.Line1","1 The Street",sessid) + d setSessionValue^%zewdAPI("person.Address.2.hello","world",sessid) + d setJSONValue^%zewdAPI("json","person",sessid) + Q "" + +PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME + ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD + ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD + N ZR + M ^CacheTempEWD($j)=@INXML ; + S ZR=$$parseDocument^%zewdHTMLParser(INDOC) + Q ZR + ; +TEST2(sessid) ; try to put a ccr in the session + S U="^" + D PSEUDO ; FAKE LOGIN + S ZIO=$IO + S DEV="/dev/null" + O DEV U DEV + N G + N ZDFN + S ZDFN=$$getSessionValue^%zewdAPI("vista.dfn",sessid) + I ZDFN="" S ZDFN=2 + ;K ^TMP("GPL") + ;M ^TMP("GPL")=^%zewdSession("session",sessid) + D CCRRPC^C0CCCR(.GPL,ZDFN) + K GPL(0) + S GPL(2)="" + C DEV U ZIO + ;M ^CacheTempEWD($j)=GPL + S DOCNAME="CCR" + ;ZWR GPL + ;S ZR=$$parseDocument^%zewdHTMLParser(DOCNAME) + ;d setSessionValues^%zewdAPI(DOCNAME,GPL,sessid) + d mergeArrayToSession^%zewdAPI(.GPL,DOCNAME,sessid) + Q "" + ; +INITSES(sessid) ;initialize an EWD/CPRS session + K ^TMP("GPL") + ;M ^TMP("GPL")=^%zewdSession("session",sessid) + N ZT,ZDFN + S ZT=$$URLTOKEN^C0CEWD(sessid) + ;S ^TMP("GPL")=ZT + d trace^%zewdAPI("*********************ZT="_ZT) + S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN + S ^TMP("GPL","DFN")=ZDFN + I ZDFN=0 S DFN=2 ; DEFAULT TEST PATIENT + D setSessionValue^%zewdAPI("vista.dfn",ZDFN,sessid) + ;M ^TMP("GPL","request")=requestArray + ;D PSEUDO + ;D ^%ZTER + q "" + ; +PRSEORTK(ZTOKEN) ;PARSES THE TOKEN SENT BY CPRS AND RETURNS THE DFN + ; OF THE PATIENT ; HERE'S WHAT THE TOKEN LOOKS LIKE: + ; ^TMP('ORWCHART',6547,'192.168.169.8',002E0FE6) + N ZX,ZN1,ZIP,ZN2,ZDFN,ZG + S ZDFN=0 ; DEFAULT RETURN + S ZN1=$P(ZTOKEN,",",2) ; FIRST NUMBER + S ZIP=$P(ZTOKEN,",",3) ; IP NUMBER + S ZIP=$P(ZIP,"'",2) ; GET RID OF ' + S ZN2=$P(ZTOKEN,",",4) ; SECOND NUMBER + S ZN2=$P(ZN2,")",1) ; GET RID OF ) + S ZG=$NA(^TMP("ORWCHART",ZN1,ZIP,ZN2)) ; BUILD THE GLOBAL NAME + I $G(@ZG)'="" S ZDFN=@ZG ; ACCESS THE GLOBAL + S ^TMP("GPL","FIRSTDFN")=ZDFN + S ^TMP("GPL","FIRSTGLB")=ZG + Q ZDFN + ; +GETPATIENTLIST(sessid) ; + D PSEUDO + D LISTALL^ORWPT(.RTN,"NAME","1") + N ZI + S ZI="" + F S ZI=$O(RTN(ZI)) Q:ZI="" D ; + . S data(ZI,"DFN")=$P(RTN(ZI),"^",1) + . S data(ZI,"Name")=$P(RTN(ZI),"^",2) + ; ZWR data + ;S data(1,"DFN")=$P(RTN(1),"^",1) + ;S data(1,"Name")=$P(RTN(1),"^",2) + d deleteFromSession^%zewdAPI("patients",sessid) + d createDataTableStore^%zewdYUIRuntime(.data,"patients",sessid) + ;d mergeArrayToSession^%zewdAPI(.data,"patients",sessid) + Q "" + ; +PSEUDO + S U="^" + S DILOCKTM=3 + S DISYS=19 + S DT=3100219 + S DTIME=999 + S DUZ=10 + S DUZ(0)="@" + S DUZ(1)="" + S DUZ(2)=1 + S DUZ("AG")="V" + S DUZ("BUF")=1 + S DUZ("LANG")="" + ;S IO="/dev/pts/2" + ;S IO(0)="/dev/pts/2" + ;S IO(1,"/dev/pts/2")="" + ;S IO("ERROR")="" + ;S IO("HOME")="41^/dev/pts/2" + ;S IO("ZIO")="/dev/pts/2" + ;S IOBS="$C(8)" + ;S IOF="#,$C(27,91,50,74,27,91,72)" + ;S SIOM=80 + Q + ; +PSEUDO2 ; FAKE LOGIN SETS SOME LOCAL VARIABLE TO FOOL FILEMAN + S DILOCKTM=3 + S DISYS=19 + S DT=3100112 + S DTIME=9999 + S DUZ=10000000020 + S DUZ(0)="@" + S DUZ(1)="" + S DUZ(2)=67 + S DUZ("AG")="E" + S DUZ("BUF")=1 + S DUZ("LANG")=1 + S IO="/dev/pts/0" + ;S IO(0)="/dev/pts/0" + ;S IO(1,"/dev/pts/0")="" + ;S IO("ERROR")="" + ;S IO("HOME")="50^/dev/pts/0" + ;S IO("ZIO")="/dev/pts/0" + ;S IOBS="$C(8)" + ;S IOF="!!!!!!!!!!!!!!!!!!!!!!!!,#,$C(27,91,50,74,27,91,72)" + ;S IOM=80 + ;S ION="GTM/UNIX TELNET" + ;S IOS=50 + ;S IOSL=24 + ;S IOST="C-VT100" + ;S IOST(0)=9 + ;S IOT="VTRM" + ;S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)" + S U="^" + S X="1;DIC(4.2," + S XPARSYS="1;DIC(4.2," + S XQXFLG="^^XUP" + S Y="DEV^VISTA^hollywood^VISTA:hollywood" + Q + ; Index: ccr/branches/ohum/p/C0CEWD.m =================================================================== --- ccr/branches/ohum/p/C0CEWD.m (revision 1332) +++ ccr/branches/ohum/p/C0CEWD.m (revision 1333) @@ -1,4 +1,4 @@ C0CEWD ; CCDCCR/GPL - CCR EWD utilities; 1/6/11 - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 77 + ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 ;Copyright 2011 George Lilly. Licensed under the terms of the GNU ;General Public License See attached copy of the License. Index: ccr/branches/ohum/p/C0CEWD1.m =================================================================== --- ccr/branches/ohum/p/C0CEWD1.m (revision 1332) +++ ccr/branches/ohum/p/C0CEWD1.m (revision 1333) @@ -1,67 +1,67 @@ -C0CEWD1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 - ;;0.1;CCDCCR;nopatch;noreleasedate - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q - ; -TEST(filepath) ; filepath IS THE PATH/FILE TO BE READ IN - i $g(^%ZISH)["" d ; if the VistA Kernal routine %ZISH exists - . n zfile,zpath,ztmp s (zfile,zpath,ztmp)="" - . s zfile=$re($p($re(filepath),"/",1)) ;file name - . s zpath=$p(filepath,zfile,1) ; file path - . s ztmp=$na(^CacheTempEWD($j,0)) - . s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2 - q - ; -TEST2 ; - s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml" - ;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath) - s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global - s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0) - ;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM") - w ok,! - q - ; -LOAD(filepath) ; load an xml file into the EWD global for DOM processing - ; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML) - ; after to process it to the DOM - isHTML=0 for XML files - n i - i $g(^%ZISH)["" d QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09 - . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)="" - . s zfile=$re($p($re(filepath),"/",1)) ;file name - . s zpath=$p(filepath,zfile,1) ; file path - . s ztmp=$na(^CacheTempEWD($j,0)) - . s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2 - . s i=$o(^CacheTempEWD($j,""),-1) ; highest line number - q i - ; -Q(ZQ,ZD) ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED - I '$D(ZD) S ZD="DerekDOM" - s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ; - d displayNodes^%zewdXPath(.nodes) - q - ; -GET1URL0(URL) ; - s ok=$$httpGET^%zewdGTM(URL,.gpl) - D INDEX^C0CXPATH("gpl","gpl2") - W !,"S URL=""",URL,"""",! - S G="" - F S G=$O(gpl2(G)) Q:G="" D ; - . W " S VDX(""",G,""")=""",gpl2(G),"""",! - W ! - Q +C0CEWD1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 + ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q + ; +TEST(filepath) ; filepath IS THE PATH/FILE TO BE READ IN + i $g(^%ZISH)["" d ; if the VistA Kernal routine %ZISH exists + . n zfile,zpath,ztmp s (zfile,zpath,ztmp)="" + . s zfile=$re($p($re(filepath),"/",1)) ;file name + . s zpath=$p(filepath,zfile,1) ; file path + . s ztmp=$na(^CacheTempEWD($j,0)) + . s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2 + q + ; +TEST2 ; + s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml" + ;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath) + s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global + s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0) + ;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM") + w ok,! + q + ; +LOAD(filepath) ; load an xml file into the EWD global for DOM processing + ; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML) + ; after to process it to the DOM - isHTML=0 for XML files + n i + i $g(^%ZISH)["" d QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09 + . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)="" + . s zfile=$re($p($re(filepath),"/",1)) ;file name + . s zpath=$p(filepath,zfile,1) ; file path + . s ztmp=$na(^CacheTempEWD($j,0)) + . s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2 + . s i=$o(^CacheTempEWD($j,""),-1) ; highest line number + q i + ; +Q(ZQ,ZD) ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED + I '$D(ZD) S ZD="DerekDOM" + s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ; + d displayNodes^%zewdXPath(.nodes) + q + ; +GET1URL0(URL) ; + s ok=$$httpGET^%zewdGTM(URL,.gpl) + D INDEX^C0CXPATH("gpl","gpl2") + W !,"S URL=""",URL,"""",! + S G="" + F S G=$O(gpl2(G)) Q:G="" D ; + . W " S VDX(""",G,""")=""",gpl2(G),"""",! + W ! + Q Index: ccr/branches/ohum/p/C0CFM1.m =================================================================== --- ccr/branches/ohum/p/C0CFM1.m (revision 1332) +++ ccr/branches/ohum/p/C0CFM1.m (revision 1333) @@ -1,4 +1,4 @@ C0CFM1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU ;General Public License See attached copy of the License. Index: ccr/branches/ohum/p/C0CFM2.m =================================================================== --- ccr/branches/ohum/p/C0CFM2.m (revision 1332) +++ ccr/branches/ohum/p/C0CFM2.m (revision 1333) @@ -1,4 +1,4 @@ C0CFM2 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU ;General Public License See attached copy of the License. Index: ccr/branches/ohum/p/C0CFM3.m =================================================================== --- ccr/branches/ohum/p/C0CFM3.m (revision 1332) +++ ccr/branches/ohum/p/C0CFM3.m (revision 1333) @@ -1,287 +1,287 @@ -C0CFM3 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 - ;;0.1;CCDCCR;nopatch;noreleasedate - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "This is the CCR FILEMAN Utility Library ",! - ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF - ; CCR ELEMENTS (^C0C(179.201, - ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE - ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT - ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS - ; ALL SUB-VARIABLES HAVE BEEN REMOVED - W ! - Q - ; -RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE - ; ' - I '$D(RIMBASE) D ASETUP^GPLRIMA ; FOR COMMAND LINE CALLS - N ZI,ZJ,ZC,ZPATBASE - S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH)) - S ZI="" - F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END - . S ZI=$O(@ZPATBASE@(ZI)) - . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE - Q - ; -PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE - ; - S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN)) - I '$D(ZWHICH) S ZWHICH="ALL" - I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED - . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) - . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION - E D ; MULTIPLE SECTIONS - . S C0CVARS=$NA(@C0CGLB) - . S C0CI="" - . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION - . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION - . . D PUTRIM1(DFN,C0CI,C0CVARSN) - Q - ; -PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS - ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" - S C0CX=0 - F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE - . W "ZOCC=",C0CX,! - . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME - . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE - . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE - . I $D(C0CMDO) D ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :() - . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV - . . S ZZCNT=0 - . . S ZZC0CI=0 - . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE - . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE - . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR - . . W "MULTIPLE:",ZZVALS,! - . . ;B - . . F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE - . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT - . . . W "COUNT:",ZZCNT,! - . . . S ZV=$NA(@ZZVALS@(ZZC0CI)) - . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV) - Q - ; -PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE - ; 171.601, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE - ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE - ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC - ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM - ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT - ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES - ; - N ZSRC,PATN,ZTYPN,XD0,ZTYP - S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 - ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE - N C0CF S C0CF=171.601 ; FILE AT ELEMENT LEVEL - N C0CFV S C0CFV=171.6011 ; FILE AT VARIABLE LVL - N C0CFDA - N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) - W "ZTYPE: ",ZTYPE," ",ZTYPN,! - N ZVARN ; IEN OF VARIABLE BEING PROCESSED - ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE - S C0CFDA(C0CF,"+1,",.01)=ZTYPN - S C0CFDA(C0CF,"+1,",.02)=DFN - S C0CFDA(C0CF,"+1,",.03)=ZSRC - S C0CFDA(C0CF,"+1,",.04)=" "_ZOCC ;CREATE OCCURANCE with leading space - D UPDIE ; CREATE THE RECORD - S C0CIEN=$O(^C0CE4("C",DFN,ZSRC,ZTYPN," "_ZOCC,"")) - N ZCNT,ZC0CI,ZVARN,C0CZ1 - S ZCNT=0 - S ZC0CI="" ; - F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; - . I ZC0CI'="M" D ; NOT A SUBVARIABLE - . . S ZCNT=ZCNT+1 ;INCREMENT COUNT - . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT - . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND - . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",.01)=ZVARN - . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",1)=@ZVALS@(ZC0CI) - . E D ; THIS IS A SUBELEMENT - . . ;PUT THE FOLLOWING BACK TO USE RECURSION - . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV - . . ;S ZZCNT=0 - . . ;S ZZC0CI=0 - . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE - . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE - . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR - . . ;W "MULTIPLE:",ZZVALS,! - . . ;B - . . ;F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE - . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT - . . ;. W "COUNT:",ZZCNT,! - . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI)) - . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION - . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION) - D UPDIE ; UPDATE - Q - ; -UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS - K ZERR - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","","ZERR") - I $D(ZERR) D ; - . W "ERROR",! - . ZWR ZERR - . B - K C0CFDA - Q - ; -PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE - ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE - ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE - ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC - ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM - ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT - ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES - ; - S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 - ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE - N ZF,ZFV S ZF=171.101 S ZFV=171.1011 - ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS - ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER - N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) - W "ZTYPE: ",ZTYPE," ",ZTYPN,! - N ZVARN ; IEN OF VARIABLE BEING PROCESSED - ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE - K C0CFDA - S C0CFDA(ZF,"?+1,",.01)=DFN - S C0CFDA(ZF,"?+1,",.02)=ZSRC - S C0CFDA(ZF,"?+1,",.03)=ZTYPN - S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE - K ZERR - ;B - D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER - I $D(ZERR) B ;OOPS - K C0CFDA - S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,"")) - W "RECORD NUMBER: ",ZD0,! - ;B - S ZCNT=0 - S ZC0CI="" ; - F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; - . I ZC0CI'="M" D ; NOT A SUBVARIABLE - . . S ZCNT=ZCNT+1 ;INCREMENT COUNT - . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT - . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND - . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN - . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) - . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN - . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) - ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" - ;S GT1(170,"?+1,",12)="DIR" - ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" - ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","","ZERR") - I $D(ZERR) D ; - . W "ERROR",! - . ZWR ZERR - . B - K C0CFDA - Q - ; -VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE - ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO - ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO - ; - N ZCCRD,ZVARN,C0CFDA2 - S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY - S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE - I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT - . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE - . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! - . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE - . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE - . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN - . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY - . I $D(ZERR) D ; LAYGO ERROR - . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! - . E D ; - . . D CLEAN^DILF ; CLEAN UP - . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE - . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! - Q ZVARN - ; -BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) - ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED - ; - N C0CDIC,C0CNODE ; - S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY - S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE - Q - ; -FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED - ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET - ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS - ; CONVERSION - ;N C0CC,C0CI,C0CJ,C0CN,C0CZX - D FIELDS^C0CRNF("C0CC",170) - S C0CI="" - F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION - . S C0CZX="" - . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE - . . W "SECTION ",C0CI," VAR ",C0CZX - . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) - . . W " TYPE: ",C0CV,! - . . D SETFDA("SECTION",C0CV) - . . ;ZWR C0CFDA - Q - ; -SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN - ; TO SET TO VALUE C0CSV. - ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE - ; C0CSN,C0CSV ARE PASSED BY VALUE - ; - N C0CSI,C0CSJ - S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER - S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER - S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV - Q -ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) - E S ZR="" - Q ZR -ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) - E S ZR="" - Q ZR - ; -ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED - ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) - ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA - I '$D(ZTAB) S ZTAB="C0CA" - N ZR - I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) - E S ZR="" - Q ZR - ; -SHOWE4(DFN) ; - ; - N ZG - S ZG="" - F S ZG=$O(^C0CE4("P",DFN,ZG)) Q:ZG="" D ZWR ^C0CE4(ZG,*) - Q - ; +C0CFM3 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 + ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "This is the CCR FILEMAN Utility Library ",! + ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF + ; CCR ELEMENTS (^C0C(179.201, + ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE + ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT + ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS + ; ALL SUB-VARIABLES HAVE BEEN REMOVED + W ! + Q + ; +RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE + ; ' + I '$D(RIMBASE) D ASETUP^GPLRIMA ; FOR COMMAND LINE CALLS + N ZI,ZJ,ZC,ZPATBASE + S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH)) + S ZI="" + F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END + . S ZI=$O(@ZPATBASE@(ZI)) + . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE + Q + ; +PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE + ; + S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN)) + I '$D(ZWHICH) S ZWHICH="ALL" + I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED + . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) + . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION + E D ; MULTIPLE SECTIONS + . S C0CVARS=$NA(@C0CGLB) + . S C0CI="" + . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION + . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION + . . D PUTRIM1(DFN,C0CI,C0CVARSN) + Q + ; +PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS + ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" + S C0CX=0 + F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE + . W "ZOCC=",C0CX,! + . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME + . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE + . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE + . I $D(C0CMDO) D ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :() + . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV + . . S ZZCNT=0 + . . S ZZC0CI=0 + . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE + . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE + . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR + . . W "MULTIPLE:",ZZVALS,! + . . ;B + . . F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE + . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT + . . . W "COUNT:",ZZCNT,! + . . . S ZV=$NA(@ZZVALS@(ZZC0CI)) + . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV) + Q + ; +PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE + ; 171.601, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE + ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE + ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC + ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM + ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT + ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES + ; + N ZSRC,PATN,ZTYPN,XD0,ZTYP + S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 + ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE + N C0CF S C0CF=171.601 ; FILE AT ELEMENT LEVEL + N C0CFV S C0CFV=171.6011 ; FILE AT VARIABLE LVL + N C0CFDA + N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) + W "ZTYPE: ",ZTYPE," ",ZTYPN,! + N ZVARN ; IEN OF VARIABLE BEING PROCESSED + ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE + S C0CFDA(C0CF,"+1,",.01)=ZTYPN + S C0CFDA(C0CF,"+1,",.02)=DFN + S C0CFDA(C0CF,"+1,",.03)=ZSRC + S C0CFDA(C0CF,"+1,",.04)=" "_ZOCC ;CREATE OCCURANCE with leading space + D UPDIE ; CREATE THE RECORD + S C0CIEN=$O(^C0CE4("C",DFN,ZSRC,ZTYPN," "_ZOCC,"")) + N ZCNT,ZC0CI,ZVARN,C0CZ1 + S ZCNT=0 + S ZC0CI="" ; + F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; + . I ZC0CI'="M" D ; NOT A SUBVARIABLE + . . S ZCNT=ZCNT+1 ;INCREMENT COUNT + . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT + . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND + . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",.01)=ZVARN + . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",1)=@ZVALS@(ZC0CI) + . E D ; THIS IS A SUBELEMENT + . . ;PUT THE FOLLOWING BACK TO USE RECURSION + . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV + . . ;S ZZCNT=0 + . . ;S ZZC0CI=0 + . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE + . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE + . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR + . . ;W "MULTIPLE:",ZZVALS,! + . . ;B + . . ;F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE + . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT + . . ;. W "COUNT:",ZZCNT,! + . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI)) + . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION + . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION) + D UPDIE ; UPDATE + Q + ; +UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS + K ZERR + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","","ZERR") + I $D(ZERR) D ; + . W "ERROR",! + . ZWR ZERR + . B + K C0CFDA + Q + ; +PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE + ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE + ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE + ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC + ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM + ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT + ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES + ; + S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 + ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE + N ZF,ZFV S ZF=171.101 S ZFV=171.1011 + ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS + ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER + N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) + W "ZTYPE: ",ZTYPE," ",ZTYPN,! + N ZVARN ; IEN OF VARIABLE BEING PROCESSED + ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE + K C0CFDA + S C0CFDA(ZF,"?+1,",.01)=DFN + S C0CFDA(ZF,"?+1,",.02)=ZSRC + S C0CFDA(ZF,"?+1,",.03)=ZTYPN + S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE + K ZERR + ;B + D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER + I $D(ZERR) B ;OOPS + K C0CFDA + S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,"")) + W "RECORD NUMBER: ",ZD0,! + ;B + S ZCNT=0 + S ZC0CI="" ; + F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; + . I ZC0CI'="M" D ; NOT A SUBVARIABLE + . . S ZCNT=ZCNT+1 ;INCREMENT COUNT + . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT + . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND + . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN + . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) + . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN + . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) + ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" + ;S GT1(170,"?+1,",12)="DIR" + ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" + ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","","ZERR") + I $D(ZERR) D ; + . W "ERROR",! + . ZWR ZERR + . B + K C0CFDA + Q + ; +VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE + ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO + ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO + ; + N ZCCRD,ZVARN,C0CFDA2 + S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY + S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE + I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT + . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE + . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! + . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE + . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE + . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN + . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY + . I $D(ZERR) D ; LAYGO ERROR + . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! + . E D ; + . . D CLEAN^DILF ; CLEAN UP + . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE + . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! + Q ZVARN + ; +BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) + ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED + ; + N C0CDIC,C0CNODE ; + S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY + S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE + Q + ; +FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED + ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET + ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS + ; CONVERSION + ;N C0CC,C0CI,C0CJ,C0CN,C0CZX + D FIELDS^C0CRNF("C0CC",170) + S C0CI="" + F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION + . S C0CZX="" + . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE + . . W "SECTION ",C0CI," VAR ",C0CZX + . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) + . . W " TYPE: ",C0CV,! + . . D SETFDA("SECTION",C0CV) + . . ;ZWR C0CFDA + Q + ; +SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN + ; TO SET TO VALUE C0CSV. + ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE + ; C0CSN,C0CSV ARE PASSED BY VALUE + ; + N C0CSI,C0CSJ + S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER + S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER + S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV + Q +ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) + E S ZR="" + Q ZR +ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) + E S ZR="" + Q ZR + ; +ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED + ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) + ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA + I '$D(ZTAB) S ZTAB="C0CA" + N ZR + I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) + E S ZR="" + Q ZR + ; +SHOWE4(DFN) ; + ; + N ZG + S ZG="" + F S ZG=$O(^C0CE4("P",DFN,ZG)) Q:ZG="" D ZWR ^C0CE4(ZG,*) + Q + ; Index: ccr/branches/ohum/p/C0CIM2.m =================================================================== --- ccr/branches/ohum/p/C0CIM2.m (revision 1332) +++ ccr/branches/ohum/p/C0CIM2.m (revision 1333) @@ -1,4 +1,4 @@ C0CIM2 ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10 - ;;1.0;C0C;;Feb 16, 2010;Build 38 + ;;1.0;C0C;;Feb 16, 2010;Build 1 ;Copyright 2010 George Lilly, University of Minnesota and others. ;Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CIMMU.m =================================================================== --- ccr/branches/ohum/p/C0CIMMU.m (revision 1332) +++ ccr/branches/ohum/p/C0CIMMU.m (revision 1333) @@ -1,4 +1,4 @@ C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008,2009 George Lilly, University of Minnesota. ;Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CIN.m =================================================================== --- ccr/branches/ohum/p/C0CIN.m (revision 1332) +++ ccr/branches/ohum/p/C0CIN.m (revision 1333) @@ -1,4 +1,4 @@ C0CIN ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08 - ;;1.0;C0C;;Sep 20, 2009;Build 38 + ;;1.0;C0C;;Sep 20, 2009;Build 1 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU ;General Public License See attached copy of the License. Index: ccr/branches/ohum/p/C0CLA7DD.m =================================================================== --- ccr/branches/ohum/p/C0CLA7DD.m (revision 1332) +++ ccr/branches/ohum/p/C0CLA7DD.m (revision 1333) @@ -1,252 +1,252 @@ -C0CLA7DD ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009 - ;;1.0;C0C;;May 19, 2009; - ; - ; Tasked by C0C post-install routine C0CENV to create C0C cross-references on V LAB file. - ; - Q - ; - ; -EN ; Add new style cross-references to V LAB file if it exists. - ; OLD entry point - see new KIDS check points in C0CENV. - ; - ; - ; Quit if AUPNVLAB global does not exist. - I $$VFILE^DILFD(9000010.09)'=1 Q - ; - N MSG - ; - S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR1 - S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - ; - S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR2 - S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - ; - S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR3 - S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - ; - S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR4 - S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - ; - S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - D ALR5 - S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") - D BMES(MSG) - ; - Q - ; - ; -ALR1 ; Installation of ALR1 cross-reference - ; - N C0CFLAG,C0CXR,C0CRES,C0COUT - ; - S C0CFLAG="" - ; - S C0CXR("FILE")=9000010.09 - S C0CXR("NAME")="ALR1" - S C0CXR("TYPE")="R" - S C0CXR("USE")="S" - S C0CXR("EXECUTION")="R" - S C0CXR("ACTIVITY")="IR" - S C0CXR("SHORT DESCR")="X-ref to link entry with parent in LAB DATA file (#63)" - S C0CXR("VAL",1)=.02 - S C0CXR("VAL",1,"SUBSCRIPT")=1 - S C0CXR("VAL",1,"COLLATION")="F" - S C0CXR("VAL",2)=.06 - S C0CXR("VAL",2,"SUBSCRIPT")=2 - S C0CXR("VAL",2,"LENGTH")=30 - S C0CXR("VAL",2,"COLLATION")="F" - S C0CXR("VAL",3)=.01 - S C0CXR("VAL",3,"SUBSCRIPT")=3 - S C0CXR("VAL",3,"COLLATION")="F" - S C0CXR("VAL",4)=1201 - S C0CXR("VAL",4,"SUBSCRIPT")=4 - S C0CXR("VAL",4,"COLLATION")="F" - D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") - ; - Q - ; - ; -ALR2 ; Installation of ALR2 cross-reference - ; - N C0CFLAG,C0CXR,C0CRES,C0COUT - ; - S C0CFLAG="" - ; - S C0CXR("FILE")=9000010.09 - S C0CXR("NAME")="ALR2" - S C0CXR("TYPE")="MU" - S C0CXR("USE")="S" - S C0CXR("EXECUTION")="R" - S C0CXR("ACTIVITY")="IR" - S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result." - S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes" - S C0CXR("DESCR",2)="that has been assigned to a lab result. Allows queries to" - S C0CXR("DESCR",3)="retrieve the LOINC code associated with a specific test" - S C0CXR("DESCR",4)="result." - S C0CXR("SET")="S ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)=""""" - S C0CXR("KILL")="K ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)" - S C0CXR("WHOLE KILL")="K ^AUPNVLAB(""ALR2"")" - S C0CXR("VAL",1)=.02 - S C0CXR("VAL",1,"SUBSCRIPT")=1 - S C0CXR("VAL",1,"COLLATION")="F" - S C0CXR("VAL",2)=1201 - S C0CXR("VAL",2,"SUBSCRIPT")=2 - S C0CXR("VAL",2,"COLLATION")="F" - S C0CXR("VAL",3)=.06 - S C0CXR("VAL",3,"SUBSCRIPT")=3 - S C0CXR("VAL",3,"COLLATION")="F" - S C0CXR("VAL",4)=.01 - S C0CXR("VAL",4,"SUBSCRIPT")=4 - S C0CXR("VAL",4,"COLLATION")="F" - S C0CXR("VAL",5)=1113 - S C0CXR("VAL",5,"SUBSCRIPT")=5 - S C0CXR("VAL",5,"COLLATION")="F" - D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") - ; - Q - ; - ; -ALR3 ; Installation of ALR3 cross-reference - ; - N C0CFLAG,C0CXR,C0CRES,C0COUT - ; - S C0CFLAG="" - ; - S C0CXR("FILE")=9000010.09 - S C0CXR("NAME")="ALR3" - S C0CXR("TYPE")="R" - S C0CXR("USE")="S" - S C0CXR("EXECUTION")="F" - S C0CXR("ACTIVITY")="IR" - S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result - any patient" - S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes that has been assigned to a lab result. Allows queries" - S C0CXR("DESCR",2)="to retrieve the LOINC code associated with a specific test result. It allows any patient" - S C0CXR("DESCR",3)="lab results to be identified by LOINC" - S C0CXR("VAL",1)=1113 - S C0CXR("VAL",1,"SUBSCRIPT")=1 - S C0CXR("VAL",1,"COLLATION")="F" - ; - D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") - ; - Q - ; - ; -ALR4 ; Installation of ALR4 cross-reference - ; - N C0CFLAG,C0CXR,C0CRES,C0COUT - ; - S C0CFLAG="" - ; - S C0CXR("FILE")=9000010.09 - S C0CXR("NAME")="ALR4" - S C0CXR("TYPE")="R" - S C0CXR("USE")="S" - S C0CXR("EXECUTION")="R" - S C0CXR("ACTIVITY")="IR" - S C0CXR("SHORT DESCR")="X-ref by patient and collection date/time" - S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a" - S C0CXR("DESCR",2)="patient by collection date/time. This includes results that are only in" - S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA" - S C0CXR("DESCR",4)="file (#63)." - S C0CXR("VAL",1)=.02 - S C0CXR("VAL",1,"SUBSCRIPT")=1 - S C0CXR("VAL",1,"COLLATION")="F" - S C0CXR("VAL",2)=1201 - S C0CXR("VAL",2,"SUBSCRIPT")=2 - S C0CXR("VAL",2,"COLLATION")="F" - ; - D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") - ; - Q - ; - ; -ALR5 ; Installation of ALR5 cross-reference - ; - N C0CFLAG,C0CXR,C0CRES,C0COUT - ; - S C0CFLAG="" - ; - S C0CXR("FILE")=9000010.09 - S C0CXR("NAME")="ALR5" - S C0CXR("TYPE")="R" - S C0CXR("USE")="S" - S C0CXR("EXECUTION")="R" - S C0CXR("ACTIVITY")="IR" - S C0CXR("SHORT DESCR")="X-ref by patient and results availble date/time" - S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a" - S C0CXR("DESCR",2)="patient by results available date/time. This includes results that are only in" - S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA" - S C0CXR("DESCR",4)="file (#63)." - S C0CXR("VAL",1)=.02 - S C0CXR("VAL",1,"SUBSCRIPT")=1 - S C0CXR("VAL",1,"COLLATION")="F" - S C0CXR("VAL",2)=1212 - S C0CXR("VAL",2,"SUBSCRIPT")=2 - S C0CXR("VAL",2,"COLLATION")="F" - ; - D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") - ; - Q - ; - ; -REINDEX ; Set data into indexes for current entries. - ; - ; - N C0CHLOG,DA,DIK,MSG - ; - S C0CHLOG("START")=$H - S MSG="Starting indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") - D BMES(MSG),SENDXQA(MSG) - ; - S DIK="^AUPNVLAB(" - S DIK(1)=".02^ALR1^ALR2^ALR4^ALR5" - D ENALL^DIK - ; - S C0CHLOG("END")=$H - S MSG="Finished indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z") - D BMES(MSG),SENDXQA(MSG) - ; - S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3) - D BMES(MSG) - ; - S C0CHLOG("START")=$H - S MSG="Starting indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") - D BMES(MSG),SENDXQA(MSG) - ; - K DA,DIK - S DIK="^AUPNVLAB(" - S DIK(1)="1113^ALR3" - D ENALL^DIK - ; - S C0CHLOG("END")=$H - S MSG="Finished indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z") - D BMES(MSG),SENDXQA(MSG) - ; - S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3) - D BMES(MSG) - ; - Q - ; - ; -BMES(STR) ; Write BMES^XPDUTL statements - ; - D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM)) - ; - Q - ; - ; +C0CLA7DD ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009 + ;;1.0;C0C;;May 19, 2009;Build 1 + ; + ; Tasked by C0C post-install routine C0CENV to create C0C cross-references on V LAB file. + ; + Q + ; + ; +EN ; Add new style cross-references to V LAB file if it exists. + ; OLD entry point - see new KIDS check points in C0CENV. + ; + ; + ; Quit if AUPNVLAB global does not exist. + I $$VFILE^DILFD(9000010.09)'=1 Q + ; + N MSG + ; + S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR1 + S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + ; + S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR2 + S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + ; + S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR3 + S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + ; + S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR4 + S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + ; + S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + D ALR5 + S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") + D BMES(MSG) + ; + Q + ; + ; +ALR1 ; Installation of ALR1 cross-reference + ; + N C0CFLAG,C0CXR,C0CRES,C0COUT + ; + S C0CFLAG="" + ; + S C0CXR("FILE")=9000010.09 + S C0CXR("NAME")="ALR1" + S C0CXR("TYPE")="R" + S C0CXR("USE")="S" + S C0CXR("EXECUTION")="R" + S C0CXR("ACTIVITY")="IR" + S C0CXR("SHORT DESCR")="X-ref to link entry with parent in LAB DATA file (#63)" + S C0CXR("VAL",1)=.02 + S C0CXR("VAL",1,"SUBSCRIPT")=1 + S C0CXR("VAL",1,"COLLATION")="F" + S C0CXR("VAL",2)=.06 + S C0CXR("VAL",2,"SUBSCRIPT")=2 + S C0CXR("VAL",2,"LENGTH")=30 + S C0CXR("VAL",2,"COLLATION")="F" + S C0CXR("VAL",3)=.01 + S C0CXR("VAL",3,"SUBSCRIPT")=3 + S C0CXR("VAL",3,"COLLATION")="F" + S C0CXR("VAL",4)=1201 + S C0CXR("VAL",4,"SUBSCRIPT")=4 + S C0CXR("VAL",4,"COLLATION")="F" + D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") + ; + Q + ; + ; +ALR2 ; Installation of ALR2 cross-reference + ; + N C0CFLAG,C0CXR,C0CRES,C0COUT + ; + S C0CFLAG="" + ; + S C0CXR("FILE")=9000010.09 + S C0CXR("NAME")="ALR2" + S C0CXR("TYPE")="MU" + S C0CXR("USE")="S" + S C0CXR("EXECUTION")="R" + S C0CXR("ACTIVITY")="IR" + S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result." + S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes" + S C0CXR("DESCR",2)="that has been assigned to a lab result. Allows queries to" + S C0CXR("DESCR",3)="retrieve the LOINC code associated with a specific test" + S C0CXR("DESCR",4)="result." + S C0CXR("SET")="S ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)=""""" + S C0CXR("KILL")="K ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)" + S C0CXR("WHOLE KILL")="K ^AUPNVLAB(""ALR2"")" + S C0CXR("VAL",1)=.02 + S C0CXR("VAL",1,"SUBSCRIPT")=1 + S C0CXR("VAL",1,"COLLATION")="F" + S C0CXR("VAL",2)=1201 + S C0CXR("VAL",2,"SUBSCRIPT")=2 + S C0CXR("VAL",2,"COLLATION")="F" + S C0CXR("VAL",3)=.06 + S C0CXR("VAL",3,"SUBSCRIPT")=3 + S C0CXR("VAL",3,"COLLATION")="F" + S C0CXR("VAL",4)=.01 + S C0CXR("VAL",4,"SUBSCRIPT")=4 + S C0CXR("VAL",4,"COLLATION")="F" + S C0CXR("VAL",5)=1113 + S C0CXR("VAL",5,"SUBSCRIPT")=5 + S C0CXR("VAL",5,"COLLATION")="F" + D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") + ; + Q + ; + ; +ALR3 ; Installation of ALR3 cross-reference + ; + N C0CFLAG,C0CXR,C0CRES,C0COUT + ; + S C0CFLAG="" + ; + S C0CXR("FILE")=9000010.09 + S C0CXR("NAME")="ALR3" + S C0CXR("TYPE")="R" + S C0CXR("USE")="S" + S C0CXR("EXECUTION")="F" + S C0CXR("ACTIVITY")="IR" + S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result - any patient" + S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes that has been assigned to a lab result. Allows queries" + S C0CXR("DESCR",2)="to retrieve the LOINC code associated with a specific test result. It allows any patient" + S C0CXR("DESCR",3)="lab results to be identified by LOINC" + S C0CXR("VAL",1)=1113 + S C0CXR("VAL",1,"SUBSCRIPT")=1 + S C0CXR("VAL",1,"COLLATION")="F" + ; + D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") + ; + Q + ; + ; +ALR4 ; Installation of ALR4 cross-reference + ; + N C0CFLAG,C0CXR,C0CRES,C0COUT + ; + S C0CFLAG="" + ; + S C0CXR("FILE")=9000010.09 + S C0CXR("NAME")="ALR4" + S C0CXR("TYPE")="R" + S C0CXR("USE")="S" + S C0CXR("EXECUTION")="R" + S C0CXR("ACTIVITY")="IR" + S C0CXR("SHORT DESCR")="X-ref by patient and collection date/time" + S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a" + S C0CXR("DESCR",2)="patient by collection date/time. This includes results that are only in" + S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA" + S C0CXR("DESCR",4)="file (#63)." + S C0CXR("VAL",1)=.02 + S C0CXR("VAL",1,"SUBSCRIPT")=1 + S C0CXR("VAL",1,"COLLATION")="F" + S C0CXR("VAL",2)=1201 + S C0CXR("VAL",2,"SUBSCRIPT")=2 + S C0CXR("VAL",2,"COLLATION")="F" + ; + D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") + ; + Q + ; + ; +ALR5 ; Installation of ALR5 cross-reference + ; + N C0CFLAG,C0CXR,C0CRES,C0COUT + ; + S C0CFLAG="" + ; + S C0CXR("FILE")=9000010.09 + S C0CXR("NAME")="ALR5" + S C0CXR("TYPE")="R" + S C0CXR("USE")="S" + S C0CXR("EXECUTION")="R" + S C0CXR("ACTIVITY")="IR" + S C0CXR("SHORT DESCR")="X-ref by patient and results availble date/time" + S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a" + S C0CXR("DESCR",2)="patient by results available date/time. This includes results that are only in" + S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA" + S C0CXR("DESCR",4)="file (#63)." + S C0CXR("VAL",1)=.02 + S C0CXR("VAL",1,"SUBSCRIPT")=1 + S C0CXR("VAL",1,"COLLATION")="F" + S C0CXR("VAL",2)=1212 + S C0CXR("VAL",2,"SUBSCRIPT")=2 + S C0CXR("VAL",2,"COLLATION")="F" + ; + D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") + ; + Q + ; + ; +REINDEX ; Set data into indexes for current entries. + ; + ; + N C0CHLOG,DA,DIK,MSG + ; + S C0CHLOG("START")=$H + S MSG="Starting indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") + D BMES(MSG),SENDXQA(MSG) + ; + S DIK="^AUPNVLAB(" + S DIK(1)=".02^ALR1^ALR2^ALR4^ALR5" + D ENALL^DIK + ; + S C0CHLOG("END")=$H + S MSG="Finished indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z") + D BMES(MSG),SENDXQA(MSG) + ; + S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3) + D BMES(MSG) + ; + S C0CHLOG("START")=$H + S MSG="Starting indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") + D BMES(MSG),SENDXQA(MSG) + ; + K DA,DIK + S DIK="^AUPNVLAB(" + S DIK(1)="1113^ALR3" + D ENALL^DIK + ; + S C0CHLOG("END")=$H + S MSG="Finished indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z") + D BMES(MSG),SENDXQA(MSG) + ; + S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3) + D BMES(MSG) + ; + Q + ; + ; +BMES(STR) ; Write BMES^XPDUTL statements + ; + D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM)) + ; + Q + ; + ; SENDXQA(MSG) ; Send alert for reindex status ; Index: ccr/branches/ohum/p/C0CLA7Q.m =================================================================== --- ccr/branches/ohum/p/C0CLA7Q.m (revision 1332) +++ ccr/branches/ohum/p/C0CLA7Q.m (revision 1333) @@ -1,4 +1,4 @@ C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ; ; Index: ccr/branches/ohum/p/C0CLABS.m =================================================================== --- ccr/branches/ohum/p/C0CLABS.m (revision 1332) +++ ccr/branches/ohum/p/C0CLABS.m (revision 1333) @@ -1,4 +1,4 @@ C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008,2009 George Lilly, University of Minnesota. ;Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CMAIL.m =================================================================== --- ccr/branches/ohum/p/C0CMAIL.m (revision 1332) +++ ccr/branches/ohum/p/C0CMAIL.m (revision 1333) @@ -1,372 +1,372 @@ C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr -V ;;0.1;C0C;nopatch;noreleasedate - ;Copyright 2011 Chris Richardson, Richardson Computer Research - ; Modified 3110516@1818 - ; rcr@rcresearch.us - ; Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; ------------------ - ;Entry Points - ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) - ; Input: - ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL - ; or "*" for all boxes, default is "IN" if missing]" - ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", - ; "*" for All or 9,999 maximum - ; MALL?1.n = that number of the n most recent - ; Internally: - ; BNAM = Box Name - ; Output: - ; C0CDATA - ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket - ; (BNAM,"MSG",C0CIEN,"FROM")=Name - ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address - ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address - ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title - ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments - ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text - ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text - ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes - ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) - ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line - ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details - ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data - ; - ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments - ; Input; - ; D0 - The IEN for the message in file 3.9, MESSAGE global - ; Output - ; OUTBF - The array of your choice to save the expanded and decoded message. - ; -GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data - K:'$G(C0CDATA("KEEP")) C0CDATA - N U - S U="^" - D:$G(C0CINPUT) - . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL - . S INPUT=C0CINPUT - . S DUZ=+INPUT - . D:$D(^XMB(3.7,DUZ,0))#2 - . . S MBLST=$P(INPUT,";",2) - . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag - . . S:MALL["*" MALL=99999 - . . ; Only one of these can be correct - . . D - . . . ; If nul, make it "IN" only - . . . I MBLST="" D QUIT - . . . . S MBLST("IN")=0,I=0 - . . . . D GATHER(DUZ,"IN",.LST) - . . . .QUIT - . . . ; - . . . ; If "*", Get all Mailboxes and look for New Messages - . . . I MBLST["*" D QUIT - . . . . N NAM,NUM - . . . . S NUM=0 - . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D - . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) - . . . . . D GATHER(DUZ,NAM,.LST) - . . . . .QUIT - . . . .QUIT - . . . ; - . . . ; If comma separated, look for mailboxes with new messages - . . . I $L(MBLST,",")>1 D QUIT - . . . . S NAM="" - . . . . N T,V - . . . . F T=1:1:$L(MBLST,",") S V=$P(MBLST,",",T) I $L(V) D - . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) - . . . . . S:NAM="" NAM=V - . . . . . D GATHER(DUZ,NAM,.LST) - . . . . .QUIT - . . . .QUIT - . . . ; - . . . ; If only 1 mailbox named, go get it - . . . I $L(MBLST) D GATHER(DUZ,MBLST,.LST) QUIT - . . .QUIT - . . MERGE C0CDATA=LST - . .QUIT - .QUIT - QUIT - ; =================== -GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail - N I,J,K,L - S (I,K)=0 - S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) - F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D - . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) - . D ; :L - . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails - . . S LST(NAM,"MSG",I)=L - . . D GETTYP(I) - . .QUIT - .QUIT - S LST(NAM,"NUMBER")=K - QUIT - ; =================== - ; D0 is the IEN into the Message Global ^XMB(3.9,D0) - ; The products of these emails are scanned to identify - ; the number of documents stored in the MIME package. - ; The protocol runs like this; - ; Line 1 is the --separator - ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD - ; Line n+2 thru t-1 where t does NOT have "Content-" - ; Line t is Next Section Terminator, or Message Terminator, --separator - ; Line t+1 should not exist in the data set if Message Terminator - ; CON = "Content-" - ; FLG = "--" - ; SEP = FLG+7 or more characters ; Separator - ; END = SEP+FLG - ; SGC = Segment Count - ; Note: separator is a string of specific characters of - ; indeterminate length - ; LST() the transfer array - ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line - ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data - ; -GETTYP(D0) ; Look for the goodies in the Mail - N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM - S CON="Content-" - S FLG="--" - S SEP="" ; Start SEP as null, so we can use this to help identify the type - S (BCN,CNT,D1,END,SGC)=0 - S XX=$G(^XMB(3.9,D0,0)) - S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) - S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) - F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) - S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) - S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) - ; Get the folks the email is sent to. - S D1=0 - F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D - . N T - . S T=+$G(^XMB(3.9,D0,1,D1,0)) - . S:T T=$P($G(^VA(200,+T,0)),"^") - . S LST("TO",D1)=T - . S T=$G(^XMB(3.9,D0,6,D1,0)) - . S:T T=$P($G(^VA(200,+T,0)),"^") - . S:T="" T="" - . S LST("TO NAME",D1)=T - .QUIT - ; Preload first Segment (0) with beginning on Line 1 - ; if not a 64bit - S LST(NAM,"MSG",D0,"SEG",0)=1 - S D1=.9999,SEP="--" - F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D - . ; Clear any control characters (cr/lf/ff) off - . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) - . ; Enter once to set the SEP to capture the separator - . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q - . . S SEP=X,END=X_FLG - . . S (CNT,SGC)=1,BCN=0 - . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 - . .QUIT - . ; - . ; A new separator is set, process original - . I X=SEP D QUIT - . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN - . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) - . . S SGC=SGC+1,BCN=0 - . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 - . .QUIT - . ; - . S BCN=BCN+$L(X) - . I X[CON D Q - . . S J=$P($P(X,";"),CON,2) - . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) - . .QUIT - . ; - . ; S LST(NAM,"MSG",D0,"SEG",D1)=X - .QUIT - QUIT - ; =================== -NAME(NM) ; Return the name of the Sender - N NAME - S NAME="" - D - . ; Look first for a value to use with the NEW PERSON file - . ; - . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q - . ; - . I $L(NM) S NAME=NM Q - . ; - . ; Else, pull the data from the message and display the foreign source - . ; of the message. - . N T - . S VAL=$G(^XMB(3.9,D0,.7)) - . S:VAL T=$P(^VA(200,VAL,0),U) - . I $L($G(T)) S NAME=T Q - . ; - .QUIT - QUIT NAME - ; =================== -TIME(Y) ; The time and date of the sending - X ^DD("DD") - QUIT Y - ; =================== - ; Segments in Message need to be identified and decoded properly - ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message - ; ARRAY will have the details of this one call - ; - ; Inputs; - ; C0CINPUT - The IEN of the message to expand - ; Outputs; - ; C0CDATA - Carrier for the returned structure of the Message - ; C0CDATA(D0,"SEG")=number of SEGMENTS - ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details - ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details - ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details - ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details - ; -DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery - N LST,D0,D1,U - S U="^" - S D0=+$G(C0CINPUT) - I D0 D QUIT - . D GETTYP2(D0) - . I $D(LST) M C0CDATA(D0)=LST - .QUIT - QUIT - ; =================== - ; End note if needed - ; MSK - Set of characters that do not exist in 64 bit encoding -GETTYP2(D0) ; Try to get the types and MSK for the - N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM - S CON="Content-",U="^" - S FLG="--" - S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" - S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type - S (BCN,CNT,D1,END,SGC)=0 - S XX=$G(^XMB(3.9,D0,0)) - ; S K=$P(^XMB(3.9,D0,2,0),U,3) - S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) - S LST("CREATED")=$$TIME($P(XX,U,3)) - F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) - S LST("FROM")=$$NAME(XXNM) - ; Get the folks the email is sent to. - S D1=0 - F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" - . N I,T - . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) - . S:T T=$P($G(^VA(200,T,0)),"^") - . S LST("TO",+D1)=T - . S T=$G(^XMB(3.9,D0,6,+D1,0)) - . S:T="" T=$P($G(^VA(200,+T,0)),"^") - . S:T="" T="" - . S LST("TO NAME",D1)=T - .QUIT - ; Get the Header for the message - S D1=0 - F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D - . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) - .QUIT - ; Start walking the different sections - S D1=.99999,SEP="--" - F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D - . ; Clear any control characters (cr/lf/ff) off - . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) - . ; Enter once to set the SEP to capture the separator - . I (SEP="--")&($E(X,1,2)=FLG)&($L(X,FLG)=2) D Q - . . S SEP=X,END=X_FLG - . . S (CNT,SGC)=1,BCN=0 - . . S LST("SEG",SGC)=D1 - . .QUIT - . ; - . ; A new SEGMENT separator is set, process original - . I X=SEP D QUIT - . . ; Save Current Values - . . S LST("SEG",SGC,"SIZE")=BCN - . . ; Close this Segment and prepare to start a New Segment - . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) - . . ; Put the result in LST("SEG",SGC,"XML") - . . I $L(BF) D - . . . S ZN=1 - . . . N I,T,TBF - . . . S TBF=BF - . . . F I=1:1:($L(TBF,"=")) D - . . . . S BF=$P(TBF,"=",I)_"=" - . . . . I BF'="=" D DECODER - . . . .QUIT - . . . S BF="" - . . .QUIT - . . S SGC=SGC+1,BCN=0 - . . ; Incriment SGC to start a new Segment - . . S LST("SEG",SGC)=D1 - . .QUIT - . ; - . ; Accumulate the 64 bit encoding - . I X=$TR(X,MSK)&$L(X) D Q - . . S BF=BF_X - . . S BCN=BCN+$L(X) - . .QUIT - . ; - . ; Ending Condition, close out the Segment - . I X=END D QUIT - . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) - . . I $L(BF) S ZN=1 D DECODER S BF="" Q - . .QUIT - . ; - . S BCN=BCN+$L(X) - . ; Split out the Content Info - . I X[CON D Q - . . S J=$P(X,CON,2) - . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9) - . .QUIT - . ; - . ; Everything else is Text - . S LST("SEG",SGC,"TXT",D1)=X - .QUIT - QUIT - ; =================== - ; Break down the Buffer Array so it can be saved. - ; BF is passed in. -DECODER ; - N RCNT,TBF,ZBF,ZI,ZJ,ZK,ZSIZE - S ZBF=BF - ; Full Buffer, BF, now check for Encryption and Unpack - F RCNT=1:1:$L(ZBF,"=") D - . N BF - . S BF=$P(ZBF,"=",RCNT) - . ; Unpacking the 64 bit encoding - . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) - . D:$L(TBF) - . . N XBF - . . S BF=BF_"=" - . . D NORMAL(.XBF,.TBF) - . . M LST("SEG",SGC,"XML",RCNT)=XBF - . .QUIT - .QUIT - QUIT - ; =================== - ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT - ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT - ; >D NORMAL^C0CMAIL(.OUT,BF) -NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML - ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME - ; - N ZN,OUTBF - S ZN=1 - S OUTBF(ZN)=$P(INXML,"><",ZN)_">" - F ZN=ZN+1:1 S OUTBF(ZN)="<"_$P(INXML,"><",ZN) Q:$P(INXML,"><",ZN+1)="" D ; - . S OUTBF(ZN)=OUTBF(ZN)_">" - .QUIT - M OUTXML=OUTBF - QUIT - ; =================== - ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv - ; End note if needed - QUIT - ; =================== +V ;;0.1;C0C;nopatch;noreleasedate;Build 1 + ;Copyright 2011 Chris Richardson, Richardson Computer Research + ; Modified 3110516@1818 + ; rcr@rcresearch.us + ; Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; ------------------ + ;Entry Points + ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) + ; Input: + ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL + ; or "*" for all boxes, default is "IN" if missing]" + ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", + ; "*" for All or 9,999 maximum + ; MALL?1.n = that number of the n most recent + ; Internally: + ; BNAM = Box Name + ; Output: + ; C0CDATA + ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket + ; (BNAM,"MSG",C0CIEN,"FROM")=Name + ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title + ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments + ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text + ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text + ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes + ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) + ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data + ; + ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments + ; Input; + ; D0 - The IEN for the message in file 3.9, MESSAGE global + ; Output + ; OUTBF - The array of your choice to save the expanded and decoded message. + ; +GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data + K:'$G(C0CDATA("KEEP")) C0CDATA + N U + S U="^" + D:$G(C0CINPUT) + . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL + . S INPUT=C0CINPUT + . S DUZ=+INPUT + . D:$D(^XMB(3.7,DUZ,0))#2 + . . S MBLST=$P(INPUT,";",2) + . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag + . . S:MALL["*" MALL=99999 + . . ; Only one of these can be correct + . . D + . . . ; If nul, make it "IN" only + . . . I MBLST="" D QUIT + . . . . S MBLST("IN")=0,I=0 + . . . . D GATHER(DUZ,"IN",.LST) + . . . .QUIT + . . . ; + . . . ; If "*", Get all Mailboxes and look for New Messages + . . . I MBLST["*" D QUIT + . . . . N NAM,NUM + . . . . S NUM=0 + . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D + . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) + . . . . . D GATHER(DUZ,NAM,.LST) + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If comma separated, look for mailboxes with new messages + . . . I $L(MBLST,",")>1 D QUIT + . . . . S NAM="" + . . . . N T,V + . . . . F T=1:1:$L(MBLST,",") S V=$P(MBLST,",",T) I $L(V) D + . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) + . . . . . S:NAM="" NAM=V + . . . . . D GATHER(DUZ,NAM,.LST) + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If only 1 mailbox named, go get it + . . . I $L(MBLST) D GATHER(DUZ,MBLST,.LST) QUIT + . . .QUIT + . . MERGE C0CDATA=LST + . .QUIT + .QUIT + QUIT + ; =================== +GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail + N I,J,K,L + S (I,K)=0 + S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) + F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D + . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) + . D ; :L + . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails + . . S LST(NAM,"MSG",I)=L + . . D GETTYP(I) + . .QUIT + .QUIT + S LST(NAM,"NUMBER")=K + QUIT + ; =================== + ; D0 is the IEN into the Message Global ^XMB(3.9,D0) + ; The products of these emails are scanned to identify + ; the number of documents stored in the MIME package. + ; The protocol runs like this; + ; Line 1 is the --separator + ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD + ; Line n+2 thru t-1 where t does NOT have "Content-" + ; Line t is Next Section Terminator, or Message Terminator, --separator + ; Line t+1 should not exist in the data set if Message Terminator + ; CON = "Content-" + ; FLG = "--" + ; SEP = FLG+7 or more characters ; Separator + ; END = SEP+FLG + ; SGC = Segment Count + ; Note: separator is a string of specific characters of + ; indeterminate length + ; LST() the transfer array + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data + ; +GETTYP(D0) ; Look for the goodies in the Mail + N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM + S CON="Content-" + S FLG="--" + S SEP="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) + S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D + . N T + . S T=+$G(^XMB(3.9,D0,1,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S LST("TO",D1)=T + . S T=$G(^XMB(3.9,D0,6,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . S LST("TO NAME",D1)=T + .QUIT + ; Preload first Segment (0) with beginning on Line 1 + ; if not a 64bit + S LST(NAM,"MSG",D0,"SEG",0)=1 + S D1=.9999,SEP="--" + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; Enter once to set the SEP to capture the separator + . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q + . . S SEP=X,END=X_FLG + . . S (CNT,SGC)=1,BCN=0 + . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 + . .QUIT + . ; + . ; A new separator is set, process original + . I X=SEP D QUIT + . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN + . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) + . . S SGC=SGC+1,BCN=0 + . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 + . .QUIT + . ; + . S BCN=BCN+$L(X) + . I X[CON D Q + . . S J=$P($P(X,";"),CON,2) + . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) + . .QUIT + . ; + . ; S LST(NAM,"MSG",D0,"SEG",D1)=X + .QUIT + QUIT + ; =================== +NAME(NM) ; Return the name of the Sender + N NAME + S NAME="" + D + . ; Look first for a value to use with the NEW PERSON file + . ; + . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q + . ; + . I $L(NM) S NAME=NM Q + . ; + . ; Else, pull the data from the message and display the foreign source + . ; of the message. + . N T + . S VAL=$G(^XMB(3.9,D0,.7)) + . S:VAL T=$P(^VA(200,VAL,0),U) + . I $L($G(T)) S NAME=T Q + . ; + .QUIT + QUIT NAME + ; =================== +TIME(Y) ; The time and date of the sending + X ^DD("DD") + QUIT Y + ; =================== + ; Segments in Message need to be identified and decoded properly + ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message + ; ARRAY will have the details of this one call + ; + ; Inputs; + ; C0CINPUT - The IEN of the message to expand + ; Outputs; + ; C0CDATA - Carrier for the returned structure of the Message + ; C0CDATA(D0,"SEG")=number of SEGMENTS + ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details + ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details + ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details + ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details + ; +DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery + N LST,D0,D1,U + S U="^" + S D0=+$G(C0CINPUT) + I D0 D QUIT + . D GETTYP2(D0) + . I $D(LST) M C0CDATA(D0)=LST + .QUIT + QUIT + ; =================== + ; End note if needed + ; MSK - Set of characters that do not exist in 64 bit encoding +GETTYP2(D0) ; Try to get the types and MSK for the + N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM + S CON="Content-",U="^" + S FLG="--" + S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" + S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + ; S K=$P(^XMB(3.9,D0,2,0),U,3) + S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST("CREATED")=$$TIME($P(XX,U,3)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST("FROM")=$$NAME(XXNM) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" + . N I,T + . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) + . S:T T=$P($G(^VA(200,T,0)),"^") + . S LST("TO",+D1)=T + . S T=$G(^XMB(3.9,D0,6,+D1,0)) + . S:T="" T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . S LST("TO NAME",D1)=T + .QUIT + ; Get the Header for the message + S D1=0 + F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D + . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) + .QUIT + ; Start walking the different sections + S D1=.99999,SEP="--" + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; Enter once to set the SEP to capture the separator + . I (SEP="--")&($E(X,1,2)=FLG)&($L(X,FLG)=2) D Q + . . S SEP=X,END=X_FLG + . . S (CNT,SGC)=1,BCN=0 + . . S LST("SEG",SGC)=D1 + . .QUIT + . ; + . ; A new SEGMENT separator is set, process original + . I X=SEP D QUIT + . . ; Save Current Values + . . S LST("SEG",SGC,"SIZE")=BCN + . . ; Close this Segment and prepare to start a New Segment + . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) + . . ; Put the result in LST("SEG",SGC,"XML") + . . I $L(BF) D + . . . S ZN=1 + . . . N I,T,TBF + . . . S TBF=BF + . . . F I=1:1:($L(TBF,"=")) D + . . . . S BF=$P(TBF,"=",I)_"=" + . . . . I BF'="=" D DECODER + . . . .QUIT + . . . S BF="" + . . .QUIT + . . S SGC=SGC+1,BCN=0 + . . ; Incriment SGC to start a new Segment + . . S LST("SEG",SGC)=D1 + . .QUIT + . ; + . ; Accumulate the 64 bit encoding + . I X=$TR(X,MSK)&$L(X) D Q + . . S BF=BF_X + . . S BCN=BCN+$L(X) + . .QUIT + . ; + . ; Ending Condition, close out the Segment + . I X=END D QUIT + . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) + . . I $L(BF) S ZN=1 D DECODER S BF="" Q + . .QUIT + . ; + . S BCN=BCN+$L(X) + . ; Split out the Content Info + . I X[CON D Q + . . S J=$P(X,CON,2) + . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9) + . .QUIT + . ; + . ; Everything else is Text + . S LST("SEG",SGC,"TXT",D1)=X + .QUIT + QUIT + ; =================== + ; Break down the Buffer Array so it can be saved. + ; BF is passed in. +DECODER ; + N RCNT,TBF,ZBF,ZI,ZJ,ZK,ZSIZE + S ZBF=BF + ; Full Buffer, BF, now check for Encryption and Unpack + F RCNT=1:1:$L(ZBF,"=") D + . N BF + . S BF=$P(ZBF,"=",RCNT) + . ; Unpacking the 64 bit encoding + . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) + . D:$L(TBF) + . . N XBF + . . S BF=BF_"=" + . . D NORMAL(.XBF,.TBF) + . . M LST("SEG",SGC,"XML",RCNT)=XBF + . .QUIT + .QUIT + QUIT + ; =================== + ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT + ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT + ; >D NORMAL^C0CMAIL(.OUT,BF) +NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML + ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME + ; + N ZN,OUTBF + S ZN=1 + S OUTBF(ZN)=$P(INXML,"><",ZN)_">" + F ZN=ZN+1:1 S OUTBF(ZN)="<"_$P(INXML,"><",ZN) Q:$P(INXML,"><",ZN+1)="" D ; + . S OUTBF(ZN)=OUTBF(ZN)_">" + .QUIT + M OUTXML=OUTBF + QUIT + ; =================== + ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv + ; End note if needed + QUIT + ; =================== Index: ccr/branches/ohum/p/C0CMAIL2.m =================================================================== --- ccr/branches/ohum/p/C0CMAIL2.m (revision 1332) +++ ccr/branches/ohum/p/C0CMAIL2.m (revision 1333) @@ -1,464 +1,464 @@ C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr -V ;;0.1;C0C;nopatch;noreleasedate - ;Copyright 2011 Chris Richardson, Richardson Computer Research - ; Modified 3110615@1040 - ; rcr@rcresearch.us - ; Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; ------------------ - ;Entry Points - ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments - ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) - ; Input: - ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL - ; or "*" for all boxes, default is "IN" if missing]" - ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", - ; "*" for All or 9,999 maximum - ; MALL?1.n = that number of the n most recent - ; Internally: - ; BNAM = Box Name - ; Output: - ; C0CDATA - ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket - ; (BNAM,"MSG",C0CIEN,"FROM")=Name - ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address - ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address - ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title - ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments - ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text - ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text - ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes - ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) - ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line - ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details - ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data - ; - ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments - ; Input; - ; D0 - The IEN for the message in file 3.9, MESSAGE global - ; Output - ; OUTBF - The array of your choice to save the expanded and decoded message. - ; -GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data - K:'$G(C0CDATA("KEEP")) C0CDATA - N U - S U="^" - D:$G(C0CINPUT) - . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL - . S INPUT=C0CINPUT - . S DUZ=+INPUT - . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q - . ; - . D:$D(^XMB(3.7,DUZ,0))#2 - . . S MBLST=$P(INPUT,";",2) - . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag - . . S:MALL["*" MALL=99999 - . . ; Only one of these can be correct - . . D - . . . ; If nul, make it "IN" only - . . . I MBLST="" D QUIT - . . . . S MBLST("IN")=0,I=0 - . . . . D GATHER(DUZ,"IN",.LST) - . . . .QUIT - . . . ; - . . . ; If "*", Get all Mailboxes and look for New Messages - . . . I MBLST["*" D QUIT - . . . . N NAM,NUM - . . . . S NUM=0 - . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D - . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) - . . . . . D GATHER(DUZ,NAM,.LST) - . . . . .QUIT - . . . .QUIT - . . . ; - . . . ; If comma separated, look for mailboxes with new messages - . . . I $L(MBLST,",")>1 D QUIT - . . . . S NAM="" - . . . . N TN,V - . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D - . . . . . I $L(V) D QUIT - . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) - . . . . . . S:NAM="" NAM=V - . . . . . . D GATHER(DUZ,NAM,.LST) - . . . . . .QUIT - . . . . . ; - . . . . . D ERROR("ER08") - . . . . .QUIT - . . . .QUIT - . . . ; - . . . ; If only 1 mailbox named, go get it - . . . I $L(MBLST) D QUIT - . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT - . . . . ; - . . . . D ERROR("ER07") - . . .QUIT - . . MERGE C0CDATA=LST - . .QUIT - .QUIT - QUIT - ; =================== -GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail - N I,J,K,L - S (I,K)=0 - S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) - F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D - . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) - . D ; :L - . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails - . . S LST(NAM,"MSG",I)=L - . . D GETTYP(I) - . .QUIT - .QUIT - S LST(NAM,"NUMBER")=K - QUIT - ; =================== - ; D0 is the IEN into the Message Global ^XMB(3.9,D0) - ; The products of these emails are scanned to identify - ; the number of documents stored in the MIME package. - ; The protocol runs like this; - ; Line 1 is the --separator - ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD - ; Line n+2 thru t-1 where t does NOT have "Content-" - ; Line t is Next Section Terminator, or Message Terminator, --separator - ; Line t+1 should not exist in the data set if Message Terminator - ; CON = "Content-" - ; FLG = "--" - ; SEP = FLG+7 or more characters ; Separator - ; END = SEP+FLG - ; SGC = Segment Count - ; Note: separator is a string of specific characters of - ; indeterminate length - ; LST() the transfer array - ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line - ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data - ; -GETTYP(D0) ; Look for the goodies in the Mail - N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM - S CON="Content-" - S FLG="--" - S SEP="" ; Start SEP as null, so we can use this to help identify the type - S (BCN,CNT,D1,END,SGC)=0 - S XX=$G(^XMB(3.9,D0,0)) - S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) - S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) - F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) - S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) - S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) - ; Get the folks the email is sent to. - S D1=0 - F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D - . N T - . S T=+$G(^XMB(3.9,D0,1,D1,0)) - . S:T T=$P($G(^VA(200,+T,0)),"^") - . S LST("TO",D1)=T - . S T=$G(^XMB(3.9,D0,6,D1,0)) - . S:T T=$P($G(^VA(200,+T,0)),"^") - . S:T="" T="" - . S LST("TO NAME",D1)=T - .QUIT - ; Preload first Segment (0) with beginning on Line 1 - ; if not a 64bit - S LST(NAM,"MSG",D0,"SEG",0)=1 - S D1=.9999,SEP="@@" - F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D - . ; Clear any control characters (cr/lf/ff) off - . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) - . ; Enter once to set the SEP to capture the separator - . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q - . . S SEP=X,END=X_FLG - . . S (CNT,SGC)=1,BCN=0 - . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 - . .QUIT - . ; - . ; A new separator is set, process original - . I X=SEP D QUIT - . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF) - . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) - . . S SGC=SGC+1,BCN=0 - . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 - . .QUIT - . ; - . S BCN=BCN+$L(X) - . I X[CON D Q - . . S J=$P($P(X,";"),CON,2) - . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) - . .QUIT - . ; - . ; S LST(NAM,"MSG",D0,"SEG",D1)=X - .QUIT - QUIT - ; =================== -NAME(NM) ; Return the name of the Sender - N NAME - S NAME="" - D - . ; Look first for a value to use with the NEW PERSON file - . ; - . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q - . ; - . I $L(NM) S NAME=NM Q - . ; - . ; Else, pull the data from the message and display the foreign source - . ; of the message. - . N T - . S VAL=$G(^XMB(3.9,D0,.7)) - . S:VAL T=$P(^VA(200,VAL,0),U) - . I $L($G(T)) S NAME=T Q - . ; - .QUIT - QUIT NAME - ; =================== -TIME(Y) ; The time and date of the sending - X ^DD("DD") - QUIT Y - ; =================== - ; Segments in Message need to be identified and decoded properly - ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message - ; ARRAY will have the details of this one call - ; - ; Inputs; - ; C0CINPUT - The IEN of the message to expand - ; Outputs; - ; C0CDATA - Carrier for the returned structure of the Message - ; C0CDATA(D0,"SEG")=number of SEGMENTS - ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type - ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details - ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details - ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details - ; -DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery - N LST,D0,D1,U - S U="^" - S D0=+$G(C0CINPUT) - I D0 D QUIT - . I $D(^XMB(3.9,D0))<10 D ERROR("ER01") QUIT - . ; - . D GETTYP2(D0) - . I $D(LST) M C0CDATA(D0)=LST Q - . ; - . D ERROR("ER02") - .QUIT - QUIT - ; =================== - ; End note if needed - ; MSK - Set of characters that do not exist in 64 bit encoding -GETTYP2(D0) ; Try to get the types and MSK for the - N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM - S CON="Content-",U="^" - S FLG="--" - S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" - S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type - S (BCN,CNT,D1,END,SGC)=0 - S XX=$G(^XMB(3.9,D0,0)) - ; S K=$P(^XMB(3.9,D0,2,0),U,3) - S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) - S LST("CREATED")=$$TIME($P(XX,U,3)) - F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) - S LST("FROM")=$$NAME(XXNM) - ; Get the folks the email is sent to. - S D1=0 - F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" - . N I,T - . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) - . S:T T=$P($G(^VA(200,T,0)),"^") - . S LST("TO",+D1)=T - . S T=$G(^XMB(3.9,D0,6,+D1,0)) - . S:T="" T=$P($G(^VA(200,+T,0)),"^") - . S:T="" T="" - . S LST("TO NAME",D1)=T - .QUIT - ; Get the Header for the message - S D1=0 - F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D - . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) - .QUIT - ; Start walking the different sections - S D1=.99999,SEP="@@",SGC=0 - F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D - . ; Clear any control characters (cr/lf/ff) off - . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) - . ; Enter once to set the SEP to capture the separator - . I (SEP="@@")&(X?2."--"5.AN.E) D Q - . . I $L(X,FLG)>2 D ERROR("ER10") - . . S SEP=X,END=X_FLG - . . S (CNT,SGC)=1,BCN=0 - . . S LST("SEG",SGC)=D1 - . .QUIT - . ; - . ; A new SEGMENT separator is set, process original - . I X=SEP D QUIT - . . ; Save Current Values - . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF) - . . ; Close this Segment and prepare to start a New Segment - . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1) - . . ; Put the result in LST("SEG",SGC,"XML") - . . I $L(BF) D - . . . S ZN=1 - . . . N I,T,TBF - . . . S TBF=BF - . . . F I=1:1:($L(TBF,"=")) D - . . . . S BF=$P(TBF,"=",I)_"=" - . . . . I BF'="=" D DECODER - . . . .QUIT - . . . S BF="" - . . .QUIT - . . S SGC=SGC+1,BCN=0 - . . ; Incriment SGC to start a new Segment - . . S LST("SEG",SGC)=D1 - . .QUIT - . ; - . ; Accumulate the 64 bit encoding - . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT - . ; - . ; Ending Condition, close out the Segment - . I X=END D QUIT - . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) - . . I $L(BF) S ZN=1 D DECODER S BF="" Q - . .QUIT - . ; - . ; Accumulate the lengths of other lines of the message - . S BCN=BCN+$L(X) - . ; Split out the Content Info - . I X[CON D Q - . . S J=$P(X,CON,2) - . . I J[" boundary=" D - . . . S SEP=$P($P(J," boundary=",2),"""",2),END=SEP_FLG - . . . Q:SEP?2"-"5.ANP - . . . ; - . . . D ERROR("ER11") - . . . Q:SEP'[" " - . . . ; - . . . D ERROR("ER12") - . . .QUIT - . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9) - . .QUIT - . ; - . ; Everything else is Text, Check for CCR/CCD. - . N KK,UBF - . D - . . S UBF=$$UPPER(X) - . . I UBF["126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q - . . ; - . . D - . . . I 'OK S (BF,UBF,TBF,XBF)="" Q - . . . ; - . . . S BF=BF_"=" - . . . D NORMAL(.XBF,.TBF) - . . .QUIT - . . M LST("SEG",SGC,"XML",RCNT)=XBF - . .QUIT - .QUIT - QUIT - ; =================== - ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT - ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT - ; >D NORMAL^C0CMAIL(.OUT,BF) -NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML - ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME - ; - N ZN,OUTBF,XX,ZSEP - S INXML=$TR(INXML,$C(10,12,13)) - S ZN=1,ZSEP=">" - S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 - F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" - . S XX=$P(INXML,"><",ZN) - . S:$E($RE(XX))=">" ZSEP="" - . Q:XX="" - . ; - . S XX="<"_XX_ZSEP - . D - . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q - . . ; - . . D ERROR("ER05") - . . F ZL=ZL+1:1 D Q:XX="" - . . . N XL - . . . S XL=$E(XX,1,4000) - . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters - . . . S OUTBF(ZL)=XL - . . .QUIT - . .QUIT - .QUIT - M OUTXML=OUTBF - QUIT - ; =================== -UPPER(X) ; Convert any lowercase letters to Uppercase letters - QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ; =================== - ; EN is a counter that remains between error events -ERROR(ER) ; Error Handler - N TXXQ,XXXQ - S XXXQ="Unknown Error Encountered = "_ER - S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) - I TXXQ'="" D - . I TXXQ["_" X "S TXXQ="_TXXQ - . S XXXQ=TXXQ - .QUIT - S EN(ER)=$G(EN(ER))+1 - S LST("ERR",ER,EN(ER))=XXXQ - QUIT - ; =================== -ER01 ;;Message Missing -ER02 ;;Message Text Missing -ER03 ;;Message Not Identifiable -ER04 ;;Segment is too large -ER05 ;;Mailbox Missing -ER06 ;;"User Missing = "_$G(DUZ) -ER07 ;;"Bad DUZ = "_DUZ -ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) -ER10 ;;"Bad Separator found = "_X -ER11 ;;"Non-Standard Separator Found:>"_$G(J) -ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) - ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv - ; End note if needed - QUIT - ; =================== + ;;0.1;C0C;nopatch;noreleasedate;Build 1 + ;Copyright 2011 Chris Richardson, Richardson Computer Research + ; Modified 3110615@1040 + ; rcr@rcresearch.us + ; Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; ------------------ + ;Entry Points + ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments + ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) + ; Input: + ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL + ; or "*" for all boxes, default is "IN" if missing]" + ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", + ; "*" for All or 9,999 maximum + ; MALL?1.n = that number of the n most recent + ; Internally: + ; BNAM = Box Name + ; Output: + ; C0CDATA + ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket + ; (BNAM,"MSG",C0CIEN,"FROM")=Name + ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title + ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments + ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text + ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text + ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes + ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) + ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data + ; + ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments + ; Input; + ; D0 - The IEN for the message in file 3.9, MESSAGE global + ; Output + ; OUTBF - The array of your choice to save the expanded and decoded message. + ; +GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data + K:'$G(C0CDATA("KEEP")) C0CDATA + N U + S U="^" + D:$G(C0CINPUT) + . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL + . S INPUT=C0CINPUT + . S DUZ=+INPUT + . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q + . ; + . D:$D(^XMB(3.7,DUZ,0))#2 + . . S MBLST=$P(INPUT,";",2) + . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag + . . S:MALL["*" MALL=99999 + . . ; Only one of these can be correct + . . D + . . . ; If nul, make it "IN" only + . . . I MBLST="" D QUIT + . . . . S MBLST("IN")=0,I=0 + . . . . D GATHER(DUZ,"IN",.LST) + . . . .QUIT + . . . ; + . . . ; If "*", Get all Mailboxes and look for New Messages + . . . I MBLST["*" D QUIT + . . . . N NAM,NUM + . . . . S NUM=0 + . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D + . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) + . . . . . D GATHER(DUZ,NAM,.LST) + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If comma separated, look for mailboxes with new messages + . . . I $L(MBLST,",")>1 D QUIT + . . . . S NAM="" + . . . . N TN,V + . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D + . . . . . I $L(V) D QUIT + . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) + . . . . . . S:NAM="" NAM=V + . . . . . . D GATHER(DUZ,NAM,.LST) + . . . . . .QUIT + . . . . . ; + . . . . . D ERROR("ER08") + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If only 1 mailbox named, go get it + . . . I $L(MBLST) D QUIT + . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT + . . . . ; + . . . . D ERROR("ER07") + . . .QUIT + . . MERGE C0CDATA=LST + . .QUIT + .QUIT + QUIT + ; =================== +GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail + N I,J,K,L + S (I,K)=0 + S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) + F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D + . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) + . D ; :L + . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails + . . S LST(NAM,"MSG",I)=L + . . D GETTYP(I) + . .QUIT + .QUIT + S LST(NAM,"NUMBER")=K + QUIT + ; =================== + ; D0 is the IEN into the Message Global ^XMB(3.9,D0) + ; The products of these emails are scanned to identify + ; the number of documents stored in the MIME package. + ; The protocol runs like this; + ; Line 1 is the --separator + ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD + ; Line n+2 thru t-1 where t does NOT have "Content-" + ; Line t is Next Section Terminator, or Message Terminator, --separator + ; Line t+1 should not exist in the data set if Message Terminator + ; CON = "Content-" + ; FLG = "--" + ; SEP = FLG+7 or more characters ; Separator + ; END = SEP+FLG + ; SGC = Segment Count + ; Note: separator is a string of specific characters of + ; indeterminate length + ; LST() the transfer array + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data + ; +GETTYP(D0) ; Look for the goodies in the Mail + N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM + S CON="Content-" + S FLG="--" + S SEP="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) + S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D + . N T + . S T=+$G(^XMB(3.9,D0,1,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S LST("TO",D1)=T + . S T=$G(^XMB(3.9,D0,6,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . S LST("TO NAME",D1)=T + .QUIT + ; Preload first Segment (0) with beginning on Line 1 + ; if not a 64bit + S LST(NAM,"MSG",D0,"SEG",0)=1 + S D1=.9999,SEP="@@" + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; Enter once to set the SEP to capture the separator + . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q + . . S SEP=X,END=X_FLG + . . S (CNT,SGC)=1,BCN=0 + . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 + . .QUIT + . ; + . ; A new separator is set, process original + . I X=SEP D QUIT + . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF) + . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) + . . S SGC=SGC+1,BCN=0 + . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 + . .QUIT + . ; + . S BCN=BCN+$L(X) + . I X[CON D Q + . . S J=$P($P(X,";"),CON,2) + . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) + . .QUIT + . ; + . ; S LST(NAM,"MSG",D0,"SEG",D1)=X + .QUIT + QUIT + ; =================== +NAME(NM) ; Return the name of the Sender + N NAME + S NAME="" + D + . ; Look first for a value to use with the NEW PERSON file + . ; + . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q + . ; + . I $L(NM) S NAME=NM Q + . ; + . ; Else, pull the data from the message and display the foreign source + . ; of the message. + . N T + . S VAL=$G(^XMB(3.9,D0,.7)) + . S:VAL T=$P(^VA(200,VAL,0),U) + . I $L($G(T)) S NAME=T Q + . ; + .QUIT + QUIT NAME + ; =================== +TIME(Y) ; The time and date of the sending + X ^DD("DD") + QUIT Y + ; =================== + ; Segments in Message need to be identified and decoded properly + ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message + ; ARRAY will have the details of this one call + ; + ; Inputs; + ; C0CINPUT - The IEN of the message to expand + ; Outputs; + ; C0CDATA - Carrier for the returned structure of the Message + ; C0CDATA(D0,"SEG")=number of SEGMENTS + ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type + ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details + ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details + ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details + ; +DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery + N LST,D0,D1,U + S U="^" + S D0=+$G(C0CINPUT) + I D0 D QUIT + . I $D(^XMB(3.9,D0))<10 D ERROR("ER01") QUIT + . ; + . D GETTYP2(D0) + . I $D(LST) M C0CDATA(D0)=LST Q + . ; + . D ERROR("ER02") + .QUIT + QUIT + ; =================== + ; End note if needed + ; MSK - Set of characters that do not exist in 64 bit encoding +GETTYP2(D0) ; Try to get the types and MSK for the + N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM + S CON="Content-",U="^" + S FLG="--" + S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" + S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + ; S K=$P(^XMB(3.9,D0,2,0),U,3) + S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST("CREATED")=$$TIME($P(XX,U,3)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST("FROM")=$$NAME(XXNM) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" + . N I,T + . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) + . S:T T=$P($G(^VA(200,T,0)),"^") + . S LST("TO",+D1)=T + . S T=$G(^XMB(3.9,D0,6,+D1,0)) + . S:T="" T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . S LST("TO NAME",D1)=T + .QUIT + ; Get the Header for the message + S D1=0 + F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D + . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) + .QUIT + ; Start walking the different sections + S D1=.99999,SEP="@@",SGC=0 + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; Enter once to set the SEP to capture the separator + . I (SEP="@@")&(X?2."--"5.AN.E) D Q + . . I $L(X,FLG)>2 D ERROR("ER10") + . . S SEP=X,END=X_FLG + . . S (CNT,SGC)=1,BCN=0 + . . S LST("SEG",SGC)=D1 + . .QUIT + . ; + . ; A new SEGMENT separator is set, process original + . I X=SEP D QUIT + . . ; Save Current Values + . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF) + . . ; Close this Segment and prepare to start a New Segment + . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1) + . . ; Put the result in LST("SEG",SGC,"XML") + . . I $L(BF) D + . . . S ZN=1 + . . . N I,T,TBF + . . . S TBF=BF + . . . F I=1:1:($L(TBF,"=")) D + . . . . S BF=$P(TBF,"=",I)_"=" + . . . . I BF'="=" D DECODER + . . . .QUIT + . . . S BF="" + . . .QUIT + . . S SGC=SGC+1,BCN=0 + . . ; Incriment SGC to start a new Segment + . . S LST("SEG",SGC)=D1 + . .QUIT + . ; + . ; Accumulate the 64 bit encoding + . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT + . ; + . ; Ending Condition, close out the Segment + . I X=END D QUIT + . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) + . . I $L(BF) S ZN=1 D DECODER S BF="" Q + . .QUIT + . ; + . ; Accumulate the lengths of other lines of the message + . S BCN=BCN+$L(X) + . ; Split out the Content Info + . I X[CON D Q + . . S J=$P(X,CON,2) + . . I J[" boundary=" D + . . . S SEP=$P($P(J," boundary=",2),"""",2),END=SEP_FLG + . . . Q:SEP?2"-"5.ANP + . . . ; + . . . D ERROR("ER11") + . . . Q:SEP'[" " + . . . ; + . . . D ERROR("ER12") + . . .QUIT + . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9) + . .QUIT + . ; + . ; Everything else is Text, Check for CCR/CCD. + . N KK,UBF + . D + . . S UBF=$$UPPER(X) + . . I UBF["126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q + . . ; + . . D + . . . I 'OK S (BF,UBF,TBF,XBF)="" Q + . . . ; + . . . S BF=BF_"=" + . . . D NORMAL(.XBF,.TBF) + . . .QUIT + . . M LST("SEG",SGC,"XML",RCNT)=XBF + . .QUIT + .QUIT + QUIT + ; =================== + ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT + ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT + ; >D NORMAL^C0CMAIL(.OUT,BF) +NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML + ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME + ; + N ZN,OUTBF,XX,ZSEP + S INXML=$TR(INXML,$C(10,12,13)) + S ZN=1,ZSEP=">" + S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 + F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" + . S XX=$P(INXML,"><",ZN) + . S:$E($RE(XX))=">" ZSEP="" + . Q:XX="" + . ; + . S XX="<"_XX_ZSEP + . D + . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q + . . ; + . . D ERROR("ER05") + . . F ZL=ZL+1:1 D Q:XX="" + . . . N XL + . . . S XL=$E(XX,1,4000) + . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters + . . . S OUTBF(ZL)=XL + . . .QUIT + . .QUIT + .QUIT + M OUTXML=OUTBF + QUIT + ; =================== +UPPER(X) ; Convert any lowercase letters to Uppercase letters + QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + ; =================== + ; EN is a counter that remains between error events +ERROR(ER) ; Error Handler + N TXXQ,XXXQ + S XXXQ="Unknown Error Encountered = "_ER + S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) + I TXXQ'="" D + . I TXXQ["_" X "S TXXQ="_TXXQ + . S XXXQ=TXXQ + .QUIT + S EN(ER)=$G(EN(ER))+1 + S LST("ERR",ER,EN(ER))=XXXQ + QUIT + ; =================== +ER01 ;;Message Missing +ER02 ;;Message Text Missing +ER03 ;;Message Not Identifiable +ER04 ;;Segment is too large +ER05 ;;Mailbox Missing +ER06 ;;"User Missing = "_$G(DUZ) +ER07 ;;"Bad DUZ = "_DUZ +ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) +ER10 ;;"Bad Separator found = "_X +ER11 ;;"Non-Standard Separator Found:>"_$G(J) +ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) + ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv + ; End note if needed + QUIT + ; =================== Index: ccr/branches/ohum/p/C0CMAIL3.m =================================================================== --- ccr/branches/ohum/p/C0CMAIL3.m (revision 1332) +++ ccr/branches/ohum/p/C0CMAIL3.m (revision 1333) @@ -1,534 +1,534 @@ C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr -V ;;0.1;C0C;nopatch;noreleasedate - ;Copyright 2011 Chris Richardson, Richardson Computer Research - ; Modified 3110619@2038 - ; rcr@rcresearch.us - ; Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; ------------------ - ;Entry Points - ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments - ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) - ; Input: - ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL - ; or "*" for all boxes, default is "IN" if missing]" - ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", - ; "*" for All or 9,999 maximum - ; MALL?1.n = that number of the n most recent - ; Internally: - ; BNAM = Box Name - ; Output: - ; C0CDATA - ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket - ; (BNAM,"MSG",C0CIEN,"FROM")=Name - ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address - ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address - ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title - ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments - ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text - ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text - ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes - ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) - ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line - ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details - ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data - ; - ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments - ; Input; - ; D0 - The IEN for the message in file 3.9, MESSAGE global - ; Output - ; OUTBF - The array of your choice to save the expanded and decoded message. - ; -GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data - K:'$G(C0CDATA("KEEP")) C0CDATA - N U - S U="^" - D:$G(C0CINPUT) - . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL - . S INPUT=C0CINPUT - . S DUZ=+INPUT - . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q - . ; - . D:$D(^XMB(3.7,DUZ,0))#2 - . . S MBLST=$P(INPUT,";",2) - . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag - . . S:MALL["*" MALL=99999 - . . ; Only one of these can be correct - . . D - . . . ; If nul, make it "IN" only - . . . I MBLST="" D QUIT - . . . . S MBLST("IN")=0,I=0 - . . . . D GATHER(DUZ,"IN",.LST) - . . . .QUIT - . . . ; - . . . ; If "*", Get all Mailboxes and look for New Messages - . . . I MBLST["*" D QUIT - . . . . N NAM,NUM - . . . . S NUM=0 - . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D - . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) - . . . . . D GATHER(DUZ,NAM,.LST) - . . . . .QUIT - . . . .QUIT - . . . ; - . . . ; If comma separated, look for mailboxes with new messages - . . . I $L(MBLST,",")>1 D QUIT - . . . . S NAM="" - . . . . N TN,V - . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D - . . . . . I $L(V) D QUIT - . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) - . . . . . . S:NAM="" NAM=V - . . . . . . D GATHER(DUZ,NAM,.LST) - . . . . . .QUIT - . . . . . ; - . . . . . D ERROR("ER08") - . . . . .QUIT - . . . .QUIT - . . . ; - . . . ; If only 1 mailbox named, go get it - . . . I $L(MBLST) D QUIT - . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT - . . . . ; - . . . . D ERROR("ER07") - . . .QUIT - . . MERGE C0CDATA=LST - . .QUIT - .QUIT - QUIT - ; =================== -GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail - N I,J,K,L - S (I,K)=0 - S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) - F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D - . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) - . D ; :L - . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails - . . S LST(NAM,"MSG",I)=L - . . D GETTYP(I) - . .QUIT - .QUIT - S LST(NAM,"NUMBER")=K - QUIT - ; =================== - ; D0 is the IEN into the Message Global ^XMB(3.9,D0) - ; The products of these emails are scanned to identify - ; the number of documents stored in the MIME package. - ; The protocol runs like this; - ; Line 1 is the --separator - ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD - ; Line n+2 thru t-1 where t does NOT have "Content-" - ; Line t is Next Section Terminator, or Message Terminator, --separator - ; Line t+1 should not exist in the data set if Message Terminator - ; CON = "Content-" - ; FLG = "--" - ; SEP = FLG+7 or more characters ; Separator - ; END = SEP+FLG - ; SGC = Segment Count - ; Note: separator is a string of specific characters of - ; indeterminate length - ; LST() the transfer array - ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line - ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data - ; -GETTYP(D0) ; Look for the goodies in the Mail - N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM - S CON="Content-" - S FLG="--" - S SEP="" ; Start SEP as null, so we can use this to help identify the type - S (BCN,CNT,D1,END,SGC)=0 - S XX=$G(^XMB(3.9,D0,0)) - S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) - S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) - F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) - S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) - S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) - ; Get the folks the email is sent to. - S D1=0 - F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D - . N T - . S T=+$G(^XMB(3.9,D0,1,D1,0)) - . S:T T=$P($G(^VA(200,+T,0)),"^") - . S LST("TO",D1)=T - . S T=$G(^XMB(3.9,D0,6,D1,0)) - . S:T T=$P($G(^VA(200,+T,0)),"^") - . S:T="" T="" - . S LST("TO NAME",D1)=T - .QUIT - ; Preload first Segment (0) with beginning on Line 1 - ; if not a 64bit - S LST(NAM,"MSG",D0,"SEG",0)=1 - S D1=.9999,SEP="@@" - F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D - . ; Clear any control characters (cr/lf/ff) off - . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) - . ; Enter once to set the SEP to capture the separator - . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q - . . S SEP=X,END=X_FLG - . . S (CNT,SGC)=1,BCN=0 - . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 - . .QUIT - . ; - . ; A new separator is set, process original - . I X=SEP D QUIT - . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF) - . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) - . . S SGC=SGC+1,BCN=0 - . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 - . .QUIT - . ; - . S BCN=BCN+$L(X) - . I X[CON D Q - . . S J=$P($P(X,";"),CON,2) - . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) - . .QUIT - . ; - . ; S LST(NAM,"MSG",D0,"SEG",D1)=X - .QUIT - QUIT - ; =================== -NAME(NM) ; Return the name of the Sender - N NAME - S NAME="" - D - . ; Look first for a value to use with the NEW PERSON file - . ; - . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q - . ; - . I $L(NM) S NAME=NM Q - . ; - . ; Else, pull the data from the message and display the foreign source - . ; of the message. - . N T - . S VAL=$G(^XMB(3.9,D0,.7)) - . S:VAL T=$P(^VA(200,VAL,0),U) - . I $L($G(T)) S NAME=T Q - . ; - .QUIT - QUIT NAME - ; =================== -TIME(Y) ; The time and date of the sending - X ^DD("DD") - QUIT Y - ; =================== - ; Segments in Message need to be identified and decoded properly - ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message - ; ARRAY will have the details of this one call - ; - ; Inputs; - ; C0CINPUT - The IEN of the message to expand - ; Outputs; - ; C0CDATA - Carrier for the returned structure of the Message - ; C0CDATA(D0,"SEG")=number of SEGMENTS - ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type - ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details - ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details - ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details - ; -DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery - N LST,D0,D1,U - S U="^" - S D0=+$G(C0CINPUT) - I D0 D QUIT - . I $D(^XMB(3.9,D0))<10 D ERROR("ER01") QUIT - . ; - . D GETTYP2(D0) - . I $D(LST) M C0CDATA(D0)=LST Q - . ; - . D ERROR("ER02") - .QUIT - QUIT - ; =================== - ; End note if needed - ; MSK - Set of characters that do not exist in 64 bit encoding -GETTYP2(D0) ; Try to get the types and MSK for the - N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM - S CON="Content-",U="^" - S FLG="--",MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" - S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type - S (BCN,CNT,D1,END,SGC)=0 - S XX=$G(^XMB(3.9,D0,0)) - ; S K=$P(^XMB(3.9,D0,2,0),U,3) - S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) - S LST("CREATED")=$$TIME($P(XX,U,3)) - F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) - S LST("FROM")=$$NAME(XXNM) - ; Get the folks the email is sent to. - S D1=0 - F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" - . N I,T - . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) - . S:T T=$P($G(^VA(200,T,0)),"^") - . S LST("TO",+D1)=T - . S T=$G(^XMB(3.9,D0,6,+D1,0)) - . S:T="" T=$P($G(^VA(200,+T,0)),"^") - . S:T="" T="" - . S LST("TO NAME",D1)=T - .QUIT - ; Get the Header for the message and store as "HDR" - S D1=0,SGC=0 - F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D - . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) - .QUIT - N BNDRY,STKL,SEG - S STKL=0,SEG=0 - ; Find boundaries and map them - S D1=0 - F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D - . ; Clear any control characters (cr/lf/ff) off - . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) - . ; Look for " boundary=" in the various parts. Map the establishment and the - . ; terminator markers and the actual boundary markers. - . I X[" boundary=" D Q - . . S SEP=$P(X," boundary=",2) - . . S:$E(SEP)="""" SEP=$TR(SEP,"""") - . . S STKL=STKL+1 - . . S END=SEP_FLG - . . S BNDRY(STKL,SEP)=0 - . . S BNDRX(SEP)=STKL,BNDRZ(END)=0 - . .QUIT - . ; - . ; Look for information as to how amy boudaries are present and where - . ; they terminate - . D:X'=""&($E(X,1,2)="--")&($E(X,$L(X)-1,9999)'="--") - . . ; Boundary Found - . . I $D(BNDRX(X)) D Q - . . . S SEG=SEG+1 - . . . S BNDRE(X)=$G(BNDRE(X))_D1_";" - . . . S BND1(D1)=STKL_";B;"_SEG_";"_X - . . . S BNDR(X,D1,"B")=STKL - . . . I BNDRX(X)=X D ERROR("ER13") - . . .QUIT - . . ; - . . ; Boundary Terminator - . . I $D(BNDRZ(X)) D Q - . . . S BNDR(X,D1,"E")=STKL - . . . S BNDRZ(X)=BNDRZ(X)+1 - . . . S BND1(D1)=STKL_";E;"_SEG_";"_X - . . . S SEG=SEG+1 - . . . I BNDRX(X)=X D ERROR("ER14") - . . . S STKL=STKL-1 - . . .QUIT - . .QUIT - .QUIT - ; Start walking the TEXT/XML/64-BIT ENCODING sections of the message - N A,B,C,STACK,STYP,SEG,AX - S D1=.99999,SGC=0 - F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D - . ; Clear any control characters (cr/lf/ff) off - . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) - . ; - . D - . . I $D(BND1(D1)) D BOUNDARY(X) QUIT - . . ; - . . S DX=$O(BND1(D1)) - . . I DX="" D ERROR("ER15") Q - . . ; - . . ; Good situation, extract the parts for the section - . . S A=$G(BND1(DX)) - . . S STACK=+A,STYP=$P(A,";",2),SGC=$P(A,";",3),AX=$P(A,";",4,999) - . .QUIT - . ; Enter once to set the SEP to capture the separator - . ; - . ; A new SEGMENT separator is set, process original - . I $D(BND1(X)) D QUIT - . . ; Save Current Values - . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF) - . . ; Close this Segment and prepare to start a New Segment - . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1) - . . ; Put the result in LST("SEG",SGC,"XML") - . . I $L(BF) D - . . . S ZN=1 - . . . N I,T,TBF - . . . S TBF=BF - . . . F I=1:1:($L(TBF,"=")) D - . . . . S BF=$P(TBF,"=",I)_"=" - . . . . I "="'[BF D DECODER(.BF,.TYP) - . . . .QUIT - . . . S BF="" - . . .QUIT - . . S SGC=SGC+1,BCN=0 - . . ; Incriment SGC to start a new Segment - . . S LST("SEG",SGC)=D1 - . .QUIT - . ; - . ; Accumulate the 64 bit encoding, no spaces, or other non-64bit characters - . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT - . ; - . ; Ending Condition, close out the Segment - . I $D(BNDRZ(X)) D QUIT - . . S $P(LST("SEG",SGC),"^",2)=D1-1 - . . I $L(BF) S ZN=1 D DECODER(.BF,.TYP) S BF="" Q - . .QUIT - . ; - . ; Accumulate the content lines of the message - . S BCN=BCN+$L(X) - . ; Split out the Content Info - . I X[CON D Q - . . S J=$P(X,CON,2) - . . S TYP="CONTENT" - . . S LST("SEG",SGC,TYP,$P(J,":"))=$P(J,":",2,9) - . . D CONTENT(D1) - . .QUIT - . ; - . ; Everything else is Text, Check for CCR/CCD. - . N KK,UBF - . D - . . S UBF=$$UPPER(X) - . . I UBF["1) S TYP=$P(UP,".",2) Q - . I UP["XML" S TYP="XML" Q - . I UP["P7S" S TYP="P7S" Q - . I J[" boundary=" D BOUNDARY(J) - .QUIT - S LIS("CON",SGC,D1)=X - S LIS("CON",SGC,D1,"TYP")=TYP - ; If there is a follow-on, look for another line after this. - I $E($RE(X),1)=";" D CONTENT(D1+1) - QUIT - ; =================== -BOUNDARY(X) ; Set an additional BOUNDARY, and activate another stack level - S SEP=$P($P(X," boundary=",2),"""",2),END=SEP_FLG - Q:SEP?2"-".ANP - ; - D ERROR("ER11") - Q:SEP'[" " - ; - D ERROR("ER12") - QUIT - ; =================== - ; Break down the Buffer Array so it can be saved. - ; BF is passed in. - ; TYP is the type of -DECODER(BF,TYP) ; - N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE - S:$G(TYP)="" TYP="XML" - S ZBF=BF - ; Full Buffer, BF, now check for Encryption and Unpack - F RCNT=1:1:$L(ZBF,"=") D - . N BF - . S BF=$P(ZBF,"=",RCNT) - . ; Unpacking the 64 bit encoding - . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) - . D:$L(TBF) - . . N C,OK,OKCNT,KK,XBF,UBF - . . D - . . . S UBF=$$UPPER(TBF) - . . . I UBF["126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q - . . ; - . . D - . . . I 'OK S (BF,UBF,TBF,XBF)="" Q - . . . ; - . . . S BF=BF_"=" - . . . D NORMAL(.XBF,.TBF) - . . .QUIT - . . M LST("SEG",SGC,TYP,RCNT)=XBF - . .QUIT - .QUIT - QUIT - ; =================== - ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT - ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT - ; >D NORMAL^C0CMAIL(.OUT,BF) -NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML - ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME - ; - N ZN,OUTBF,XX,ZSEP - S INXML=$TR(INXML,$C(10,12,13)) - S ZN=1,ZSEP=">" - S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 - F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" - . S XX=$P(INXML,"><",ZN) - . S:$E($RE(XX))=">" ZSEP="" - . Q:XX="" - . ; - . S XX="<"_XX_ZSEP - . D - . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q - . . ; - . . D ERROR("ER05") - . . F ZL=ZL+1:1 D Q:XX="" - . . . N XL - . . . S XL=$E(XX,1,4000) - . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters - . . . S OUTBF(ZL)=XL - . . .QUIT - . .QUIT - .QUIT - M OUTXML=OUTBF - QUIT - ; =================== -UPPER(X) ; Convert any lowercase letters to Uppercase letters - QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - ; =================== - ; EN is a counter that remains between error events -ERROR(ER) ; Error Handler - N TXXQ,XXXQ - S XXXQ="Unknown Error Encountered = "_ER - S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) - I TXXQ'="" D - . I TXXQ["_" X "S TXXQ="_TXXQ - . S XXXQ=TXXQ - .QUIT - S EN(ER)=$G(EN(ER))+1 - S LST("ERR",ER,EN(ER))=XXXQ - QUIT - ; =================== -ER01 ;;Message Missing -ER02 ;;Message Text Missing -ER03 ;;Message Not Identifiable -ER04 ;;Segment is too large -ER05 ;;Mailbox Missing -ER06 ;;"User Missing = "_$G(DUZ) -ER07 ;;"Bad DUZ = "_DUZ -ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) -ER10 ;;"Bad Separator found = "_X -ER11 ;;"Non-Standard Separator Found:>"_$G(J) -ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) -ER13 ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X - ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv - ; End note if needed - QUIT - ; =================== + ;;0.1;C0C;nopatch;noreleasedate;Build 1 + ;Copyright 2011 Chris Richardson, Richardson Computer Research + ; Modified 3110619@2038 + ; rcr@rcresearch.us + ; Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; ------------------ + ;Entry Points + ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments + ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) + ; Input: + ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL + ; or "*" for all boxes, default is "IN" if missing]" + ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", + ; "*" for All or 9,999 maximum + ; MALL?1.n = that number of the n most recent + ; Internally: + ; BNAM = Box Name + ; Output: + ; C0CDATA + ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket + ; (BNAM,"MSG",C0CIEN,"FROM")=Name + ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title + ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments + ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text + ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text + ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes + ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) + ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data + ; + ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments + ; Input; + ; D0 - The IEN for the message in file 3.9, MESSAGE global + ; Output + ; OUTBF - The array of your choice to save the expanded and decoded message. + ; +GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data + K:'$G(C0CDATA("KEEP")) C0CDATA + N U + S U="^" + D:$G(C0CINPUT) + . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL + . S INPUT=C0CINPUT + . S DUZ=+INPUT + . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q + . ; + . D:$D(^XMB(3.7,DUZ,0))#2 + . . S MBLST=$P(INPUT,";",2) + . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag + . . S:MALL["*" MALL=99999 + . . ; Only one of these can be correct + . . D + . . . ; If nul, make it "IN" only + . . . I MBLST="" D QUIT + . . . . S MBLST("IN")=0,I=0 + . . . . D GATHER(DUZ,"IN",.LST) + . . . .QUIT + . . . ; + . . . ; If "*", Get all Mailboxes and look for New Messages + . . . I MBLST["*" D QUIT + . . . . N NAM,NUM + . . . . S NUM=0 + . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D + . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) + . . . . . D GATHER(DUZ,NAM,.LST) + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If comma separated, look for mailboxes with new messages + . . . I $L(MBLST,",")>1 D QUIT + . . . . S NAM="" + . . . . N TN,V + . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D + . . . . . I $L(V) D QUIT + . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) + . . . . . . S:NAM="" NAM=V + . . . . . . D GATHER(DUZ,NAM,.LST) + . . . . . .QUIT + . . . . . ; + . . . . . D ERROR("ER08") + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If only 1 mailbox named, go get it + . . . I $L(MBLST) D QUIT + . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT + . . . . ; + . . . . D ERROR("ER07") + . . .QUIT + . . MERGE C0CDATA=LST + . .QUIT + .QUIT + QUIT + ; =================== +GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail + N I,J,K,L + S (I,K)=0 + S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) + F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D + . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) + . D ; :L + . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails + . . S LST(NAM,"MSG",I)=L + . . D GETTYP(I) + . .QUIT + .QUIT + S LST(NAM,"NUMBER")=K + QUIT + ; =================== + ; D0 is the IEN into the Message Global ^XMB(3.9,D0) + ; The products of these emails are scanned to identify + ; the number of documents stored in the MIME package. + ; The protocol runs like this; + ; Line 1 is the --separator + ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD + ; Line n+2 thru t-1 where t does NOT have "Content-" + ; Line t is Next Section Terminator, or Message Terminator, --separator + ; Line t+1 should not exist in the data set if Message Terminator + ; CON = "Content-" + ; FLG = "--" + ; SEP = FLG+7 or more characters ; Separator + ; END = SEP+FLG + ; SGC = Segment Count + ; Note: separator is a string of specific characters of + ; indeterminate length + ; LST() the transfer array + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data + ; +GETTYP(D0) ; Look for the goodies in the Mail + N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM + S CON="Content-" + S FLG="--" + S SEP="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) + S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D + . N T + . S T=+$G(^XMB(3.9,D0,1,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S LST("TO",D1)=T + . S T=$G(^XMB(3.9,D0,6,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . S LST("TO NAME",D1)=T + .QUIT + ; Preload first Segment (0) with beginning on Line 1 + ; if not a 64bit + S LST(NAM,"MSG",D0,"SEG",0)=1 + S D1=.9999,SEP="@@" + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; Enter once to set the SEP to capture the separator + . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q + . . S SEP=X,END=X_FLG + . . S (CNT,SGC)=1,BCN=0 + . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 + . .QUIT + . ; + . ; A new separator is set, process original + . I X=SEP D QUIT + . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF) + . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) + . . S SGC=SGC+1,BCN=0 + . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 + . .QUIT + . ; + . S BCN=BCN+$L(X) + . I X[CON D Q + . . S J=$P($P(X,";"),CON,2) + . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) + . .QUIT + . ; + . ; S LST(NAM,"MSG",D0,"SEG",D1)=X + .QUIT + QUIT + ; =================== +NAME(NM) ; Return the name of the Sender + N NAME + S NAME="" + D + . ; Look first for a value to use with the NEW PERSON file + . ; + . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q + . ; + . I $L(NM) S NAME=NM Q + . ; + . ; Else, pull the data from the message and display the foreign source + . ; of the message. + . N T + . S VAL=$G(^XMB(3.9,D0,.7)) + . S:VAL T=$P(^VA(200,VAL,0),U) + . I $L($G(T)) S NAME=T Q + . ; + .QUIT + QUIT NAME + ; =================== +TIME(Y) ; The time and date of the sending + X ^DD("DD") + QUIT Y + ; =================== + ; Segments in Message need to be identified and decoded properly + ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message + ; ARRAY will have the details of this one call + ; + ; Inputs; + ; C0CINPUT - The IEN of the message to expand + ; Outputs; + ; C0CDATA - Carrier for the returned structure of the Message + ; C0CDATA(D0,"SEG")=number of SEGMENTS + ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type + ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details + ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details + ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details + ; +DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery + N LST,D0,D1,U + S U="^" + S D0=+$G(C0CINPUT) + I D0 D QUIT + . I $D(^XMB(3.9,D0))<10 D ERROR("ER01") QUIT + . ; + . D GETTYP2(D0) + . I $D(LST) M C0CDATA(D0)=LST Q + . ; + . D ERROR("ER02") + .QUIT + QUIT + ; =================== + ; End note if needed + ; MSK - Set of characters that do not exist in 64 bit encoding +GETTYP2(D0) ; Try to get the types and MSK for the + N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM + S CON="Content-",U="^" + S FLG="--",MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" + S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + ; S K=$P(^XMB(3.9,D0,2,0),U,3) + S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST("CREATED")=$$TIME($P(XX,U,3)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST("FROM")=$$NAME(XXNM) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" + . N I,T + . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) + . S:T T=$P($G(^VA(200,T,0)),"^") + . S LST("TO",+D1)=T + . S T=$G(^XMB(3.9,D0,6,+D1,0)) + . S:T="" T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . S LST("TO NAME",D1)=T + .QUIT + ; Get the Header for the message and store as "HDR" + S D1=0,SGC=0 + F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D + . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) + .QUIT + N BNDRY,STKL,SEG + S STKL=0,SEG=0 + ; Find boundaries and map them + S D1=0 + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; Look for " boundary=" in the various parts. Map the establishment and the + . ; terminator markers and the actual boundary markers. + . I X[" boundary=" D Q + . . S SEP=$P(X," boundary=",2) + . . S:$E(SEP)="""" SEP=$TR(SEP,"""") + . . S STKL=STKL+1 + . . S END=SEP_FLG + . . S BNDRY(STKL,SEP)=0 + . . S BNDRX(SEP)=STKL,BNDRZ(END)=0 + . .QUIT + . ; + . ; Look for information as to how amy boudaries are present and where + . ; they terminate + . D:X'=""&($E(X,1,2)="--")&($E(X,$L(X)-1,9999)'="--") + . . ; Boundary Found + . . I $D(BNDRX(X)) D Q + . . . S SEG=SEG+1 + . . . S BNDRE(X)=$G(BNDRE(X))_D1_";" + . . . S BND1(D1)=STKL_";B;"_SEG_";"_X + . . . S BNDR(X,D1,"B")=STKL + . . . I BNDRX(X)=X D ERROR("ER13") + . . .QUIT + . . ; + . . ; Boundary Terminator + . . I $D(BNDRZ(X)) D Q + . . . S BNDR(X,D1,"E")=STKL + . . . S BNDRZ(X)=BNDRZ(X)+1 + . . . S BND1(D1)=STKL_";E;"_SEG_";"_X + . . . S SEG=SEG+1 + . . . I BNDRX(X)=X D ERROR("ER14") + . . . S STKL=STKL-1 + . . .QUIT + . .QUIT + .QUIT + ; Start walking the TEXT/XML/64-BIT ENCODING sections of the message + N A,B,C,STACK,STYP,SEG,AX + S D1=.99999,SGC=0 + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; + . D + . . I $D(BND1(D1)) D BOUNDARY(X) QUIT + . . ; + . . S DX=$O(BND1(D1)) + . . I DX="" D ERROR("ER15") Q + . . ; + . . ; Good situation, extract the parts for the section + . . S A=$G(BND1(DX)) + . . S STACK=+A,STYP=$P(A,";",2),SGC=$P(A,";",3),AX=$P(A,";",4,999) + . .QUIT + . ; Enter once to set the SEP to capture the separator + . ; + . ; A new SEGMENT separator is set, process original + . I $D(BND1(X)) D QUIT + . . ; Save Current Values + . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF) + . . ; Close this Segment and prepare to start a New Segment + . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1) + . . ; Put the result in LST("SEG",SGC,"XML") + . . I $L(BF) D + . . . S ZN=1 + . . . N I,T,TBF + . . . S TBF=BF + . . . F I=1:1:($L(TBF,"=")) D + . . . . S BF=$P(TBF,"=",I)_"=" + . . . . I "="'[BF D DECODER(.BF,.TYP) + . . . .QUIT + . . . S BF="" + . . .QUIT + . . S SGC=SGC+1,BCN=0 + . . ; Incriment SGC to start a new Segment + . . S LST("SEG",SGC)=D1 + . .QUIT + . ; + . ; Accumulate the 64 bit encoding, no spaces, or other non-64bit characters + . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT + . ; + . ; Ending Condition, close out the Segment + . I $D(BNDRZ(X)) D QUIT + . . S $P(LST("SEG",SGC),"^",2)=D1-1 + . . I $L(BF) S ZN=1 D DECODER(.BF,.TYP) S BF="" Q + . .QUIT + . ; + . ; Accumulate the content lines of the message + . S BCN=BCN+$L(X) + . ; Split out the Content Info + . I X[CON D Q + . . S J=$P(X,CON,2) + . . S TYP="CONTENT" + . . S LST("SEG",SGC,TYP,$P(J,":"))=$P(J,":",2,9) + . . D CONTENT(D1) + . .QUIT + . ; + . ; Everything else is Text, Check for CCR/CCD. + . N KK,UBF + . D + . . S UBF=$$UPPER(X) + . . I UBF["1) S TYP=$P(UP,".",2) Q + . I UP["XML" S TYP="XML" Q + . I UP["P7S" S TYP="P7S" Q + . I J[" boundary=" D BOUNDARY(J) + .QUIT + S LIS("CON",SGC,D1)=X + S LIS("CON",SGC,D1,"TYP")=TYP + ; If there is a follow-on, look for another line after this. + I $E($RE(X),1)=";" D CONTENT(D1+1) + QUIT + ; =================== +BOUNDARY(X) ; Set an additional BOUNDARY, and activate another stack level + S SEP=$P($P(X," boundary=",2),"""",2),END=SEP_FLG + Q:SEP?2"-".ANP + ; + D ERROR("ER11") + Q:SEP'[" " + ; + D ERROR("ER12") + QUIT + ; =================== + ; Break down the Buffer Array so it can be saved. + ; BF is passed in. + ; TYP is the type of +DECODER(BF,TYP) ; + N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE + S:$G(TYP)="" TYP="XML" + S ZBF=BF + ; Full Buffer, BF, now check for Encryption and Unpack + F RCNT=1:1:$L(ZBF,"=") D + . N BF + . S BF=$P(ZBF,"=",RCNT) + . ; Unpacking the 64 bit encoding + . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) + . D:$L(TBF) + . . N C,OK,OKCNT,KK,XBF,UBF + . . D + . . . S UBF=$$UPPER(TBF) + . . . I UBF["126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q + . . ; + . . D + . . . I 'OK S (BF,UBF,TBF,XBF)="" Q + . . . ; + . . . S BF=BF_"=" + . . . D NORMAL(.XBF,.TBF) + . . .QUIT + . . M LST("SEG",SGC,TYP,RCNT)=XBF + . .QUIT + .QUIT + QUIT + ; =================== + ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT + ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT + ; >D NORMAL^C0CMAIL(.OUT,BF) +NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML + ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME + ; + N ZN,OUTBF,XX,ZSEP + S INXML=$TR(INXML,$C(10,12,13)) + S ZN=1,ZSEP=">" + S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 + F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" + . S XX=$P(INXML,"><",ZN) + . S:$E($RE(XX))=">" ZSEP="" + . Q:XX="" + . ; + . S XX="<"_XX_ZSEP + . D + . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q + . . ; + . . D ERROR("ER05") + . . F ZL=ZL+1:1 D Q:XX="" + . . . N XL + . . . S XL=$E(XX,1,4000) + . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters + . . . S OUTBF(ZL)=XL + . . .QUIT + . .QUIT + .QUIT + M OUTXML=OUTBF + QUIT + ; =================== +UPPER(X) ; Convert any lowercase letters to Uppercase letters + QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + ; =================== + ; EN is a counter that remains between error events +ERROR(ER) ; Error Handler + N TXXQ,XXXQ + S XXXQ="Unknown Error Encountered = "_ER + S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) + I TXXQ'="" D + . I TXXQ["_" X "S TXXQ="_TXXQ + . S XXXQ=TXXQ + .QUIT + S EN(ER)=$G(EN(ER))+1 + S LST("ERR",ER,EN(ER))=XXXQ + QUIT + ; =================== +ER01 ;;Message Missing +ER02 ;;Message Text Missing +ER03 ;;Message Not Identifiable +ER04 ;;Segment is too large +ER05 ;;Mailbox Missing +ER06 ;;"User Missing = "_$G(DUZ) +ER07 ;;"Bad DUZ = "_DUZ +ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) +ER10 ;;"Bad Separator found = "_X +ER11 ;;"Non-Standard Separator Found:>"_$G(J) +ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) +ER13 ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X + ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv + ; End note if needed + QUIT + ; =================== Index: ccr/branches/ohum/p/C0CMCCD.m =================================================================== --- ccr/branches/ohum/p/C0CMCCD.m (revision 1332) +++ ccr/branches/ohum/p/C0CMCCD.m (revision 1333) @@ -1,293 +1,293 @@ C0CMCCD ; GPL - MXML based CCD utilities;12/04/09 17:05 - ;;0.1;C0C;nopatch;noreleasedate - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q - ; -PARSCCD(DOC,OPTION) ; THIS WAS COPIED FROM EN^MXMLDOM TO CUSTIMIZE FOR - ; PROCESSING CCDS - N CBK,SUCCESS,LEVEL,NODE,HANDLE - K ^TMP("MXMLERR",$J) - L +^TMP("MXMLDOM",$J):5 - E Q 0 - S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)="" - L -^TMP("MXMLDOM",$J) - S CBK("STARTELEMENT")="STARTELE^C0CMCCD" ; ONLY THIS ONE IS CHANGED ;GPL - S CBK("ENDELEMENT")="ENDELE^MXMLDOM" - S CBK("COMMENT")="COMMENT^MXMLDOM" - S CBK("CHARACTERS")="CHAR^MXMLDOM" - S CBK("ENDDOCUMENT")="ENDDOC^MXMLDOM" - S CBK("ERROR")="ERROR^MXMLDOM" - S (SUCCESS,LEVEL,LEVEL(0),NODE)=0,OPTION=$G(OPTION,"V1") - D EN^MXMLPRSE(DOC,.CBK,OPTION) - D:'SUCCESS DELETE^MXMLDOM(HANDLE) - Q $S(SUCCESS:HANDLE,1:0) - ; Start element - ; Create new child node and push info on stack -STARTELE(ELE,ATTR) ; COPIED FROM STARTELE^MXMLDOM AND MODIFIED TO TREAT - ; ATTRIBUTES AS SUBELEMENTS TO MAKE CCD XPATH PROCESSING EASIER - N PARENT - S PARENT=LEVEL(LEVEL),NODE=NODE+1 - S:PARENT ^TMP("MXMLDOM",$J,HANDLE,PARENT,"C",NODE)=ELE - S LEVEL=LEVEL+1,LEVEL(LEVEL)=NODE,LEVEL(LEVEL,0)=ELE - S ^TMP("MXMLDOM",$J,HANDLE,NODE)=ELE,^(NODE,"P")=PARENT - ;M ^("A")=ATTR - N ZI S ZI="" ; INDEX FOR ATTR - F S ZI=$O(ATTR(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE - . N ELE,TXT ; ABOUT TO RECURSE - . S ELE=ZI ; TAG - . S TXT=ATTR(ZI) ; DATA - . D STARTELE(ELE,"") ; CREATE A NEW SUBNODE - . D TXT^MXMLDOM("T") ; INSERT DATA TO TAG - . D ENDELE^MXMLDOM(ELE) ; POP BACK UP A LEVEL - Q - ; -ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE - N ZN - ;I $$TAG(ZOID)["entry" B - S ZN=$$NXTSIB(ZOID) - I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG - Q 0 - ; -FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID - Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) - ; -PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID - Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) - ; -ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID - S HANDLE=C0CDOCID - K @RTN - D GETTXT^MXMLDOM("A") - Q - ; -TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE - ;I ZOID=149 B ;GPLTEST - N X,Y - S Y="" - S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE - I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y - I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) - Q Y - ; -NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING - Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) - ; -DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE - ;N ZT,ZN S ZT="" - ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) - ;Q $G(@C0CDOM@(ZOID,"T",1)) - S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) - Q - ; -CLEANARY(OUTARY,INARY) ; GOES THROUGH AN ARRAY AND CALLS CLEAN ON EACH NODE - ; INARY AND OUTARY PASSED BY NAME - N ZI S ZI="" - F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH NODE - . S @OUTARY@(ZI)=$$CLEAN(@INARY@(ZI)) ; CLEAN THE NODE - Q - ; -CLEAN(STR) ; extrinsic function; returns string - ;; Removes all non printable characters from a string. - ;; STR by Value - N TR,I - F I=0:1:31 S TR=$G(TR)_$C(I) - S TR=TR_$C(127) - QUIT $TR(STR,TR) - ; -STRIPTXT(OUTARY,ZARY) ; STRIPS THE "TEXT" PORTION OUT OF AN XML FILE - ; THIS IS USED TO DELETE THE NARATIVE HTML OUT OF THE CCD XML FILES BECAUSE - ; THEY DO NOT WORK RIGHT WITH THE PARSER - ;N ZWRK,ZBLD,ZI ; WORK ARRAY,BUILD ARRAY, AND COUNTER - S ZI=$O(@ZARY@("")) ; GET FIRST LINE NUMBER - D C0CBEGIN("ZWRK",ZI) ; INSERT FIRST LINE IN WORK ARRAY - F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH LINE OF THE ARRAY - . I $O(@ZARY@(ZI))="" D Q ; AT THE END - . . D C0CEND("ZWRK",ZI) ; INCLUDE LAST LINE IN WORK ARRAY - . I ZI=1 D C0CBEGIN("ZWRK",ZI) ; START WITH FIRST LINE - . I @ZARY@(ZI)["" D C0CBEGIN("ZWRK",ZI+1) ;NEXT LINE IS A BEGIN - S ZI="" - F S ZI=$O(ZWRK(ZI)) Q:ZI="" D ; MAKE A BUILD LIST FROM THE WORK ARRAY - . D QUEUE^C0CXPATH("ZBLD",ZARY,$P(ZWRK(ZI),"^",1),$P(ZWRK(ZI),"^",2)) - D BUILD^C0CXPATH("ZBLD",OUTARY) ; BUILD NEW ARRAY WITHOUT TEXT SECTIONS - K @OUTARY@(0) ; GET RID OF THE LINE COUNT - Q - ; -C0CBEGIN(ZA,LN) ; INSERTS A BEGIN LINE LN INTO ARRAY ZWRK, PASSED BY NAME - N ZI - S ZI=$O(@ZA@(""),-1) - I ZI="" S ZI=1 - E S ZI=ZI+1 ; INCREMENT COUNT IN WORK ARRAY - S $P(@ZA@(ZI),"^",1)=LN - Q - ; -C0CEND(ZB,LN) ; INSERTS AN END LINE LN INTO ARRAY ZWRK, PASSED BY NAME - N ZI - S ZI=$O(@ZB@(""),-1) - I ZI="" S ZI=1 - S $P(@ZB@(ZI),"^",2)=LN - Q - ; -SEPARATE(OUTARY,INARY) ; SEPARATES XPATH VARIABLES ACCORDING TO THEIR - ; ROOT ; /Problems/etc/etc goes to @OUTARY@("Problems","/Problems/etc/etc") - S ZI="" - F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH ELEMENT OF THE ARRAY - . I $P(ZI,"//",2)'="" D ; FOR NON-BODY ENTRIES - . . S ZJ=$P(ZI,"/",4) ; things like From Patient Actor - . E D ; FOR BODY PARTS - . . S ZJ=$P(ZI,"/",2) ; - . . I ZJ="" S ZJ=$P(ZI,"/",3) ; - . S @OUTARY@(ZJ,ZI)=$G(@INARY@(ZI)) ;FIX THIS FOR MULTILINE COMMENTS - Q - ; -FINDTID ; FIND TEMPLATE IDS IN DOM 1 - S C0CDOCID=1 - S ZD=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) - S ZN="" - S CURSEC="" - S TID="" - F S ZN=$O(@ZD@(ZN)) Q:ZN="" D ; - . I $$TAG(ZN)="root" D ; - . . I $$TAG($$PARENT(ZN))="templateId" D ; ONLY LOOKING FOR TEMPLATES - . . . S ZG=$$PARENT($$PARENT(ZN)) - . . . S ZG2=$$PARENT(ZG) ;COMPONENT THAT HOLDS THIS SECTION - . . . S CMT=$G(@ZD@(ZG,"X",1)) - . . . I CMT="" S CMT="?" - . . . I $$TAG(ZG)="section" D ;START OF A SECTION - . . . . S CURSEC=$$PARENT(ZG) - . . . . S SECCMT=$G(@ZD@(CURSEC,"X",1)) - . . . . I SECCMT="" S SECCMT="?" - . . . . S SECTID=$G(@ZD@(ZN,"T",1)) ;SECTION TEMPLATE ID - . . . S TID=$G(@ZD@(ZN,"T",1)) ;TEMPLATE ID - . . . I CURSEC'="" D ; IF WE ARE IN A SECTION - . . . . S CCDDIR(ZG2,CURSEC,$$TAG(ZG2),CMT,SECCMT)=TID - . . . . S DOMMAP(ZG2)=CURSEC_U_$$TAG(ZG2)_U_TID_U_SECTID - . . . W !,$$TAG(ZG2)," ",$G(@ZD@(ZG,"X",1)) - . . . W " root ",ZN," ",@ZD@(ZN,"T",1) - Q - ; -FINDALT ; PROCESS THE DOMMAP AND FIND THE ALT TAGS FOR COMPONENTS - ; - S ZI="" - F S ZI=$O(DOMMAP(ZI)) Q:ZI="" D ; FOR EACH NODE IN THE MAP - . S ZJ=DOMMAP(ZI) ; - . S PARNODE=$P(ZJ,U,1) ;PARENT NODE - . S TAG=$P(ZJ,U,2) ;THIS TAG - . S TID=$P(ZJ,U,3) ;THIS TEMPLATE ID - . S PARTID=$P(ZJ,U,4) ;PARENT TEMPLATE ID - . S ZIEN=$O(^C0CXDS(178.101,"TID",TID,"")) ;THIS NODE IEN - . S PARIEN=$O(^C0CXDS(178.101,"TID",PARTID,"")) ;PARENT NODE IEN - . I ZI=PARNODE D ; IF THIS IS A SECTION NODE - . . S ALTTAG=$$GET1^DIQ(178.101,PARIEN_",",.03) ;ALT TAG FIELD FOR PARENT - . . S NAME=$$GET1^DIQ(178.101,ZIEN_",",.01) ;NAME OF THIS NODE'S TEMPLATE - . . W ZI," ",TAG," ",ALTTAG," ",NAME,! - . . S C0CTAGS(ZI)=ALTTAG - . E D ; NOT A SECTION NODE - . . N ZJ S ZJ="" - . . S ZJ=$O(^C0CXDS(178.101,"D",PARIEN,ZIEN,"")) ;A WHEREUSED POINTER? - . . I ZJ'="" D ; THERE IS A NEW LABEL FOR THIS NODE - . . . N ZK - . . . S ZK=$$GET1^DIQ(178.111,ZJ_","_ZIEN_",",2) - . . . I ZK'="" D ; - . . . . W "FOUND ",ZK,! - . . . . S C0CTAGS(ZI)=ZK ; NEW TAG FOR INTERSECTION - Q - ; -ALTTAG(NODE) ; SET Y EQUAL TO THE ALT TAG FOUND IN C0CTAGS IF NODE IF FOUND - ; - S Y=$G(C0CTAGS(NODE)) - Q - ; -SETCBK ; SET THE TAG CALLBACK FOR XPATH PROCESSSING OF THE CCD - S C0CCBK("TAG")="D ALTTAG^C0CMCCD(ZOID)" - Q - ; -OUTCCD(GARYIN) ; OUTPUT THE PARSED CCD TO A TEXT FILE - ;D TEST3^C0CMXML - N ZT S ZT=$NA(^TMP("CCDOUT",$J)) - N ZI,ZJ - S ZI=1 S ZJ="" - K @ZT - F S ZJ=$O(GARYIN(ZJ)) Q:ZJ="" D ; - . S @ZT@(ZI)=ZJ_"^"_GARYIN(ZJ) - . S ZI=ZI+1 - S ONAME=$NA(@ZT@(1)) - W $$OUTPUT^C0CXPATH(ONAME,"CCDOUT.txt","/home/vademo2/CCR") - K @ZT - Q - ; -GENXDS(ZD) ; GENERATE THE XDS PROTOTYPE RECORDS FROM A CCDDIR ARRAY - ; ARRAY ELEMENTS LOOK LIKE: - ; CCDDIR(1659,1634,"observation"," Result observaion template "," Vital signs section template ")="2.16.840.1.113883.10.20.1.31" - ;or CCDDIR(cur node,section node,cur tag,cur name,sec name)=templateId - S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE - S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT - S DONE=0 - F Q:DONE D ; - . W @ZI,! - . S ZJ=$QS(ZI,5) - . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE - . S C0CFDA(ZF,"?+1,",.01)=ZJ - . S C0CFDA(ZF,"?+1,",.02)=$QS(ZI,4) ; TAG FOR THIS TEMPLATE - . S C0CFDA(ZF,"?+1,",1)=@ZI - . D UPDIE - . S ZI=$Q(@ZI) - . I ZI="" S DONE=1 - Q - ; -WHRUSD(ZD) ; UPDATE THE C0C XDS FILE WITH WHERE USED DATA FROM - ; CCDDIR PASS BY NAME - ; ARRAY ELEMENTS LOOK LIKE: - ; CCDDIR(1634," Vital signs section template ",1659,"observation"," Result observaion template ")="2.16.840.1.113883.10.20.1.31" - ;or CCDDIR(section node,sec name, cur node,cur tag,cur name)=templateId - S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE - S ZSF=178.111 ; WHERE USED SUBFILE OF C0C XDS PROTOTYPE FILE - S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT - S DONE=0 - F Q:DONE D ; - . W @ZI - . S ZIEN=$O(^C0CXDS(178.101,"TID",@ZI,"")) ; IEN FOR THIS NODE'S TEMPLATE - . W " IEN:",ZIEN - . S ZJ=$QS(ZI,2) - . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE - . S ZPIEN=$O(^C0CXDS(178.101,"B",ZJ,"")) ; PARENT IEN - . W " PARENT IEN:",ZPIEN - . S ZTAG=$QS(ZI,4) ; TAG FOR THIS TEMPLATE - . W " TAG:",ZTAG,! - . I ZIEN'=ZPIEN D ; ONLY FOR CHILD TEMPLATES - . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",.01)=ZPIEN ; NEW SUBFILE ENTRY WITH PAR PTR - . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",1)=ZTAG ; TAG FOR NEW ENTRY - . . D UPDIE - . ;S C0CFDA(ZF,"?+1,",1)=@ZI - . ;D UPDIE - . S ZI=$Q(@ZI) - . I ZI="" S DONE=1 - Q - ; + ;;0.1;C0C;nopatch;noreleasedate;Build 1 + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q + ; +PARSCCD(DOC,OPTION) ; THIS WAS COPIED FROM EN^MXMLDOM TO CUSTIMIZE FOR + ; PROCESSING CCDS + N CBK,SUCCESS,LEVEL,NODE,HANDLE + K ^TMP("MXMLERR",$J) + L +^TMP("MXMLDOM",$J):5 + E Q 0 + S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)="" + L -^TMP("MXMLDOM",$J) + S CBK("STARTELEMENT")="STARTELE^C0CMCCD" ; ONLY THIS ONE IS CHANGED ;GPL + S CBK("ENDELEMENT")="ENDELE^MXMLDOM" + S CBK("COMMENT")="COMMENT^MXMLDOM" + S CBK("CHARACTERS")="CHAR^MXMLDOM" + S CBK("ENDDOCUMENT")="ENDDOC^MXMLDOM" + S CBK("ERROR")="ERROR^MXMLDOM" + S (SUCCESS,LEVEL,LEVEL(0),NODE)=0,OPTION=$G(OPTION,"V1") + D EN^MXMLPRSE(DOC,.CBK,OPTION) + D:'SUCCESS DELETE^MXMLDOM(HANDLE) + Q $S(SUCCESS:HANDLE,1:0) + ; Start element + ; Create new child node and push info on stack +STARTELE(ELE,ATTR) ; COPIED FROM STARTELE^MXMLDOM AND MODIFIED TO TREAT + ; ATTRIBUTES AS SUBELEMENTS TO MAKE CCD XPATH PROCESSING EASIER + N PARENT + S PARENT=LEVEL(LEVEL),NODE=NODE+1 + S:PARENT ^TMP("MXMLDOM",$J,HANDLE,PARENT,"C",NODE)=ELE + S LEVEL=LEVEL+1,LEVEL(LEVEL)=NODE,LEVEL(LEVEL,0)=ELE + S ^TMP("MXMLDOM",$J,HANDLE,NODE)=ELE,^(NODE,"P")=PARENT + ;M ^("A")=ATTR + N ZI S ZI="" ; INDEX FOR ATTR + F S ZI=$O(ATTR(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE + . N ELE,TXT ; ABOUT TO RECURSE + . S ELE=ZI ; TAG + . S TXT=ATTR(ZI) ; DATA + . D STARTELE(ELE,"") ; CREATE A NEW SUBNODE + . D TXT^MXMLDOM("T") ; INSERT DATA TO TAG + . D ENDELE^MXMLDOM(ELE) ; POP BACK UP A LEVEL + Q + ; +ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE + N ZN + ;I $$TAG(ZOID)["entry" B + S ZN=$$NXTSIB(ZOID) + I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG + Q 0 + ; +FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID + Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) + ; +PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID + Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) + ; +ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID + S HANDLE=C0CDOCID + K @RTN + D GETTXT^MXMLDOM("A") + Q + ; +TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE + ;I ZOID=149 B ;GPLTEST + N X,Y + S Y="" + S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE + I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y + I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) + Q Y + ; +NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING + Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) + ; +DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE + ;N ZT,ZN S ZT="" + ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) + ;Q $G(@C0CDOM@(ZOID,"T",1)) + S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) + Q + ; +CLEANARY(OUTARY,INARY) ; GOES THROUGH AN ARRAY AND CALLS CLEAN ON EACH NODE + ; INARY AND OUTARY PASSED BY NAME + N ZI S ZI="" + F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH NODE + . S @OUTARY@(ZI)=$$CLEAN(@INARY@(ZI)) ; CLEAN THE NODE + Q + ; +CLEAN(STR) ; extrinsic function; returns string + ;; Removes all non printable characters from a string. + ;; STR by Value + N TR,I + F I=0:1:31 S TR=$G(TR)_$C(I) + S TR=TR_$C(127) + QUIT $TR(STR,TR) + ; +STRIPTXT(OUTARY,ZARY) ; STRIPS THE "TEXT" PORTION OUT OF AN XML FILE + ; THIS IS USED TO DELETE THE NARATIVE HTML OUT OF THE CCD XML FILES BECAUSE + ; THEY DO NOT WORK RIGHT WITH THE PARSER + ;N ZWRK,ZBLD,ZI ; WORK ARRAY,BUILD ARRAY, AND COUNTER + S ZI=$O(@ZARY@("")) ; GET FIRST LINE NUMBER + D C0CBEGIN("ZWRK",ZI) ; INSERT FIRST LINE IN WORK ARRAY + F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH LINE OF THE ARRAY + . I $O(@ZARY@(ZI))="" D Q ; AT THE END + . . D C0CEND("ZWRK",ZI) ; INCLUDE LAST LINE IN WORK ARRAY + . I ZI=1 D C0CBEGIN("ZWRK",ZI) ; START WITH FIRST LINE + . I @ZARY@(ZI)["" D C0CBEGIN("ZWRK",ZI+1) ;NEXT LINE IS A BEGIN + S ZI="" + F S ZI=$O(ZWRK(ZI)) Q:ZI="" D ; MAKE A BUILD LIST FROM THE WORK ARRAY + . D QUEUE^C0CXPATH("ZBLD",ZARY,$P(ZWRK(ZI),"^",1),$P(ZWRK(ZI),"^",2)) + D BUILD^C0CXPATH("ZBLD",OUTARY) ; BUILD NEW ARRAY WITHOUT TEXT SECTIONS + K @OUTARY@(0) ; GET RID OF THE LINE COUNT + Q + ; +C0CBEGIN(ZA,LN) ; INSERTS A BEGIN LINE LN INTO ARRAY ZWRK, PASSED BY NAME + N ZI + S ZI=$O(@ZA@(""),-1) + I ZI="" S ZI=1 + E S ZI=ZI+1 ; INCREMENT COUNT IN WORK ARRAY + S $P(@ZA@(ZI),"^",1)=LN + Q + ; +C0CEND(ZB,LN) ; INSERTS AN END LINE LN INTO ARRAY ZWRK, PASSED BY NAME + N ZI + S ZI=$O(@ZB@(""),-1) + I ZI="" S ZI=1 + S $P(@ZB@(ZI),"^",2)=LN + Q + ; +SEPARATE(OUTARY,INARY) ; SEPARATES XPATH VARIABLES ACCORDING TO THEIR + ; ROOT ; /Problems/etc/etc goes to @OUTARY@("Problems","/Problems/etc/etc") + S ZI="" + F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH ELEMENT OF THE ARRAY + . I $P(ZI,"//",2)'="" D ; FOR NON-BODY ENTRIES + . . S ZJ=$P(ZI,"/",4) ; things like From Patient Actor + . E D ; FOR BODY PARTS + . . S ZJ=$P(ZI,"/",2) ; + . . I ZJ="" S ZJ=$P(ZI,"/",3) ; + . S @OUTARY@(ZJ,ZI)=$G(@INARY@(ZI)) ;FIX THIS FOR MULTILINE COMMENTS + Q + ; +FINDTID ; FIND TEMPLATE IDS IN DOM 1 + S C0CDOCID=1 + S ZD=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) + S ZN="" + S CURSEC="" + S TID="" + F S ZN=$O(@ZD@(ZN)) Q:ZN="" D ; + . I $$TAG(ZN)="root" D ; + . . I $$TAG($$PARENT(ZN))="templateId" D ; ONLY LOOKING FOR TEMPLATES + . . . S ZG=$$PARENT($$PARENT(ZN)) + . . . S ZG2=$$PARENT(ZG) ;COMPONENT THAT HOLDS THIS SECTION + . . . S CMT=$G(@ZD@(ZG,"X",1)) + . . . I CMT="" S CMT="?" + . . . I $$TAG(ZG)="section" D ;START OF A SECTION + . . . . S CURSEC=$$PARENT(ZG) + . . . . S SECCMT=$G(@ZD@(CURSEC,"X",1)) + . . . . I SECCMT="" S SECCMT="?" + . . . . S SECTID=$G(@ZD@(ZN,"T",1)) ;SECTION TEMPLATE ID + . . . S TID=$G(@ZD@(ZN,"T",1)) ;TEMPLATE ID + . . . I CURSEC'="" D ; IF WE ARE IN A SECTION + . . . . S CCDDIR(ZG2,CURSEC,$$TAG(ZG2),CMT,SECCMT)=TID + . . . . S DOMMAP(ZG2)=CURSEC_U_$$TAG(ZG2)_U_TID_U_SECTID + . . . W !,$$TAG(ZG2)," ",$G(@ZD@(ZG,"X",1)) + . . . W " root ",ZN," ",@ZD@(ZN,"T",1) + Q + ; +FINDALT ; PROCESS THE DOMMAP AND FIND THE ALT TAGS FOR COMPONENTS + ; + S ZI="" + F S ZI=$O(DOMMAP(ZI)) Q:ZI="" D ; FOR EACH NODE IN THE MAP + . S ZJ=DOMMAP(ZI) ; + . S PARNODE=$P(ZJ,U,1) ;PARENT NODE + . S TAG=$P(ZJ,U,2) ;THIS TAG + . S TID=$P(ZJ,U,3) ;THIS TEMPLATE ID + . S PARTID=$P(ZJ,U,4) ;PARENT TEMPLATE ID + . S ZIEN=$O(^C0CXDS(178.101,"TID",TID,"")) ;THIS NODE IEN + . S PARIEN=$O(^C0CXDS(178.101,"TID",PARTID,"")) ;PARENT NODE IEN + . I ZI=PARNODE D ; IF THIS IS A SECTION NODE + . . S ALTTAG=$$GET1^DIQ(178.101,PARIEN_",",.03) ;ALT TAG FIELD FOR PARENT + . . S NAME=$$GET1^DIQ(178.101,ZIEN_",",.01) ;NAME OF THIS NODE'S TEMPLATE + . . W ZI," ",TAG," ",ALTTAG," ",NAME,! + . . S C0CTAGS(ZI)=ALTTAG + . E D ; NOT A SECTION NODE + . . N ZJ S ZJ="" + . . S ZJ=$O(^C0CXDS(178.101,"D",PARIEN,ZIEN,"")) ;A WHEREUSED POINTER? + . . I ZJ'="" D ; THERE IS A NEW LABEL FOR THIS NODE + . . . N ZK + . . . S ZK=$$GET1^DIQ(178.111,ZJ_","_ZIEN_",",2) + . . . I ZK'="" D ; + . . . . W "FOUND ",ZK,! + . . . . S C0CTAGS(ZI)=ZK ; NEW TAG FOR INTERSECTION + Q + ; +ALTTAG(NODE) ; SET Y EQUAL TO THE ALT TAG FOUND IN C0CTAGS IF NODE IF FOUND + ; + S Y=$G(C0CTAGS(NODE)) + Q + ; +SETCBK ; SET THE TAG CALLBACK FOR XPATH PROCESSSING OF THE CCD + S C0CCBK("TAG")="D ALTTAG^C0CMCCD(ZOID)" + Q + ; +OUTCCD(GARYIN) ; OUTPUT THE PARSED CCD TO A TEXT FILE + ;D TEST3^C0CMXML + N ZT S ZT=$NA(^TMP("CCDOUT",$J)) + N ZI,ZJ + S ZI=1 S ZJ="" + K @ZT + F S ZJ=$O(GARYIN(ZJ)) Q:ZJ="" D ; + . S @ZT@(ZI)=ZJ_"^"_GARYIN(ZJ) + . S ZI=ZI+1 + S ONAME=$NA(@ZT@(1)) + W $$OUTPUT^C0CXPATH(ONAME,"CCDOUT.txt","/home/vademo2/CCR") + K @ZT + Q + ; +GENXDS(ZD) ; GENERATE THE XDS PROTOTYPE RECORDS FROM A CCDDIR ARRAY + ; ARRAY ELEMENTS LOOK LIKE: + ; CCDDIR(1659,1634,"observation"," Result observaion template "," Vital signs section template ")="2.16.840.1.113883.10.20.1.31" + ;or CCDDIR(cur node,section node,cur tag,cur name,sec name)=templateId + S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE + S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT + S DONE=0 + F Q:DONE D ; + . W @ZI,! + . S ZJ=$QS(ZI,5) + . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE + . S C0CFDA(ZF,"?+1,",.01)=ZJ + . S C0CFDA(ZF,"?+1,",.02)=$QS(ZI,4) ; TAG FOR THIS TEMPLATE + . S C0CFDA(ZF,"?+1,",1)=@ZI + . D UPDIE + . S ZI=$Q(@ZI) + . I ZI="" S DONE=1 + Q + ; +WHRUSD(ZD) ; UPDATE THE C0C XDS FILE WITH WHERE USED DATA FROM + ; CCDDIR PASS BY NAME + ; ARRAY ELEMENTS LOOK LIKE: + ; CCDDIR(1634," Vital signs section template ",1659,"observation"," Result observaion template ")="2.16.840.1.113883.10.20.1.31" + ;or CCDDIR(section node,sec name, cur node,cur tag,cur name)=templateId + S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE + S ZSF=178.111 ; WHERE USED SUBFILE OF C0C XDS PROTOTYPE FILE + S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT + S DONE=0 + F Q:DONE D ; + . W @ZI + . S ZIEN=$O(^C0CXDS(178.101,"TID",@ZI,"")) ; IEN FOR THIS NODE'S TEMPLATE + . W " IEN:",ZIEN + . S ZJ=$QS(ZI,2) + . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE + . S ZPIEN=$O(^C0CXDS(178.101,"B",ZJ,"")) ; PARENT IEN + . W " PARENT IEN:",ZPIEN + . S ZTAG=$QS(ZI,4) ; TAG FOR THIS TEMPLATE + . W " TAG:",ZTAG,! + . I ZIEN'=ZPIEN D ; ONLY FOR CHILD TEMPLATES + . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",.01)=ZPIEN ; NEW SUBFILE ENTRY WITH PAR PTR + . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",1)=ZTAG ; TAG FOR NEW ENTRY + . . D UPDIE + . ;S C0CFDA(ZF,"?+1,",1)=@ZI + . ;D UPDIE + . S ZI=$Q(@ZI) + . I ZI="" S DONE=1 + Q + ; UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS - K ZERR - D CLEAN^DILF - D UPDATE^DIE("","C0CFDA","","ZERR") - I $D(ZERR) D ; - . W "ERROR",! - . ZWR ZERR - . B - K C0CFDA - Q - ; + K ZERR + D CLEAN^DILF + D UPDATE^DIE("","C0CFDA","","ZERR") + I $D(ZERR) D ; + . W "ERROR",! + . ZWR ZERR + . B + K C0CFDA + Q + ; Index: ccr/branches/ohum/p/C0CMED.m =================================================================== --- ccr/branches/ohum/p/C0CMED.m (revision 1332) +++ ccr/branches/ohum/p/C0CMED.m (revision 1333) @@ -1,4 +1,4 @@ C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel. ; Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CMED1.m =================================================================== --- ccr/branches/ohum/p/C0CMED1.m (revision 1332) +++ ccr/branches/ohum/p/C0CMED1.m (revision 1333) @@ -1,4 +1,4 @@ C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;;Last modified Sat Jan 10 21:42:27 PST 2009 ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU @@ -56,8 +56,8 @@ ; @(0) contains the number of meds or -1^NO DATA FOUND ; If it is -1, we quit. - I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT + I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 Q ZWRITE:$G(DEBUG) MEDS N RXIEN S RXIEN=0 - F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="" D ; FOR EACH MEDICATION IN THE LIST + F S RXIEN=$O(MEDS(RXIEN)) Q:$G(RXIEN)="" D ; FOR EACH MEDICATION IN THE LIST . N MED M MED=MEDS(RXIEN) . I 'ALL,ACTIVE,$P(MED(100),U,2)'="ACTIVE" QUIT Index: ccr/branches/ohum/p/C0CMED2.m =================================================================== --- ccr/branches/ohum/p/C0CMED2.m (revision 1332) +++ ccr/branches/ohum/p/C0CMED2.m (revision 1333) @@ -1,4 +1,4 @@ C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;;Last Modified Sat Jan 10 21:41:14 PST 2009 ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU Index: ccr/branches/ohum/p/C0CMED3.m =================================================================== --- ccr/branches/ohum/p/C0CMED3.m (revision 1332) +++ ccr/branches/ohum/p/C0CMED3.m (revision 1333) @@ -1,4 +1,4 @@ C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;;Last Modified: Sun Jan 11 05:45:03 UTC 2009 ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU Index: ccr/branches/ohum/p/C0CMED4.m =================================================================== --- ccr/branches/ohum/p/C0CMED4.m (revision 1332) +++ ccr/branches/ohum/p/C0CMED4.m (revision 1333) @@ -1,178 +1,178 @@ -C0CMED4 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 - ;;0.1;CCDCCR;;; - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ; General Public License See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE - ; - ; MINXML is the Input XML Template, passed by name - ; DFN is Patient IEN - ; OUTXML is the resultant XML. - ; - ; MEDS is return array from API. - ; MED is holds each array element from MEDS, one medicine - ; MAP is a mapping variable map (store result) for each med - ; - ; Inpatient Meds will be extracted using this routine and and the one following. - ; Inpatient Meds Unit Dose is going to be C0CMED4 - ; Inpatient Meds IVs is going to be C0CMED5 - ; - ; We will use two Pharmacy ReEnginnering API's: - ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info - ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info - ; For more information, see the PRE documentation at: - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf - ; - ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient - ; - N MEDS,MAP - K ^TMP($J) - D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*) - I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT ; No Meds - Quit - ; Otherwise, we go on... - M MEDS=^TMP($J,"UD") - I DEBUG ZWR MEDS - S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) - N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array - N I S I=0 - F S I=$O(MEDS("B",I)) Q:'I D ; For each medication in B index - . N MED M MED=MEDS(I) - . S MEDCOUNT=MEDCOUNT+1 - . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter - . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) - . N RXIEN S RXIEN=MED(.01) ; Order Number - . I DEBUG W "RXIEN IS ",RXIEN,! - . I DEBUG W "MAP= ",MAP,! - . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN - . S @MAP@("MEDISSUEDATETXT")="Order Date" - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT") - . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient - . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient - . S @MAP@("MEDRXNOTXT")="" ; For Outpatient - . S @MAP@("MEDRXNO")="" ; For Outpatient - . S @MAP@("MEDTYPETEXT")="Medication" - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses - . S @MAP@("MEDSTATUSTEXT")="ACTIVE" - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) - . S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) - . ; NDC is field 31 in the drug file. - . ; The actual drug entry in the drug file is not necessarily supplied. - . ; It' node 1, internal form. - . N MEDIEN S MEDIEN=MED(1,"I") - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") - . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") - . S @MAP@("MEDBRANDNAMETEXT")="" - . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") - . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) - . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") - . S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") - . ; Units, concentration, etc, come from another call - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters - . ; NDF Entry IEN, and VA Product Name - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") - . ; Documented in the same manual. - . N NDFDATA,CONCDATA - . I $L(MEDIEN) D - . . D NDF^PSS50(MEDIEN,,,,,"CONC") - . . M NDFDATA=^TMP($J,"CONC",MEDIEN) - . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) - . . N VAPROD S VAPROD=$P(NDFDATA(22),U) - . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" - . . ; and this will crash the call. So... - . . I NDFIEN="" S CONCDATA="" - . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) - . E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. - . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") - . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") - . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") - . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. - . ; Oddly, there is no easy place to find the dispense unit. - . ; It's not included in the original call, so we have to go to the drug file. - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") - . ; Node 14.5 is the Dispense Unit - . I $L(MEDIEN) D - . . D DATA^PSS50(MEDIEN,,,,,"QTY") - . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) - . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) - E S @MAP@("MEDQUANTITYUNIT")="" - . ; - . ; --- START OF DIRECTIONS --- - . ; Dosage is field 2, route is 3, schedule is 4 - . ; These are all free text fields, and don't point to any files - . ; For that reason, I will use the field I never used before: - . ; MEDDIRECTIONDESCRIPTIONTEXT - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. - . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" - . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" - . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" - . ; - . ; --- END OF DIRECTIONS --- - . ; - . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" - . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field - . S @MAP@("MEDRFNO")="" - . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) - . K @RESULT - . D MAP^GPLXPATH(MINXML,MAP,RESULT) - . ; D PARY^GPLXPATH(RESULT) - . ; MAPPING DIRECTIONS - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT - . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) - . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") - . ; N MDZ1,MDZNA - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) - . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) - . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") - . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy - . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML - N MEDTMP,MEDI - D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ - . W "MEDICATION MISSING ",! - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! - Q - ; +C0CMED4 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 + ;;0.1;CCDCCR;;;Build 1 + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE + ; + ; MINXML is the Input XML Template, passed by name + ; DFN is Patient IEN + ; OUTXML is the resultant XML. + ; + ; MEDS is return array from API. + ; MED is holds each array element from MEDS, one medicine + ; MAP is a mapping variable map (store result) for each med + ; + ; Inpatient Meds will be extracted using this routine and and the one following. + ; Inpatient Meds Unit Dose is going to be C0CMED4 + ; Inpatient Meds IVs is going to be C0CMED5 + ; + ; We will use two Pharmacy ReEnginnering API's: + ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info + ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info + ; For more information, see the PRE documentation at: + ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf + ; + ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient + ; + N MEDS,MAP + K ^TMP($J) + D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*) + I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT ; No Meds - Quit + ; Otherwise, we go on... + M MEDS=^TMP($J,"UD") + I DEBUG ZWR MEDS + S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) + N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array + N I S I=0 + F S I=$O(MEDS("B",I)) Q:'I D ; For each medication in B index + . N MED M MED=MEDS(I) + . S MEDCOUNT=MEDCOUNT+1 + . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter + . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) + . N RXIEN S RXIEN=MED(.01) ; Order Number + . I DEBUG W "RXIEN IS ",RXIEN,! + . I DEBUG W "MAP= ",MAP,! + . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN + . S @MAP@("MEDISSUEDATETXT")="Order Date" + . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT") + . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient + . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient + . S @MAP@("MEDRXNOTXT")="" ; For Outpatient + . S @MAP@("MEDRXNO")="" ; For Outpatient + . S @MAP@("MEDTYPETEXT")="Medication" + . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses + . S @MAP@("MEDSTATUSTEXT")="ACTIVE" + . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) + . S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) + . ; NDC is field 31 in the drug file. + . ; The actual drug entry in the drug file is not necessarily supplied. + . ; It' node 1, internal form. + . N MEDIEN S MEDIEN=MED(1,"I") + . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") + . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") + . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") + . S @MAP@("MEDBRANDNAMETEXT")="" + . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") + . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) + . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") + . S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") + . ; Units, concentration, etc, come from another call + . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit + . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters + . ; NDF Entry IEN, and VA Product Name + . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") + . ; Documented in the same manual. + . N NDFDATA,CONCDATA + . I $L(MEDIEN) D + . . D NDF^PSS50(MEDIEN,,,,,"CONC") + . . M NDFDATA=^TMP($J,"CONC",MEDIEN) + . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) + . . N VAPROD S VAPROD=$P(NDFDATA(22),U) + . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" + . . ; and this will crash the call. So... + . . I NDFIEN="" S CONCDATA="" + . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) + . E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. + . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") + . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") + . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") + . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. + . ; Oddly, there is no easy place to find the dispense unit. + . ; It's not included in the original call, so we have to go to the drug file. + . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") + . ; Node 14.5 is the Dispense Unit + . I $L(MEDIEN) D + . . D DATA^PSS50(MEDIEN,,,,,"QTY") + . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) + . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) + E S @MAP@("MEDQUANTITYUNIT")="" + . ; + . ; --- START OF DIRECTIONS --- + . ; Dosage is field 2, route is 3, schedule is 4 + . ; These are all free text fields, and don't point to any files + . ; For that reason, I will use the field I never used before: + . ; MEDDIRECTIONDESCRIPTIONTEXT + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. + . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" + . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" + . ; + . ; --- END OF DIRECTIONS --- + . ; + . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" + . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field + . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field + . S @MAP@("MEDRFNO")="" + . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) + . K @RESULT + . D MAP^GPLXPATH(MINXML,MAP,RESULT) + . ; D PARY^GPLXPATH(RESULT) + . ; MAPPING DIRECTIONS + . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) + . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") + . ; N MDZ1,MDZNA + . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS + . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION + . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) + . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) + . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") + . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy + . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML + N MEDTMP,MEDI + D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "MEDICATION MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; Index: ccr/branches/ohum/p/C0CMED6.m =================================================================== --- ccr/branches/ohum/p/C0CMED6.m (revision 1332) +++ ccr/branches/ohum/p/C0CMED6.m (revision 1333) @@ -1,331 +1,331 @@ -C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09 - ;;1.0;C0C;;May 19, 2009; - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ; General Public License See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE - ; - ; MINXML and OUTXML are passed by name so globals can be used - ; MINXML will contain only the medications skeleton of the overall template - ; MEDCOUNT is a counter passed by Reference. - ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool) - ; FLAGS are set-up in C0CMED. - ; - ; MEDS is return array from RPC. - ; MAP is a mapping variable map (store result) for each med - ; MED is holds each array element from MEDS(J), one medicine - ; J is a counter. - ; - ; GETRXS^BEHORXFN(ARRAYNAME,DFN,DAYS) will be the the API used. - ; This API has been developed by Medsphere for IHS for getting - ; Medications from RPMS. It has most of what we need. - ; API written by Doug Martin when he worked for Medsphere (thanks Doug!) - ; -- ARRAYNAME is passed by name (required) - ; -- DFN is passed by value (required) - ; -- DAYS is passed by value (optional; if not passed defaults to 365) - ; - ; Return: - ; ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID - ; ^Status^LastFill^Chronic^Issued^Rx #^Provider^ - ; Status Reason^DEA Handling - ; - N MEDS,MEDS1,MAP - D GETRXS^BEHORXFN("MEDS1",DFN,$P($P(FLAGS,U,2),"-",2)) ; 2nd piece of FLAGS is # of days to retrieve, which comes in the form "T-360" - N ALL S ALL=+FLAGS - N ACTIVE S ACTIVE=$P(FLAGS,U,3) - N PENDING S PENDING=$P(FLAGS,U,4) - S @OUTXML@(0)=0 ;By default, no meds - ; If MEDS1 is not defined, then no meds - I '$D(MEDS1) QUIT - I DEBUG ZWR MEDS1,MINXML - N MEDCNT S MEDCNT=0 ; Med Count - ; The next line is a super line. It goes through the array return - ; and if the first characters are ~OP, it grabs the line. - ; This means that line is for a dispensed Outpatient Med. - ; That line has the metadata about the med that I need. - ; The next lines, however many, are the med and the sig. - ; I won't be using those because I have to get the sig parsed exactly. - N J S J="" F S J=$O(MEDS1(J)) Q:J="" I $E(MEDS1(J),1,3)="~OP" S MEDCNT=MEDCNT+1 S MEDS(MEDCNT)=MEDS1(J) - K MEDS1 - S MEDCNT="" ; Initialize for $Order - F S MEDCNT=$O(MEDS(MEDCNT)) Q:MEDCNT="" D ; for each medication in the list - . I 'ALL,ACTIVE,$P(MEDS(MEDCNT),U,10)'="ACTIVE" QUIT - . I 'ALL,PENDING,$P(MEDS(MEDCNT),U,10)'="PENDING" QUIT - . I DEBUG W "MEDCNT IS ",MEDCNT,! - . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCNT)) - . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED - . I DEBUG W "MAP= ",MAP,! - . S @MAP@("MEDOBJECTID")="MED"_MEDCNT ; MEDCNT FOR ID - . S @MAP@("MEDISSUEDATETXT")="Issue Date" - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,15),"DT") - . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" - . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,11),"DT") - . S @MAP@("MEDRXNOTXT")="Prescription Number" - . S @MAP@("MEDRXNO")=$P(MEDS(MEDCNT),U,14) - . S @MAP@("MEDTYPETEXT")="Medication" - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses - . S @MAP@("MEDSTATUSTEXT")=$P(MEDS(MEDCNT),U,10) - . ; Provider only provided in API as text, not DUZ. - . ; We need to get DUZ from filman file 52 (Prescription) - . ; Field 4; IEN is Piece 2 of Meds stripped of trailing characters. - . ; Note that I will use RXIEN several times later - . N RXIEN S RXIEN=+$P(MEDS(MEDCNT),U,2) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52,RXIEN,4,"I") - . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MEDS(MEDCNT),U,3) - . ; --- RxNorm Stuff - . ; 176.001 is the file for Concepts; 176.003 is the file for - . ; sources (i.e. for RxNorm Version) - . ; - . ; I use 176.001 for the Vista version of this routine (files 1-3) - . ; Since IHS does not have VUID's, I will be getting RxNorm codes - . ; using NDCs. My specially crafted index (sounds evil) named "NDC" - . ; is in file 176.002. The file is called RxNorm NDC to VUID. - . ; Except that I don't need the VUID, but it's there if I need it. - . ; - . ; We obviously need the NDC. That is easily obtained from the prescription. - . ; Field 27 in file 52 - . N NDC S NDC=$$GET1^DIQ(52,RXIEN,27,"I") - . ; I discovered that file 176.002 might give you two codes for the NDC - . ; One for the Clinical Drug, and one for the ingredient. - . ; So the plan is to get the two RxNorm codes, and then find from - . ; file 176.001 which one is the Clinical Drug. - . ; ... I refactored this into GETRXN - . N RXNORM,SRCIEN,RXNNAME,RXNVER - . I +NDC,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. - . . S RXNORM=$$GETRXN(NDC) - . . S SRCIEN=$$FIND1^DIC(176.003,,,"RXNORM","B") - . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) - . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) - . ; - . E S (RXNORM,RXNNAME,RXNVER)="" - . ; End if/else block - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME - . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER - . ; --- End RxNorm section - . ; - . ; Brand name is 52 field 6.5 - . S @MAP@("MEDBRANDNAMETEXT")=$$GET1^DIQ(52,RXIEN,6.5) - . ; - . ; Next I need Med Form (tab, cap etc), strength (250mg) - . ; concentration for liquids (250mg/mL) - . ; Since IHS does not have any of the new calls that - . ; Vista has, I will be doing a crosswalk: - . ; File 52, field 6 is Drug IEN in file 50 - . ; File 50, field 22 is VA Product IEN in file 50.68 - . ; In file 50.68, I will get the following: - . ; -- 1: Dosage Form - . ; -- 2: Strength - . ; -- 3: Units - . ; -- 8: Dispense Units - . ; -- Conc is 2 concatenated with 3 - . ; - . ; *** If Drug is not matched to NDF, then VA Product will be "" *** - . ; - . N MEDIEN S MEDIEN=$$GET1^DIQ(52,RXIEN,6,"I") ; Drug IEN in 50 - . N VAPROD S VAPROD=$$GET1^DIQ(50,MEDIEN,22,"I") ; VA Product in file 50.68 - . I +VAPROD D - . . S @MAP@("MEDSTRENGTHVALUE")=$$GET1^DIQ(50.68,VAPROD,2) - . . S @MAP@("MEDSTRENGTHUNIT")=$$GET1^DIQ(50.68,VAPROD,3) - . . S @MAP@("MEDFORMTEXT")=$$GET1^DIQ(50.68,VAPROD,1) - . . S @MAP@("MEDCONCVALUE")=@MAP@("MEDSTRENGTHVALUE") - . . S @MAP@("MEDCONCUNIT")=@MAP@("MEDSTRENGTHUNIT") - . E D - . . S @MAP@("MEDSTRENGTHVALUE")="" - . . S @MAP@("MEDSTRENGTHUNIT")="" - . . S @MAP@("MEDFORMTEXT")="" - . . S @MAP@("MEDCONCVALUE")="" - . . S @MAP@("MEDCONCUNIT")="" - . ; End Strengh/Conc stuff - . ; - . ; Quantity is in the prescription, field 7 - . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52,RXIEN,7) - . ; Dispense unit is in the drug file, field 14.5 - . S @MAP@("MEDQUANTITYUNIT")=$$GET1^DIQ(50,MEDIEN,14.5) - . ; - . ; --- START OF DIRECTIONS --- - . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... - . ; we want the components. - . ; It's in multiple 113 in the Prescription File (52) - . ; #.01 DOSAGE ORDERED [1F] "20" - . ; #1 DISPENSE UNITS PER DOSE [2N] "1" - . ; #2 UNITS [3P:50.607] "MG" - . ; #3 NOUN [4F] "TABLET" - . ; #4 DURATION [5F] "10D" - . ; #5 CONJUNCTION [6S] "AND" - . ; #6 ROUTE [7P:51.2] "ORAL" - . ; #7 SCHEDULE [8F] "BID" - . ; #8 VERB [9F] "TAKE" - . ; - . ; Will use GETS^DIQ to get fields. - . ; Data comes out like this: - . ; SAMINS(52.0113,"1,23,",.01)=20 - . ; SAMINS(52.0113,"1,23,",1)=1 - . ; SAMINS(52.0113,"1,23,",2)="MG" - . ; SAMINS(52.0113,"1,23,",3)="TABLET" - . ; SAMINS(52.0113,"1,23,",4)="5D" - . ; SAMINS(52.0113,"1,23,",5)="THEN" - . ; - . N RAWDATA - . D GETS^DIQ(52,RXIEN,"113*",,"RAWDATA","DIERR") - . D:$D(DIERR) ^%ZTER ; Log if there's an error in retrieving sig field - . ; none the less, continue; some parts are retrievable. - . N FMSIG M FMSIG=RAWDATA(52.0113) ; Merge into subfile... - . K RAWDATA - . N FMSIGNUM S FMSIGNUM="" ; Sigline number in fileman. - . ; FMSIGNUM gets outputted as "IEN,RXIEN,". - . ; DIRCNT is the proper Sigline numer. - . ; SIGDATA is the simplfied array. - . F S FMSIGNUM=$O(FMSIG(FMSIGNUM)) Q:FMSIGNUM="" D - . . N DIRCNT S DIRCNT=$P(FMSIGNUM,",") - . . N SIGDATA M SIGDATA=FMSIG(FMSIGNUM) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$G(SIGDATA(8)) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$G(SIGDATA(.01)) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=$G(SIGDATA(2)) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$G(SIGDATA(6)) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$G(SIGDATA(7)) - . . ; Invervals... again another call. - . . ; In the wisdom of the original programmers, the schedule is a free text field - . . ; However, it gets translated by a call to the administration schedule file - . . ; to see if that schedule exists. - . . ; That's the same thing I am going to do. - . . ; Search B index of 51.1 (Admin Schedule) with schedule - . . ; First, remove "PRN" if it exists (don't ask, that's how the file - . . ; works; I wouldn't do it that way). - . . N SCHNOPRN S SCHNOPRN=$G(SIGDATA(7)) - . . I SCHNOPRN["PRN" S SCHNOPRN=$E(SCHNOPRN,1,$F(SCHNOPRN,"PRN")-5) - . . ; Super call below: - . . ; 1=File 51.1 3=Field 2 (Frequency in Minutes) - . . ; 4=Packed format, Exact Match 5=Lookup Value - . . ; 6=# of entries to return 7=Index 10=Return Array - . . ; - . . ; I do not account for the fact that two schedules can be - . . ; spelled identically (ie duplicate entry). In that case, - . . ; I get the first. That's just a bad pharmacy pkg maintainer. - . . N C0C515 - . . D FIND^DIC(51.1,,"@;2","PX",SCHNOPRN,1,"B",,,"C0C515") - . . N INTERVAL S INTERVAL="" ; Default - . . ; If there are entries found, get it - . . I +$G(C0C515("DILIST",0)) S INTERVAL=$P(C0C515("DILIST",1,0),U,2) - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" - . . ; Duration is 10M minutes, 10H hours, 10D for Days - . . ; 10W for weeks, 10L for months. I smell $Select - . . ; But we don't need to do that if there isn't a duration - . . I +$G(SIGDATA(4)) D - . . . N DURUNIT S DURUNIT=$E(SIGDATA(4),$L(SIGDATA(4))) ; get last char - . . . N DURTXT S DURTXT=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"Days") - . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=+SIGDATA(4) - . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=DURTXT - . . E D - . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")="" - . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$G(SIGDATA(4))["PRN" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" ; when avail - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; not stored - . . ; Another confusing line; I am pretty bad: - . . ; If there is another entry in the FMSIG array (i.e. another line - . . ; in the sig), set the direction count indicator. - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")="" ; Default - . . S:+$O(FMSIG(FMSIGNUM)) @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRCNT - . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$G(SIGDATA(5)) - . ; - . ; --- END OF DIRECTIONS --- - . ; - . ; Med instructions is a WP field, thus the acrobatics - . ; Notice buffer overflow protection set at 10,000 chars - . ; -- 1. Med Patient Instructions - . N MEDPTIN1 S MEDPTIN1=$$GET1^DIQ(52,RXIEN,115,,"MEDPTIN1") - . N MEDPTIN2,J S (MEDPTIN2,J)="" - . I $L(MEDPTIN1) F S J=$O(@MEDPTIN1@(J)) Q:J="" Q:$L(MEDPTIN2)>10000 S MEDPTIN2=MEDPTIN2_@MEDPTIN1@(J)_" " - . S @MAP@("MEDPTINSTRUCTIONS")=MEDPTIN2 - . K J - . ; -- 2. Med Provider Instructions - . N MEDPVIN1 S MEDPVIN1=$$GET1^DIQ(52,RXIEN,39,,"MEDPVIN1") - . N MEDPVIN2,J S (MEDPVIN2,J)="" - . I $L(MEDPVIN1) F S J=$O(@MEDPVIN1@(J)) Q:J="" Q:$L(MEDPVIN2)>10000 S MEDPVIN2=MEDPVIN2_@MEDPVIN1@(J)_" " - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MEDPVIN2 - . ; - . ; Remaining refills - . S @MAP@("MEDRFNO")=$P(MEDS(MEDCNT),U,6) - . ; ------ END OF MAPPING - . ; - . ; ------ BEGIN XML INSERTION - . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) - . K @RESULT - . D MAP^C0CXPATH(MINXML,MAP,RESULT) - . ; D PARY^C0CXPATH(RESULT) - . ; MAPPING DIRECTIONS - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT - . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) - . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") - . ; N MDZ1,MDZNA - . N DIRCNT S DIRCNT="" - . I +$O(@MAP@("M","DIRECTIONS",DIRCNT)) D ; IF THERE ARE DIRCTIONS - . . F DIRCNT=$O(@MAP@("M","DIRECTIONS",DIRCNT)) D ; FOR EACH DIRECTION - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",DIRCNT)) - . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) - . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") - . D:MEDCNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy - . D:MEDCNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML - . S MEDCOUNT=MEDCNT - N MEDTMP,MEDI - D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ - . W "MEDICATION MISSING ",! - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! - Q - ; +C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09 + ;;1.0;C0C;;May 19, 2009;Build 1 + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE + ; + ; MINXML and OUTXML are passed by name so globals can be used + ; MINXML will contain only the medications skeleton of the overall template + ; MEDCOUNT is a counter passed by Reference. + ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool) + ; FLAGS are set-up in C0CMED. + ; + ; MEDS is return array from RPC. + ; MAP is a mapping variable map (store result) for each med + ; MED is holds each array element from MEDS(J), one medicine + ; J is a counter. + ; + ; GETRXS^BEHORXFN(ARRAYNAME,DFN,DAYS) will be the the API used. + ; This API has been developed by Medsphere for IHS for getting + ; Medications from RPMS. It has most of what we need. + ; API written by Doug Martin when he worked for Medsphere (thanks Doug!) + ; -- ARRAYNAME is passed by name (required) + ; -- DFN is passed by value (required) + ; -- DAYS is passed by value (optional; if not passed defaults to 365) + ; + ; Return: + ; ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID + ; ^Status^LastFill^Chronic^Issued^Rx #^Provider^ + ; Status Reason^DEA Handling + ; + N MEDS,MEDS1,MAP + D GETRXS^BEHORXFN("MEDS1",DFN,$P($P(FLAGS,U,2),"-",2)) ; 2nd piece of FLAGS is # of days to retrieve, which comes in the form "T-360" + N ALL S ALL=+FLAGS + N ACTIVE S ACTIVE=$P(FLAGS,U,3) + N PENDING S PENDING=$P(FLAGS,U,4) + S @OUTXML@(0)=0 ;By default, no meds + ; If MEDS1 is not defined, then no meds + I '$D(MEDS1) QUIT + I DEBUG ZWR MEDS1,MINXML + N MEDCNT S MEDCNT=0 ; Med Count + ; The next line is a super line. It goes through the array return + ; and if the first characters are ~OP, it grabs the line. + ; This means that line is for a dispensed Outpatient Med. + ; That line has the metadata about the med that I need. + ; The next lines, however many, are the med and the sig. + ; I won't be using those because I have to get the sig parsed exactly. + N J S J="" F S J=$O(MEDS1(J)) Q:J="" I $E(MEDS1(J),1,3)="~OP" S MEDCNT=MEDCNT+1 S MEDS(MEDCNT)=MEDS1(J) + K MEDS1 + S MEDCNT="" ; Initialize for $Order + F S MEDCNT=$O(MEDS(MEDCNT)) Q:MEDCNT="" D ; for each medication in the list + . I 'ALL,ACTIVE,$P(MEDS(MEDCNT),U,10)'="ACTIVE" QUIT + . I 'ALL,PENDING,$P(MEDS(MEDCNT),U,10)'="PENDING" QUIT + . I DEBUG W "MEDCNT IS ",MEDCNT,! + . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCNT)) + . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED + . I DEBUG W "MAP= ",MAP,! + . S @MAP@("MEDOBJECTID")="MED"_MEDCNT ; MEDCNT FOR ID + . S @MAP@("MEDISSUEDATETXT")="Issue Date" + . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,15),"DT") + . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" + . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,11),"DT") + . S @MAP@("MEDRXNOTXT")="Prescription Number" + . S @MAP@("MEDRXNO")=$P(MEDS(MEDCNT),U,14) + . S @MAP@("MEDTYPETEXT")="Medication" + . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses + . S @MAP@("MEDSTATUSTEXT")=$P(MEDS(MEDCNT),U,10) + . ; Provider only provided in API as text, not DUZ. + . ; We need to get DUZ from filman file 52 (Prescription) + . ; Field 4; IEN is Piece 2 of Meds stripped of trailing characters. + . ; Note that I will use RXIEN several times later + . N RXIEN S RXIEN=+$P(MEDS(MEDCNT),U,2) + . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52,RXIEN,4,"I") + . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MEDS(MEDCNT),U,3) + . ; --- RxNorm Stuff + . ; 176.001 is the file for Concepts; 176.003 is the file for + . ; sources (i.e. for RxNorm Version) + . ; + . ; I use 176.001 for the Vista version of this routine (files 1-3) + . ; Since IHS does not have VUID's, I will be getting RxNorm codes + . ; using NDCs. My specially crafted index (sounds evil) named "NDC" + . ; is in file 176.002. The file is called RxNorm NDC to VUID. + . ; Except that I don't need the VUID, but it's there if I need it. + . ; + . ; We obviously need the NDC. That is easily obtained from the prescription. + . ; Field 27 in file 52 + . N NDC S NDC=$$GET1^DIQ(52,RXIEN,27,"I") + . ; I discovered that file 176.002 might give you two codes for the NDC + . ; One for the Clinical Drug, and one for the ingredient. + . ; So the plan is to get the two RxNorm codes, and then find from + . ; file 176.001 which one is the Clinical Drug. + . ; ... I refactored this into GETRXN + . N RXNORM,SRCIEN,RXNNAME,RXNVER + . I +NDC,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. + . . S RXNORM=$$GETRXN(NDC) + . . S SRCIEN=$$FIND1^DIC(176.003,,,"RXNORM","B") + . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) + . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) + . ; + . E S (RXNORM,RXNNAME,RXNVER)="" + . ; End if/else block + . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM + . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME + . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER + . ; --- End RxNorm section + . ; + . ; Brand name is 52 field 6.5 + . S @MAP@("MEDBRANDNAMETEXT")=$$GET1^DIQ(52,RXIEN,6.5) + . ; + . ; Next I need Med Form (tab, cap etc), strength (250mg) + . ; concentration for liquids (250mg/mL) + . ; Since IHS does not have any of the new calls that + . ; Vista has, I will be doing a crosswalk: + . ; File 52, field 6 is Drug IEN in file 50 + . ; File 50, field 22 is VA Product IEN in file 50.68 + . ; In file 50.68, I will get the following: + . ; -- 1: Dosage Form + . ; -- 2: Strength + . ; -- 3: Units + . ; -- 8: Dispense Units + . ; -- Conc is 2 concatenated with 3 + . ; + . ; *** If Drug is not matched to NDF, then VA Product will be "" *** + . ; + . N MEDIEN S MEDIEN=$$GET1^DIQ(52,RXIEN,6,"I") ; Drug IEN in 50 + . N VAPROD S VAPROD=$$GET1^DIQ(50,MEDIEN,22,"I") ; VA Product in file 50.68 + . I +VAPROD D + . . S @MAP@("MEDSTRENGTHVALUE")=$$GET1^DIQ(50.68,VAPROD,2) + . . S @MAP@("MEDSTRENGTHUNIT")=$$GET1^DIQ(50.68,VAPROD,3) + . . S @MAP@("MEDFORMTEXT")=$$GET1^DIQ(50.68,VAPROD,1) + . . S @MAP@("MEDCONCVALUE")=@MAP@("MEDSTRENGTHVALUE") + . . S @MAP@("MEDCONCUNIT")=@MAP@("MEDSTRENGTHUNIT") + . E D + . . S @MAP@("MEDSTRENGTHVALUE")="" + . . S @MAP@("MEDSTRENGTHUNIT")="" + . . S @MAP@("MEDFORMTEXT")="" + . . S @MAP@("MEDCONCVALUE")="" + . . S @MAP@("MEDCONCUNIT")="" + . ; End Strengh/Conc stuff + . ; + . ; Quantity is in the prescription, field 7 + . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52,RXIEN,7) + . ; Dispense unit is in the drug file, field 14.5 + . S @MAP@("MEDQUANTITYUNIT")=$$GET1^DIQ(50,MEDIEN,14.5) + . ; + . ; --- START OF DIRECTIONS --- + . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... + . ; we want the components. + . ; It's in multiple 113 in the Prescription File (52) + . ; #.01 DOSAGE ORDERED [1F] "20" + . ; #1 DISPENSE UNITS PER DOSE [2N] "1" + . ; #2 UNITS [3P:50.607] "MG" + . ; #3 NOUN [4F] "TABLET" + . ; #4 DURATION [5F] "10D" + . ; #5 CONJUNCTION [6S] "AND" + . ; #6 ROUTE [7P:51.2] "ORAL" + . ; #7 SCHEDULE [8F] "BID" + . ; #8 VERB [9F] "TAKE" + . ; + . ; Will use GETS^DIQ to get fields. + . ; Data comes out like this: + . ; SAMINS(52.0113,"1,23,",.01)=20 + . ; SAMINS(52.0113,"1,23,",1)=1 + . ; SAMINS(52.0113,"1,23,",2)="MG" + . ; SAMINS(52.0113,"1,23,",3)="TABLET" + . ; SAMINS(52.0113,"1,23,",4)="5D" + . ; SAMINS(52.0113,"1,23,",5)="THEN" + . ; + . N RAWDATA + . D GETS^DIQ(52,RXIEN,"113*",,"RAWDATA","DIERR") + . D:$D(DIERR) ^%ZTER ; Log if there's an error in retrieving sig field + . ; none the less, continue; some parts are retrievable. + . N FMSIG M FMSIG=RAWDATA(52.0113) ; Merge into subfile... + . K RAWDATA + . N FMSIGNUM S FMSIGNUM="" ; Sigline number in fileman. + . ; FMSIGNUM gets outputted as "IEN,RXIEN,". + . ; DIRCNT is the proper Sigline numer. + . ; SIGDATA is the simplfied array. + . F S FMSIGNUM=$O(FMSIG(FMSIGNUM)) Q:FMSIGNUM="" D + . . N DIRCNT S DIRCNT=$P(FMSIGNUM,",") + . . N SIGDATA M SIGDATA=FMSIG(FMSIGNUM) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$G(SIGDATA(8)) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$G(SIGDATA(.01)) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=$G(SIGDATA(2)) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$G(SIGDATA(6)) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$G(SIGDATA(7)) + . . ; Invervals... again another call. + . . ; In the wisdom of the original programmers, the schedule is a free text field + . . ; However, it gets translated by a call to the administration schedule file + . . ; to see if that schedule exists. + . . ; That's the same thing I am going to do. + . . ; Search B index of 51.1 (Admin Schedule) with schedule + . . ; First, remove "PRN" if it exists (don't ask, that's how the file + . . ; works; I wouldn't do it that way). + . . N SCHNOPRN S SCHNOPRN=$G(SIGDATA(7)) + . . I SCHNOPRN["PRN" S SCHNOPRN=$E(SCHNOPRN,1,$F(SCHNOPRN,"PRN")-5) + . . ; Super call below: + . . ; 1=File 51.1 3=Field 2 (Frequency in Minutes) + . . ; 4=Packed format, Exact Match 5=Lookup Value + . . ; 6=# of entries to return 7=Index 10=Return Array + . . ; + . . ; I do not account for the fact that two schedules can be + . . ; spelled identically (ie duplicate entry). In that case, + . . ; I get the first. That's just a bad pharmacy pkg maintainer. + . . N C0C515 + . . D FIND^DIC(51.1,,"@;2","PX",SCHNOPRN,1,"B",,,"C0C515") + . . N INTERVAL S INTERVAL="" ; Default + . . ; If there are entries found, get it + . . I +$G(C0C515("DILIST",0)) S INTERVAL=$P(C0C515("DILIST",1,0),U,2) + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" + . . ; Duration is 10M minutes, 10H hours, 10D for Days + . . ; 10W for weeks, 10L for months. I smell $Select + . . ; But we don't need to do that if there isn't a duration + . . I +$G(SIGDATA(4)) D + . . . N DURUNIT S DURUNIT=$E(SIGDATA(4),$L(SIGDATA(4))) ; get last char + . . . N DURTXT S DURTXT=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"Days") + . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=+SIGDATA(4) + . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=DURTXT + . . E D + . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")="" + . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$G(SIGDATA(4))["PRN" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" ; when avail + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; not stored + . . ; Another confusing line; I am pretty bad: + . . ; If there is another entry in the FMSIG array (i.e. another line + . . ; in the sig), set the direction count indicator. + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")="" ; Default + . . S:+$O(FMSIG(FMSIGNUM)) @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRCNT + . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$G(SIGDATA(5)) + . ; + . ; --- END OF DIRECTIONS --- + . ; + . ; Med instructions is a WP field, thus the acrobatics + . ; Notice buffer overflow protection set at 10,000 chars + . ; -- 1. Med Patient Instructions + . N MEDPTIN1 S MEDPTIN1=$$GET1^DIQ(52,RXIEN,115,,"MEDPTIN1") + . N MEDPTIN2,J S (MEDPTIN2,J)="" + . I $L(MEDPTIN1) F S J=$O(@MEDPTIN1@(J)) Q:J="" Q:$L(MEDPTIN2)>10000 S MEDPTIN2=MEDPTIN2_@MEDPTIN1@(J)_" " + . S @MAP@("MEDPTINSTRUCTIONS")=MEDPTIN2 + . K J + . ; -- 2. Med Provider Instructions + . N MEDPVIN1 S MEDPVIN1=$$GET1^DIQ(52,RXIEN,39,,"MEDPVIN1") + . N MEDPVIN2,J S (MEDPVIN2,J)="" + . I $L(MEDPVIN1) F S J=$O(@MEDPVIN1@(J)) Q:J="" Q:$L(MEDPVIN2)>10000 S MEDPVIN2=MEDPVIN2_@MEDPVIN1@(J)_" " + . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MEDPVIN2 + . ; + . ; Remaining refills + . S @MAP@("MEDRFNO")=$P(MEDS(MEDCNT),U,6) + . ; ------ END OF MAPPING + . ; + . ; ------ BEGIN XML INSERTION + . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) + . K @RESULT + . D MAP^C0CXPATH(MINXML,MAP,RESULT) + . ; D PARY^C0CXPATH(RESULT) + . ; MAPPING DIRECTIONS + . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) + . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") + . ; N MDZ1,MDZNA + . N DIRCNT S DIRCNT="" + . I +$O(@MAP@("M","DIRECTIONS",DIRCNT)) D ; IF THERE ARE DIRCTIONS + . . F DIRCNT=$O(@MAP@("M","DIRECTIONS",DIRCNT)) D ; FOR EACH DIRECTION + . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",DIRCNT)) + . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) + . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") + . D:MEDCNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy + . D:MEDCNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML + . S MEDCOUNT=MEDCNT + N MEDTMP,MEDI + D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "MEDICATION MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; GETRXN(NDC) ; Extrinsic Function; PUBLIC; NDC to RxNorm - ;; Get RxNorm Concept Number for a Given NDC - ; - S NDC=$TR(NDC,"-") ; Remove dashes - N RXNORM,C0CZRXN,DIERR - D FIND^DIC(176.002,,"@;.01","PX",NDC,"*","NDC",,,"C0CZRXN","DIERR") - I $D(DIERR) D ^%ZTER BREAK - S RXNORM(0)=+C0CZRXN("DILIST",0) ; RxNorm(0) will be # of entries - N I S I=0 - F S I=$O(C0CZRXN("DILIST",I)) Q:I="" S RXNORM(I)=$P(C0CZRXN("DILIST",I,0),U,2) - ; At this point, RxNorm(0) is # of entries; RxNorm(1...) are the entries - ; If RxNorm(0) is 1, then we only have one entry, and that's it. - I RXNORM(0)=1 QUIT RXNORM(1) ; RETURN RXNORM(1) - ; Otherwise, we need to find out which one is the semantic - ; clinical drug. I built an index on 176.001 (RxNorm Concepts) - ; for that purpose. - I RXNORM(0)>1 D - . S I=0 - . F S I=$O(RXNORM(I)) Q:I="" D Q:$G(RXNORM) - . . N RXNIEN S RXNIEN=$$FIND1^DIC(176.001,,,RXNORM(I),"SCD") - . . I +$G(RXNIEN)=0 QUIT ; try the next entry... - . . E S RXNORM=RXNORM(I) QUIT ; We found the right code - QUIT +$G(RXNORM) ; RETURN RXNORM; if we couldn't find a clnical drug, return with 0 - + ;; Get RxNorm Concept Number for a Given NDC + ; + S NDC=$TR(NDC,"-") ; Remove dashes + N RXNORM,C0CZRXN,DIERR + D FIND^DIC(176.002,,"@;.01","PX",NDC,"*","NDC",,,"C0CZRXN","DIERR") + I $D(DIERR) D ^%ZTER BREAK + S RXNORM(0)=+C0CZRXN("DILIST",0) ; RxNorm(0) will be # of entries + N I S I=0 + F S I=$O(C0CZRXN("DILIST",I)) Q:I="" S RXNORM(I)=$P(C0CZRXN("DILIST",I,0),U,2) + ; At this point, RxNorm(0) is # of entries; RxNorm(1...) are the entries + ; If RxNorm(0) is 1, then we only have one entry, and that's it. + I RXNORM(0)=1 QUIT RXNORM(1) ; RETURN RXNORM(1) + ; Otherwise, we need to find out which one is the semantic + ; clinical drug. I built an index on 176.001 (RxNorm Concepts) + ; for that purpose. + I RXNORM(0)>1 D + . S I=0 + . F S I=$O(RXNORM(I)) Q:I="" D Q:$G(RXNORM) + . . N RXNIEN S RXNIEN=$$FIND1^DIC(176.001,,,RXNORM(I),"SCD") + . . I +$G(RXNIEN)=0 QUIT ; try the next entry... + . . E S RXNORM=RXNORM(I) QUIT ; We found the right code + QUIT +$G(RXNORM) ; RETURN RXNORM; if we couldn't find a clnical drug, return with 0 + Index: ccr/branches/ohum/p/C0CMIME.m =================================================================== --- ccr/branches/ohum/p/C0CMIME.m (revision 1332) +++ ccr/branches/ohum/p/C0CMIME.m (revision 1333) @@ -1,339 +1,339 @@ -C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm - ;;1.0;C0C;;Mar 8, 2011; - ;Copyright 2008 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q - ; -TEST(ZDFN) ; - D CCRRPC^C0CCCR(.ZCCR,ZDFN) ; GET A CCR TO WORK WITH - ;M ZCOPY=ZCCR - S ZCOPY(1)="" - N ZI S ZI=0 - F S ZI=$O(ZCCR(ZI)) Q:ZI="" D ; FOR EACH LINE - . S ZCOPY(1)=ZCOPY(1)_ZCCR(ZI) - ;D ENCODE("ZCOPY",1,ZCOPY(1)) - S G(1)=$$ENCODE^RGUTUU(ZCOPY(1)) - D CHUNK("G2","G",45) - Q -ENCODE(ZRTN,ZARY) ; - ; ROUTINE TO ENCODE AN XML DOCUMENT FOR SENDING - ; ZARY IS PASSED BY NAME - ; ZRTN IS PASSED BY REFERENCE AND IS THE RETURN - ; - S ZCOPY(1)="" - N ZI S ZI=0 - F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH LINE - . S ZCOPY(1)=ZCOPY(1)_@ZARY@(ZI) - N G - S G(1)=$$ENCODE^RGUTUU(ZCOPY(1)) - D CHUNK(ZRTN,"G",45) - Q - ; THIS ROUTINE WAS COPIED FROM LRSRVR4 AND THEN MODIFIED . THANKS JOHN -ENCODEOLD(IARY,LRNODE,LRSTR) ; Encode a string, keep remainder for next line - ; Call with LRSTR by reference, Remainder returned in LRSTR - ; IARY IS PASSED BY NAME - S LRQUIT=0,LRLEN=$L(LRSTR) - F D Q:LRQUIT - . I $L(LRSTR)<45 S LRQUIT=1 Q - . S LRX=$E(LRSTR,1,45) - . S LRNODE=LRNODE+1,@IARY@(LRNODE)=$$UUEN^LRSRVR4(LRX) - . S LRSTR=$E(LRSTR,46,LRLEN) - Q - ; -TESTMAIL ; - ; TEST OF MAILSEND - ;S ZTO("glilly@glilly.net")="" - S ZTO("mish@nhin.openforum.opensourcevista.net")="" - ;S ZTO("martijn@djigzo.com")="" - ;S ZTO("profmish@gmail.com")="" - ;S ZTO("nanthracite@earthlink.net")="" - S ZFROM="ANTHRACITE.NANCY" - S ZATTACH=$NA(^GPL("CCR")) - I $G(@ZATTACH@(1))="" D ; NO CCR THERE - . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2 - . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME - S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE" - D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,,ZATTACH) - ZWR GR - Q - ; -TESTMAIL2 ; - ; TEST OF MAILSEND TO gpl.mdc-crew.net - N C0CGM - S C0CGM(1)="This is a test message." - S C0CGM(2)="A Continuity of Care record is attached" - S C0CGM(3)="It contains no Protected Health Information (PHI)" - S C0CGM(4)="It is purely test data used for software development" - S C0CGM(5)="It does not represent information about any person living or dead" - ;S ZTO("glilly@glilly.net")="" - ;S ZTO("george.lilly@pobox.com")="" - ;S ZTO("george@nhin.openforum.opensourcevista.net")="" - ;S ZTO("mish@nhin.openforum.opensourcevista.net")="" - S ZTO("brooks.richard@securemail.opensourcevista.net")="" - ;S ZTO("LILLY.GEORGE@mdc-crew.net")="" - ;S ZTO("ncoal@live.com")="" - ;S ZTO("martijn@djigzo.com")="" - ;S ZTO("profmish@gmail.com")="" - ;S ZTO("nanthracite@earthlink.net")="" - S ZTO("gpl.doctortest@gmail.com")="" - S ZFROM="LILLY.GEORGE" - S ZATTACH=$NA(^GPL("CCR")) - I $G(@ZATTACH@(1))="" D ; NO CCR THERE - . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2 - . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME - S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE" - D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH,"CCR.xml") - ZWR GR - Q - ; -LINE(C0CFILE,C0CTO) ; read a file name passed in C0CFILE and send it to - ; the email address in C0CTO - ; the directory and the "from" are all hard coded - ; - N ZZFROM S ZZFROM="LILLY.GEORGE" - N GN S GN=$NA(^TMP("C0CMIME2",$J)) - N GN1 S GN1=$NA(@GN@(1)) - K @GN - I '$D(C0CFILE) Q ; NO FILENAME PASSED - I '$D(C0CTO) S C0CTO="brooks.richard@securemail.opensourcevista.net" - S ZZTO(C0CTO)="" - N ZMESS S ZMESS(1)="file transmission from wvehr3-09" - N GD S GD="/home/wvehr3-09/EHR/" ; directory - I '$$FTG^%ZISH(GD,C0CFILE,GN1,3) Q D ; - . W !,"error reading file",C0CFILE - D MAILSEND(.ZRTN,ZZFROM,"ZZTO",,"file transmission","ZMESS",GN,C0CFILE) - K @GN ; CLEAN UP - ;ZWR ZRTN - W !,$G(ZRTN(1)) - Q - ; -MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FNAME,FLAGS) ; MAIL SENDING INTERFACE - ; RTN IS THE RETURN ARRAY PASSED BY REFERENCE - ; FROM IS PASSED BY VALUE AND IS THE EMAIL ADDRESS OF THE SENDER - ; IF NULL, WILL SEND FROM THE CURRENT DUZ - ; TO AND CC ARE RECIEPIENT EMAIL ADDRESSES PASSED BY NAME - ; @TO@("addr1@domain1.net") - ; @CC@("addr2@domain2.com") both can be multiples - ; SUBJECT IS PASSED BY VALUE AND WILL GO IN THE SUBJECT LINE - ; MESSAGE IS PASSED BY NAME AND IS AN ARRAY OF TEXT - ; ATTACH IS PASSED BY NAME AND IS AN XML OR HTML FILE TO BE ATTACHED - ; FNAME IS THE FILENAME OF THE ATTACHMENT, DEFAULT IS ccr.xml - ; - I '$D(FNAME) S FNAME="ccr.xml" ; default filename - N GN - S GN=$NA(^TMP($J,"C0CMIME")) - K @GN - S GM(1)="MIME-Version: 1.0" - S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" - S GM(3)="" - S GM(4)="" - ;S GM(5)="--123456788888" - ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) - S GM(5)="--123456899999" - S GM(6)="Content-Type: text/xml; name="_FNAME - S GM(7)="Content-Transfer-Encoding: base64" - S GM(8)="Content-Disposition: attachment; filename="_FNAME - S GM(9)="" - S GM(10)="" ; FOR THE END - ;S GM(11)="--123456788888--" - S GM(11)="--123456899999--" - S GM(12)="" - S GM(13)="" - S GG(1)="--123456899999" - S GG(2)="Content-Type: text/plain; charset=ISO-8859-1; format=flowed" - S GG(3)="Content-Transfer-Encoding: 7bit" - S GG(4)="" - S GG(5)="This is a test message." - S GG(6)="A Continuity of Care record is attached" - S GG(7)="It contains no Protected Health Information (PHI)" - S GG(8)="It is purely test data used for software development" - S GG(9)="It does not represent information about any person living or dead" - S GG(10)="" - S GG(11)="--123456899999--" - ;S GG(11)="Content-Type: text/plain; charset=""us-ascii""" - S GG(12)="" - ;S GG(13)="This is a test message." - S GG(14)="A Continuity of Care record is attached" - S GG(15)="It contains no Protected Health Information (PHI)" - S GG(16)="It is purely test data used for software development" - S GG(17)="It does not represent information about any person living or dead" - S GG(18)="" - S GG(19)="--123456899999" - S GG(20)="--987654321--" - K GBLD - ;D QUEUE^C0CXPATH("GBLD","GGG",1,3) ; THE MESSAGE - ;D QUEUE^C0CXPATH("GBLD","GG",1,10) ; THE MESSAGE - I $D(MESSAGE)'="" D ; THERE IS A MESSAGE - . D QUEUE^C0CXPATH("GBLD","GG",1,4) ; THE MIME BOUNDARY - . D QUEUE^C0CXPATH("GBLD",MESSAGE,1,$O(@MESSAGE@(""),-1)) ;THE MESSAGE - . D QUEUE^C0CXPATH("GBLD","GG",10,10) ;A BLANK LINE - D QUEUE^C0CXPATH("GBLD","GM",5,9) - I $D(ATTACH)'="" D ; IF WE HAVE AN ATTACHMENT - . D ENCODE("G2",ATTACH) ; ENCODE FOR SENDING - . D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1)) - D QUEUE^C0CXPATH("GBLD","GM",11,12) - D BUILD^C0CXPATH("GBLD",GN) - ;S GGG=$NA(^GPL("MIME2")) - K @GN@(0) ; KILL THE LINE COUNT - K LRINSTR,LRTASK,LRTO,XMERR,XMZ - M LRTO=@TO - I $D(CC) M LRTO=@CC - S LRINSTR("ADDR FLAGS")="R" - S LRINSTR("FROM")=$G(FROM) - S LRMSUBJ=$G(SUBJECT) - S LRMSUBJ=$E(LRMSUBJ,1,65) - D SENDMSG^XMXAPI(DUZ,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK) - I $G(XMERR)=1 S RTN(1)="ERROR SENDING MESSAGE" Q ; - S RTN(1)="OK" - Q - ; -MAILSEND0(LRMSUBJ) ; Send extract back to requestor. - ; - ;D TEST - S GN=$NA(^TMP($J,"C0CMIME")) - K @GN - ;M @GN=G2 - S GM(1)="MIME-Version: 1.0" - S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" - S GM(3)="" - S GM(4)="" - S GM(5)="--1234567" - ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) - S GM(6)="Content-Type: text/xml; name=""ccr.xml""" - S GM(7)="Content-Transfer-Encoding: base64" - S GM(8)="Content-Disposition: attachment; filename=""ccr.xml""" - ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml") - S GM(9)="" - S GM(10)="" ; FOR THE END - S GM(11)="--frontier--" - S GM(12)="." - S GM(13)="" - K GBLD - ;D QUEUE^C0CXPATH("GBLD","GM",1,9) - ;D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1)) - ;D QUEUE^C0CXPATH("GBLD","GM",10,13) - ;D BUILD^C0CXPATH("GBLD",GN) - S GGG=$NA(^GPL("MIME2")) - ;D QUEUE^C0CXPATH("GBLD","GM",1,1) - D QUEUE^C0CXPATH("GBLD",GGG,21,159) - D BUILD^C0CXPATH("GBLD",GN) - K @GN@(0) ; KILL THE LINE COUNT - K LRINSTR,LRTASK,LRTO,XMERR,XMZ - S XQSND="glilly@glilly.net" - ;S XQSND="nanthracite@earthlink.net" - ;S XQSND="dlefevre@orohosp.com" - ;S XQSND="gregwoodhouse@me.com" - ;S XQSND="rick.marshall@vistaexpertise.net" - S LRTO(XQSND)="" - S LRINSTR("ADDR FLAGS")="R" - S LRINSTR("FROM")="CCR_PACKAGE" - S LRMSUBJ="A SAMPLE CCR" - S LRMSUBJ=$E(LRMSUBJ,1,65) - D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK) - I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q ; - ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0" - ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9" - Q - ; -MAILSEND2(UDFN,ADDR) ; Send extract back to requestor. - ; - I +$G(UDFN)=0 S UDFN=2 ; - D TEST(UDFN) - S GN=$NA(^TMP($J,"C0CMIME")) - K @GN - ;M @GN=G2 - S GM(1)="MIME-Version: 1.0" - S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" - S GM(3)="" - S GM(4)="" - S GM(5)="--1234567" - ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) - S GM(6)="Content-Type: text/xml; name=""ccr.xml""" - S GM(7)="Content-Transfer-Encoding: base64" - S GM(8)="Content-Disposition: attachment; filename=""ccr.xml""" - ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml") - S GM(9)="" - S GM(10)="" ; FOR THE END - S GM(11)="--1234567--" - S GM(12)="" - S GM(13)="" - K GBLD - D QUEUE^C0CXPATH("GBLD","GM",5,9) - D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1)) - D QUEUE^C0CXPATH("GBLD","GM",10,12) - D BUILD^C0CXPATH("GBLD",GN) - S GGG=$NA(^GPL("MIME2")) - ;D QUEUE^C0CXPATH("GBLD","GM",1,1) - ;D QUEUE^C0CXPATH("GBLD",GGG,21,159) - ;D BUILD^C0CXPATH("GBLD",GN) - K @GN@(0) ; KILL THE LINE COUNT - K LRINSTR,LRTASK,LRTO,XMERR,XMZ - I $G(ADDR)'="" S XQSND=ADDR - E S XQSND="glilly@glilly.net" - ;S XQSND="nanthracite@earthlink.net" - ;S XQSND="dlefevre@orohosp.com" - ;S XQSND="gregwoodhouse@me.com" - ;S XQSND="rick.marshall@vistaexpertise.net" - S LRTO(XQSND)="" - ;S LRTO("glilly@glilly.net")="" - S LRINSTR("ADDR FLAGS")="R" - S LRINSTR("FROM")="ANTHRACITE.NANCY" - S LRMSUBJ="Sending a CCR with Mailman" - S LRMSUBJ=$E(LRMSUBJ,1,65) - D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK) - I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q ; - ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0" - ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9" - Q - ; -SIMPLE ; - S GN(1)="SIMPLE TEST MESSAGE" - K LRINSTR,LRTASK,LRTO,XMERR,XMZ - S XQSND="glilly@glilly.net" - S LRTO(XQSND)="" - S LRINSTR("ADDR FLAGS")="R" - S LRINSTR("FROM")="CCR_PACKAGE" - S LRMSUBJ="A SAMPLE CCR" - S LRMSUBJ=$E(LRMSUBJ,1,65) - D SENDMSG^XMXAPI(9,LRMSUBJ,"GN",.LRTO,.LRINSTR,.LRTASK) - Q -CHUNK(OUTXML,INXML,ZSIZE) ; BREAKS INXML INTO ZSIZE BLOCKS - ; INXML IS AN ARRAY PASSED BY NAME OF STRINGS - ; OUTXML IS ALSO PASSED BY NAME - ; IF ZSIZE IS NOT PASSED, 1000 IS USED - I '$D(ZSIZE) S ZSIZE=1000 ; DEFAULT BLOCK SIZE - N ZB,ZI,ZJ,ZK,ZL,ZN - S ZB=ZSIZE-1 - S ZN=1 - S ZI=0 ; BEGINNING OF INDEX TO INXML - F S ZI=$O(@INXML@(ZI)) Q:+ZI=0 D ; FOR EACH STRING IN INXML - . S ZL=$L(@INXML@(ZI)) ; LENGTH OF THE STRING - . F ZJ=1:ZSIZE:ZL D ; - . . S ZK=$S(ZJ+ZB") D OUTPUT("<"_DOC_">") - Q - ; -END ;Call this once to close out the document - D OUTPUT("") - I '$G(^TMP("MXMLBLD",$J,"CNT")) K ^TMP("MXMLBLD",$J) - K ^TMP("MXMLBLD",$J,"DOC"),^("CNT"),^("STK") - Q - ; -ITEM(INDENT,TAG,ATT,VALUE) ;Output a Item - N I,X - S ATT=$G(ATT) - I '$D(VALUE) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_" />") Q - D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">"_$$CHARCHK(VALUE)_"") - Q - ;DOITEM is a callback to output the lower level. -MULTI(INDENT,TAG,ATT,DOITEM) ;Output a Multipule - N I,X,S - S ATT=$G(ATT) - D PUSH($G(INDENT),TAG,.ATT) - D @DOITEM - D POP - Q - ; -ATT(ATT) ;Output a string of attributes - I $D(ATT)<9 Q "" - N I,S,V - S S="",I="" - F S I=$O(ATT(I)) Q:I="" S S=S_" "_I_"="_$$Q(ATT(I)) - Q S - ; -Q(X) ;Add Quotes - Changed by gpl to use single instead of double quotes 6/11 - ;I X'[$C(34) Q $C(34)_X_$C(34) - I X'[$C(39) Q $C(39)_X_$C(39) - ;N Q,Y,I,Z S Q=$C(34),(Y,Z)="" - N Q,Y,I,Z S Q=$C(39),(Y,Z)="" - F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q - S Y=Y_$P(X,Q,$L(X,Q)) - ;Q $C(34)_Y_$C(34) - Q $C(39)_Y_$C(39) - ; -XMLHDR() ; -- provides current XML standard header - Q "" - ; -OUTPUT(S) ;Output - N C S C=$G(^TMP("MXMLBLD",$J,"CNT")) - I C S ^TMP("MXMLBLD",$J,C)=S,^TMP("MXMLBLD",$J,"CNT")=C+1 Q - W S,! - Q - ; -CHARCHK(STR) ; -- replace xml character limits with entities - N A,I,X,Y,Z,NEWSTR - S (Y,Z)="" - ;IF STR["&" SET NEWSTR=STR DO SET STR=Y_Z - ;. FOR X=1:1 SET Y=Y_$PIECE(NEWSTR,"&",X)_"&",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&" - I STR["&" F I=1:1:$L(STR,"&")-1 S STR=$P(STR,"&",1,I)_"&"_$P(STR,"&",I+1,999) - I STR["<" F S STR=$PIECE(STR,"<",1)_"<"_$PIECE(STR,"<",2,99) Q:STR'["<" - I STR[">" F S STR=$PIECE(STR,">",1)_">"_$PIECE(STR,">",2,99) Q:STR'[">" - I STR["'" F S STR=$PIECE(STR,"'",1)_"'"_$PIECE(STR,"'",2,99) Q:STR'["'" - I STR["""" F S STR=$PIECE(STR,"""",1)_"""_$PIECE(STR,"""",2,99) Q:STR'["""" - ; - S STR=$TR(STR,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31)) - QUIT STR - ; -COMMENT(VAL) ;Add Comments - N I,L - ;I $D($G(VAL))=1 D OUTPUT("") Q - I $D(VAL) D OUTPUT("") Q ;CHANGED BY GPL FOR GTM - S I="",L="") - Q - ; -PUSH(INDENT,TAG,ATT) ;Write a TAG and save. - N CNT - S ATT=$G(ATT) - D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">") - S CNT=$G(^TMP("MXMLBLD",$J,"STK"))+1,^TMP("MXMLBLD",$J,"STK")=CNT,^TMP("MXMLBLD",$J,"STK",CNT)=INDENT_"^"_TAG - Q - ; -POP ;Write last pushed tag and pop - N CNT,TAG,INDENT,X - S CNT=$G(^TMP("MXMLBLD",$J,"STK")),X=^TMP("MXMLBLD",$J,"STK",CNT),^TMP("MXMLBLD",$J,"STK")=CNT-1 - S INDENT=+X,TAG=$P(X,"^",2) - D OUTPUT($$BLS(INDENT)_"") - Q - ; -BLS(I) ;Return INDENT string - N S - S S="",I=$G(I) S:I>0 $P(S," ",I)=" " - Q S - ; -INDENT() ;Renturn indent level - Q +$G(^TMP("MXMLBLD",$J,"STK")) +MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09 16:55 + ;;8.0;KERNEL;;;Build 1 + QUIT + ; + ;DOC - The top level tag + ;DOCTYPE - Want to include a DOCTYPE node + ;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J, +START(DOC,DOCTYPE,FLAG,NO1ST) ;Call this once at the begining. + K ^TMP("MXMLBLD",$J) + S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0 + I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1 + I $G(NO1ST)'=1 D OUTPUT($$XMLHDR) + D:$L($G(DOCTYPE)) OUTPUT("") D OUTPUT("<"_DOC_">") + Q + ; +END ;Call this once to close out the document + D OUTPUT("") + I '$G(^TMP("MXMLBLD",$J,"CNT")) K ^TMP("MXMLBLD",$J) + K ^TMP("MXMLBLD",$J,"DOC"),^("CNT"),^("STK") + Q + ; +ITEM(INDENT,TAG,ATT,VALUE) ;Output a Item + N I,X + S ATT=$G(ATT) + I '$D(VALUE) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_" />") Q + D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">"_$$CHARCHK(VALUE)_"") + Q + ;DOITEM is a callback to output the lower level. +MULTI(INDENT,TAG,ATT,DOITEM) ;Output a Multipule + N I,X,S + S ATT=$G(ATT) + D PUSH($G(INDENT),TAG,.ATT) + D @DOITEM + D POP + Q + ; +ATT(ATT) ;Output a string of attributes + I $D(ATT)<9 Q "" + N I,S,V + S S="",I="" + F S I=$O(ATT(I)) Q:I="" S S=S_" "_I_"="_$$Q(ATT(I)) + Q S + ; +Q(X) ;Add Quotes - Changed by gpl to use single instead of double quotes 6/11 + ;I X'[$C(34) Q $C(34)_X_$C(34) + I X'[$C(39) Q $C(39)_X_$C(39) + ;N Q,Y,I,Z S Q=$C(34),(Y,Z)="" + N Q,Y,I,Z S Q=$C(39),(Y,Z)="" + F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q + S Y=Y_$P(X,Q,$L(X,Q)) + ;Q $C(34)_Y_$C(34) + Q $C(39)_Y_$C(39) + ; +XMLHDR() ; -- provides current XML standard header + Q "" + ; +OUTPUT(S) ;Output + N C S C=$G(^TMP("MXMLBLD",$J,"CNT")) + I C S ^TMP("MXMLBLD",$J,C)=S,^TMP("MXMLBLD",$J,"CNT")=C+1 Q + W S,! + Q + ; +CHARCHK(STR) ; -- replace xml character limits with entities + N A,I,X,Y,Z,NEWSTR + S (Y,Z)="" + ;IF STR["&" SET NEWSTR=STR DO SET STR=Y_Z + ;. FOR X=1:1 SET Y=Y_$PIECE(NEWSTR,"&",X)_"&",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&" + I STR["&" F I=1:1:$L(STR,"&")-1 S STR=$P(STR,"&",1,I)_"&"_$P(STR,"&",I+1,999) + I STR["<" F S STR=$PIECE(STR,"<",1)_"<"_$PIECE(STR,"<",2,99) Q:STR'["<" + I STR[">" F S STR=$PIECE(STR,">",1)_">"_$PIECE(STR,">",2,99) Q:STR'[">" + I STR["'" F S STR=$PIECE(STR,"'",1)_"'"_$PIECE(STR,"'",2,99) Q:STR'["'" + I STR["""" F S STR=$PIECE(STR,"""",1)_"""_$PIECE(STR,"""",2,99) Q:STR'["""" + ; + S STR=$TR(STR,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31)) + QUIT STR + ; +COMMENT(VAL) ;Add Comments + N I,L + ;I $D($G(VAL))=1 D OUTPUT("") Q + I $D(VAL) D OUTPUT("") Q ;CHANGED BY GPL FOR GTM + S I="",L="") + Q + ; +PUSH(INDENT,TAG,ATT) ;Write a TAG and save. + N CNT + S ATT=$G(ATT) + D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">") + S CNT=$G(^TMP("MXMLBLD",$J,"STK"))+1,^TMP("MXMLBLD",$J,"STK")=CNT,^TMP("MXMLBLD",$J,"STK",CNT)=INDENT_"^"_TAG + Q + ; +POP ;Write last pushed tag and pop + N CNT,TAG,INDENT,X + S CNT=$G(^TMP("MXMLBLD",$J,"STK")),X=^TMP("MXMLBLD",$J,"STK",CNT),^TMP("MXMLBLD",$J,"STK")=CNT-1 + S INDENT=+X,TAG=$P(X,"^",2) + D OUTPUT($$BLS(INDENT)_"") + Q + ; +BLS(I) ;Return INDENT string + N S + S S="",I=$G(I) S:I>0 $P(S," ",I)=" " + Q S + ; +INDENT() ;Renturn indent level + Q +$G(^TMP("MXMLBLD",$J,"STK")) Index: ccr/branches/ohum/p/C0CMXP.m =================================================================== --- ccr/branches/ohum/p/C0CMXP.m (revision 1332) +++ ccr/branches/ohum/p/C0CMXP.m (revision 1333) @@ -1,4 +1,4 @@ C0CMXP ; GPL - MXML based XPath utilities;12/04/09 17:05 - ;;0.1;C0C;nopatch;noreleasedate;Build 38 + ;;0.1;C0C;nopatch;noreleasedate;Build 1 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU ;General Public License See attached copy of the License. Index: ccr/branches/ohum/p/C0CNHIN.m =================================================================== --- ccr/branches/ohum/p/C0CNHIN.m (revision 1332) +++ ccr/branches/ohum/p/C0CNHIN.m (revision 1333) @@ -1,323 +1,323 @@ C0CNHIN ; GPL - PROCESSING FOR OUTPUT OF NHINV ROUTINES;6/3/11 17:05 - ;;0.1;C0C;nopatch;noreleasedate;Build 38 - ;Copyright 2011 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q -EN(ZRTN,ZDFN,ZPART,KEEP) ; GENERATE AN NHIN ARRAY FOR A PATIENT - ; - K GARY,GNARY,GIDX,C0CDOCID - N GN - K ^TMP("NHINV",$J) ; CLEAN UP FROM LAST CALL - K ^TMP("MXMLDOM",$J) ; CLEAN UP DOM - K ^TMP("MXMLERR",$J) ; CLEAN UP MXML ERRORS - D GET^NHINV(.GN,ZDFN,ZPART) ; CALL NHINV ROUTINES TO PULL XML - S GN=$P(GN,")",1)_")" ; CUT OFF THE REST OF LINE PROTOCOL - S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML - D DOMO^C0CDOM(C0CDOCID,"/","ZRTN","GIDX","GARY",,"/results/") ; BLD ARRAYS - I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 - ;D PROCESS("ZRTN",GN,"/result/",$G(KEEP)) - Q - ; -PQRI(ZOUT,KEEP) ; RETURN THE NHIN ARRAY FOR THE PQRI XML TEMPLATE - ; - N ZG - S ZG=$NA(^TMP("PQRIXML",$J)) - K @ZG - D GETXML^C0CMXP(ZG,"PQRIXML") ; GET THE XML FROM C0C MISC XML - N C0CDOCID - S C0CDOCID=$$PARSE^C0CDOM(ZG,"PQRIXML") ; PARSE THE XML - D DOMO^C0CDOM(C0CDOCID,"/","ZOUT","GIDX","GARY",,"//submission") ; BLD ARRAYS - I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 - Q - ; -PQRI2(ZRTN) ; RETURN THE NHIN ARRAY FOR PQRI ONE MEASURE - ; - ;N GG - D GETXML^C0CMXP("GG","PQRI ONE MEASURE") - D PROCESS(ZRTN,"GG","root",1) - Q - ; -PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP) ; PARSE AND RUN DOMO ON XML - ; ZRTN IS PASSED BY REFERENCE - ; ZXML IS PASSED BY NAME - ; IF KEEP IS 1, GARY AND GIDX ARE NOT KILLED - ; - N GN - S GN=$NA(^TMP("C0CPROCESS",$J)) - K @GN - M @GN=@ZXML - S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML - K @GN - D DOMO^C0CDOM(C0CDOCID,"/","ZRSLT","GIDX","GARY",,$G(ZREDUCE)) ; BLD ARRAYS - I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 - Q - ; -LOADSMRT ; - ; - K ^GPL("SMART") - S GN=$NA(^GPL("SMART",1)) - I $$FTG^%ZISH("/home/george/","alex-lewis2.xml",GN,2) W !,"SMART FILE LOADED" - Q - ; -SMART ; TRY IT WITH SMART - ; - S GN=$NA(^GPL("SMART")) - ;K ^TMP("MXMLDOM",$J) - K ^TMP("MXMLERR",$J) - S C0CDOCID=$$PARSE(GN,"SMART") - D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//rdf:RDF/") - ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG - Q - ; -CCR ; TRY IT WITH A CCR - ; - S GN=$NA(^GPL("CCR")) - ;K ^TMP("MXMLDOM",$J) - K ^TMP("MXMLERR",$J) - S C0CDOCID=$$PARSE(GN,"CCR") - D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ContinuityOfCareRecord/Body/") - ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG - Q - ; -MED ; TRY IT WITH A CCR MED SECTION - ; - S GN=$NA(^GPL("MED")) - K ^TMP("MXMLDOM",$J) - K ^TMP("MXMLERR",$J) - S C0CDOCID=$$PARSE(GN,"MED") - D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//Medications/") - ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG - Q - ; -CCD ; TRY IT WITH A CCD - ; - S GN=$NA(^GPL("CCD")) - ;K ^TMP("MXMLDOM",$J) - K ^TMP("MXMLERR",$J) - S C0CDOCID=$$PARSE(GN,"CCD") - D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ClinicalDocument/component/structuredBody/") - ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG - Q - ; -TEST1 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") - ; PARSED WITH MXML - ; RUN THROUGH XPATH - K GARY,GIDX,C0CDOCID - S GN=$NA(^GPL("NHIN")) - ;S GN=$NA(^GPL("DOMI")) - S C0CDOCID=$$PARSE(GN,"GPLTEST") - D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/") - K ^GPL("GNARY") - M ^GPL("GNARY")=GNARY - Q - ; -TEST2 ; PUT GNARY THROUGH DOMI AND STORE XML IN ^GPL("DOMI") - ; - S GN=$NA(^GPL("GNARY")) - S C0CDOCID=$$DOMI^C0CDOM(GN,,"results") - D OUTXML^C0CDOM("G",C0CDOCID) - K ^GPL("DOMI") - M ^GPL("DOMI")=G - Q - ; -TEST3 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") - ; PARSED WITH MXML - ; RUN THROUGH XPATH - K GARY,GIDX,C0CDOCID - ;S GN=$NA(^GPL("NHIN")) - S GN=$NA(^GPL("DOMI")) - S C0CDOCID=$$PARSE(GN,"GPLTEST") - D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/") - Q - ; + ;;0.1;C0C;nopatch;noreleasedate;Build 1 + ;Copyright 2011 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q +EN(ZRTN,ZDFN,ZPART,KEEP) ; GENERATE AN NHIN ARRAY FOR A PATIENT + ; + K GARY,GNARY,GIDX,C0CDOCID + N GN + K ^TMP("NHINV",$J) ; CLEAN UP FROM LAST CALL + K ^TMP("MXMLDOM",$J) ; CLEAN UP DOM + K ^TMP("MXMLERR",$J) ; CLEAN UP MXML ERRORS + D GET^NHINV(.GN,ZDFN,ZPART) ; CALL NHINV ROUTINES TO PULL XML + S GN=$P(GN,")",1)_")" ; CUT OFF THE REST OF LINE PROTOCOL + S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML + D DOMO^C0CDOM(C0CDOCID,"/","ZRTN","GIDX","GARY",,"/results/") ; BLD ARRAYS + I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 + ;D PROCESS("ZRTN",GN,"/result/",$G(KEEP)) + Q + ; +PQRI(ZOUT,KEEP) ; RETURN THE NHIN ARRAY FOR THE PQRI XML TEMPLATE + ; + N ZG + S ZG=$NA(^TMP("PQRIXML",$J)) + K @ZG + D GETXML^C0CMXP(ZG,"PQRIXML") ; GET THE XML FROM C0C MISC XML + N C0CDOCID + S C0CDOCID=$$PARSE^C0CDOM(ZG,"PQRIXML") ; PARSE THE XML + D DOMO^C0CDOM(C0CDOCID,"/","ZOUT","GIDX","GARY",,"//submission") ; BLD ARRAYS + I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 + Q + ; +PQRI2(ZRTN) ; RETURN THE NHIN ARRAY FOR PQRI ONE MEASURE + ; + ;N GG + D GETXML^C0CMXP("GG","PQRI ONE MEASURE") + D PROCESS(ZRTN,"GG","root",1) + Q + ; +PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP) ; PARSE AND RUN DOMO ON XML + ; ZRTN IS PASSED BY REFERENCE + ; ZXML IS PASSED BY NAME + ; IF KEEP IS 1, GARY AND GIDX ARE NOT KILLED + ; + N GN + S GN=$NA(^TMP("C0CPROCESS",$J)) + K @GN + M @GN=@ZXML + S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML + K @GN + D DOMO^C0CDOM(C0CDOCID,"/","ZRSLT","GIDX","GARY",,$G(ZREDUCE)) ; BLD ARRAYS + I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 + Q + ; +LOADSMRT ; + ; + K ^GPL("SMART") + S GN=$NA(^GPL("SMART",1)) + I $$FTG^%ZISH("/home/george/","alex-lewis2.xml",GN,2) W !,"SMART FILE LOADED" + Q + ; +SMART ; TRY IT WITH SMART + ; + S GN=$NA(^GPL("SMART")) + ;K ^TMP("MXMLDOM",$J) + K ^TMP("MXMLERR",$J) + S C0CDOCID=$$PARSE(GN,"SMART") + D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//rdf:RDF/") + ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG + Q + ; +CCR ; TRY IT WITH A CCR + ; + S GN=$NA(^GPL("CCR")) + ;K ^TMP("MXMLDOM",$J) + K ^TMP("MXMLERR",$J) + S C0CDOCID=$$PARSE(GN,"CCR") + D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ContinuityOfCareRecord/Body/") + ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG + Q + ; +MED ; TRY IT WITH A CCR MED SECTION + ; + S GN=$NA(^GPL("MED")) + K ^TMP("MXMLDOM",$J) + K ^TMP("MXMLERR",$J) + S C0CDOCID=$$PARSE(GN,"MED") + D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//Medications/") + ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG + Q + ; +CCD ; TRY IT WITH A CCD + ; + S GN=$NA(^GPL("CCD")) + ;K ^TMP("MXMLDOM",$J) + K ^TMP("MXMLERR",$J) + S C0CDOCID=$$PARSE(GN,"CCD") + D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ClinicalDocument/component/structuredBody/") + ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG + Q + ; +TEST1 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") + ; PARSED WITH MXML + ; RUN THROUGH XPATH + K GARY,GIDX,C0CDOCID + S GN=$NA(^GPL("NHIN")) + ;S GN=$NA(^GPL("DOMI")) + S C0CDOCID=$$PARSE(GN,"GPLTEST") + D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/") + K ^GPL("GNARY") + M ^GPL("GNARY")=GNARY + Q + ; +TEST2 ; PUT GNARY THROUGH DOMI AND STORE XML IN ^GPL("DOMI") + ; + S GN=$NA(^GPL("GNARY")) + S C0CDOCID=$$DOMI^C0CDOM(GN,,"results") + D OUTXML^C0CDOM("G",C0CDOCID) + K ^GPL("DOMI") + M ^GPL("DOMI")=G + Q + ; +TEST3 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") + ; PARSED WITH MXML + ; RUN THROUGH XPATH + K GARY,GIDX,C0CDOCID + ;S GN=$NA(^GPL("NHIN")) + S GN=$NA(^GPL("DOMI")) + S C0CDOCID=$$PARSE(GN,"GPLTEST") + D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/") + Q + ; DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE - ; THE XPATH INDEX ZXIDX, PASSED BY NAME - ; THE XPATH ARRAY XPARY, PASSED BY NAME - ; ZOID IS THE STARTING OID - ; ZPATH IS THE STARTING XPATH, USUALLY "/" - ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE - ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT - I $G(ZREDUX)="" S ZREDUX="" - N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY - N NEWNUM S NEWNUM="" - I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" - S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE - I $G(ZREDUX)'="" D ; REDUX PROVIDED? - . N GT S GT=$P(NEWPATH,ZREDUX,2) - . I GT'="" S NEWPATH=GT - S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX - N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE - I $D(GA) D ; PROCESS THE ATTRIBUTES - . N ZI S ZI="" - . F S ZI=$O(GA(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE - . . N ZP S ZP=NEWPATH_"/"_ZI ; PATH FOR ATTRIBUTE - . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY - . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE - N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE - I $D(GD(2)) D ; - . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY - E I $D(GD(1)) D ; - . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY - . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY - N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD - I ZFRST'=0 D ; THERE IS A CHILD - . N ZNUM - . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE - . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD - N GNXT S GNXT=$$NXTSIB(ZOID) - I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES - I GNXT'=0 D ; - . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? - . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES - . . N ZNUM S ZNUM=1 ; - . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB - . E D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB - Q - ; -ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY - ; - N ZZI,ZZJ,ZZN - S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY - I ZZI="" Q ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE - S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY - S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH . - I ZZI'["]" D ; A SINGLETON - . S ZZN=1 - E D ; THERE IS AN [x] OCCURANCE - . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE - . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X] - I ZZJ'="" S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE - Q - ; + ; THE XPATH INDEX ZXIDX, PASSED BY NAME + ; THE XPATH ARRAY XPARY, PASSED BY NAME + ; ZOID IS THE STARTING OID + ; ZPATH IS THE STARTING XPATH, USUALLY "/" + ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE + ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT + I $G(ZREDUX)="" S ZREDUX="" + N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY + N NEWNUM S NEWNUM="" + I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" + S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE + I $G(ZREDUX)'="" D ; REDUX PROVIDED? + . N GT S GT=$P(NEWPATH,ZREDUX,2) + . I GT'="" S NEWPATH=GT + S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX + N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE + I $D(GA) D ; PROCESS THE ATTRIBUTES + . N ZI S ZI="" + . F S ZI=$O(GA(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE + . . N ZP S ZP=NEWPATH_"/"_ZI ; PATH FOR ATTRIBUTE + . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY + . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE + N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE + I $D(GD(2)) D ; + . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY + E I $D(GD(1)) D ; + . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY + . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY + N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD + I ZFRST'=0 D ; THERE IS A CHILD + . N ZNUM + . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE + . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD + N GNXT S GNXT=$$NXTSIB(ZOID) + I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES + I GNXT'=0 D ; + . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? + . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES + . . N ZNUM S ZNUM=1 ; + . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB + . E D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB + Q + ; +ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY + ; + N ZZI,ZZJ,ZZN + S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY + I ZZI="" Q ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE + S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY + S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH . + I ZZI'["]" D ; A SINGLETON + . S ZZN=1 + E D ; THERE IS AN [x] OCCURANCE + . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE + . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X] + I ZZJ'="" S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE + Q + ; PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME - ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW - ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML - ;Q $$EN^MXMLDOM(INXML) - Q $$EN^MXMLDOM(INXML,"W") - ; + ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW + ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML + ;Q $$EN^MXMLDOM(INXML) + Q $$EN^MXMLDOM(INXML,"W") + ; ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE - N ZN - ;I $$TAG(ZOID)["entry" B - S ZN=$$NXTSIB(ZOID) - I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG - Q 0 - ; + N ZN + ;I $$TAG(ZOID)["entry" B + S ZN=$$NXTSIB(ZOID) + I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG + Q 0 + ; FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID - Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) - ; + Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) + ; PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID - Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) - ; + Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) + ; ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID - S HANDLE=C0CDOCID - K @RTN - D GETTXT^MXMLDOM("A") - Q - ; + S HANDLE=C0CDOCID + K @RTN + D GETTXT^MXMLDOM("A") + Q + ; TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE - ;I ZOID=149 B ;GPLTEST - N X,Y - S Y="" - S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE - I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y - I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) - Q Y - ; + ;I ZOID=149 B ;GPLTEST + N X,Y + S Y="" + S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE + I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y + I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) + Q Y + ; NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING - Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) - ; + Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) + ; DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE - ;N ZT,ZN S ZT="" - ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) - ;Q $G(@C0CDOM@(ZOID,"T",1)) - S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) - Q - ; + ;N ZT,ZN S ZT="" + ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) + ;Q $G(@C0CDOM@(ZOID,"T",1)) + S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) + Q + ; OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM - ; - S C0CDOCID=INID - D START^C0CMXMLB($$TAG(1),,"G") - D NDOUT($$FIRST(1)) - D END^C0CMXMLB ;END THE DOCUMENT - M @ZRTN=^TMP("MXMLBLD",$J) - K ^TMP("MXMLBLD",$J) - Q - ; + ; + S C0CDOCID=INID + D START^C0CMXMLB($$TAG(1),,"G") + D NDOUT($$FIRST(1)) + D END^C0CMXMLB ;END THE DOCUMENT + M @ZRTN=^TMP("MXMLBLD",$J) + K ^TMP("MXMLBLD",$J) + Q + ; NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE - N ZI S ZI=$$FIRST(ZOID) - I ZI'=0 D ; THERE IS A CHILD - . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT - . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN - E D ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT - . ;W "DOING",ZOID,! - . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA - . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES - . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN - I $$NXTSIB(ZOID)'=0 D ; THERE IS A SIBLING - . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS - Q - ; -WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE - ; - N GN,GN2 - D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML - S GN2=$NA(@GN@(1)) - W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/") - Q - ; -TESTNARY ; TEST MAKING A NHIN ARRAY - N ZI S ZI="" - N ZH ; DOM HANDLE - D TEST1 ; PARSE AN NHIN RESULT INTO THE DOM - S ZH=C0CDOCID ; SET THE HANDLE - N ZD S ZD=$NA(^TMP("MXMLDOM",$J,ZH)) - F S ZI=$O(@ZD@(ZI)) Q:ZI="" D ; FOR EACH NODE - . N ZATT - . D MNARY(.ZATT,ZH,ZI) - . N ZPRE,ZN - . S ZPRE=$$PRE(ZI) - . S ZN=$P(ZPRE,",",2) - . S ZPRE=$P(ZPRE,",",1) - . ;I $D(ZATT) ZWR ZATT - . N ZJ S ZJ="" - . F S ZJ=$O(ZATT(ZJ)) Q:ZJ="" D ; FOR EACH ATTRIBUTE - . . W ZPRE_"["_ZN_"]"_$$TAG(ZI)_"."_ZJ_"="_ZATT(ZJ),! - . . S GOUT(ZPRE,ZN,$$TAG(ZI)_"."_ZJ)=ZATT(ZJ) - Q - ; -PRE(ZNODE) ; EXTRINSIC WHICH RETURNS THE PREFIX FOR A NODE - ; - N GI,GI2,GPT,GJ,GN - S GI=$$PARENT(ZNODE) ; PARENT NODE - I GI=0 Q "" ; NO PARENT - S GPT=$$TAG(GI) ; TAG OF PARENT - S GI2=$$PARENT(GI) ; PARENT OF PARENT - I (GI2'=0)&($$TAG(GI2)'="results") S GPT=$$TAG(GI2)_"."_GPT - S GJ=$$FIRST(GI) ; NODE OF FIRST SIB - I GJ=ZNODE Q:$$TAG(GI)_",1" - F GN=2:1 Q:GJ=ZNODE D ; - . S GJ=$$NXTSIB(GJ) ; NEXT SIBLING - Q GPT_","_GN - ; -MNARY(ZRTN,ZHANDLE,ZOID) ; MAKE A NHIN ARRAY FROM A DOM NODE - ; RETURNED IN ZRTN, PASSED BY REFERENCE - ; ZHANDLE IS THE DOM DOCUMENT ID - ; ZOID IS THE DOM NODE - D ATT("ZRTN",ZOID) - Q - ; + N ZI S ZI=$$FIRST(ZOID) + I ZI'=0 D ; THERE IS A CHILD + . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT + . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN + E D ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT + . ;W "DOING",ZOID,! + . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA + . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES + . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN + I $$NXTSIB(ZOID)'=0 D ; THERE IS A SIBLING + . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS + Q + ; +WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE + ; + N GN,GN2 + D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML + S GN2=$NA(@GN@(1)) + W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/") + Q + ; +TESTNARY ; TEST MAKING A NHIN ARRAY + N ZI S ZI="" + N ZH ; DOM HANDLE + D TEST1 ; PARSE AN NHIN RESULT INTO THE DOM + S ZH=C0CDOCID ; SET THE HANDLE + N ZD S ZD=$NA(^TMP("MXMLDOM",$J,ZH)) + F S ZI=$O(@ZD@(ZI)) Q:ZI="" D ; FOR EACH NODE + . N ZATT + . D MNARY(.ZATT,ZH,ZI) + . N ZPRE,ZN + . S ZPRE=$$PRE(ZI) + . S ZN=$P(ZPRE,",",2) + . S ZPRE=$P(ZPRE,",",1) + . ;I $D(ZATT) ZWR ZATT + . N ZJ S ZJ="" + . F S ZJ=$O(ZATT(ZJ)) Q:ZJ="" D ; FOR EACH ATTRIBUTE + . . W ZPRE_"["_ZN_"]"_$$TAG(ZI)_"."_ZJ_"="_ZATT(ZJ),! + . . S GOUT(ZPRE,ZN,$$TAG(ZI)_"."_ZJ)=ZATT(ZJ) + Q + ; +PRE(ZNODE) ; EXTRINSIC WHICH RETURNS THE PREFIX FOR A NODE + ; + N GI,GI2,GPT,GJ,GN + S GI=$$PARENT(ZNODE) ; PARENT NODE + I GI=0 Q "" ; NO PARENT + S GPT=$$TAG(GI) ; TAG OF PARENT + S GI2=$$PARENT(GI) ; PARENT OF PARENT + I (GI2'=0)&($$TAG(GI2)'="results") S GPT=$$TAG(GI2)_"."_GPT + S GJ=$$FIRST(GI) ; NODE OF FIRST SIB + I GJ=ZNODE Q:$$TAG(GI)_",1" + F GN=2:1 Q:GJ=ZNODE D ; + . S GJ=$$NXTSIB(GJ) ; NEXT SIBLING + Q GPT_","_GN + ; +MNARY(ZRTN,ZHANDLE,ZOID) ; MAKE A NHIN ARRAY FROM A DOM NODE + ; RETURNED IN ZRTN, PASSED BY REFERENCE + ; ZHANDLE IS THE DOM DOCUMENT ID + ; ZOID IS THE DOM NODE + D ATT("ZRTN",ZOID) + Q + ; Index: ccr/branches/ohum/p/C0CNMED2.m =================================================================== --- ccr/branches/ohum/p/C0CNMED2.m (revision 1332) +++ ccr/branches/ohum/p/C0CNMED2.m (revision 1333) @@ -1,121 +1,121 @@ C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 - ;;1.0;C0C;;May 19, 2009;Build 38 - ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel. - ; Licensed under the terms of the GNU General Public License. - ; See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - ; --Revision History - ; July 2008 - Initial Version/GPL - ; July 2008 - March 2009 various revisions - ; March 2009 - Reconstruction of routine as driver for other med routines/SMH - ; June 2011 - Redone to support all meds using the FOIA NHIN routines/gpl - ; - Q - ; - ; THIS VERSION IS DEPRECATED BECAUSE IT DOES NOT GENEREATE XML IN - ; THE RIGHT ORDER... AND IT HAS TO BE IN THE RIGHT ORDER... :( - ; GPL - ; -EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template - ; DFN passed by reference - ; MEDXML and MEDOUTXML are passed by Name - ; MEDXML is the input template - ; MEDOUTXML is the output template - ; Both of them refer to ^TMP globals where the XML documents are stored - ; - N GN - D EN^C0CNHIN(.GN,DFN,"MED;",1) ; RETRIEVE NHIN ARRAY OF MEDS - ; this call uses GET^NHINV to retrieve xml of the meds and then - ; parses with MXML and uses DOMO^C0CDOM to extract an NHIN array - ; - ; we now create an NHIN Array of the Meds section of the CCR - ; - N ZI S ZI="" - F S ZI=$O(GN("med",ZI)) Q:ZI="" D ; for each med - . N GA S GA=$NA(GN("med",ZI)) - . N GM S GM="Medication" ; to keep the lines shorter - . S GC(GM,ZI,"CCRDataObjectID")="MED_"_ZI - . N ZD,ZD2 S ZD=$G(@GA@("ordered@value")) ; FILEMAN DATE - . I ZD="" S ZD=$G(@GA@("start@value")) ; for inpatient meds - . S ZD2=$$FMDTOUTC^C0CUTIL(ZD,"DT") - . S GC(GM,ZI,"DateTime[1].ExactDateTime")=ZD2 - . S GC(GM,ZI,"DateTime[1].Type.Text")="Documented Date" - . ;S GC(GM,ZI,"DateTime[2].ExactDateTime")="" - . ;S GC(GM,ZI,"DateTime[2].Type.Text")="" - . N GSIG S GSIG=$G(@GA@("sig")) - . I GSIG["|" S GSIG=$P(GSIG,"|",2) ; eRx has name of drug separated by | - . S GC(GM,ZI,"Description.Text")=GSIG - . N GD S GD="Directions.Direction" ; MAKING THE STRINGS SHORTER - . ;S GC(GM,ZI,GD_".DeliveryMethod.Text")="@@MEDDELIVERYMETHOD@@" - . ;S GC(GM,ZI,GD_".Description.Text")="" - . ;S GC(GM,ZI,GD_".DirectionSequenceModifier")="@@MEDDIRSEQ@@" - . ;S GC(GM,ZI,GD_".Dose.Rate.Units.Unit")="@@MEDRATEUNIT@@" - . ;S GC(GM,ZI,GD_".Dose.Rate.Value")="@@MEDRATEVALUE@@" - . ;S GC(GM,ZI,GD_".Dose.Units.Unit")="@@MEDDOSEUNIT@@" - . ;S GC(GM,ZI,GD_".Dose.Value")="@@MEDDOSEVALUE@@" - . ;S GC(GM,ZI,GD_".DoseIndicator.Text")="@@MEDDOSEINDICATOR@@" - . ;S GC(GM,ZI,GD_".Duration.Units.Unit")="@@MEDDURATIONUNIT@@" - . ;S GC(GM,ZI,GD_".Duration.Value")="@@MEDDURATIONVALUE@@" - . ;S GC(GM,ZI,GD_".Frequency.Value")="@@MEDFREQUENCYVALUE@@" - . ;S GC(GM,ZI,GD_".Indication.PRNFlag.Text")="@@MEDPRNFLAG@@" - . ;S GC(GM,ZI,GD_".Indication.Problem.CCRDataObjectID")="" - . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.CodingSystem")="" - . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Value")="" - . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Version")="" - . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Text")="" - . ;S GC(GM,ZI,GD_".Indication.Problem.Source.Actor.ActorID")="" - . ;S GC(GM,ZI,GD_".Indication.Problem.Type.Text")="" - . ;S GC(GM,ZI,GD_".Interval.Units.Unit")="@@MEDINTERVALUNIT@@" - . ;S GC(GM,ZI,GD_".Interval.Value")="@@MEDINTERVALVALUE@@" - . ;S GC(GM,ZI,GD_".MultipleDirectionModifier.Text")="@@MEDMULDIRMOD@@" - . S GC(GM,ZI,GD_".Route.Text")=$G(@GA@("doses.dose@route")) - . ;S GC(GM,ZI,GD_".StopIndicator.Text")="@@MEDSTOPINDICATOR@@" - . ;S GC(GM,ZI,GD_".Vehicle.Text")="@@MEDVEHICLETEXT@@" - . ;S GC(GM,ZI,"FullfillmentInstructions.Text")="" - . ;S GC(GM,ZI,"IDs.ID")="@@MEDRXNO@@" - . ;S GC(GM,ZI,"IDs.Type.Text")="@@MEDRXNOTXT@@" - . ;S GC(GM,ZI,"PatientInstructions.Instruction.Text")="@@MEDPTINSTRUCTIONS@@" - . ;S GC(GM,ZI,"Product.BrandName.Text")="@@MEDBRANDNAMETEXT@@" - . S GC(GM,ZI,"Product.Concentration.Units.Unit")=$G(@GA@("doses.dose@units")) - . S GC(GM,ZI,"Product.Concentration.Value")=$G(@GA@("doses.dose@dose")) - . S GC(GM,ZI,"Product.Form.Text")=$G(@GA@("form@value")) - . N GV S GV=$G(@GA@("products.product.vaProduct@vuid")) - . N GR S GR=$$RXNCUI3^C0PLKUP(GV) - . S GC(GM,ZI,"Product.ProductName.Code.CodingSystem")=$S(GR:"RxNorm",1:"VUID") - . S GC(GM,ZI,"Product.ProductName.Code.Value")=$S(GR:GR,1:GV) - . S GC(GM,ZI,"Product.ProductName.Code.Version")="08AB_081201F" - . S GC(GM,ZI,"Product.ProductName.Text")=$G(@GA@("name@value")) - . S GC(GM,ZI,"Product.Strength.Units.Unit")=$G(@GA@("doses.dose@units")) - . S GC(GM,ZI,"Product.Strength.Value")=$G(@GA@("doses.dose@dose")) - . ;S GC(GM,ZI,"Quantity.Units.Unit")="@@MEDQUANTITYUNIT@@" - . ;S GC(GM,ZI,"Quantity.Value")="@@MEDQUANTITYVALUE@@" - . ;S GC(GM,ZI,"Refills.Refill.Number")="@@MEDRFNO@@" - . N GDUZ S GDUZ=$G(@GA@("orderingProvider@code")) ;PROVIDER DUZ - . S GC(GM,ZI,"Source.Actor.ActorID")="PROVIDER_"_GDUZ - . S GC(GM,ZI,"Status.Text")=$G(@GA@("status@value")) - . S GC(GM,ZI,"Type.Text")="Medication" - N C0CDOCID - S C0CDOCID=$$DOMI^C0CDOM("GC",,"Medications") ; insert to dom - D OUTXML^C0CDOM(MEDOUTXML,C0CDOCID,1) ; render the xml - N ZSIZE S ZSIZE=$O(@MEDOUTXML@(""),-1) - S @MEDOUTXML@(0)=ZSIZE ; RETURN STATUS IS NUMBER OF LINES OF XML - W !,MEDOUTXML - ;ZWR GN - ;ZWR GC - ;B - Q - ; + ;;1.0;C0C;;May 19, 2009;Build 1 + ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel. + ; Licensed under the terms of the GNU General Public License. + ; See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; --Revision History + ; July 2008 - Initial Version/GPL + ; July 2008 - March 2009 various revisions + ; March 2009 - Reconstruction of routine as driver for other med routines/SMH + ; June 2011 - Redone to support all meds using the FOIA NHIN routines/gpl + ; + Q + ; + ; THIS VERSION IS DEPRECATED BECAUSE IT DOES NOT GENEREATE XML IN + ; THE RIGHT ORDER... AND IT HAS TO BE IN THE RIGHT ORDER... :( + ; GPL + ; +EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template + ; DFN passed by reference + ; MEDXML and MEDOUTXML are passed by Name + ; MEDXML is the input template + ; MEDOUTXML is the output template + ; Both of them refer to ^TMP globals where the XML documents are stored + ; + N GN + D EN^C0CNHIN(.GN,DFN,"MED;",1) ; RETRIEVE NHIN ARRAY OF MEDS + ; this call uses GET^NHINV to retrieve xml of the meds and then + ; parses with MXML and uses DOMO^C0CDOM to extract an NHIN array + ; + ; we now create an NHIN Array of the Meds section of the CCR + ; + N ZI S ZI="" + F S ZI=$O(GN("med",ZI)) Q:ZI="" D ; for each med + . N GA S GA=$NA(GN("med",ZI)) + . N GM S GM="Medication" ; to keep the lines shorter + . S GC(GM,ZI,"CCRDataObjectID")="MED_"_ZI + . N ZD,ZD2 S ZD=$G(@GA@("ordered@value")) ; FILEMAN DATE + . I ZD="" S ZD=$G(@GA@("start@value")) ; for inpatient meds + . S ZD2=$$FMDTOUTC^C0CUTIL(ZD,"DT") + . S GC(GM,ZI,"DateTime[1].ExactDateTime")=ZD2 + . S GC(GM,ZI,"DateTime[1].Type.Text")="Documented Date" + . ;S GC(GM,ZI,"DateTime[2].ExactDateTime")="" + . ;S GC(GM,ZI,"DateTime[2].Type.Text")="" + . N GSIG S GSIG=$G(@GA@("sig")) + . I GSIG["|" S GSIG=$P(GSIG,"|",2) ; eRx has name of drug separated by | + . S GC(GM,ZI,"Description.Text")=GSIG + . N GD S GD="Directions.Direction" ; MAKING THE STRINGS SHORTER + . ;S GC(GM,ZI,GD_".DeliveryMethod.Text")="@@MEDDELIVERYMETHOD@@" + . ;S GC(GM,ZI,GD_".Description.Text")="" + . ;S GC(GM,ZI,GD_".DirectionSequenceModifier")="@@MEDDIRSEQ@@" + . ;S GC(GM,ZI,GD_".Dose.Rate.Units.Unit")="@@MEDRATEUNIT@@" + . ;S GC(GM,ZI,GD_".Dose.Rate.Value")="@@MEDRATEVALUE@@" + . ;S GC(GM,ZI,GD_".Dose.Units.Unit")="@@MEDDOSEUNIT@@" + . ;S GC(GM,ZI,GD_".Dose.Value")="@@MEDDOSEVALUE@@" + . ;S GC(GM,ZI,GD_".DoseIndicator.Text")="@@MEDDOSEINDICATOR@@" + . ;S GC(GM,ZI,GD_".Duration.Units.Unit")="@@MEDDURATIONUNIT@@" + . ;S GC(GM,ZI,GD_".Duration.Value")="@@MEDDURATIONVALUE@@" + . ;S GC(GM,ZI,GD_".Frequency.Value")="@@MEDFREQUENCYVALUE@@" + . ;S GC(GM,ZI,GD_".Indication.PRNFlag.Text")="@@MEDPRNFLAG@@" + . ;S GC(GM,ZI,GD_".Indication.Problem.CCRDataObjectID")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.CodingSystem")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Value")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Version")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Text")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Source.Actor.ActorID")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Type.Text")="" + . ;S GC(GM,ZI,GD_".Interval.Units.Unit")="@@MEDINTERVALUNIT@@" + . ;S GC(GM,ZI,GD_".Interval.Value")="@@MEDINTERVALVALUE@@" + . ;S GC(GM,ZI,GD_".MultipleDirectionModifier.Text")="@@MEDMULDIRMOD@@" + . S GC(GM,ZI,GD_".Route.Text")=$G(@GA@("doses.dose@route")) + . ;S GC(GM,ZI,GD_".StopIndicator.Text")="@@MEDSTOPINDICATOR@@" + . ;S GC(GM,ZI,GD_".Vehicle.Text")="@@MEDVEHICLETEXT@@" + . ;S GC(GM,ZI,"FullfillmentInstructions.Text")="" + . ;S GC(GM,ZI,"IDs.ID")="@@MEDRXNO@@" + . ;S GC(GM,ZI,"IDs.Type.Text")="@@MEDRXNOTXT@@" + . ;S GC(GM,ZI,"PatientInstructions.Instruction.Text")="@@MEDPTINSTRUCTIONS@@" + . ;S GC(GM,ZI,"Product.BrandName.Text")="@@MEDBRANDNAMETEXT@@" + . S GC(GM,ZI,"Product.Concentration.Units.Unit")=$G(@GA@("doses.dose@units")) + . S GC(GM,ZI,"Product.Concentration.Value")=$G(@GA@("doses.dose@dose")) + . S GC(GM,ZI,"Product.Form.Text")=$G(@GA@("form@value")) + . N GV S GV=$G(@GA@("products.product.vaProduct@vuid")) + . N GR S GR=$$RXNCUI3^C0PLKUP(GV) + . S GC(GM,ZI,"Product.ProductName.Code.CodingSystem")=$S(GR:"RxNorm",1:"VUID") + . S GC(GM,ZI,"Product.ProductName.Code.Value")=$S(GR:GR,1:GV) + . S GC(GM,ZI,"Product.ProductName.Code.Version")="08AB_081201F" + . S GC(GM,ZI,"Product.ProductName.Text")=$G(@GA@("name@value")) + . S GC(GM,ZI,"Product.Strength.Units.Unit")=$G(@GA@("doses.dose@units")) + . S GC(GM,ZI,"Product.Strength.Value")=$G(@GA@("doses.dose@dose")) + . ;S GC(GM,ZI,"Quantity.Units.Unit")="@@MEDQUANTITYUNIT@@" + . ;S GC(GM,ZI,"Quantity.Value")="@@MEDQUANTITYVALUE@@" + . ;S GC(GM,ZI,"Refills.Refill.Number")="@@MEDRFNO@@" + . N GDUZ S GDUZ=$G(@GA@("orderingProvider@code")) ;PROVIDER DUZ + . S GC(GM,ZI,"Source.Actor.ActorID")="PROVIDER_"_GDUZ + . S GC(GM,ZI,"Status.Text")=$G(@GA@("status@value")) + . S GC(GM,ZI,"Type.Text")="Medication" + N C0CDOCID + S C0CDOCID=$$DOMI^C0CDOM("GC",,"Medications") ; insert to dom + D OUTXML^C0CDOM(MEDOUTXML,C0CDOCID,1) ; render the xml + N ZSIZE S ZSIZE=$O(@MEDOUTXML@(""),-1) + S @MEDOUTXML@(0)=ZSIZE ; RETURN STATUS IS NUMBER OF LINES OF XML + W !,MEDOUTXML + ;ZWR GN + ;ZWR GC + ;B + Q + ; Index: ccr/branches/ohum/p/C0CNMED4.m =================================================================== --- ccr/branches/ohum/p/C0CNMED4.m (revision 1332) +++ ccr/branches/ohum/p/C0CNMED4.m (revision 1333) @@ -1,221 +1,221 @@ -C0CMED4 ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 - ;;0.1;CCDCCR;;; - ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU - ; General Public License See attached copy of the License. - ; - ; This program is free software; you can redistribute it and/or modify - ; it under the terms of the GNU General Public License as published by - ; the Free Software Foundation; either version 2 of the License, or - ; (at your option) any later version. - ; - ; This program is distributed in the hope that it will be useful, - ; but WITHOUT ANY WARRANTY; without even the implied warranty of - ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ; GNU General Public License for more details. - ; - ; You should have received a copy of the GNU General Public License along - ; with this program; if not, write to the Free Software Foundation, Inc., - ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - W "NO ENTRY FROM TOP",! - Q - ; -EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE - ; - ; this routine has be adapted to retrieve meds from GET^NHINV by gpl 6/2011 - ; - ; MINXML is the Input XML Template, passed by name - ; DFN is Patient IEN - ; OUTXML is the resultant XML. - ; - ; MEDS is return array from API. - ; MED is holds each array element from MEDS, one medicine - ; MAP is a mapping variable map (store result) for each med - ; - ; Inpatient Meds will be extracted using this routine and and the one following. - ; Inpatient Meds Unit Dose is going to be C0CMED4 - ; Inpatient Meds IVs is going to be C0CMED5 - ; - ; We will use two Pharmacy ReEnginnering API's: - ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info - ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info - ; For more information, see the PRE documentation at: - ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf - ; - ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient - ; - N MEDS,MAP - ;K ^TMP($J) - ;D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*) - ;I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT ; No Meds - Quit - ;; Otherwise, we go on... - D EN^C0CNHIN(.MEDS,DFN,"MED;") ; gpl get the NHIN Array of meds - I '$D(MEDS) Q ; no meds - N ZI S ZI="" - N ZCOUNT S ZCOUNT=0 - F S ZI=$O(MEDS("med",ZI)) Q:ZI="" D ; for each returned med - . I $G(MEDS("med",ZI,"vaType@value"))="I" S ZCOUNT=ZCOUNT+1 - IF ZCOUNT=0 Q ; no inpatient meds - ;M MEDS=^TMP($J,"UD") - I DEBUG ZWR MEDS - S MEDMAP=$NA(^TMP("C0CCCR",$J,"MEDMAP")) - ;N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array - N I S I=0 - F S I=$O(MEDS("med",I)) Q:'I D ; For each medication - . N MED M MED=MEDS("med",I) - . I $G(MED("vaType@value"))'="I" Q ; not inpatient - . S MEDCOUNT=MEDCOUNT+1 - . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter - . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) - . ;N RXIEN S RXIEN=MED(.01) ; Order Number - . N RXIEN S RXIEN=$G(MED("orderID@value")) ; ien of the med - . I DEBUG W "RXIEN IS ",RXIEN,! - . I DEBUG W "MAP= ",MAP,! - . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN - . S @MAP@("MEDISSUEDATETXT")="Order Date" - . ;S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT") - . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($G(MED("start@value")),"DT") - . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient - . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient - . S @MAP@("MEDRXNOTXT")="" ; For Outpatient - . S @MAP@("MEDRXNO")="" ; For Outpatient - . S @MAP@("MEDTYPETEXT")="Medication" - . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses - . ;S @MAP@("MEDSTATUSTEXT")="ACTIVE" - . N C0CMST S C0CMST=$G(MED("vaStatus@value")) ; need to filter status - . I C0CMST="EXPIRED" S C0CMST="Prior History No Longer Active" - . I C0CMST="ACTIVE" S C0CMST="Active" ; - . S @MAP@("MEDSTATUSTEXT")=C0CMST - . ;S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) - . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$G(MED("orderingProvider@code")) - . ;S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) - . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value")) - . ; NDC is field 31 in the drug file. - . ; The actual drug entry in the drug file is not necessarily supplied. - . ; It' node 1, internal form. - . ;N MEDIEN S MEDIEN=MED(1,"I") - . ;S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") - . N ZVUID S ZVUID=$G(MED("products.product.vaProduct@vuid")) ; VUID - . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION - . D ; - . . S ZC=$$CODE^C0CUTIL(ZVUID) - . . S ZCD=$P(ZC,"^",1) ; CODE TO USE - . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID - . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION - . ;N ZRXNORM S ZRXNORM="" - . ;S ZRXNORM=$$RXNCUI3^C0PLKUP(ZVUID) - . S @MAP@("MEDPRODUCTNAMECODEVALUE")=ZCD - . ;S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") - . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=ZCDS - . ;S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") - . S @MAP@("MEDPRODUCTNAMECODEVERSION")=ZCDSV - . S @MAP@("MEDBRANDNAMETEXT")="" - . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))_" "_ZCDS_": "_ZCD - . ;I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") - . ;I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) - . ;S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") - . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("doses.dose@dose")) - . ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") - . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("doses.dose@units")) - . ; Units, concentration, etc, come from another call - . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit - . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters - . ; NDF Entry IEN, and VA Product Name - . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") - . ; Documented in the same manual. - . ;N NDFDATA,CONCDATA - . ;I $L(MEDIEN) D - . ;. D NDF^PSS50(MEDIEN,,,,,"CONC") - . ;. M NDFDATA=^TMP($J,"CONC",MEDIEN) - . ;. N NDFIEN S NDFIEN=$P(NDFDATA(20),U) - . ;. N VAPROD S VAPROD=$P(NDFDATA(22),U) - . ;. ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" - . ;. ; and this will crash the call. So... - . ;. I NDFIEN="" S CONCDATA="" - . ;. E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) - . ;E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. - . ;S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") - . S @MAP@("MEDFORMTEXT")=$G(MED("form@value")) - . ;S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") - . S @MAP@("MEDCONCVALUE")=$G(MED("doses.dose@dose")) - . ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") - . S @MAP@("MEDCONCUNIT")=$G(MED("doses.does@units")) - . ;S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. - . S @MAP@("MEDQUANTITYVALUE")=$G(MED("doses.dose@unitsPerDose")) ; - . ; Oddly, there is no easy place to find the dispense unit. - . ; It's not included in the original call, so we have to go to the drug file. - . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") - . ; Node 14.5 is the Dispense Unit - . ;I $L(MEDIEN) D - . ;. D DATA^PSS50(MEDIEN,,,,,"QTY") - . ;. N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) - . ;. S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) - . ;E S @MAP@("MEDQUANTITYUNIT")="" - . S @MAP@("MEDQUANTITYUNIT")=$G(MED("dose.dose@unitsPerDose")) - . ; - . ; --- START OF DIRECTIONS --- - . ; Dosage is field 2, route is 3, schedule is 4 - . ; These are all free text fields, and don't point to any files - . ; For that reason, I will use the field I never used before: - . ; MEDDIRECTIONDESCRIPTIONTEXT - . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=$G(MED("sig")) - . ; $G(MED("products.product.vaProduct@name")) - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. - . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" - . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" - . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" - . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" - . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" - . ; - . ; --- END OF DIRECTIONS --- - . ; - . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" - . ;S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field - . S @MAP@("MEDPTINSTRUCTIONS")="" - . ;S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field - . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" - . S @MAP@("MEDRFNO")="" - . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) - . K @RESULT - . D MAP^C0CXPATH(MINXML,MAP,RESULT) - . ; D PARY^C0CXPATH(RESULT) - . ; MAPPING DIRECTIONS - . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE - . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT - . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) - . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") - . ; N MDZ1,MDZNA - . N DIRCNT S DIRCNT=1 ; THERE ARE ALWAYS DIRECTIONS - . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS - . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION - . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) - . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) - . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") - . D:MEDCOUNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy - . D:MEDCOUNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML - N MEDTMP,MEDI - D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS - I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ - . W "MEDICATION MISSING ",! - . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! - Q - ; +C0CMED4 ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 + ;;0.1;CCDCCR;;;Build 1 + ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU + ; General Public License See attached copy of the License. + ; + ; This program is free software; you can redistribute it and/or modify + ; it under the terms of the GNU General Public License as published by + ; the Free Software Foundation; either version 2 of the License, or + ; (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU General Public License for more details. + ; + ; You should have received a copy of the GNU General Public License along + ; with this program; if not, write to the Free Software Foundation, Inc., + ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE + ; + ; this routine has be adapted to retrieve meds from GET^NHINV by gpl 6/2011 + ; + ; MINXML is the Input XML Template, passed by name + ; DFN is Patient IEN + ; OUTXML is the resultant XML. + ; + ; MEDS is return array from API. + ; MED is holds each array element from MEDS, one medicine + ; MAP is a mapping variable map (store result) for each med + ; + ; Inpatient Meds will be extracted using this routine and and the one following. + ; Inpatient Meds Unit Dose is going to be C0CMED4 + ; Inpatient Meds IVs is going to be C0CMED5 + ; + ; We will use two Pharmacy ReEnginnering API's: + ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info + ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info + ; For more information, see the PRE documentation at: + ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf + ; + ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient + ; + N MEDS,MAP + ;K ^TMP($J) + ;D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*) + ;I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT ; No Meds - Quit + ;; Otherwise, we go on... + D EN^C0CNHIN(.MEDS,DFN,"MED;") ; gpl get the NHIN Array of meds + I '$D(MEDS) Q ; no meds + N ZI S ZI="" + N ZCOUNT S ZCOUNT=0 + F S ZI=$O(MEDS("med",ZI)) Q:ZI="" D ; for each returned med + . I $G(MEDS("med",ZI,"vaType@value"))="I" S ZCOUNT=ZCOUNT+1 + IF ZCOUNT=0 Q ; no inpatient meds + ;M MEDS=^TMP($J,"UD") + I DEBUG ZWR MEDS + S MEDMAP=$NA(^TMP("C0CCCR",$J,"MEDMAP")) + ;N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array + N I S I=0 + F S I=$O(MEDS("med",I)) Q:'I D ; For each medication + . N MED M MED=MEDS("med",I) + . I $G(MED("vaType@value"))'="I" Q ; not inpatient + . S MEDCOUNT=MEDCOUNT+1 + . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter + . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) + . ;N RXIEN S RXIEN=MED(.01) ; Order Number + . N RXIEN S RXIEN=$G(MED("orderID@value")) ; ien of the med + . I DEBUG W "RXIEN IS ",RXIEN,! + . I DEBUG W "MAP= ",MAP,! + . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN + . S @MAP@("MEDISSUEDATETXT")="Order Date" + . ;S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT") + . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($G(MED("start@value")),"DT") + . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient + . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient + . S @MAP@("MEDRXNOTXT")="" ; For Outpatient + . S @MAP@("MEDRXNO")="" ; For Outpatient + . S @MAP@("MEDTYPETEXT")="Medication" + . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses + . ;S @MAP@("MEDSTATUSTEXT")="ACTIVE" + . N C0CMST S C0CMST=$G(MED("vaStatus@value")) ; need to filter status + . I C0CMST="EXPIRED" S C0CMST="Prior History No Longer Active" + . I C0CMST="ACTIVE" S C0CMST="Active" ; + . S @MAP@("MEDSTATUSTEXT")=C0CMST + . ;S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) + . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$G(MED("orderingProvider@code")) + . ;S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) + . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value")) + . ; NDC is field 31 in the drug file. + . ; The actual drug entry in the drug file is not necessarily supplied. + . ; It' node 1, internal form. + . ;N MEDIEN S MEDIEN=MED(1,"I") + . ;S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") + . N ZVUID S ZVUID=$G(MED("products.product.vaProduct@vuid")) ; VUID + . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION + . D ; + . . S ZC=$$CODE^C0CUTIL(ZVUID) + . . S ZCD=$P(ZC,"^",1) ; CODE TO USE + . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID + . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION + . ;N ZRXNORM S ZRXNORM="" + . ;S ZRXNORM=$$RXNCUI3^C0PLKUP(ZVUID) + . S @MAP@("MEDPRODUCTNAMECODEVALUE")=ZCD + . ;S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") + . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=ZCDS + . ;S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") + . S @MAP@("MEDPRODUCTNAMECODEVERSION")=ZCDSV + . S @MAP@("MEDBRANDNAMETEXT")="" + . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))_" "_ZCDS_": "_ZCD + . ;I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") + . ;I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) + . ;S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") + . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("doses.dose@dose")) + . ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") + . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("doses.dose@units")) + . ; Units, concentration, etc, come from another call + . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit + . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters + . ; NDF Entry IEN, and VA Product Name + . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") + . ; Documented in the same manual. + . ;N NDFDATA,CONCDATA + . ;I $L(MEDIEN) D + . ;. D NDF^PSS50(MEDIEN,,,,,"CONC") + . ;. M NDFDATA=^TMP($J,"CONC",MEDIEN) + . ;. N NDFIEN S NDFIEN=$P(NDFDATA(20),U) + . ;. N VAPROD S VAPROD=$P(NDFDATA(22),U) + . ;. ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" + . ;. ; and this will crash the call. So... + . ;. I NDFIEN="" S CONCDATA="" + . ;. E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) + . ;E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. + . ;S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") + . S @MAP@("MEDFORMTEXT")=$G(MED("form@value")) + . ;S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") + . S @MAP@("MEDCONCVALUE")=$G(MED("doses.dose@dose")) + . ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") + . S @MAP@("MEDCONCUNIT")=$G(MED("doses.does@units")) + . ;S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. + . S @MAP@("MEDQUANTITYVALUE")=$G(MED("doses.dose@unitsPerDose")) ; + . ; Oddly, there is no easy place to find the dispense unit. + . ; It's not included in the original call, so we have to go to the drug file. + . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") + . ; Node 14.5 is the Dispense Unit + . ;I $L(MEDIEN) D + . ;. D DATA^PSS50(MEDIEN,,,,,"QTY") + . ;. N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) + . ;. S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) + . ;E S @MAP@("MEDQUANTITYUNIT")="" + . S @MAP@("MEDQUANTITYUNIT")=$G(MED("dose.dose@unitsPerDose")) + . ; + . ; --- START OF DIRECTIONS --- + . ; Dosage is field 2, route is 3, schedule is 4 + . ; These are all free text fields, and don't point to any files + . ; For that reason, I will use the field I never used before: + . ; MEDDIRECTIONDESCRIPTIONTEXT + . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=$G(MED("sig")) + . ; $G(MED("products.product.vaProduct@name")) + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. + . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" + . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" + . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" + . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" + . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" + . ; + . ; --- END OF DIRECTIONS --- + . ; + . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" + . ;S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field + . S @MAP@("MEDPTINSTRUCTIONS")="" + . ;S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field + . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" + . S @MAP@("MEDRFNO")="" + . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) + . K @RESULT + . D MAP^C0CXPATH(MINXML,MAP,RESULT) + . ; D PARY^C0CXPATH(RESULT) + . ; MAPPING DIRECTIONS + . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE + . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT + . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) + . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") + . ; N MDZ1,MDZNA + . N DIRCNT S DIRCNT=1 ; THERE ARE ALWAYS DIRECTIONS + . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS + . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION + . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) + . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) + . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") + . D:MEDCOUNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy + . D:MEDCOUNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML + N MEDTMP,MEDI + D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS + I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ + . W "MEDICATION MISSING ",! + . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! + Q + ; Index: ccr/branches/ohum/p/C0CORSLT.m =================================================================== --- ccr/branches/ohum/p/C0CORSLT.m (revision 1332) +++ ccr/branches/ohum/p/C0CORSLT.m (revision 1333) @@ -1,4 +1,4 @@ -C0CORSLT ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11 - ;;1.0;C0C;;Jan 21, 2010;Build 38 +C0CORSLT ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11 + ;;1.0;C0C;;Jan 21, 2010;Build 1 ;Copyright 2011 George Lilly. ;Licensed under the terms of the GNU General Public License. @@ -22,48 +22,48 @@ Q ; -EN(ZVARS,DFN) ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS - ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE - ; AN EXAMPLE IS EKG RESULTS THAT ARE FOUND IN NOTES AND CONSULTS - ; THIS IS CREATED FOR MU CERTIFICATION BY GPL - D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE - N ZN ; RESULT NUMBER - S ZN=$O(@ZVARS@(""),-1) ; NEXT RESULT - N ZI S ZI="" - F S ZI=$O(VISIT(ZI)) Q:ZI="" D ; FOR EACH VISIT - . I $G(VISIT(ZI,"TEXT",1))["ECG DONE" D ; GOT AN ECG - . . S ZN=ZN+1 ; INCREMENT RESULT COUNT - . . N ZDATE,ZPRV,ZTXT - . . S ZDATE=$G(VISIT(ZI,"DATE",0)) ; DATE OF PROCEDURE - . . S ZPRV=$P($G(VISIT(ZI,"PRV",2)),"^",1) ;PROVIDER - . . S ZTXT=$P($G(VISIT(ZI,"TEXT",4)),"ECG RESULTS: ",2) - . . S @ZVARS@(ZN,"RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") - . . S @ZVARS@(ZN,"RESULTCODE")="34534-8" - . . S @ZVARS@(ZN,"RESULTCODINGSYSTEM")="LOINC" - . . S @ZVARS@(ZN,"RESULTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" - . . S @ZVARS@(ZN,"RESULTOBJECTID")="RESULT"_ZN - . . S @ZVARS@(ZN,"RESULTSOURCEACTORID")="ACTORPROVIDER_"_ZPRV - . . S @ZVARS@(ZN,"RESULTSTATUS")="" - . . S @ZVARS@(ZN,"M","TEST",0)=1 - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODEVALUE")="34534-8" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODINGSYSTEM")="LOINC" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTFLAG")="" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALDESCTEXT")="" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALSOURCEACTORID")="ACTORORGANIZATION_VASTANUM" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTOBJECTID")="RESULTTEST_ECG_"_ZN - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSOURCEACTORID")="ACTORPROVIDER"_ZPRV - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSTATUSTEXT")="F" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTUNITS")="" - . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTVALUE")=ZTXT - . . S @ZVARS@(0)=ZN ; UPDATE RESULTS COUNT - Q - ; -OLD ; OLD CODE FOR OTHER WAYS OF DOING THE ECG - ; FOR CERTIFICATION - SAVE EKG RESULTS gpl - W !,"CPT=",ZCPT - I ZCPT["93000" D ; THIS IS AN EKG - . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS - . M ^GPL("RNF2")=@C0CPRSLT - Q - ; +EN(ZVARS,DFN) ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS + ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE + ; AN EXAMPLE IS EKG RESULTS THAT ARE FOUND IN NOTES AND CONSULTS + ; THIS IS CREATED FOR MU CERTIFICATION BY GPL + D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE + N ZN ; RESULT NUMBER + S ZN=$O(@ZVARS@(""),-1) ; NEXT RESULT + N ZI S ZI="" + F S ZI=$O(VISIT(ZI)) Q:ZI="" D ; FOR EACH VISIT + . I $G(VISIT(ZI,"TEXT",1))["ECG DONE" D ; GOT AN ECG + . . S ZN=ZN+1 ; INCREMENT RESULT COUNT + . . N ZDATE,ZPRV,ZTXT + . . S ZDATE=$G(VISIT(ZI,"DATE",0)) ; DATE OF PROCEDURE + . . S ZPRV=$P($G(VISIT(ZI,"PRV",2)),"^",1) ;PROVIDER + . . S ZTXT=$P($G(VISIT(ZI,"TEXT",4)),"ECG RESULTS: ",2) + . . S @ZVARS@(ZN,"RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") + . . S @ZVARS@(ZN,"RESULTCODE")="34534-8" + . . S @ZVARS@(ZN,"RESULTCODINGSYSTEM")="LOINC" + . . S @ZVARS@(ZN,"RESULTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" + . . S @ZVARS@(ZN,"RESULTOBJECTID")="RESULT"_ZN + . . S @ZVARS@(ZN,"RESULTSOURCEACTORID")="ACTORPROVIDER_"_ZPRV + . . S @ZVARS@(ZN,"RESULTSTATUS")="" + . . S @ZVARS@(ZN,"M","TEST",0)=1 + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODEVALUE")="34534-8" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODINGSYSTEM")="LOINC" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTFLAG")="" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALDESCTEXT")="" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALSOURCEACTORID")="ACTORORGANIZATION_VASTANUM" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTOBJECTID")="RESULTTEST_ECG_"_ZN + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSOURCEACTORID")="ACTORPROVIDER"_ZPRV + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSTATUSTEXT")="F" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTUNITS")="" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTVALUE")=ZTXT + . . S @ZVARS@(0)=ZN ; UPDATE RESULTS COUNT + Q + ; +OLD ; OLD CODE FOR OTHER WAYS OF DOING THE ECG + ; FOR CERTIFICATION - SAVE EKG RESULTS gpl + W !,"CPT=",ZCPT + I ZCPT["93000" D ; THIS IS AN EKG + . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS + . M ^GPL("RNF2")=@C0CPRSLT + Q + ; Index: ccr/branches/ohum/p/C0CPARMS.m =================================================================== --- ccr/branches/ohum/p/C0CPARMS.m (revision 1332) +++ ccr/branches/ohum/p/C0CPARMS.m (revision 1333) @@ -1,4 +1,4 @@ C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU ;General Public License See attached copy of the License. @@ -38,13 +38,25 @@ ; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS ; IF THEY FAIL, THE FOLLOWING WILL BE HARDCODED DEFAULTS - I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH + ;OHUM/RUT commented the hardcoded limits + ;I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH + ;I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY + ;I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS + ;I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY + ;I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY + ;I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS + ;I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES + ;I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO + ;I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE + S @C0CPARMS@("LABLIMIT")=^TMP("C0CCCR","LABLIMIT"),@C0CPARMS@("VITLIMIT")=^TMP("C0CCCR","VITLIMIT"),@C0CPARMS@("TIULIMIT")=^TMP("C0CCCR","TIULIMIT"),@C0CPARMS@("MEDLIMIT")=^TMP("C0CCCR","MEDLIMIT") I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY - I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY - I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO - I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE + I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=1 ; NON-PENDING NON-ACTIVE + ;I '$D(@C0CPARMS@("RALIMIT")) S @C0CPARMS@("RALIMIT")="T-36500" ;ONE YR WORTH + ;I '$D(@C0CPARMS@("RASTART")) S @C0CPARMS@("RASTART")="T" ;TODAY + I '$D(@C0CPARMS@("TIUSTART")) S @C0CPARMS@("TIUSTART")="T" ;TODAY + ;OHUM/RUT Q ; Index: ccr/branches/ohum/p/C0CPROBS.m =================================================================== --- ccr/branches/ohum/p/C0CPROBS.m (revision 1332) +++ ccr/branches/ohum/p/C0CPROBS.m (revision 1333) @@ -1,4 +1,4 @@ C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008,2009 George Lilly, University of Minnesota. ;Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CPROC.m =================================================================== --- ccr/branches/ohum/p/C0CPROC.m (revision 1332) +++ ccr/branches/ohum/p/C0CPROC.m (revision 1333) @@ -1,4 +1,4 @@ C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10 - ;;1.0;C0C;;Jan 21, 2010;Build 38 + ;;1.0;C0C;;Jan 21, 2010;Build 1 ;Copyright 2010 George Lilly, University of Minnesota and others. ;Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CPXRM.m =================================================================== --- ccr/branches/ohum/p/C0CPXRM.m (revision 1332) +++ ccr/branches/ohum/p/C0CPXRM.m (revision 1333) @@ -1,74 +1,73 @@ -C0CPXRM ; -;;; -DOIT ; - S G="PXRMXSEPCLINIC3110302.224804" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.223957" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.223738" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.223516" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.222158" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.213944" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.212219" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.211506" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.002714" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.001841" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110302.000846" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110115.141918" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110115.132312" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110115.131653" ZWR ^XTMP(G,*) - S G="PXRMXSEPCLINIC3110115.131008" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT988 3110224.210456" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT986 3110224.210456" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT932 3110224.210456" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT932 3110224.210455" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT8015 3110301.215142" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT8015 3110301.215141" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT5265 3110309.124047" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT5265 3110309.124046" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT4742 3101129.221201" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT4742 3101129.215741" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT4710 3101129.215701" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT3297 3101127.123134" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT32495 3110224.194246" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT32493 3110224.194246" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT32354 3110224.194246" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT32354 3110224.194245" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT31106 3110224.175105" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT31090 3110224.175105" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT30339 3110224.175105" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT30339 3110224.175103" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT2761 3110115.174109" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT2761 3110115.174108" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT27327 3110227.013658" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT27327 3110227.013657" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT27327 3110227.013523" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT27327 3110227.013522" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT27253 3110227.012747" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT27253 3110227.012746" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT2559 3110115.170835" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT25549 3110228.231135" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT25549 3110228.231134" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT2205 3101129.215343" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT21092 3110114.195621" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT21092 3110114.193803" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT19640 3110226.032943" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT19640 3110226.032941" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT19353 3101212.162833" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT18780 3110221.215603" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT18156 3101212.152654" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT17800 3110315.202432" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT1650 3110220.192925" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT16110 3110313.224636" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT16004 3110317.151215" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT16004 3110317.150834" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT14955 3110315.165018" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT14816 3110315.164839" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT14816 3110315.164512" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT12415 3110315.135514" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT11797 3110315.131141" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT11573 3110315.131811" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT10728 3110114.025022" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT10578 3110114.021524" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT10243 3110114.020338" ZWR ^XTMP(G,*) - S G="PXRM PXK EVENT10105 3101204.230554" ZWR ^XTMP(G,*) - Q - ; +C0CPXRM ; +DOIT ; + S G="PXRMXSEPCLINIC3110302.224804" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.223957" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.223738" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.223516" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.222158" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.213944" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.212219" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.211506" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.002714" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.001841" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110302.000846" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110115.141918" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110115.132312" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110115.131653" ZWR ^XTMP(G,*) + S G="PXRMXSEPCLINIC3110115.131008" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT988 3110224.210456" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT986 3110224.210456" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT932 3110224.210456" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT932 3110224.210455" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT8015 3110301.215142" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT8015 3110301.215141" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT5265 3110309.124047" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT5265 3110309.124046" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT4742 3101129.221201" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT4742 3101129.215741" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT4710 3101129.215701" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT3297 3101127.123134" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT32495 3110224.194246" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT32493 3110224.194246" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT32354 3110224.194246" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT32354 3110224.194245" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT31106 3110224.175105" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT31090 3110224.175105" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT30339 3110224.175105" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT30339 3110224.175103" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT2761 3110115.174109" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT2761 3110115.174108" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT27327 3110227.013658" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT27327 3110227.013657" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT27327 3110227.013523" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT27327 3110227.013522" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT27253 3110227.012747" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT27253 3110227.012746" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT2559 3110115.170835" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT25549 3110228.231135" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT25549 3110228.231134" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT2205 3101129.215343" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT21092 3110114.195621" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT21092 3110114.193803" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT19640 3110226.032943" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT19640 3110226.032941" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT19353 3101212.162833" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT18780 3110221.215603" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT18156 3101212.152654" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT17800 3110315.202432" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT1650 3110220.192925" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT16110 3110313.224636" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT16004 3110317.151215" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT16004 3110317.150834" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT14955 3110315.165018" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT14816 3110315.164839" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT14816 3110315.164512" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT12415 3110315.135514" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT11797 3110315.131141" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT11573 3110315.131811" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT10728 3110114.025022" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT10578 3110114.021524" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT10243 3110114.020338" ZWR ^XTMP(G,*) + S G="PXRM PXK EVENT10105 3101204.230554" ZWR ^XTMP(G,*) + Q + ; Index: ccr/branches/ohum/p/C0CQRY1.m =================================================================== --- ccr/branches/ohum/p/C0CQRY1.m (revision 1332) +++ ccr/branches/ohum/p/C0CQRY1.m (revision 1333) @@ -1,123 +1,123 @@ -LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99 13:48 - ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 31 - ; - Q - ; -CHKSC ; Check search NLT/LOINC codes - ; - N J - ; - S J=0 - F S J=$O(LA7SC(J)) Q:'J D - . N X - . S X=LA7SC(J) - . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D Q - . . S ^TMP("LA7-NLT",$J,$P(X,"^"))="" - . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D Q - . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))="" - . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed" - . K LA7SC(J) - Q - ; - ; -SPEC ; Convert HL7 Specimen Codes to File #61, Topography codes - ; Find all topographies that use this HL7 specimen code - N J,K,L - ; - S J=0 - F S J=$O(LA7SPEC(J)) Q:'J D - . S K=LA7SPEC(J),L=0 - . F S L=$O(^LAB(61,"HL7",K,L)) Q:'L S ^TMP("LA7-61",$J,L)="" - Q - ; - ; -BUILDMSG ; Build HL7 message with result of query - ; - N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X - ; - I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&" - S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5) - S (HLQ,HL("Q"))="""""" - ; Set flag to not send HL7 message - S LA7NOMSG=1 - ; Create dummy MSH to pass HL7 delimiters - S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS - D FILESEG^LA7VHLU(GBL,.LA7MSH) - ; - F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)="" - ; - ; Take search results and put in HL7 message structure - S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0 - ; F S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT D ;change per John M - F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" D Q:LA7QUIT - . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q - . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0 - . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR - . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR - . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR - . D OBX - ; - Q - ; - ; -PID ; Build PID segment - ; - N LA7PID - ; - S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3) - S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) - D DEM^LRX - D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL) - D FILESEG^LA7VHLU(GBL,.LA7PID) - S (LA("LRIDT"),LA("SUB"))="" - Q - ; - ; -ORC ; Build ORC segment - ; - N X - ; - S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5) - S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) - S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")) - S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4) - I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6) - S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0 - D ORC^LA7VORU - S LA("NLT")="" - ; - Q - ; - ; -OBR ; Build OBR segment - ; - N LA764,LA7NLT - ; - S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))="" - I $L(LA7NLT) D - . S LA764=+$O(^LAM("E",LA7NLT,0)) - . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01) - I LA("SUB")="CH" D - . D OBR^LA7VORU - . D NTE^LA7VORU - . S LA7OBXSN=0 - ; - Q - ; - ; -OBX ; Build OBX segment - ; - N LA7DATA,LA7VT - ; - S LA7NTESN=0 - I LA("SUB")="MI" D MI^LA7VORU1 Q - I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q - ; - S LA7VT=$QS(LA7ROOT,7) - D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH) - I '$D(LA7DATA) Q - D FILESEG^LA7VHLU(GBL,.LA7DATA) - ; Send any test interpretation from file #60 - D INTRP^LA7VORUA - ; - Q +LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99 13:48 + ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 1 + ; + Q + ; +CHKSC ; Check search NLT/LOINC codes + ; + N J + ; + S J=0 + F S J=$O(LA7SC(J)) Q:'J D + . N X + . S X=LA7SC(J) + . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D Q + . . S ^TMP("LA7-NLT",$J,$P(X,"^"))="" + . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D Q + . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))="" + . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed" + . K LA7SC(J) + Q + ; + ; +SPEC ; Convert HL7 Specimen Codes to File #61, Topography codes + ; Find all topographies that use this HL7 specimen code + N J,K,L + ; + S J=0 + F S J=$O(LA7SPEC(J)) Q:'J D + . S K=LA7SPEC(J),L=0 + . F S L=$O(^LAB(61,"HL7",K,L)) Q:'L S ^TMP("LA7-61",$J,L)="" + Q + ; + ; +BUILDMSG ; Build HL7 message with result of query + ; + N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X + ; + I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&" + S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5) + S (HLQ,HL("Q"))="""""" + ; Set flag to not send HL7 message + S LA7NOMSG=1 + ; Create dummy MSH to pass HL7 delimiters + S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS + D FILESEG^LA7VHLU(GBL,.LA7MSH) + ; + F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)="" + ; + ; Take search results and put in HL7 message structure + S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0 + ; F S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT D ;change per John M + F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" D Q:LA7QUIT + . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q + . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0 + . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR + . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR + . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR + . D OBX + ; + Q + ; + ; +PID ; Build PID segment + ; + N LA7PID + ; + S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3) + S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) + D DEM^LRX + D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL) + D FILESEG^LA7VHLU(GBL,.LA7PID) + S (LA("LRIDT"),LA("SUB"))="" + Q + ; + ; +ORC ; Build ORC segment + ; + N X + ; + S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5) + S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) + S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")) + S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4) + I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6) + S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0 + D ORC^LA7VORU + S LA("NLT")="" + ; + Q + ; + ; +OBR ; Build OBR segment + ; + N LA764,LA7NLT + ; + S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))="" + I $L(LA7NLT) D + . S LA764=+$O(^LAM("E",LA7NLT,0)) + . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01) + I LA("SUB")="CH" D + . D OBR^LA7VORU + . D NTE^LA7VORU + . S LA7OBXSN=0 + ; + Q + ; + ; +OBX ; Build OBX segment + ; + N LA7DATA,LA7VT + ; + S LA7NTESN=0 + I LA("SUB")="MI" D MI^LA7VORU1 Q + I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q + ; + S LA7VT=$QS(LA7ROOT,7) + D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH) + I '$D(LA7DATA) Q + D FILESEG^LA7VHLU(GBL,.LA7DATA) + ; Send any test interpretation from file #60 + D INTRP^LA7VORUA + ; + Q Index: ccr/branches/ohum/p/C0CQRY2.m =================================================================== --- ccr/branches/ohum/p/C0CQRY2.m (revision 1332) +++ ccr/branches/ohum/p/C0CQRY2.m (revision 1333) @@ -1,184 +1,184 @@ -LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09 - ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994 - ; JMC - mods to check for IHS V LAB file - ; - Q - ; -PATID ; Resolve patient id and establish patient environment - ; - N LA7X - ; - S (DFN,LRDFN)="",LA7PTYP=0 - ; - ; SSN passed as patient identifier - I LA7PTID?9N.1A D - . S LA7PTYP=1 - . S LA7X=$O(^DPT("SSN",LA7PTID,0)) - . I LA7X>0 D SETDFN(LA7X) - ; - ; MPI/ICN (integration control number) passed as patient identifier - I LA7PTID?10N1"V"6N D - . S LA7PTYP=2 - . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V")) - . I LA7X>0 D SETDFN(LA7X) - ; - ; If no patient identified/no laboratory record - return exception message - I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed" - I 'DFN S LA7ERR(2)="No patient found with requested identifier" - I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient" - I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient" - Q - ; - ; -BCD ; Search by specimen collection date. - ; - N LA763,LA7QUIT - ; - S (LA7SDT(0),LA7EDT(0))=0 - I LA7SDT S LA7SDT(0)=9999999-LA7SDT - I LA7EDT S LA7EDT(0)=9999999-LA7EDT - ; - F LRSS="CH","MI","SP" D - . S (LA7QUIT,LRIDT)=0 - . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1) - . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT D - . . ; Quit if reached end of data or outside date criteria - . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q - . . D SEARCH - ; - Q - ; - ; -BRAD ; Search by results available date (completion date). - ; Assumes cross-references still exist for dates in LRO(69) global. - ; Collects specimen date/time values for a given LRDFN and completion date. - ; Cross-reference is by date only, time stripped from start date. - ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)="" - ; - N LA763,LA7DT,LA7ROOT,LA7SRC,X - ; - ; Check if orders still exist Iin file #69 for search range - S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0 - S X=$O(^LRO(69,LA7SDT(1))) - I X,XLA7EDT(1)) D - . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")" - . . F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN") D - . . . I $QS(LA7ROOT,6)'=LRDFN Q - . . . S LRIDT=$QS(LA7ROOT,7) - . . . F LRSS="CH","MI","SP" D SEARCH - ; - ; If no orders in #69 then do long search through file #63. - I 'LA7SRC D - . F LRSS="CH","MI","SP" D - . . S LRIDT=0 - . . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT D - . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) - . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)0 D SETDFN(LA7X) + ; + ; MPI/ICN (integration control number) passed as patient identifier + I LA7PTID?10N1"V"6N D + . S LA7PTYP=2 + . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V")) + . I LA7X>0 D SETDFN(LA7X) + ; + ; If no patient identified/no laboratory record - return exception message + I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed" + I 'DFN S LA7ERR(2)="No patient found with requested identifier" + I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient" + I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient" + Q + ; + ; +BCD ; Search by specimen collection date. + ; + N LA763,LA7QUIT + ; + S (LA7SDT(0),LA7EDT(0))=0 + I LA7SDT S LA7SDT(0)=9999999-LA7SDT + I LA7EDT S LA7EDT(0)=9999999-LA7EDT + ; + F LRSS="CH","MI","SP" D + . S (LA7QUIT,LRIDT)=0 + . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1) + . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT D + . . ; Quit if reached end of data or outside date criteria + . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q + . . D SEARCH + ; + Q + ; + ; +BRAD ; Search by results available date (completion date). + ; Assumes cross-references still exist for dates in LRO(69) global. + ; Collects specimen date/time values for a given LRDFN and completion date. + ; Cross-reference is by date only, time stripped from start date. + ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)="" + ; + N LA763,LA7DT,LA7ROOT,LA7SRC,X + ; + ; Check if orders still exist Iin file #69 for search range + S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0 + S X=$O(^LRO(69,LA7SDT(1))) + I X,XLA7EDT(1)) D + . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")" + . . F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN") D + . . . I $QS(LA7ROOT,6)'=LRDFN Q + . . . S LRIDT=$QS(LA7ROOT,7) + . . . F LRSS="CH","MI","SP" D SEARCH + ; + ; If no orders in #69 then do long search through file #63. + I 'LA7SRC D + . F LRSS="CH","MI","SP" D + . . S LRIDT=0 + . . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT D + . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) + . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)C0CCNT) D ; - . S GN=GN+1 - . W $$FMDTOUTC^C0CUTIL(9999999-G),! - Q - ; -VISITS2(C0CDFN,C0CCNT) ;SECOND VERSION USING NEXTV - ; - N C0CG,GN - S C0CG="" - S GN=0 - I '$D(C0CCNT) S C0CCNT=99999999 - F S C0CG=$$NEXTV(C0CDFN,C0CG) Q:(C0CG="")!(GN'C0CCNT) D ; + . S GN=GN+1 + . W $$FMDTOUTC^C0CUTIL(9999999-G),! + Q + ; +VISITS2(C0CDFN,C0CCNT) ;SECOND VERSION USING NEXTV + ; + N C0CG,GN + S C0CG="" + S GN=0 + I '$D(C0CCNT) S C0CCNT=99999999 + F S C0CG=$$NEXTV(C0CDFN,C0CG) Q:(C0CG="")!(GN'0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN - . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS - . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","SNOTBL","MEDSCODE") ;CODES - . ; D PATD^C0CSNOA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES - D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED - ; W "ATTRIBUTES: ",SATTR,! - Q SATTR - ; -RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES - K ^TMP("C0CSNO","RESUME") - K ^TMP("C0CSNO") - Q - ; -CLIST ; LIST THE CATEGORIES - ; - I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS - N CLBASE,CLNUM,ZI,CLIDX - S CLBASE=$NA(@SNOBASE@("SNOTBL","CATS")) - S CLNUM=@CLBASE@(0) - F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES - . S CLIDX=@CLBASE@(ZI) - . W "(",$P(@CLBASE@(CLIDX),"^",1) - . W ":",$P(@CLBASE@(CLIDX),"^",2),") " - . W CLIDX,! - ; D PARY^C0CXPATH(CLBASE) - Q - ; -CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES - ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT - ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE - ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME - ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, - ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" - ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES - ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY - ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING - ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY - ; NUMBER IE CTBL_X(CDFN)="" - ; - ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST - S CCTBL=$NA(@CBASE@(CTBL,"CATS")) - ; W "CBASE: ",CCTBL,! - ; - I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY - . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY - . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY - . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT - . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY - . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME - . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 - ; - S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY - S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT - S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK - ; - S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED - ; - S CPATLIST=$NA(@CBASE@(CTBL,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT - ; W "IENS BASE: ",CPATLIST,! - S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST - ; - Q - ; -REUSE ; GET SAVED VALUES FROM ^TMP("C0CSAV") AND PUT THEM IN A DATABASE - ; - D ASETUP - D AINIT - N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH - S SAVBASE=$NA(^TMP("C0CSAV","VARS")) - S SNOI="" - F D Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST - . S SNOI=$O(@SAVBASE@(SNOI)) - . S SNOJ=@SAVBASE@(SNOI) - . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1) - . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE - . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON - . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE - . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE - . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE - . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,! - . W SNOK,! - . W SNOJ,! - Q - ; +C0CSNOA ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/08 + ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 + ;Copyright 2008,2009 George Lilly, University of Minnesota. + ;Licensed under the terms of the GNU General Public License. + ;See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + ; THESE ROUTINES ANALYZE THE POTENTIAL RETRIEVAL OF SNOMED CT CODES + ; FOR PATIENT DRUG ALLERGIES FOR INCLUSION IN THE CCR OR CCD + ; USING THE VISTA LEXICON ^LEX + ; +ANALYZE(BEGIEN,IENCNT) ; SNOMED RETRIEVAL ANALYSIS ROUTINE + ; BEGINS AT BEGIEN AND GOES FOR IENCNT DRUGS IN GMRD + ; TO RESUME AT NEXT DRUG, USE BEGIEN="" + ; USE RESET^C0CSNOA TO RESET TO TOP OF DRUG LIST + ; + N SNOARY,SNOTMP,SNOI,SNOIEN,RATTR + N CCRGLO + D ASETUP ; SET UP VARIABLES AND GLOBALS + D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE + I '$D(@SNOBASE@("RESUME")) S @SNOBASE@("RESUME")=$O(@GMRBASE@(1)) ;1ST TME + S RESUME=@SNOBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN + S SNOIEN=BEGIEN ; BEGIN WITH THE BEGIEN RECORD + I SNOIEN="" S SNOIEN=RESUME + I +SNOIEN=0 D Q ; AT THE END OF THE ALLERGY LIST + . W "END OF DRUG LIST, CALL RESET^C0CSNOA",! + F SNOI=1:1:IENCNT D Q:+SNOIEN=0 ; FOR IENCNT NUMBER OF PATIENTS OR END + . ;D CCRRPC^C0CCCR(.CCRGLO,SNOIEN,"CCR","","","") ;PROCESS THE CCR + . W SNOIEN,@GMRBASE@(SNOIEN,0),! + . N SNORTN,TTERM ; RETURN ARRAY + . S TTERM=$P(@GMRBASE@(SNOIEN,0),"^",1)_" ALLERGY" + . D TEXTRPC(.SNORTN,TTERM) + . I $D(SNORTN) ZWR SNORTN + . K @SNOBASE@("VARS",SNOIEN) ; CLEAR OUT OLD VARS + . I $P(TTMP,"^",1)=1 S @SNOBASE@("VARS",SNOIEN)=TTERM_"^"_TTMP_"^"_SNORTN(0) + . ; + . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP + . ; + . S RATTR=$$SETATTR(SNOIEN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS + . S @SNOBASE@("ATTR",SNOIEN)=RATTR ; SAVE THE ATRIBUTES FOR THIS DRUG + . ; + . N CATNAME,CATTBL + . S CATNAME="" + . D CPUSH(.CATNAME,SNOBASE,"SNOTBL",SNOIEN,RATTR) ; ADD TO CATEGORY + . ; W "CATEGORY NAME: ",CATNAME,! + . ; + . S SNOIEN=$O(@GMRBASE@(SNOIEN)) ; NEXT RECORD + . S @SNOBASE@("RESUME")=SNOIEN ; WHERE WE ARE LEAVING OFF THIS RUN + ; D PARY^C0CXPATH(@SNOBASE@("ATTRTBL")) + Q + ; +TEXTRPC(ORTN,ITEXT) ; CALL THE LEXICON WITH ITEXT AND RETURN RESULTS IN ORTN + ; + ;N TTMP + W ITEXT,! + S TTMP=$$TEXT^LEXTRAN(ITEXT,"","","SCT","ORTN") + Q + ; +ASETUP ; SET UP GLOBALS AND VARS SNOBASE AND SNOTBL + I '$D(SNOBASE) S SNOBASE=$NA(^TMP("C0CSNO")) + I '$D(@SNOBASE) S @SNOBASE="" + I '$D(GMRBASE) S GMRBASE=$NA(^GMRD(120.82)) + I '$D(SNOTBL) S SNOTBL=$NA(^TMP("C0CSNO","SNOTBL","TABLE")) ; ATTR TABLE + S ^TMP("C0CSNO","TABLES","SNOTBL")=SNOTBL ; TABLE OF TABLES + Q + ; +AINIT ; INITIALIZE ATTRIBUTE TABLE + I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS + K @SNOTBL + D APUSH^C0CRIMA(SNOTBL,"CODE") + D APUSH^C0CRIMA(SNOTBL,"NOCODE") + D APUSH^C0CRIMA(SNOTBL,"MULTICODE") + D APUSH^C0CRIMA(SNOTBL,"SUBMULTI") + D APUSH^C0CRIMA(SNOTBL,"DONE") + Q +APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL + ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING + ; PTBL IS THE NAME OF A TABLE IN @SNOBASE@("TABLES") - "SNOTBL"=ALL VALUES + ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) + I '$D(SNOBASE) D ASETUP ; FOR COMMANDLINE PROCESSING + N USETBL + I '$D(@SNOBASE@("TABLES",PTBL)) D Q ; NO TABLE + . W "ERROR NO SUCH TABLE",! + S USETBL=@SNOBASE@("TABLES",PTBL) + S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL + Q +SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS + N SBASE,SATTR + S SBASE=$NA(@SNOBASE@("VARS",SDFN)) + D APOST("SATTR","SNOTBL","DONE") + I $P(TTMP,"^",1)=1 D APOST("SATTR","SNOTBL","CODE") + I $P(TTMP,"^",1)=-1 D APOST("SATTR","SNOTBL","NOCODE") + Q SATTR ; C0C + I $D(@SBASE@("PROBLEMS",1)) D ; + . D APOST("SATTR","SNOTBL","PROBLEMS") + . ; W "POSTING PROBLEMS",! + I $D(@SBASE@("VITALS",1)) D APOST("SATTR","SNOTBL","VITALS") + I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES + . D APOST("SATTR","SNOTBL","MEDS") + . N ZR,ZI + . D GETPA^C0CRIMA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES + . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN + . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS + . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","SNOTBL","MEDSCODE") ;CODES + . ; D PATD^C0CSNOA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES + D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED + ; W "ATTRIBUTES: ",SATTR,! + Q SATTR + ; +RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES + K ^TMP("C0CSNO","RESUME") + K ^TMP("C0CSNO") + Q + ; +CLIST ; LIST THE CATEGORIES + ; + I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS + N CLBASE,CLNUM,ZI,CLIDX + S CLBASE=$NA(@SNOBASE@("SNOTBL","CATS")) + S CLNUM=@CLBASE@(0) + F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES + . S CLIDX=@CLBASE@(ZI) + . W "(",$P(@CLBASE@(CLIDX),"^",1) + . W ":",$P(@CLBASE@(CLIDX),"^",2),") " + . W CLIDX,! + ; D PARY^C0CXPATH(CLBASE) + Q + ; +CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES + ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT + ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE + ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME + ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, + ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" + ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES + ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY + ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING + ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY + ; NUMBER IE CTBL_X(CDFN)="" + ; + ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST + S CCTBL=$NA(@CBASE@(CTBL,"CATS")) + ; W "CBASE: ",CCTBL,! + ; + I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY + . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY + . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY + . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT + . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY + . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME + . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 + ; + S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY + S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT + S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK + ; + S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED + ; + S CPATLIST=$NA(@CBASE@(CTBL,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT + ; W "IENS BASE: ",CPATLIST,! + S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST + ; + Q + ; +REUSE ; GET SAVED VALUES FROM ^TMP("C0CSAV") AND PUT THEM IN A DATABASE + ; + D ASETUP + D AINIT + N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH + S SAVBASE=$NA(^TMP("C0CSAV","VARS")) + S SNOI="" + F D Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST + . S SNOI=$O(@SAVBASE@(SNOI)) + . S SNOJ=@SAVBASE@(SNOI) + . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1) + . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE + . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON + . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE + . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE + . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE + . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,! + . W SNOK,! + . W SNOJ,! + Q + ; Index: ccr/branches/ohum/p/C0CSOAP.m =================================================================== --- ccr/branches/ohum/p/C0CSOAP.m (revision 1332) +++ ccr/branches/ohum/p/C0CSOAP.m (revision 1333) @@ -1,4 +1,4 @@ C0CSOAP ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU ;General Public License See attached copy of the License. Index: ccr/branches/ohum/p/C0CSUB1.m =================================================================== --- ccr/branches/ohum/p/C0CSUB1.m (revision 1332) +++ ccr/branches/ohum/p/C0CSUB1.m (revision 1333) @@ -1,4 +1,4 @@ C0CSUB1 ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU ;General Public License See attached copy of the License. Index: ccr/branches/ohum/p/C0CSYS.m =================================================================== --- ccr/branches/ohum/p/C0CSYS.m (revision 1332) +++ ccr/branches/ohum/p/C0CSYS.m (revision 1333) @@ -1,4 +1,4 @@ C0CSYS ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU ; General Public License See attached copy of the License. Index: ccr/branches/ohum/p/C0CUNIT.m =================================================================== --- ccr/branches/ohum/p/C0CUNIT.m (revision 1332) +++ ccr/branches/ohum/p/C0CUNIT.m (revision 1333) @@ -1,4 +1,4 @@ C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU ;General Public License See attached copy of the License. Index: ccr/branches/ohum/p/C0CUTIL.m =================================================================== --- ccr/branches/ohum/p/C0CUTIL.m (revision 1332) +++ ccr/branches/ohum/p/C0CUTIL.m (revision 1333) @@ -1,4 +1,4 @@ C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08 - ;;0.1;C0C;;Jun 15, 2008;Build 38 + ;;0.1;C0C;;Jun 15, 2008;Build 1 ;Copyright 2008-2009 Sam Habiel & George Lilly. ;Licensed under the terms of the GNU @@ -136,33 +136,33 @@ ; RXNFN() Q 1130590011.001 ; RxNorm Concepts file number - ; -CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF - ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR - N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT - I $G(ZVUID)="" Q "" - I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED - N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID") - S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES - N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01) - S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED - I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F" - Q ZRSLT - ; -NISTMAP(ZRXN) ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO - ; CONFORM TO NIST REQUIREMENTS - ;INPATIENT CERTIFICATION - I ZRXN=309362 S ZRXN=213169 - I ZRXN=855318 S ZRXN=855320 - I ZRXN=197361 S ZRXN=212549 - ;OUTPATIENT CERTIFICATION - I ZRXN=310534 S ZRXN=205875 - I ZRXN=617312 S ZRXN=617314 - I ZRXN=310429 S ZRXN=200801 - I ZRXN=628953 S ZRXN=628958 - I ZRXN=745679 S ZRXN=630208 - I ZRXN=311564 S ZRXN=979334 - I ZRXN=836343 S ZRXN=836370 - Q ZRXN - ; + ; +CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF + ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR + N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT + I $G(ZVUID)="" Q "" + I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED + N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID") + S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES + N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01) + S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED + I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F" + Q ZRSLT + ; +NISTMAP(ZRXN) ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO + ; CONFORM TO NIST REQUIREMENTS + ;INPATIENT CERTIFICATION + I ZRXN=309362 S ZRXN=213169 + I ZRXN=855318 S ZRXN=855320 + I ZRXN=197361 S ZRXN=212549 + ;OUTPATIENT CERTIFICATION + I ZRXN=310534 S ZRXN=205875 + I ZRXN=617312 S ZRXN=617314 + I ZRXN=310429 S ZRXN=200801 + I ZRXN=628953 S ZRXN=628958 + I ZRXN=745679 S ZRXN=630208 + I ZRXN=311564 S ZRXN=979334 + I ZRXN=836343 S ZRXN=836370 + Q ZRXN + ; RPMS() ; Are we running on an RPMS system rather than Vista? Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service Index: ccr/branches/ohum/p/C0CVA200.m =================================================================== --- ccr/branches/ohum/p/C0CVA200.m (revision 1332) +++ ccr/branches/ohum/p/C0CVA200.m (revision 1333) @@ -1,4 +1,4 @@ C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008 Sam Habiel. Licensed under the terms of the GNU ;General Public License See attached copy of the License. Index: ccr/branches/ohum/p/C0CVIT2.m =================================================================== --- ccr/branches/ohum/p/C0CVIT2.m (revision 1332) +++ ccr/branches/ohum/p/C0CVIT2.m (revision 1333) @@ -1,4 +1,4 @@ C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 - ;;1.0;C0C;;Feb 16, 2010;Build 38 + ;;1.0;C0C;;Feb 16, 2010;Build 1 ;Copyright 2008,2009 George Lilly, University of Minnesota and others. ;Licensed under the terms of the GNU General Public License. Index: ccr/branches/ohum/p/C0CVITAL.m =================================================================== --- ccr/branches/ohum/p/C0CVITAL.m (revision 1332) +++ ccr/branches/ohum/p/C0CVITAL.m (revision 1333) @@ -1,4 +1,4 @@ C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008,2009 George Lilly, University of Minnesota and others. ;Licensed under the terms of the GNU General Public License. @@ -72,8 +72,8 @@ . . I DEBUG W $P(VITPTMP,U,4),! . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID - . . ;B ;gpl - . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6) - . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; - . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" + . . ;B ;gpl + . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6) + . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" . . I $P(VITPTMP,U,2)="HT" D . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" @@ -203,6 +203,6 @@ . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN" - . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; - . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ; + . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; + . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ; . . S VITARYTMP=$NA(@VITTARYTMP@(J)) . . K @VITARYTMP Index: ccr/branches/ohum/p/C0CVOBX1.m =================================================================== --- ccr/branches/ohum/p/C0CVOBX1.m (revision 1332) +++ ccr/branches/ohum/p/C0CVOBX1.m (revision 1333) @@ -1,22 +1,22 @@ -LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09 - ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994 - ; JMC - mods to check for IHS V LAB file - ; -CH ; Observation/Result segment for "CH" subscript results. - ; Called by LA7VOBX - ; - N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X - ; - ; "CH" subscript requires a dataname - I '$G(LRSB) Q - ; - ; get result node from LR global. - S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) - S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB)) - ; - ; Check if test is OK to send - (O)utput or (B)oth - S LA7X=$P(LA7VAL,"^",12) - I LA7X]"","BO"'[LA7X Q - I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q +LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09 + ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994;Build 1 + ; JMC - mods to check for IHS V LAB file + ; +CH ; Observation/Result segment for "CH" subscript results. + ; Called by LA7VOBX + ; + N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X + ; + ; "CH" subscript requires a dataname + I '$G(LRSB) Q + ; + ; get result node from LR global. + S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) + S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB)) + ; + ; Check if test is OK to send - (O)utput or (B)oth + S LA7X=$P(LA7VAL,"^",12) + I LA7X]"","BO"'[LA7X Q + I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q ; ; If no result NLT or LOINC try to determine from file #60 @@ -27,88 +27,88 @@ I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5)) ; No result NLT code - log error - I $P($P(LA7VAL,"^",3),"!",2)="" D - . N LA7X - . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL") - . D CREATE^LA7LOG(36) - ; - ; something missing - No NLT code, etc. - I LA7VAL="" Q - ; - ; Check for missing units/reference ranges - S LA7X=$P(LA7VAL,"^",5) - ; - ; Results missing units, lookup in file #60 - I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3) - ; - ; If results missing reference ranges, use values from file #60. - I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D - . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)) - . S $P(LA7X,"!",2)=$P(LA7Y,"^") - . S $P(LA7X,"!",3)=$P(LA7Y,"^",2) - . S $P(LA7X,"!",11)=$P(LA7Y,"^",6) - . S $P(LA7X,"!",12)=$P(LA7Y,"^",7) - ; Use therapeutic low/high if low/high missing. - I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D - . S $P(LA7X,"!",2)=$P(LA7X,"!",11) - . S $P(LA7X,"!",3)=$P(LA7X,"!",12) - ; - ; Evaluate low/high reference ranges in case M code in these fields. - S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99 - F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D - . S @("X="_$P(LA7X,"!",LA7I)) - . S $P(LA7X,"!",LA7I)=X - ; - ; Put units/reference ranges back in variable LA7VAL - S $P(LA7VAL,"^",5)=LA7X - ; - ; Initialize OBX segment - S LA7OBX(0)="OBX" - S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN) - ; - ; Value type - S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB) - ; - ; Observation identifer - ; build alternate code based on dataname from file #63 in case it's needed - S LA7X=$P(LA7VAL,"^",3) - S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63" - S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH) - ; - ; Test value - S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH) - ; - ; Units - remove leading and trailing spaces - S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ") - S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH) - ; - ; Reference range - S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH) - ; - ; Abnormal flags - S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2)) - ; - ; "P"artial or "F"inal results - S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F")) - ; - ; Observation date/time - collection date/time per HL7 standard - I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^")) - ; - S LA7DIV=$P(LA7VAL,"^",9) - I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0)) - ; - ; Facility that performed the testing - S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH) - ; - ; Person that verified the test - S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH) - ; - ; Observation method - S LA7X=$P($P(LA7VAL,"^",3),"!",4) - I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH) - ; - ; Equipment entity identifier - I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH) - ; - D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS) - ; - Q + I $P($P(LA7VAL,"^",3),"!",2)="" D + . N LA7X + . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL") + . D CREATE^LA7LOG(36) + ; + ; something missing - No NLT code, etc. + I LA7VAL="" Q + ; + ; Check for missing units/reference ranges + S LA7X=$P(LA7VAL,"^",5) + ; + ; Results missing units, lookup in file #60 + I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3) + ; + ; If results missing reference ranges, use values from file #60. + I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D + . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)) + . S $P(LA7X,"!",2)=$P(LA7Y,"^") + . S $P(LA7X,"!",3)=$P(LA7Y,"^",2) + . S $P(LA7X,"!",11)=$P(LA7Y,"^",6) + . S $P(LA7X,"!",12)=$P(LA7Y,"^",7) + ; Use therapeutic low/high if low/high missing. + I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D + . S $P(LA7X,"!",2)=$P(LA7X,"!",11) + . S $P(LA7X,"!",3)=$P(LA7X,"!",12) + ; + ; Evaluate low/high reference ranges in case M code in these fields. + S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99 + F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D + . S @("X="_$P(LA7X,"!",LA7I)) + . S $P(LA7X,"!",LA7I)=X + ; + ; Put units/reference ranges back in variable LA7VAL + S $P(LA7VAL,"^",5)=LA7X + ; + ; Initialize OBX segment + S LA7OBX(0)="OBX" + S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN) + ; + ; Value type + S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB) + ; + ; Observation identifer + ; build alternate code based on dataname from file #63 in case it's needed + S LA7X=$P(LA7VAL,"^",3) + S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63" + S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH) + ; + ; Test value + S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH) + ; + ; Units - remove leading and trailing spaces + S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ") + S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH) + ; + ; Reference range + S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH) + ; + ; Abnormal flags + S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2)) + ; + ; "P"artial or "F"inal results + S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F")) + ; + ; Observation date/time - collection date/time per HL7 standard + I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^")) + ; + S LA7DIV=$P(LA7VAL,"^",9) + I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0)) + ; + ; Facility that performed the testing + S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH) + ; + ; Person that verified the test + S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH) + ; + ; Observation method + S LA7X=$P($P(LA7VAL,"^",3),"!",4) + I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH) + ; + ; Equipment entity identifier + I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH) + ; + D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS) + ; + Q Index: ccr/branches/ohum/p/C0CVORU.m =================================================================== --- ccr/branches/ohum/p/C0CVORU.m (revision 1332) +++ ccr/branches/ohum/p/C0CVORU.m (revision 1333) @@ -1,274 +1,274 @@ -C0C7VORU ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009 - ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994 - ; -EN(LA) ; called from C0CVLAB - ; variables - ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68) - ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4) - ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68) - ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64) - ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64) - ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time) - ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60) - ; LA("LRDFN") - IEN in LAB DATA file (#63) - ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results. - ; LA("AUTO-INST") - Auto-Instrument - ; - N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY - ; - S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")="" - I $G(PRIMARY)'="" D - . S PRIMARY=$$SITE^VASITE(DT,PRIMARY) - . S PRIMARY=$P(PRIMARY,U,3) - . S LA("AUTO-INST")="LA7V HOST "_PRIMARY - ; - I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D Q - . ; need to add error logging when no entry in 63. - ; - ; Get zeroth node of entry in #63. - S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) - S LA7NLT=$G(LA("NLT")) - ; - S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE")) - S LA7NTESN=0 - D ORC - ; - I $G(LA("SUB"))="CH" D CH - ;I $G(LA("SUB"))="MI" D MI^LA7VORU1 - ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2 - Q - ; - ; -CH ; Build segments for "CH" subscript - ; - D OBR - D NTE - S LA7OBXSN=0 - D OBX - ; - Q - ; - ; -ORC ; Build ORC segment - ; - N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC - ; - S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) - ; - S ORC(0)="ORC" - ; - ; Order control - S ORC(1)=$$ORC1^LA7VORC("RE") - ; - ; Remote UID - S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH) - ; - ; Host UID - S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH) - ; - ; Return shipping manifest if found - S LA7SM="",LA7696=0 - I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0)) - I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14) - I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH) - ; - ; Order status - ; DoD/CHCS requires ORC-5 valued otherwise will not process message - I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH) - ; - ; Ordering provider - S (LA7X,LA7Y)="" - ; "CH" subscript stores requesting provider and requesting div/location. - I LA("SUB")="CH" D - . N LA7J - . S LA7J=$P(LA763(0),"^",13) - . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") - . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") - . S LA7X=$P(LA763(0),"^",10) - ; - ; Other subscripts only store requesting provider - I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) - ; Get default institution from MailMan Site Parameters file - I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") - S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) - ; - ; Entering organization - S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH) - ; - D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS) - D FILESEG^LA7VHLU(GBL,.LA7DATA) - ; - ; Check for flag to only build message but do not file - I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA) - ; - Q - ; - ; -OBR ;Observation Request segment for Lab Order - ; - N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR - ; - ; Retrieve placer's OBR information stored in #69.6 - D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR) - ; - ; Initialize OBR segment - S OBR(0)="OBR" - S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN) - ; - ; Remote UID - S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH) - ; - ; Host UID - S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH) - ; - ; Universal service ID, build from info stored in #69.6 - S LA7X="" - I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH) - E S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH) - ; - ; Collection D/T - S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U)) - ; - ; Specimen action code - ; If no OBR from PENDING ORDER file (#69.6) then assume added test. - I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A") - ; - ; Infection Warning - S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH) - ; - ; Lab Arrival Time - ; "CH" subscript does not store lab arrival time, use collection time. - ; Other subscripts do store lab arrival time (date/time received). - I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10)) - I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^")) - ; - ; Specimen source - S (LA761,LA762)="" - I "CHMI"[LA("SUB") D - . S LA761=$P(LA763(0),U,5) - . I LA761="" D CREATE^LA7LOG(27) - . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11) - S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH) - ; - ; Ordering provider - S (LA7X,LA7Y)="" - ; "CH" subscript stores requesting provider and requesting div/location. - I LA("SUB")="CH" D - . N LA7J - . S LA7J=$P(LA763(0),"^",13) - . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") - . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") - . S LA7X=$P(LA763(0),"^",10) - ; - ; Other subscripts only store requesting provider - I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) - ; Get default institution from MailMan Site Parameters file - I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") - S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) - ; - ; Placer Field #1 (remote auto-inst) - ; Build from info stored in #69.6 - I $G(LA7PLOBR("OBR-18"))'="" D - . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH) - ; Else build "auto instrument" if sending to VA facility - I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D - . N LA7X - . S LA7X(1)=LA("AUTO-INST") - . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH) - ; - ; Placer Field #2 - I $G(LA7PLOBR("OBR-19"))'="" D - . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH) - ; Else build collecting UID if sending to VA facility - I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D - . K LA7X - . S LA7X(7)=LA("RUID") - . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH) - ; - ; Filler Field #1 - ; Send file #63 ien info - used by HDR to track patient/specimen - K LA7X - S LA7X(1)=LA("LRDFN") - S LA7X(2)=LA("SUB") - S LA7X(3)=LA("LRIDT") - S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH) - ; - ; Date Report Completed - I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3)) - ; - ; Diagnostic service id - S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB)) - ; - ; Parent Result and Parent - I $D(LA7PARNT) D - . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH) - . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH) - ; - ; Principle result interpreter - ; Get default institution from MailMan Site Parameters file - I "CYEMMISP"[LA("SUB") D - . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4) - . E S LA7X=$P(LA763(0),"^",2) - . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") - . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) - ; - ; Assistant result interpreter - ; Get default institution from MailMan Site Parameters file - I "EMSP"[LA("SUB") D - . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") - . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) - ; - ; Technician - ; Get default institution from MailMan Site Parameters file - I "CYEM"[LA("SUB") D - . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") - . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) - ; - ; Typist - VistA stores as free text - ; Get default institution from MailMan Site Parameters file - I "CYEMSP"[LA("SUB") D - . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") - . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) - ; - D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS) - D FILESEG^LA7VHLU(GBL,.LA7DATA) - ; - ; Check for flag to only build message but do not file - I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) - ; - Q - ; - ; -OBX ;Observation/Result segment for Lab Results - ; - N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X - ; - S LA7VTIEN=0 - F S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN D - . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2) - . ; Build OBX segment - . K LA7DATA - . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF)) - . ; If OBX failed to build then don't store - . I '$D(LA7DATA) Q - . ; - . D FILESEG^LA7VHLU(GBL,.LA7DATA) - . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) - . ; - . ; Send performing lab comment and interpretation from file #60 - . S LA7NTESN=0 - . I LA7NVAF=1 D PLC^LA7VORUA - . D INTRP^LA7VORUA - . ; - . ; Mark result as sent - set to 1, if corrected results set to 2 - . I LA("SUB")="CH" D - . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q - . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1) - ; - Q - ; - ; -NTE ; Build NTE segment - ; - D NTE^LA7VORUA - Q +C0C7VORU ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009 + ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994;Build 1 + ; +EN(LA) ; called from C0CVLAB + ; variables + ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68) + ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4) + ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68) + ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64) + ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64) + ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time) + ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60) + ; LA("LRDFN") - IEN in LAB DATA file (#63) + ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results. + ; LA("AUTO-INST") - Auto-Instrument + ; + N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY + ; + S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")="" + I $G(PRIMARY)'="" D + . S PRIMARY=$$SITE^VASITE(DT,PRIMARY) + . S PRIMARY=$P(PRIMARY,U,3) + . S LA("AUTO-INST")="LA7V HOST "_PRIMARY + ; + I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D Q + . ; need to add error logging when no entry in 63. + ; + ; Get zeroth node of entry in #63. + S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) + S LA7NLT=$G(LA("NLT")) + ; + S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE")) + S LA7NTESN=0 + D ORC + ; + I $G(LA("SUB"))="CH" D CH + ;I $G(LA("SUB"))="MI" D MI^LA7VORU1 + ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2 + Q + ; + ; +CH ; Build segments for "CH" subscript + ; + D OBR + D NTE + S LA7OBXSN=0 + D OBX + ; + Q + ; + ; +ORC ; Build ORC segment + ; + N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC + ; + S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) + ; + S ORC(0)="ORC" + ; + ; Order control + S ORC(1)=$$ORC1^LA7VORC("RE") + ; + ; Remote UID + S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH) + ; + ; Host UID + S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH) + ; + ; Return shipping manifest if found + S LA7SM="",LA7696=0 + I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0)) + I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14) + I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH) + ; + ; Order status + ; DoD/CHCS requires ORC-5 valued otherwise will not process message + I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH) + ; + ; Ordering provider + S (LA7X,LA7Y)="" + ; "CH" subscript stores requesting provider and requesting div/location. + I LA("SUB")="CH" D + . N LA7J + . S LA7J=$P(LA763(0),"^",13) + . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") + . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") + . S LA7X=$P(LA763(0),"^",10) + ; + ; Other subscripts only store requesting provider + I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) + ; Get default institution from MailMan Site Parameters file + I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") + S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) + ; + ; Entering organization + S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH) + ; + D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS) + D FILESEG^LA7VHLU(GBL,.LA7DATA) + ; + ; Check for flag to only build message but do not file + I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA) + ; + Q + ; + ; +OBR ;Observation Request segment for Lab Order + ; + N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR + ; + ; Retrieve placer's OBR information stored in #69.6 + D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR) + ; + ; Initialize OBR segment + S OBR(0)="OBR" + S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN) + ; + ; Remote UID + S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH) + ; + ; Host UID + S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH) + ; + ; Universal service ID, build from info stored in #69.6 + S LA7X="" + I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH) + E S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH) + ; + ; Collection D/T + S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U)) + ; + ; Specimen action code + ; If no OBR from PENDING ORDER file (#69.6) then assume added test. + I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A") + ; + ; Infection Warning + S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH) + ; + ; Lab Arrival Time + ; "CH" subscript does not store lab arrival time, use collection time. + ; Other subscripts do store lab arrival time (date/time received). + I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10)) + I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^")) + ; + ; Specimen source + S (LA761,LA762)="" + I "CHMI"[LA("SUB") D + . S LA761=$P(LA763(0),U,5) + . I LA761="" D CREATE^LA7LOG(27) + . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11) + S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH) + ; + ; Ordering provider + S (LA7X,LA7Y)="" + ; "CH" subscript stores requesting provider and requesting div/location. + I LA("SUB")="CH" D + . N LA7J + . S LA7J=$P(LA763(0),"^",13) + . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") + . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") + . S LA7X=$P(LA763(0),"^",10) + ; + ; Other subscripts only store requesting provider + I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) + ; Get default institution from MailMan Site Parameters file + I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") + S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) + ; + ; Placer Field #1 (remote auto-inst) + ; Build from info stored in #69.6 + I $G(LA7PLOBR("OBR-18"))'="" D + . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH) + ; Else build "auto instrument" if sending to VA facility + I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D + . N LA7X + . S LA7X(1)=LA("AUTO-INST") + . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH) + ; + ; Placer Field #2 + I $G(LA7PLOBR("OBR-19"))'="" D + . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH) + ; Else build collecting UID if sending to VA facility + I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D + . K LA7X + . S LA7X(7)=LA("RUID") + . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH) + ; + ; Filler Field #1 + ; Send file #63 ien info - used by HDR to track patient/specimen + K LA7X + S LA7X(1)=LA("LRDFN") + S LA7X(2)=LA("SUB") + S LA7X(3)=LA("LRIDT") + S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH) + ; + ; Date Report Completed + I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3)) + ; + ; Diagnostic service id + S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB)) + ; + ; Parent Result and Parent + I $D(LA7PARNT) D + . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH) + . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH) + ; + ; Principle result interpreter + ; Get default institution from MailMan Site Parameters file + I "CYEMMISP"[LA("SUB") D + . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4) + . E S LA7X=$P(LA763(0),"^",2) + . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") + . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) + ; + ; Assistant result interpreter + ; Get default institution from MailMan Site Parameters file + I "EMSP"[LA("SUB") D + . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") + . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) + ; + ; Technician + ; Get default institution from MailMan Site Parameters file + I "CYEM"[LA("SUB") D + . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") + . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) + ; + ; Typist - VistA stores as free text + ; Get default institution from MailMan Site Parameters file + I "CYEMSP"[LA("SUB") D + . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") + . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) + ; + D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS) + D FILESEG^LA7VHLU(GBL,.LA7DATA) + ; + ; Check for flag to only build message but do not file + I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) + ; + Q + ; + ; +OBX ;Observation/Result segment for Lab Results + ; + N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X + ; + S LA7VTIEN=0 + F S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN D + . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2) + . ; Build OBX segment + . K LA7DATA + . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF)) + . ; If OBX failed to build then don't store + . I '$D(LA7DATA) Q + . ; + . D FILESEG^LA7VHLU(GBL,.LA7DATA) + . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) + . ; + . ; Send performing lab comment and interpretation from file #60 + . S LA7NTESN=0 + . I LA7NVAF=1 D PLC^LA7VORUA + . D INTRP^LA7VORUA + . ; + . ; Mark result as sent - set to 1, if corrected results set to 2 + . I LA("SUB")="CH" D + . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q + . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1) + ; + Q + ; + ; +NTE ; Build NTE segment + ; + D NTE^LA7VORUA + Q Index: ccr/branches/ohum/p/C0CXEWD.m =================================================================== --- ccr/branches/ohum/p/C0CXEWD.m (revision 1332) +++ ccr/branches/ohum/p/C0CXEWD.m (revision 1333) @@ -1,126 +1,126 @@ -C0CXEWD ; C0C/GPL - EWD based XPath utilities; 10/11/09 - ;;0.1;C0C;nopatch;noreleasedate - ;Copyright 2009 George Lilly. Licensed under the terms of the GNU - ;General Public License See attached copy of the License. - ; - ;This program is free software; you can redistribute it and/or modify - ;it under the terms of the GNU General Public License as published by - ;the Free Software Foundation; either version 2 of the License, or - ;(at your option) any later version. - ; - ;This program is distributed in the hope that it will be useful, - ;but WITHOUT ANY WARRANTY; without even the implied warranty of - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;GNU General Public License for more details. - ; - ;You should have received a copy of the GNU General Public License along - ;with this program; if not, write to the Free Software Foundation, Inc., - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - ; - Q - ; -TEST ; - D XPATH($$FIRST($$ID("CCR1")),"/","GIDX","GARY") - Q - ; -TEST2 ; - S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail" - D XPATH($$FIRST($$ID("gpl")),"/","GIDX","GARY","",REDUX) - Q - ; -XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE - ; THE XPATH INDEX ZXIDX, PASSED BY NAME - ; THE XPATH ARRAY XPARY, PASSED BY NAME - ; ZOID IS THE STARTING OID - ; ZPATH IS THE STARTING XPATH, USUALLY "/" - ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE - ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT - I '$D(ZREDUX) S ZREDUX="" - N NEWPATH - N NEWNUM S NEWNUM="" - I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" - S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE - I $G(ZREDUX)'="" D ; REDUX PROVIDED? - . N GT S GT=$P(NEWPATH,ZREDUX,2) - . I GT'="" S NEWPATH=GT - S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX - N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE - I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY - E I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY - I GD'="" S @ZXPARY@(NEWPATH)=GD ; IF YES, ADD IT TO THE XPATH ARRAY - N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD - I ZFRST'="" D ; THERE IS A CHILD - . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE - . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD - N GNXT S GNXT=$$NXTSIB(ZOID) - I GNXT'="" D ; MOVE ON TO THE NEXT SIBLING - . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB - Q - ; -PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME - ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD - ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD - N ZR - M ^CacheTempEWD($j)=@INXML ; - S ZR=$$parseDocument^%zewdHTMLParser(INDOC) - Q ZR - ; -ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE - N ZN - S ZN=$$NXTSIB(ZOID) - I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG - Q 0 - ; -DETAIL(ZRTN,ZOID) ; RETURNS DETAIL FOR NODE ZOID IN ZRTN, PASSED BY NAME - N DET - D getElementDetails^%zewdXPath(ZOID,.DET) - M @ZRTN=DET - Q - ; -ID(ZNAME) ;RETURNS THE docOID OF THE DOCUMENT NAMED ZNAME - Q $$getDocumentNode^%zewdDOM(ZNAME) - ; -NAME(ZOID) ;RETURNS THE NAME OF THE DOCUMENAT WITH docOID ZOID - Q $$getDocumentName^%zewdDOM(ZOID) - ; -FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID - N GOID - S GOID=ZOID - S GOID=$$getFirstChild^%zewdDOM(GOID) - I GOID="" Q "" - I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID) - Q GOID - ; -HASCHILD(ZOID) ; RETURNS TRUE IF ZOID HAS CHILD NODES - Q $$hasChildNodes^%zewdDOM(ZOID) - ; -CHILDREN(ZRTN,ZOID) ;RETURNS CHILDREN OF ZOID IN ARRAY ZRTN, PASSED BY NAME - N childArray - d getChildrenInOrder^%zewdDOM(ZOID,.childArray) - m @ZRTN=childArray - q - ; -TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE - Q $$getName^%zewdDOM(ZOID) - ; -NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING - Q $$getNextSibling^%zewdDOM(ZOID) - ; -NXTCHLD(ZOID) ; RETURNS THE NEXT CHILD IN PARENT ZPAR - N GOID - S GOID=$$getNextChild^%zewdDOM($$PARENT(ZOID),ZOID) - I GOID="" Q "" - I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID) - Q GOID - ; -PARENT(ZOID) ; RETURNS PARENT OF ZOID - Q $$getParentNode^%zewdDOM(ZOID) - ; -DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE - N ZT2 - S ZT2=$$getElementText^%zewdDOM(ZOID,.ZT2) - M @ZT=ZT2 - Q - ;Q $$getTextValue^%zewdXPath(ZOID) - ;Q $$getData^%zewdDOM(ZOID,.ZT) - ; +C0CXEWD ; C0C/GPL - EWD based XPath utilities; 10/11/09 + ;;0.1;C0C;nopatch;noreleasedate;Build 1 + ;Copyright 2009 George Lilly. Licensed under the terms of the GNU + ;General Public License See attached copy of the License. + ; + ;This program is free software; you can redistribute it and/or modify + ;it under the terms of the GNU General Public License as published by + ;the Free Software Foundation; either version 2 of the License, or + ;(at your option) any later version. + ; + ;This program is distributed in the hope that it will be useful, + ;but WITHOUT ANY WARRANTY; without even the implied warranty of + ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;GNU General Public License for more details. + ; + ;You should have received a copy of the GNU General Public License along + ;with this program; if not, write to the Free Software Foundation, Inc., + ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + ; + Q + ; +TEST ; + D XPATH($$FIRST($$ID("CCR1")),"/","GIDX","GARY") + Q + ; +TEST2 ; + S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail" + D XPATH($$FIRST($$ID("gpl")),"/","GIDX","GARY","",REDUX) + Q + ; +XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE + ; THE XPATH INDEX ZXIDX, PASSED BY NAME + ; THE XPATH ARRAY XPARY, PASSED BY NAME + ; ZOID IS THE STARTING OID + ; ZPATH IS THE STARTING XPATH, USUALLY "/" + ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE + ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT + I '$D(ZREDUX) S ZREDUX="" + N NEWPATH + N NEWNUM S NEWNUM="" + I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" + S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE + I $G(ZREDUX)'="" D ; REDUX PROVIDED? + . N GT S GT=$P(NEWPATH,ZREDUX,2) + . I GT'="" S NEWPATH=GT + S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX + N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE + I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY + E I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY + I GD'="" S @ZXPARY@(NEWPATH)=GD ; IF YES, ADD IT TO THE XPATH ARRAY + N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD + I ZFRST'="" D ; THERE IS A CHILD + . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE + . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD + N GNXT S GNXT=$$NXTSIB(ZOID) + I GNXT'="" D ; MOVE ON TO THE NEXT SIBLING + . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB + Q + ; +PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME + ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD + ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD + N ZR + M ^CacheTempEWD($j)=@INXML ; + S ZR=$$parseDocument^%zewdHTMLParser(INDOC) + Q ZR + ; +ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE + N ZN + S ZN=$$NXTSIB(ZOID) + I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG + Q 0 + ; +DETAIL(ZRTN,ZOID) ; RETURNS DETAIL FOR NODE ZOID IN ZRTN, PASSED BY NAME + N DET + D getElementDetails^%zewdXPath(ZOID,.DET) + M @ZRTN=DET + Q + ; +ID(ZNAME) ;RETURNS THE docOID OF THE DOCUMENT NAMED ZNAME + Q $$getDocumentNode^%zewdDOM(ZNAME) + ; +NAME(ZOID) ;RETURNS THE NAME OF THE DOCUMENAT WITH docOID ZOID + Q $$getDocumentName^%zewdDOM(ZOID) + ; +FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID + N GOID + S GOID=ZOID + S GOID=$$getFirstChild^%zewdDOM(GOID) + I GOID="" Q "" + I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID) + Q GOID + ; +HASCHILD(ZOID) ; RETURNS TRUE IF ZOID HAS CHILD NODES + Q $$hasChildNodes^%zewdDOM(ZOID) + ; +CHILDREN(ZRTN,ZOID) ;RETURNS CHILDREN OF ZOID IN ARRAY ZRTN, PASSED BY NAME + N childArray + d getChildrenInOrder^%zewdDOM(ZOID,.childArray) + m @ZRTN=childArray + q + ; +TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE + Q $$getName^%zewdDOM(ZOID) + ; +NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING + Q $$getNextSibling^%zewdDOM(ZOID) + ; +NXTCHLD(ZOID) ; RETURNS THE NEXT CHILD IN PARENT ZPAR + N GOID + S GOID=$$getNextChild^%zewdDOM($$PARENT(ZOID),ZOID) + I GOID="" Q "" + I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID) + Q GOID + ; +PARENT(ZOID) ; RETURNS PARENT OF ZOID + Q $$getParentNode^%zewdDOM(ZOID) + ; +DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE + N ZT2 + S ZT2=$$getElementText^%zewdDOM(ZOID,.ZT2) + M @ZT=ZT2 + Q + ;Q $$getTextValue^%zewdXPath(ZOID) + ;Q $$getData^%zewdDOM(ZOID,.ZT) + ; Index: ccr/branches/ohum/p/C0CXPAT0.m =================================================================== --- ccr/branches/ohum/p/C0CXPAT0.m (revision 1332) +++ ccr/branches/ohum/p/C0CXPAT0.m (revision 1333) @@ -1,4 +1,4 @@ C0CXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU ;General Public License See attached copy of the License. Index: ccr/branches/ohum/p/C0CXPATH.m =================================================================== --- ccr/branches/ohum/p/C0CXPATH.m (revision 1332) +++ ccr/branches/ohum/p/C0CXPATH.m (revision 1333) @@ -1,4 +1,4 @@ C0CXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 - ;;1.0;C0C;;May 19, 2009;Build 38 + ;;1.0;C0C;;May 19, 2009;Build 1 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU ;General Public License See attached copy of the License.