- Timestamp:
- Jan 4, 2012, 12:05:49 AM (13 years ago)
- Location:
- ccr/branches/ohum/p
- Files:
-
- 70 edited
Legend:
- Unmodified
- Added
- Removed
-
ccr/branches/ohum/p/C0CACTOR.m
r1332 r1333 1 1 C0CACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CALERT.m
r1332 r1333 1 1 C0CALERT ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota and others. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CBAT.m
r1332 r1333 1 1 C0CBAT ; CCDCCR/GPL - CCR Batch utilities; 4/21/09 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CCCD.m
r1332 r1333 1 1 C0CCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CCCD1.m
r1332 r1333 1 1 C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CCCR.m
r1332 r1333 1 1 C0CCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. … … 26 26 I Y<1 Q ; EXIT 27 27 S DFN=$P(Y,U,1) ; SET THE PATIENT 28 ;OHUM/RUT 3120102 To take inputs from user for date limits and notes 29 D ^C0CVALID 30 ;OHUM/RUT 28 31 D XPAT(DFN) ; EXPORT TO A FILE 29 32 Q … … 168 171 ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") 169 172 ; gpl - turned off Encounters for Certification 173 ;OHUM/RUT 3111228 Condition for Notes ; It should be included or not 174 I ^TMP("C0CCCR","TIULIMIT")'="" D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") 175 ;OHUM/RUT 170 176 Q 171 177 ; -
ccr/branches/ohum/p/C0CCCR0.m
r1332 r1333 1 1 C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CCMT.m
r1332 r1333 1 1 C0CCMT ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10 2 ;;1.0;C0C;;May 21, 2010;Build 382 ;;1.0;C0C;;May 21, 2010;Build 1 3 3 ;Copyright 2010 George Lilly, University of Minnesota and others. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CCPT.m
r1332 r1333 1 1 C0CCPT ;;BSL;RETURN CPT DATA; 2 ;Sequence Managers Software GPL;;;;;Build 382 ;Sequence Managers Software GPL;;;;;Build 1 3 3 ;Copied into C0C namespace from SQMCPT with permission from 4 4 ;Brian Lord - and with our thanks. gpl 01/20/2010 … … 19 19 ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE 20 20 ;GET DATE OF NOTE 21 ;OHUM/RUT 3111228 Date Range for Notes 22 S STDT=^TMP("C0CCCR","TIULIMIT") D NOW^%DTC S ENDDT=X 23 ;OHUM/RUT 21 24 S Z="" 22 25 F S Z=$O(NOTE(Z)) Q:Z="" D -
ccr/branches/ohum/p/C0CDIC.m
r1332 r1333 1 C0CDIC 2 ;;0.1;CCDCCR;nopatch;noreleasedate 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 DIC2CSV 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 GVARS(C0CVARS,C0CT) 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 GXPATH(C0CPVARS,C0CPT) 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 HASHV 86 87 88 89 90 91 92 93 SORTV 94 95 96 97 98 99 100 101 102 103 104 LOAD 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 INIT 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 SETFDA(C0CSN,C0CSV) 183 184 185 186 187 188 189 190 191 192 ZFILE(ZFN,ZTAB) 193 194 195 196 197 ZFIELD(ZFN,ZTAB) 198 199 200 201 202 ZVALUE(ZFN,ZTAB) 203 204 205 206 207 1 C0CDIC ; CCDCCR/GPL - CCR Dictionary utilities; 6/1/08 2 ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 3 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU 4 ;General Public License See attached copy of the License. 5 ; 6 ;This program is free software; you can redistribute it and/or modify 7 ;it under the terms of the GNU General Public License as published by 8 ;the Free Software Foundation; either version 2 of the License, or 9 ;(at your option) any later version. 10 ; 11 ;This program is distributed in the hope that it will be useful, 12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ;GNU General Public License for more details. 15 ; 16 ;You should have received a copy of the GNU General Public License along 17 ;with this program; if not, write to the Free Software Foundation, Inc., 18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 19 ; 20 W "This is the CCR Dictionary Utility Library ",! 21 W ! 22 Q 23 ; 24 DIC2CSV ;OUTPUT THE CCR DICTIONARY TO A CSV FILE 25 ; 26 N ZI 27 S ZI="" 28 S G1=$NA(^TMP($J,"C0CCSV",1)) 29 S G1A=$NA(@G1@("V")) 30 S G2=$NA(^TMP($J,"C0CCSV",2)) 31 D GETN2^C0CRNF(G1,170) ; GET THE MATRIX 32 F S ZI=$O(@G1A@(ZI)) Q:ZI="" D ;FOR EACH ROW IN THE MATRIX 33 . I $G(@G1A@(ZI,"MAPPING METHOD",1))'="" D ; 34 . . W @G1A@(ZI,"MAPPING METHOD",1),! 35 . . ;K @G1A@(ZI,"MAPPING METHOD") 36 . ;W !,ZI,$G(@G1A@(ZI,"MAPPING METHOD",1)) 37 D RNF2CSV^C0CRNF(G2,G1,"VN") ; PREPARE THE CVS FILE 38 K @G1 39 D FILEOUT^C0CRNF(G2,"FILE_"_170_".csv") 40 K @G2 41 Q 42 ; 43 GVARS(C0CVARS,C0CT) ; Get the CCR variables from the CCR template 44 ; and return them in C0CVARS, which is passed by name 45 ; FIRST PIECE OF C0CVARS(x) IS THE VARIABLE NAME, SECOND PIECE 46 ; IS THE LINE NUMBER OF THE VARIABLE IN THE TEMPLATE 47 ; C0CT IS RETURNED AS THE CCR TEMPLATE 48 N C0CTVARS ; ARRAY FOR THE TEMPLATE AND ARRAY FOR THE VARS 49 D LOAD^GPLCCR0(C0CT) ; LOAD THE CCR TEMPLATE 50 D XVARS^GPLXPATH("C0CTVARS",C0CT) ; PULL OUT THE VARS 51 N C0CI,C0CX 52 S @C0CVARS@(0)=C0CTVARS(0) ; SAME COUNT 53 F C0CI=1:1:C0CTVARS(0) D ; FOR EVERY LINE IN THE ARRAY 54 . S C0CX=C0CTVARS(C0CI) ; THE VARIABLE - 3 PIECES, FIRST ONE NULL 55 . S @C0CVARS@(C0CI)=$P(C0CX,"^",2)_"^"_$P(C0CX,"^",3) ; VAR NAME^LINE NUMBER 56 ;D PARY^GPLXPATH("C0CVARS") 57 Q 58 ; 59 GXPATH(C0CPVARS,C0CPT) ; LOAD THE CCR TEMPLATE INTO C0CPT, PULL OUT VARIABLES 60 ; AND THE XPATH TO THE VARIABLES INTO C0CPVARS 61 ; BY INDEXING THE TEMPLATE C0CT AND MATCHING THE XPATH TO THE VARIABLE 62 ; BOTH ARE PASSED BY NAME 63 ; C0CPVARS(x) IS VAR^LINENUM^XPATH SORTED BY LINENUM 64 ; C0CPVARS(0) IS NUMBER OF VARIABLES 65 ; C0CPT(0) IS NUMBER OF LINES IN THE TEMPLATE 66 D GVARS(C0CPVARS,C0CPT) ; GET THE VARIABLES AND LINE NUMBERS 67 ;N C0CTVARS ; HASH TABLE FOR VARIABLE BY LINE NUMBER 68 D HASHV ; PUT THE VARIABLES IN A LINE NUMBER HASH FOR MATCHING TO XPATHS 69 ; NOW GO GET THE XPATH INDEXES 70 D INDEX^GPLXPATH(C0CPT) ; ADD THE XPATH INDEXES TO THE TEMPLATE ARRAY 71 S C0CI="" ; GOING TO LOOP THROUGH THE WHOLE ARRAY LOOKING AT XPATHS 72 F S C0CI=$O(@C0CPT@(C0CI)) Q:C0CI="" D ; VISIT EVERY LINE 73 . I +C0CI'=0 Q ; SKIP EVERYTHING BUT THE XPATH INDEX 74 . I C0CI=0 Q ; SKIP THE ZERO NODE 75 . S C0CX=@C0CPT@(C0CI) ; PULL OUT THE LINE NUMBERS X^Y 76 . S C0CY=$P(C0CX,"^",1) ; STARTING LINE NUMBER 77 . S C0CZ=$P(C0CX,"^",2) ; ENDING LINE NUMBER 78 . I C0CY=C0CZ D ; THIS IS AN XPATH END NODE, HAS A VARIABLE (WE HOPE) 79 . . ; W "FOUND ",C0CI,! 80 . . I $D(C0CTVARS(C0CY)) D ; IF THERE IS A VARIABLE THERE 81 . . . S $P(C0CTVARS(C0CY),"^",3)=C0CI ; INSERT THE XPATH FOR THE VAR 82 D SORTV ; SORT THE ARRAY BY LINE NUMBER 83 Q 84 ; 85 HASHV ; INTERNAL ROUTINE TO PUT VARIABLE NAMES IN A LINE NUMBER HASH 86 ;N C0CI,C0CTVARS,C0CX,C0CY 87 F C0CI=1:1:@C0CPVARS@(0) D ; FOR THE ENTIRE ARRAY 88 . S C0CX=$P(@C0CPVARS@(C0CI),"^",2) ; LINE NUMBER 89 . S C0CY=$P(@C0CPVARS@(C0CI),"^",1) ; VARIABLE NAME 90 . S C0CTVARS(C0CX)=C0CY ; BUILD HASH OF VARIABLES BY LINE NUMBER 91 Q 92 ; 93 SORTV ; INTERNAL ROUTINE TO OUTPUT VARIABLES (AND XPATHS) IN LINE NUMBER ORDER 94 ;N C0CV2 ; SCRACTH SPACE FOR BUILDING SORTED ARRAY 95 S C0CI="" ; 96 F S C0CI=$O(C0CTVARS(C0CI)) Q:C0CI="" D ; BY LINE NUMBER 97 . S C0CX=C0CTVARS(C0CI) ;VARIABLE NAME 98 . S $P(C0CX,"^",2)=C0CI ; LINE NUMBER IS SECOND PIECE 99 . D PUSH^GPLXPATH("C0C2",C0CX) ; PUT ONTO ARRAY 100 K @C0CPVARS 101 M @C0CPVARS=C0C2 102 Q 103 ; 104 LOAD ; LOAD VARIABLE NAMES AND XPATH IN ^C0CDIC(170 105 ; INITIAL LOAD OF THE CCR DICTIONARY 106 ; 107 N C0CDIC,C0CARY,C0CXML,C0CFDA,C0CI 108 S C0CDIC="^C0CDIC(170," ; ROOT OF THE CCR DICTIONARY 109 D GXPATH("C0CARY","C0CXML") ; FETCH THE VARIABLES AND XPATH INTO C0CARY 110 ; C0CXML WILL CONTAIN THE TEMPLATE - NOT NEEDED FOR LOAD 111 D PARY^GPLXPATH("C0CARY") ;TEST 112 F C0CI=1:1:C0CARY(0) D ; LOAD EACH VARIABLE 113 . S C0CFDA(170,"+"_C0CI_",",.01)=$P(C0CARY(C0CI),"^",1) ; VAR NAME 114 . S C0CFDA(170,"+"_C0CI_",",2)=$P(C0CARY(C0CI),"^",3) ; XPATH 115 . D UPDATE^DIE("","C0CFDA") 116 . I $D(^TMP("DIERR",$J)) U $P BREAK 117 . W "LOADING:",C0CI," ",C0CARY(C0CI),! 118 Q 119 ; 120 INIT ; INITIALIZE CCR DICTIONARY BASED ON VARIABLE NAMES 121 ; 122 ; CHEAT SHEET FOR VARIABLE NAMES IN ^C0CDIC(170.xx, 123 ; THIS IS WHAT WILL BE IN C0CA FOR EACH DICTIONARY ENTRY 124 ;G1("CODING")="170^8" 125 ;G1("DATA ELEMENT")="170^7" 126 ;G1("DESCRIPTION")="170^3" 127 ;G1("ID")="170^1" 128 ;G1("M","170^8","CODING")="170.08^.01" 129 ;G1("MAPPING METHOD")="170.08^1" 130 ;G1("SECTION")="170^10" 131 ;G1("SOURCE")="170^4" 132 ;G1("STATUS")="170^9" 133 ;G1("TYPE")="170^6" 134 ;G1("VARIABLE")="170^.01" 135 ;G1("XPATH")="170^2" 136 ; 137 N C0CZA,C0CZX,C0CN,C0CSTAT 138 S C0CZX=0 139 S C0CSTAT=0 ; INIT STATUS SET FLAG 140 F S C0CZX=$O(^C0CDIC(170,C0CZX)) Q:+C0CZX=0 D ; FOR EACH DICT ENTRY 141 . ;W C0CZX,! 142 . K C0CA,C0CN ; CLEAR OUT THE LAST ONE 143 . D GETN1^C0CRNF("C0CA",170,C0CZX,"","ALL") ; GET VARIABLE HASH 144 . ;ZWR C0CA B ; 145 . S C0CN=$$ZVALUE("VARIABLE") ;NAME OF THE VARIABLE 146 . W "VARIABLE: ",C0CN,! 147 . I $E(C0CN,1,5)="ACTOR" D SETFDA("SECTION","ACTORS") ; 148 . I $E(C0CN,1,6)="SOCIAL" D ; 149 . . D SETFDA("SECTION","SOC") ; 150 . . D SETFDA("STATUS","X") ;SOCIAL HISTORY NOT IMPLEMENTED 151 . . S C0CSTAT=1 152 . I $E(C0CN,1,6)="FAMILY" D ; 153 . . D SETFDA("SECTION","FAM") ; 154 . . D SETFDA("STATUS","X") ;FAMILY HISTORY NOT IMPLEMENTED 155 . . S C0CSTAT=1 156 . ;D SETFDA("TYPE","") ;CORRECT FOR TYPE ERRORS 157 . I $E(C0CN,1,5)="ALERT" D SETFDA("SECTION","ALERTS") 158 . I $E(C0CN,1,5)="VITAL" D SETFDA("SECTION","VITALS") 159 . I $E(C0CN,1,7)="PROBLEM" D SETFDA("SECTION","PROBLEMS") 160 . I $E(C0CN,1,10)="RESULTTEST" D SETFDA("SECTION","TEST") 161 . E I $E(C0CN,1,6)="RESULT" D SETFDA("SECTION","LABS") 162 . I C0CN["CODEVALUE" D SETFDA("TYPE","CD") ;CODES 163 . I C0CN["CODEVERSION" D SETFDA("TYPE","CV") ; CODE VERSION 164 . I C0CN["CODINGSYSTEM" D SETFDA("TYPE","CS") ;CODING SYSTEM 165 . I $$ZVALUE("STATUS")=""!'C0CSTAT D SETFDA("STATUS","N") ;BLANK STATUS TO N 166 . I $$ZVALUE("XPATH")["/Medication/Directions/" D ; MEDS DIRECTIONS VAR 167 . . D SETFDA("SECTION","DIR") ; SPECIAL SECTION FOR DIRECTIONS 168 . E I $$ZVALUE("XPATH")["/Medications/Medication/" D ; ALL OTHER MEDS 169 . . D SETFDA("SECTION","MEDS") ; A MEDS VAR 170 . I $E(C0CN,($L(C0CN)-1),$L(C0CN))="ID" D SETFDA("TYPE","ID") ;CATCH THE IDS 171 . I C0CN["DATETIME" D SETFDA("TYPE","DT") ; DATE/TIME VARIABLE 172 . W "VARIABLE: ",C0CZX," ",C0CA("VARIABLE"),! 173 . ;ZWR C0CFDA 174 . I $D(C0CFDA) D ; WE HAVE CHANGES ON THIS VARIABLE 175 . . ;ZWR C0CFDA 176 . . D UPDATE^DIE("","C0CFDA(C0CZX)") 177 . . I $D(^TMP("DIERR",$J)) U $P BREAK 178 . . D CLEAN^DILF ; CLEAN UP 179 . ;ZWR C0CFDA 180 Q 181 ; 182 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 183 ; TO SET TO VALUE C0CSV. 184 ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE 185 ; C0CSN,C0CSV ARE PASSED BY VALUE 186 ; 187 N C0CSI,C0CSJ 188 S C0CSI=$$ZFILE(C0CSN,"C0CA") ; FILE NUMBER 189 S C0CSJ=$$ZFIELD(C0CSN,"C0CA") ; FIELD NUMBER 190 S C0CFDA(C0CZX,C0CSI,C0CZX_",",C0CSJ)=C0CSV 191 Q 192 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 193 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) 194 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 195 I '$D(ZTAB) S ZTAB="C0CA" 196 Q $P(@ZTAB@(ZFN),"^",1) 197 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 198 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) 199 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 200 I '$D(ZTAB) S ZTAB="C0CA" 201 Q $P(@ZTAB@(ZFN),"^",2) 202 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 203 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) 204 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 205 I '$D(ZTAB) S ZTAB="C0CA" 206 Q $P(@ZTAB@(ZFN),"^",3) 207 ; -
ccr/branches/ohum/p/C0CDOM.m
r1332 r1333 1 1 C0CDOM ; GPL - DOM PROCESSING ROUTINES ;6/6/11 17:05 2 ;;0.1;C0C;nopatch;noreleasedate;Build 38 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 2 ;;0.1;C0C;nopatch;noreleasedate;Build 1 3 ;Copyright 2011 George Lilly. Licensed under the terms of the GNU 4 ;General Public License See attached copy of the License. 5 ; 6 ;This program is free software; you can redistribute it and/or modify 7 ;it under the terms of the GNU General Public License as published by 8 ;the Free Software Foundation; either version 2 of the License, or 9 ;(at your option) any later version. 10 ; 11 ;This program is distributed in the hope that it will be useful, 12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ;GNU General Public License for more details. 15 ; 16 ;You should have received a copy of the GNU General Public License along 17 ;with this program; if not, write to the Free Software Foundation, Inc., 18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 19 ; 20 Q 21 ; 22 22 DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 ADDNARY(ZXP,ZVALUE) 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 23 ; THE XPATH INDEX ZXIDX, PASSED BY NAME 24 ; THE XPATH ARRAY XPARY, PASSED BY NAME 25 ; ZOID IS THE STARTING OID 26 ; ZPATH IS THE STARTING XPATH, USUALLY "/" 27 ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE 28 ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT 29 I $G(ZREDUX)="" S ZREDUX="" 30 N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY 31 N NEWNUM S NEWNUM="" 32 I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" 33 S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE 34 I $G(ZREDUX)'="" D ; REDUX PROVIDED? 35 . N GT S GT=$P(NEWPATH,ZREDUX,2) 36 . I GT'="" S NEWPATH=GT 37 S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX 38 N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE 39 I $D(GA) D ; PROCESS THE ATTRIBUTES 40 . N ZI S ZI="" 41 . F S ZI=$O(GA(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE 42 . . N ZP S ZP=NEWPATH_"@"_ZI ; PATH FOR ATTRIBUTE 43 . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY 44 . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE 45 N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE 46 I $D(GD(2)) D ; 47 . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY 48 E I $D(GD(1)) D ; 49 . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY 50 . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY 51 N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD 52 I ZFRST'=0 D ; THERE IS A CHILD 53 . N ZNUM 54 . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE 55 . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD 56 N GNXT S GNXT=$$NXTSIB(ZOID) 57 I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES 58 I GNXT'=0 D ; 59 . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? 60 . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES 61 . . N ZNUM S ZNUM=1 ; 62 . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB 63 . E D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB 64 Q 65 ; 66 ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY 67 ; 68 ; IF ZATT=1 THE ARRAY IS ADDED AS ATTRIBUTES 69 ; 70 N ZZI,ZZJ,ZZN 71 S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY 72 I ZZI="" Q ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE 73 S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY 74 S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH . 75 I ZZI'["]" D ; A SINGLETON 76 . S ZZN=1 77 E D ; THERE IS AN [x] OCCURANCE 78 . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE 79 . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X] 80 I ZZJ'="" D ; TIME TO ADD THE VALUE 81 . S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE 82 Q 83 ; 84 84 PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME 85 86 87 88 89 85 ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW 86 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML 87 ;Q $$EN^MXMLDOM(INXML) 88 Q $$EN^MXMLDOM(INXML,"W") 89 ; 90 90 ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE 91 92 93 94 95 96 91 N ZN 92 ;I $$TAG(ZOID)["entry" B 93 S ZN=$$NXTSIB(ZOID) 94 I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG 95 Q 0 96 ; 97 97 FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID 98 99 98 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) 99 ; 100 100 PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID 101 102 101 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) 102 ; 103 103 ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID 104 105 106 107 108 104 S HANDLE=C0CDOCID 105 K @RTN 106 D GETTXT^MXMLDOM("A") 107 Q 108 ; 109 109 TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE 110 111 112 113 114 115 116 117 110 ;I ZOID=149 B ;GPLTEST 111 N X,Y 112 S Y="" 113 S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE 114 I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y 115 I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) 116 Q Y 117 ; 118 118 NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING 119 120 119 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) 120 ; 121 121 DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE 122 123 124 125 126 127 122 ;N ZT,ZN S ZT="" 123 ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) 124 ;Q $G(@C0CDOM@(ZOID,"T",1)) 125 S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) 126 Q 127 ; 128 128 OUTXML(ZRTN,INID,NO1ST) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM 129 130 131 132 133 134 135 136 137 138 129 ; 130 S C0CDOCID=INID 131 I '$D(NO1ST) S NO1ST=0 ; DO NOT SURPRESS THE <?xml tag generation 132 D START^C0CMXMLB($$TAG(1),,"G",NO1ST) 133 D NDOUT($$FIRST(1)) 134 D END^C0CMXMLB ;END THE DOCUMENT 135 M @ZRTN=^TMP("MXMLBLD",$J) 136 K ^TMP("MXMLBLD",$J) 137 Q 138 ; 139 139 NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE 140 141 142 143 144 145 146 147 148 149 150 151 152 153 WNHIN(ZDFN) 154 155 156 157 158 159 160 161 NARY2XML(ZGOUT,ZGIN) 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 DOMI(INARY,HANDLE,PARENT) 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 MAJOR(ZARY) 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 EXPAND(ZZOUT,ZZIN) 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 NEWDOM() 312 313 314 315 316 317 318 319 140 N ZI S ZI=$$FIRST(ZOID) 141 I ZI'=0 D ; THERE IS A CHILD 142 . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT 143 . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN 144 E D ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT 145 . ;W "DOING",ZOID,! 146 . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA 147 . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES 148 . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN 149 I $$NXTSIB(ZOID)'=0 D ; THERE IS A SIBLING 150 . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS 151 Q 152 ; 153 WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE 154 ; 155 N GN,GN2 156 D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML 157 S GN2=$NA(@GN@(1)) 158 W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/") 159 Q 160 ; 161 NARY2XML(ZGOUT,ZGIN) ; CREATE XML FROM AN NHIN ARRAY 162 ; ZGOUT AND ZGIN ARE PASSED BY NAME 163 N C0CDOCID 164 W !,ZGOUT," ",ZGIN 165 S C0CDOCID=$$DOMI(ZGIN) ; PUT IT INTO THE DOM 166 D OUTXML(ZGOUT,C0CDOCID) 167 Q 168 ; 169 ; EXAMPLE OF NHIN ARRAY FORMAT - THIS IS AN OUTPUT OF DOMO ABOVE WHEN RUN 170 ; AGAINST THE OUTPUT OF THE GET^NHINV ROUTINE. (THIS IS NOT REAL PATIENT DATA) 171 ; 172 ;GNARY("med",1,"doses.dose@dose")=10 173 ;GNARY("med",1,"doses.dose@noun")="TABLET" 174 ;GNARY("med",1,"doses.dose@route")="PO" 175 ;GNARY("med",1,"doses.dose@schedule")="QD" 176 ;GNARY("med",1,"doses.dose@units")="MG" 177 ;GNARY("med",1,"doses.dose@unitsPerDose")=1 178 ;GNARY("med",1,"facility@code")=100 179 ;GNARY("med",1,"facility@name")="VOE OFFICE INSTITUTION" 180 ;GNARY("med",1,"form@value")="TAB" 181 ;GNARY("med",1,"id@value")="1N;O" 182 ;GNARY("med",1,"location@code")=5 183 ;GNARY("med",1,"location@name")="3 WEST" 184 ;GNARY("med",1,"name@value")="LISINOPRIL TAB" 185 ;GNARY("med",1,"orderID@value")=294 186 ;GNARY("med",1,"ordered@value")=3110531.001233 187 ;GNARY("med",1,"orderingProvider@code")=63 188 ;GNARY("med",1,"orderingProvider@name")="KING,MATTHEW MICHAEL" 189 ;GNARY("med",1,"products.product.class@code")="ACE INHIBITORS" 190 ;GNARY("med",1,"products.product.vaGeneric@code")=1990 191 ;GNARY("med",1,"products.product.vaGeneric@name")="LISINOPRIL" 192 ;GNARY("med",1,"products.product.vaGeneric@vuid")=4019380 193 ;GNARY("med",1,"products.product.vaProduct@code")=8118 194 ;GNARY("med",1,"products.product.vaProduct@name")="LISINOPRIL 10MG TAB" 195 ;GNARY("med",1,"products.product.vaProduct@vuid")=4008593 196 ;GNARY("med",1,"products.product@code")=6174 197 ;GNARY("med",1,"products.product@name")="LISINOPRIL 10MG U/D" 198 ;GNARY("med",1,"products.product@role")="D" 199 ;GNARY("med",1,"sig")="10MG BY MOUTH EVERY DAY" 200 ;GNARY("med",1,"sig@xml:space")="preserve" 201 ;GNARY("med",1,"status@value")="active" 202 ;GNARY("med",1,"type@value")="OTC" 203 ;GNARY("med",1,"vaType@value")="N" 204 ; 205 ; DOMI is an extrinsic to insert NHIN ARRAY FORMAT arrays into the DOM 206 ; it returns 0 or 1 based on success. 207 ; 208 ; INARY is passed by name and has the format shown above 209 ; HANDLE is the document number in the DOM (both MXML and EWD DOMs will 210 ; be supported eventually - initial implementation is for MXML 211 ; 212 ; PARENT is the node id or tag of the parent under which the DOM will 213 ; be populated. If it is numeric, it is a node. If it is a string, the DOM 214 ; will be searched to find the tag. If not found and there is no root, 215 ; it will be inserted as the root. If not found and there is a root, it 216 ; will be inserted under the root. 217 ; 218 ; For the above example the call would be OK=$$DOMI("GNARY",0,"results") 219 ; because "results" is the root tag. Use OUTXML to render the xml from 220 ; the DOM. 221 ; 222 DOMI(INARY,HANDLE,PARENT) ; EXTRINSIC TO INSERT NHIN ARRAYS TO A DOM 223 ; 224 N ZPARNODE 225 S (SUCCESS,LEVEL,LEVEL(0),NODE)=0 226 I '$D(INARY) Q 0 ; NO ARRAY PASSED 227 I '$D(HANDLE) S HANDLE=$$NEWDOM() ; MAKE A NEW DOM 228 ;I PARENT="" S PARENT="root" 229 I +$G(PARENT)>0 S ZPARNODE=PARENT ; WE HAVE BEEN PASSED A PARENT NODE ID 230 E I $L($G(PARENT))>0 D ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL 231 . D STARTELE^MXMLDOM(PARENT) ; INSERT THE PARENT NODE 232 . S ZPARNODE=1 ; 233 ; WE NOW HAVE A HANDLE AND A PARENT NODE AND LEVEL HAS BEEN SET 234 N ZEXARY 235 D EXPAND("ZEXARY",INARY) ; EXPAND THE NHIN ARRAY 236 D MAJOR("ZEXARY") ; PROCESS ALL THE NODES TO BE ADDED 237 I $L($G(PARENT))>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE 238 Q HANDLE ; SUCCESS 239 ; 240 MAJOR(ZARY) ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES 241 N ZI S ZI="" 242 N ZTAG 243 F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH SECTION 244 . N ZELEADD S ZELEADD=0 245 . I ZI["@" D ; END NODE HAS NO VALUE, ONLY ATTRIBUTES 246 . . S ZTAG=$P(ZI,"@",1) ; PULL OUT THE TAG 247 . . K ZATT ; CLEAR OUT LAST ONE 248 . . M ZATT=@ZARY@(ZI,1) ; GET ATTRIBUTE ARRAY 249 . . D STARTELE^MXMLDOM(ZTAG,.ZATT) ; ADD THE NODE 250 . . S ZELEADD=1 ; FLAG TO NOT ADD THE ELEMENT TWICE 251 . I $O(@ZARY@(ZI,""))="" D ;END NODE 252 . . S ZTAG=ZI ; USE ZI FOR THE TAG 253 . . I 'ZELEADD D STARTELE^MXMLDOM(ZTAG) ; ADD ELEMENT IF NOT THERE 254 . . S ZELEADD=1 ; ADDED AN ELEMENT 255 . . D CHAR^MXMLDOM($G(@ZARY@(ZI))) ; INSERT THE VALUE 256 . I ZELEADD D Q ; NO MORE TO DO ON THIS LEVEL 257 . . D ENDELE^MXMLDOM(ZTAG) ; CLOSE THE ELEMENT BEFORE LEAVING 258 . N NEWARY ; INDENTED ARRAY 259 . N ZN S ZN=0 260 . F S ZN=$O(@ZARY@(ZI,ZN)) Q:ZN="" D ; FOR EACH MULTIPLE 261 . . D STARTELE^MXMLDOM(ZI) ; ADD THE INTERMEDIATE TAG 262 . . S NEWARY=$NA(@ZARY@(ZI,ZN)) ; INDENT THE ARRAY 263 . . D MAJOR(NEWARY) ; RECURSE FOR INDENTED ARRAY 264 . . D ENDELE^MXMLDOM(ZI) ; END THE INTERMEDIATE TAG 265 Q 266 ; 267 EXPAND(ZZOUT,ZZIN) ; EXPANDS NHIN ARRAY FORMAT TO AN EXPANDED 268 ; CONSISTENT FORMAT 269 ; GNARY("patient",1,"facilities[2].facility@code")="050" 270 ; becomes G2ARY("patient",1,"facilities",2,"facility@",1,"code")="050" 271 ; for easier processing (this is fileman format genius) 272 ; basically removes the dot notation from the strings 273 ; 274 N ZZI 275 S ZZI="" 276 F S ZZI=$O(@ZZIN@(ZZI)) Q:ZZI="" D ; 277 . N ZZN S ZZN=0 278 . F S ZZN=$O(@ZZIN@(ZZI,ZZN)) Q:ZZN="" D ; 279 . . N ZZS S ZZS="" 280 . . N GA ;PUSH STACK 281 . . F S ZZS=$O(@ZZIN@(ZZI,ZZN,ZZS)) Q:ZZS="" D ; 282 . . . K GA ; NEW STACK 283 . . . D PUSH^C0CXPATH("GA",ZZI_"^"_ZZN) ; PUSH PARENT 284 . . . N ZZV ; PLACE TO STASH THE VALUE 285 . . . S ZZV=@ZZIN@(ZZI,ZZN,ZZS) ; VALUE 286 . . . W !,"VALUE:",ZZV 287 . . . N GK ; COUNTER 288 . . . F GK=1:1:$L(ZZS,".") D ; FOR EACH INTERMEDIATE NODE 289 . . . . N ZZN2 S ZZN2=1 ; DEFAULT IF NO [X] 290 . . . . N GM S GM=$P(ZZS,".",GK) ; TAG 291 . . . . I GM["[" D ; IT'S A MULTIPLE 292 . . . . . S ZZN2=$P($P(GM,"[",2),"]",1) ; PULL OUT THE NUMBER 293 . . . . . S GM=$P(GM,"[",1) ; PULL OUT THE TAG 294 . . . . I GM["@" D ; IT'S GOT ATTRIBUTES 295 . . . . . N GM2 S GM2=$P(GM,"@",2) ; PULLOUT THE ATTRIBUTE NAME 296 . . . . . D PUSH^C0CXPATH("GA",$P(GM,"@",1)_"@"_"^"_ZZN2) ; PUSH THE TAG 297 . . . . . D PUSH^C0CXPATH("GA",GM2_"^"_ZZN2) 298 . . . . E D PUSH^C0CXPATH("GA",GM_"^"_ZZN2) ; 299 . . . S GA(GA(0))=$P(GA(GA(0)),"^",1)_"^" ; GET RID OF THE LAST "1" 300 . . . N GZI S GZI="" ; STRING FOR THE INDEX 301 . . . F GK=1:1:GA(0) D ; TIME TO REVERSE POP THE TAGS 302 . . . . S GM=$P(GA(GK),"^",1) ; THE TAG 303 . . . . S ZZN2=$P(GA(GK),"^",2) ; THE NUMBER IF ANY 304 . . . . I ZZN2="" S GZI=GZI_""""_GM_"""" ; FOR THE LAST ONE 305 . . . . E S GZI=GZI_""""_GM_""""_","_ZZN2_"," ; FOR THE REST 306 . . . S GZI2=ZZOUT_"("_GZI_")" ; INCLUDE THE ARRAY NAME 307 . . . W !,GZI 308 . . . S @GZI2=ZZV ; REMEMBER THE VALUE? 309 Q 310 ; 311 NEWDOM() ; extrinsic which creates a new DOM and returns the HANDLE 312 N CBK,SUCCESS,LEVEL,NODE,HANDLE 313 K ^TMP("MXMLERR",$J) 314 L +^TMP("MXMLDOM",$J):5 315 E Q 0 316 S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)="" 317 L -^TMP("MXMLDOM",$J) 318 Q HANDLE 319 ; -
ccr/branches/ohum/p/C0CDPT.m
r1332 r1333 1 1 C0CDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ; 4 4 ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -
ccr/branches/ohum/p/C0CENC.m
r1332 r1333 1 1 C0CENC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10 2 ;;1.0;C0C;;May 21, 2010;Build 382 ;;1.0;C0C;;May 21, 2010;Build 1 3 3 ;Copyright 2010 George Lilly, University of Minnesota and others. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CENV.m
r1332 r1333 1 C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009 2 ;;1.0;C0C;;May 19, 2009; 3 ; 4 ; 5 ENV ; Does not prevent loading of the transport global. 6 ; Environment check is done only during the install. 7 ; 8 N XQA,XQAMSG 9 ; 10 ; 11 ; Make sure the patch name exist 12 ; 13 I '$D(XPDNM) D Q 14 . D BMES("No valid patch name exist") 15 . S XPDQUIT=2 16 . D EXIT 17 ; 18 D CHECK 19 D EXIT 20 Q 21 ; 22 ; 23 CHECK ; Perform environment check 1 C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009 2 ;;1.0;C0C;;May 19, 2009;Build 1 24 3 ; 25 I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D 26 . D BMES("Terminal Device is not defined") 27 . S XPDQUIT=2 28 ; 29 I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D 30 . D BMES("Please log in to set local DUZ... variables") 31 . S XPDQUIT=2 32 ; 33 I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D 34 . D BMES("You are not a valid user on this system") 35 . S XPDQUIT=2 4 ; 5 ENV ; Does not prevent loading of the transport global. 6 ; Environment check is done only during the install. 7 ; 8 N XQA,XQAMSG 9 ; 10 ; 11 ; Make sure the patch name exist 12 ; 13 I '$D(XPDNM) D Q 14 . D BMES("No valid patch name exist") 15 . S XPDQUIT=2 16 . D EXIT 17 ; 18 D CHECK 19 D EXIT 36 20 Q 37 21 ; 38 22 ; 39 EXIT ; 23 CHECK ; Perform environment check 24 ; 25 I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D 26 . D BMES("Terminal Device is not defined") 27 . S XPDQUIT=2 28 ; 29 I $S('$G(DUZ):1,$D(DUZ)[0:1,$D(DUZ(0))[0:1,1:0) D 30 . D BMES("Please log in to set local DUZ... variables") 31 . S XPDQUIT=2 32 ; 33 I $P($$ACTIVE^XUSER(DUZ),"^")'=1 D 34 . D BMES("You are not a valid user on this system") 35 . S XPDQUIT=2 36 Q 40 37 ; 41 38 ; 42 I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q 43 D BMES("--- Environment Check is Ok ---") 44 ; 45 Q 39 EXIT ; 46 40 ; 47 41 ; 48 PRE ;Pre-install entry point 42 I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q 43 D BMES("--- Environment Check is Ok ---") 44 ; 45 Q 46 ; 47 ; 48 PRE ;Pre-install entry point 49 49 ; 50 50 ; No action needed in pre-install … … 54 54 ; 55 55 ; 56 POST 56 POST ;Post install 57 57 ; 58 58 ; Check for RPMS system with V LAB file. … … 131 131 ; 132 132 ; 133 POST6 133 POST6 ; Checkpoint call back entry point. 134 134 ; Check for RPMS system and determine LAB patch level 135 135 ; and need to load in C0C version of LA7 routines. … … 174 174 ; 175 175 ; 176 BMES(STR) 176 BMES(STR) ; Write BMES^XPDUTL statements 177 177 ; 178 178 D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM)) -
ccr/branches/ohum/p/C0CEVC.m
r1332 r1333 1 1 C0CEVC ; CCDCCR/GPL - SUPPORT FOR EWD VISTCOM PAGES ; 3/1/2010 2 ;;1.0;C0C;;Mar 1, 2010; 3 gpltest2 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 gpltest 23 24 25 26 27 28 29 30 TEST(sessid); 31 32 33 34 35 36 37 38 39 PARSE(INXML,INDOC) 40 41 42 43 44 45 46 47 TEST2(sessid) 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 INITSES(sessid) 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 PRSEORTK(ZTOKEN) 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 GETPATIENTLIST(sessid) 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 PSEUDO 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 PSEUDO2 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 2 ;;1.0;C0C;;Mar 1, 2010;Build 1 3 gpltest2 ; experiment with sending a CCR to an ewd page 4 N ZI 5 S ZI="" 6 D PSEUDO 7 N ZIO 8 S ZIO=IO 9 S IO="/dev/null" 10 OPEN IO 11 U IO 12 N G 13 S G=$$URLTOKEN^C0CEWD 14 D CCRRPC^C0CCCR(.GPL,2) 15 S IO=ZIO 16 OPEN IO 17 U IO 18 K GPL(0) 19 F S ZI=$O(GPL(ZI)) Q:ZI="" W GPL(ZI),! 20 Q 21 ; 22 gpltest ; experiment with sending a CCR to an ewd page 23 N ZI 24 S ZI="" 25 K ^GPL(0) 26 S ^GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>" 27 F S ZI=$O(^GPL(ZI)) Q:ZI="" W ^GPL(ZI),! 28 Q 29 ; 30 TEST(sessid); 31 d setSessionValue^%zewdAPI("person.Name","Rob",sessid) 32 d setSessionValue^%zewdAPI("person.DateOfBirth","13/06/55",sessid) 33 d setSessionValue^%zewdAPI("person.Address.PostCode","SW1 3QA",sessid) 34 d setSessionValue^%zewdAPI("person.Address.Line1","1 The Street",sessid) 35 d setSessionValue^%zewdAPI("person.Address.2.hello","world",sessid) 36 d setJSONValue^%zewdAPI("json","person",sessid) 37 Q "" 38 39 PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME 40 ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD 41 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD 42 N ZR 43 M ^CacheTempEWD($j)=@INXML ; 44 S ZR=$$parseDocument^%zewdHTMLParser(INDOC) 45 Q ZR 46 ; 47 TEST2(sessid) ; try to put a ccr in the session 48 S U="^" 49 D PSEUDO ; FAKE LOGIN 50 S ZIO=$IO 51 S DEV="/dev/null" 52 O DEV U DEV 53 N G 54 N ZDFN 55 S ZDFN=$$getSessionValue^%zewdAPI("vista.dfn",sessid) 56 I ZDFN="" S ZDFN=2 57 ;K ^TMP("GPL") 58 ;M ^TMP("GPL")=^%zewdSession("session",sessid) 59 D CCRRPC^C0CCCR(.GPL,ZDFN) 60 K GPL(0) 61 S GPL(2)="<?xml-stylesheet type=""text/xsl"" href=""/resources/ccr.xsl""?>" 62 C DEV U ZIO 63 ;M ^CacheTempEWD($j)=GPL 64 S DOCNAME="CCR" 65 ;ZWR GPL 66 ;S ZR=$$parseDocument^%zewdHTMLParser(DOCNAME) 67 ;d setSessionValues^%zewdAPI(DOCNAME,GPL,sessid) 68 d mergeArrayToSession^%zewdAPI(.GPL,DOCNAME,sessid) 69 Q "" 70 ; 71 INITSES(sessid) ;initialize an EWD/CPRS session 72 K ^TMP("GPL") 73 ;M ^TMP("GPL")=^%zewdSession("session",sessid) 74 N ZT,ZDFN 75 S ZT=$$URLTOKEN^C0CEWD(sessid) 76 ;S ^TMP("GPL")=ZT 77 d trace^%zewdAPI("*********************ZT="_ZT) 78 S ZDFN=$$PRSEORTK(ZT) ; PARSE THE TOKEN AND LOOK UP THE DFN 79 S ^TMP("GPL","DFN")=ZDFN 80 I ZDFN=0 S DFN=2 ; DEFAULT TEST PATIENT 81 D setSessionValue^%zewdAPI("vista.dfn",ZDFN,sessid) 82 ;M ^TMP("GPL","request")=requestArray 83 ;D PSEUDO 84 ;D ^%ZTER 85 q "" 86 ; 87 PRSEORTK(ZTOKEN) ;PARSES THE TOKEN SENT BY CPRS AND RETURNS THE DFN 88 ; OF THE PATIENT ; HERE'S WHAT THE TOKEN LOOKS LIKE: 89 ; ^TMP('ORWCHART',6547,'192.168.169.8',002E0FE6) 90 N ZX,ZN1,ZIP,ZN2,ZDFN,ZG 91 S ZDFN=0 ; DEFAULT RETURN 92 S ZN1=$P(ZTOKEN,",",2) ; FIRST NUMBER 93 S ZIP=$P(ZTOKEN,",",3) ; IP NUMBER 94 S ZIP=$P(ZIP,"'",2) ; GET RID OF ' 95 S ZN2=$P(ZTOKEN,",",4) ; SECOND NUMBER 96 S ZN2=$P(ZN2,")",1) ; GET RID OF ) 97 S ZG=$NA(^TMP("ORWCHART",ZN1,ZIP,ZN2)) ; BUILD THE GLOBAL NAME 98 I $G(@ZG)'="" S ZDFN=@ZG ; ACCESS THE GLOBAL 99 S ^TMP("GPL","FIRSTDFN")=ZDFN 100 S ^TMP("GPL","FIRSTGLB")=ZG 101 Q ZDFN 102 ; 103 GETPATIENTLIST(sessid) ; 104 D PSEUDO 105 D LISTALL^ORWPT(.RTN,"NAME","1") 106 N ZI 107 S ZI="" 108 F S ZI=$O(RTN(ZI)) Q:ZI="" D ; 109 . S data(ZI,"DFN")=$P(RTN(ZI),"^",1) 110 . S data(ZI,"Name")=$P(RTN(ZI),"^",2) 111 ; ZWR data 112 ;S data(1,"DFN")=$P(RTN(1),"^",1) 113 ;S data(1,"Name")=$P(RTN(1),"^",2) 114 d deleteFromSession^%zewdAPI("patients",sessid) 115 d createDataTableStore^%zewdYUIRuntime(.data,"patients",sessid) 116 ;d mergeArrayToSession^%zewdAPI(.data,"patients",sessid) 117 Q "" 118 ; 119 PSEUDO 120 S U="^" 121 S DILOCKTM=3 122 S DISYS=19 123 S DT=3100219 124 S DTIME=999 125 S DUZ=10 126 S DUZ(0)="@" 127 S DUZ(1)="" 128 S DUZ(2)=1 129 S DUZ("AG")="V" 130 S DUZ("BUF")=1 131 S DUZ("LANG")="" 132 ;S IO="/dev/pts/2" 133 ;S IO(0)="/dev/pts/2" 134 ;S IO(1,"/dev/pts/2")="" 135 ;S IO("ERROR")="" 136 ;S IO("HOME")="41^/dev/pts/2" 137 ;S IO("ZIO")="/dev/pts/2" 138 ;S IOBS="$C(8)" 139 ;S IOF="#,$C(27,91,50,74,27,91,72)" 140 ;S SIOM=80 141 Q 142 ; 143 PSEUDO2 ; FAKE LOGIN SETS SOME LOCAL VARIABLE TO FOOL FILEMAN 144 S DILOCKTM=3 145 S DISYS=19 146 S DT=3100112 147 S DTIME=9999 148 S DUZ=10000000020 149 S DUZ(0)="@" 150 S DUZ(1)="" 151 S DUZ(2)=67 152 S DUZ("AG")="E" 153 S DUZ("BUF")=1 154 S DUZ("LANG")=1 155 S IO="/dev/pts/0" 156 ;S IO(0)="/dev/pts/0" 157 ;S IO(1,"/dev/pts/0")="" 158 ;S IO("ERROR")="" 159 ;S IO("HOME")="50^/dev/pts/0" 160 ;S IO("ZIO")="/dev/pts/0" 161 ;S IOBS="$C(8)" 162 ;S IOF="!!!!!!!!!!!!!!!!!!!!!!!!,#,$C(27,91,50,74,27,91,72)" 163 ;S IOM=80 164 ;S ION="GTM/UNIX TELNET" 165 ;S IOS=50 166 ;S IOSL=24 167 ;S IOST="C-VT100" 168 ;S IOST(0)=9 169 ;S IOT="VTRM" 170 ;S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)" 171 S U="^" 172 S X="1;DIC(4.2," 173 S XPARSYS="1;DIC(4.2," 174 S XQXFLG="^^XUP" 175 S Y="DEV^VISTA^hollywood^VISTA:hollywood" 176 Q 177 ; -
ccr/branches/ohum/p/C0CEWD.m
r1332 r1333 1 1 C0CEWD ; CCDCCR/GPL - CCR EWD utilities; 1/6/11 2 ;;0.1;CCDCCR;nopatch;noreleasedate;Build 772 ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 3 3 ;Copyright 2011 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CEWD1.m
r1332 r1333 1 C0CEWD1 2 ;;0.1;CCDCCR;nopatch;noreleasedate 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 TEST(filepath) 23 24 25 26 27 28 29 30 31 TEST2 32 33 34 35 36 37 38 39 40 LOAD(filepath) 41 42 43 44 45 46 47 48 49 50 51 52 53 Q(ZQ,ZD) 54 55 56 57 58 59 GET1URL0(URL) 60 61 62 63 64 65 66 67 1 C0CEWD1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 2 ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 ;General Public License See attached copy of the License. 5 ; 6 ;This program is free software; you can redistribute it and/or modify 7 ;it under the terms of the GNU General Public License as published by 8 ;the Free Software Foundation; either version 2 of the License, or 9 ;(at your option) any later version. 10 ; 11 ;This program is distributed in the hope that it will be useful, 12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ;GNU General Public License for more details. 15 ; 16 ;You should have received a copy of the GNU General Public License along 17 ;with this program; if not, write to the Free Software Foundation, Inc., 18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 19 ; 20 Q 21 ; 22 TEST(filepath) ; filepath IS THE PATH/FILE TO BE READ IN 23 i $g(^%ZISH)["" d ; if the VistA Kernal routine %ZISH exists 24 . n zfile,zpath,ztmp s (zfile,zpath,ztmp)="" 25 . s zfile=$re($p($re(filepath),"/",1)) ;file name 26 . s zpath=$p(filepath,zfile,1) ; file path 27 . s ztmp=$na(^CacheTempEWD($j,0)) 28 . s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2 29 q 30 ; 31 TEST2 ; 32 s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml" 33 ;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath) 34 s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global 35 s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0) 36 ;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM") 37 w ok,! 38 q 39 ; 40 LOAD(filepath) ; load an xml file into the EWD global for DOM processing 41 ; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML) 42 ; after to process it to the DOM - isHTML=0 for XML files 43 n i 44 i $g(^%ZISH)["" d QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09 45 . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)="" 46 . s zfile=$re($p($re(filepath),"/",1)) ;file name 47 . s zpath=$p(filepath,zfile,1) ; file path 48 . s ztmp=$na(^CacheTempEWD($j,0)) 49 . s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2 50 . s i=$o(^CacheTempEWD($j,""),-1) ; highest line number 51 q i 52 ; 53 Q(ZQ,ZD) ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED 54 I '$D(ZD) S ZD="DerekDOM" 55 s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ; 56 d displayNodes^%zewdXPath(.nodes) 57 q 58 ; 59 GET1URL0(URL) ; 60 s ok=$$httpGET^%zewdGTM(URL,.gpl) 61 D INDEX^C0CXPATH("gpl","gpl2") 62 W !,"S URL=""",URL,"""",! 63 S G="" 64 F S G=$O(gpl2(G)) Q:G="" D ; 65 . W " S VDX(""",G,""")=""",gpl2(G),"""",! 66 W ! 67 Q -
ccr/branches/ohum/p/C0CFM1.m
r1332 r1333 1 1 C0CFM1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CFM2.m
r1332 r1333 1 1 C0CFM2 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CFM3.m
r1332 r1333 1 C0CFM3 2 ;;0.1;CCDCCR;nopatch;noreleasedate 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 RIMTBL(ZWHICH) 31 32 33 34 35 36 37 38 39 40 41 PUTRIM(DFN,ZWHICH) 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 PUTRIM1(DFN,ZZTYP,ZVARS) 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 PUTELS(DFN,ZTYPE,ZOCC,ZVALS) 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 UPDIE 134 135 136 137 138 139 140 141 142 143 144 PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 VARPTR(ZVAR,ZTYP) 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 BLDTYPS 221 222 223 224 225 226 227 228 FIXSEC 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 SETFDA(C0CSN,C0CSV) 246 247 248 249 250 251 252 253 254 255 ZFILE(ZFN,ZTAB) 256 257 258 259 260 261 262 263 ZFIELD(ZFN,ZTAB) 264 265 266 267 268 269 270 271 272 ZVALUE(ZFN,ZTAB) 273 274 275 276 277 278 279 280 281 SHOWE4(DFN) 282 283 284 285 286 287 1 C0CFM3 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 2 ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 ;General Public License See attached copy of the License. 5 ; 6 ;This program is free software; you can redistribute it and/or modify 7 ;it under the terms of the GNU General Public License as published by 8 ;the Free Software Foundation; either version 2 of the License, or 9 ;(at your option) any later version. 10 ; 11 ;This program is distributed in the hope that it will be useful, 12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ;GNU General Public License for more details. 15 ; 16 ;You should have received a copy of the GNU General Public License along 17 ;with this program; if not, write to the Free Software Foundation, Inc., 18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 19 ; 20 W "This is the CCR FILEMAN Utility Library ",! 21 ; THIS SET OF ROUTINES USE CCR E2 (^C0CE(, FILE 171.101) INSTEAD OF 22 ; CCR ELEMENTS (^C0C(179.201, 23 ; E2 IS A SIMPLIFICATION OF CCR ELEMENTS WHERE SUB-ELEMENTS ARE 24 ; AT THE TOP LEVEL. OCCURANCE, THE 4TH PART OF THE KEY IS NOW FREE TEXT 25 ; AND HAS THE FORM X;Y FOR SUB-ELEMENTS 26 ; ALL SUB-VARIABLES HAVE BEEN REMOVED 27 W ! 28 Q 29 ; 30 RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE 31 ; ' 32 I '$D(RIMBASE) D ASETUP^GPLRIMA ; FOR COMMAND LINE CALLS 33 N ZI,ZJ,ZC,ZPATBASE 34 S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH)) 35 S ZI="" 36 F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END 37 . S ZI=$O(@ZPATBASE@(ZI)) 38 . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE 39 Q 40 ; 41 PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE 42 ; 43 S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN)) 44 I '$D(ZWHICH) S ZWHICH="ALL" 45 I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED 46 . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) 47 . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION 48 E D ; MULTIPLE SECTIONS 49 . S C0CVARS=$NA(@C0CGLB) 50 . S C0CI="" 51 . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION 52 . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION 53 . . D PUTRIM1(DFN,C0CI,C0CVARSN) 54 Q 55 ; 56 PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS 57 ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" 58 S C0CX=0 59 F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE 60 . W "ZOCC=",C0CX,! 61 . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME 62 . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE 63 . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE 64 . I $D(C0CMDO) D ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :() 65 . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV 66 . . S ZZCNT=0 67 . . S ZZC0CI=0 68 . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE 69 . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE 70 . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR 71 . . W "MULTIPLE:",ZZVALS,! 72 . . ;B 73 . . F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE 74 . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT 75 . . . W "COUNT:",ZZCNT,! 76 . . . S ZV=$NA(@ZZVALS@(ZZC0CI)) 77 . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV) 78 Q 79 ; 80 PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE 81 ; 171.601, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE 82 ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE 83 ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC 84 ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM 85 ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT 86 ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES 87 ; 88 N ZSRC,PATN,ZTYPN,XD0,ZTYP 89 S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 90 ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE 91 N C0CF S C0CF=171.601 ; FILE AT ELEMENT LEVEL 92 N C0CFV S C0CFV=171.6011 ; FILE AT VARIABLE LVL 93 N C0CFDA 94 N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) 95 W "ZTYPE: ",ZTYPE," ",ZTYPN,! 96 N ZVARN ; IEN OF VARIABLE BEING PROCESSED 97 ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE 98 S C0CFDA(C0CF,"+1,",.01)=ZTYPN 99 S C0CFDA(C0CF,"+1,",.02)=DFN 100 S C0CFDA(C0CF,"+1,",.03)=ZSRC 101 S C0CFDA(C0CF,"+1,",.04)=" "_ZOCC ;CREATE OCCURANCE with leading space 102 D UPDIE ; CREATE THE RECORD 103 S C0CIEN=$O(^C0CE4("C",DFN,ZSRC,ZTYPN," "_ZOCC,"")) 104 N ZCNT,ZC0CI,ZVARN,C0CZ1 105 S ZCNT=0 106 S ZC0CI="" ; 107 F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; 108 . I ZC0CI'="M" D ; NOT A SUBVARIABLE 109 . . S ZCNT=ZCNT+1 ;INCREMENT COUNT 110 . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT 111 . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND 112 . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",.01)=ZVARN 113 . . S C0CFDA(C0CFV,"+"_ZCNT_","_C0CIEN_",",1)=@ZVALS@(ZC0CI) 114 . E D ; THIS IS A SUBELEMENT 115 . . ;PUT THE FOLLOWING BACK TO USE RECURSION 116 . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV 117 . . ;S ZZCNT=0 118 . . ;S ZZC0CI=0 119 . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE 120 . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE 121 . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR 122 . . ;W "MULTIPLE:",ZZVALS,! 123 . . ;B 124 . . ;F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE 125 . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT 126 . . ;. W "COUNT:",ZZCNT,! 127 . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI)) 128 . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION 129 . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION) 130 D UPDIE ; UPDATE 131 Q 132 ; 133 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 134 K ZERR 135 D CLEAN^DILF 136 D UPDATE^DIE("","C0CFDA","","ZERR") 137 I $D(ZERR) D ; 138 . W "ERROR",! 139 . ZWR ZERR 140 . B 141 K C0CFDA 142 Q 143 ; 144 PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE 145 ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE 146 ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE 147 ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC 148 ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM 149 ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT 150 ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES 151 ; 152 S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 153 ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE 154 N ZF,ZFV S ZF=171.101 S ZFV=171.1011 155 ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS 156 ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER 157 N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) 158 W "ZTYPE: ",ZTYPE," ",ZTYPN,! 159 N ZVARN ; IEN OF VARIABLE BEING PROCESSED 160 ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE 161 K C0CFDA 162 S C0CFDA(ZF,"?+1,",.01)=DFN 163 S C0CFDA(ZF,"?+1,",.02)=ZSRC 164 S C0CFDA(ZF,"?+1,",.03)=ZTYPN 165 S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE 166 K ZERR 167 ;B 168 D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER 169 I $D(ZERR) B ;OOPS 170 K C0CFDA 171 S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,"")) 172 W "RECORD NUMBER: ",ZD0,! 173 ;B 174 S ZCNT=0 175 S ZC0CI="" ; 176 F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; 177 . I ZC0CI'="M" D ; NOT A SUBVARIABLE 178 . . S ZCNT=ZCNT+1 ;INCREMENT COUNT 179 . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT 180 . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND 181 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN 182 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) 183 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN 184 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) 185 ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" 186 ;S GT1(170,"?+1,",12)="DIR" 187 ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" 188 ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" 189 D CLEAN^DILF 190 D UPDATE^DIE("","C0CFDA","","ZERR") 191 I $D(ZERR) D ; 192 . W "ERROR",! 193 . ZWR ZERR 194 . B 195 K C0CFDA 196 Q 197 ; 198 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE 199 ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO 200 ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO 201 ; 202 N ZCCRD,ZVARN,C0CFDA2 203 S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY 204 S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 205 I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT 206 . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE 207 . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! 208 . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE 209 . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE 210 . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN 211 . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY 212 . I $D(ZERR) D ; LAYGO ERROR 213 . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! 214 . E D ; 215 . . D CLEAN^DILF ; CLEAN UP 216 . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 217 . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! 218 Q ZVARN 219 ; 220 BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) 221 ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED 222 ; 223 N C0CDIC,C0CNODE ; 224 S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY 225 S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE 226 Q 227 ; 228 FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED 229 ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET 230 ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS 231 ; CONVERSION 232 ;N C0CC,C0CI,C0CJ,C0CN,C0CZX 233 D FIELDS^C0CRNF("C0CC",170) 234 S C0CI="" 235 F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION 236 . S C0CZX="" 237 . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE 238 . . W "SECTION ",C0CI," VAR ",C0CZX 239 . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) 240 . . W " TYPE: ",C0CV,! 241 . . D SETFDA("SECTION",C0CV) 242 . . ;ZWR C0CFDA 243 Q 244 ; 245 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 246 ; TO SET TO VALUE C0CSV. 247 ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE 248 ; C0CSN,C0CSV ARE PASSED BY VALUE 249 ; 250 N C0CSI,C0CSJ 251 S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER 252 S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER 253 S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV 254 Q 255 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 256 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) 257 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 258 I '$D(ZTAB) S ZTAB="C0CA" 259 N ZR 260 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) 261 E S ZR="" 262 Q ZR 263 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 264 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) 265 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 266 I '$D(ZTAB) S ZTAB="C0CA" 267 N ZR 268 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) 269 E S ZR="" 270 Q ZR 271 ; 272 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 273 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) 274 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 275 I '$D(ZTAB) S ZTAB="C0CA" 276 N ZR 277 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) 278 E S ZR="" 279 Q ZR 280 ; 281 SHOWE4(DFN) ; 282 ; 283 N ZG 284 S ZG="" 285 F S ZG=$O(^C0CE4("P",DFN,ZG)) Q:ZG="" D ZWR ^C0CE4(ZG,*) 286 Q 287 ; -
ccr/branches/ohum/p/C0CIM2.m
r1332 r1333 1 1 C0CIM2 ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10 2 ;;1.0;C0C;;Feb 16, 2010;Build 382 ;;1.0;C0C;;Feb 16, 2010;Build 1 3 3 ;Copyright 2010 George Lilly, University of Minnesota and others. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CIMMU.m
r1332 r1333 1 1 C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CIN.m
r1332 r1333 1 1 C0CIN ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08 2 ;;1.0;C0C;;Sep 20, 2009;Build 382 ;;1.0;C0C;;Sep 20, 2009;Build 1 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CLA7DD.m
r1332 r1333 1 C0CLA7DD 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 EN 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 ALR1 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 ALR2 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 ALR3 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 ALR4 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 ALR5 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 REINDEX 206 207 208 209 210 211 212 213 ; 214 215 216 217 218 219 220 221 222 223 224 ; 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 BMES(STR) 245 246 247 248 249 250 1 C0CLA7DD ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009 2 ;;1.0;C0C;;May 19, 2009;Build 1 3 ; 4 ; Tasked by C0C post-install routine C0CENV to create C0C cross-references on V LAB file. 5 ; 6 Q 7 ; 8 ; 9 EN ; Add new style cross-references to V LAB file if it exists. 10 ; OLD entry point - see new KIDS check points in C0CENV. 11 ; 12 ; 13 ; Quit if AUPNVLAB global does not exist. 14 I $$VFILE^DILFD(9000010.09)'=1 Q 15 ; 16 N MSG 17 ; 18 S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z") 19 D BMES(MSG) 20 D ALR1 21 S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 22 D BMES(MSG) 23 ; 24 S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z") 25 D BMES(MSG) 26 D ALR2 27 S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 28 D BMES(MSG) 29 ; 30 S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z") 31 D BMES(MSG) 32 D ALR3 33 S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 34 D BMES(MSG) 35 ; 36 S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z") 37 D BMES(MSG) 38 D ALR4 39 S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 40 D BMES(MSG) 41 ; 42 S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z") 43 D BMES(MSG) 44 D ALR5 45 S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 46 D BMES(MSG) 47 ; 48 Q 49 ; 50 ; 51 ALR1 ; Installation of ALR1 cross-reference 52 ; 53 N C0CFLAG,C0CXR,C0CRES,C0COUT 54 ; 55 S C0CFLAG="" 56 ; 57 S C0CXR("FILE")=9000010.09 58 S C0CXR("NAME")="ALR1" 59 S C0CXR("TYPE")="R" 60 S C0CXR("USE")="S" 61 S C0CXR("EXECUTION")="R" 62 S C0CXR("ACTIVITY")="IR" 63 S C0CXR("SHORT DESCR")="X-ref to link entry with parent in LAB DATA file (#63)" 64 S C0CXR("VAL",1)=.02 65 S C0CXR("VAL",1,"SUBSCRIPT")=1 66 S C0CXR("VAL",1,"COLLATION")="F" 67 S C0CXR("VAL",2)=.06 68 S C0CXR("VAL",2,"SUBSCRIPT")=2 69 S C0CXR("VAL",2,"LENGTH")=30 70 S C0CXR("VAL",2,"COLLATION")="F" 71 S C0CXR("VAL",3)=.01 72 S C0CXR("VAL",3,"SUBSCRIPT")=3 73 S C0CXR("VAL",3,"COLLATION")="F" 74 S C0CXR("VAL",4)=1201 75 S C0CXR("VAL",4,"SUBSCRIPT")=4 76 S C0CXR("VAL",4,"COLLATION")="F" 77 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") 78 ; 79 Q 80 ; 81 ; 82 ALR2 ; Installation of ALR2 cross-reference 83 ; 84 N C0CFLAG,C0CXR,C0CRES,C0COUT 85 ; 86 S C0CFLAG="" 87 ; 88 S C0CXR("FILE")=9000010.09 89 S C0CXR("NAME")="ALR2" 90 S C0CXR("TYPE")="MU" 91 S C0CXR("USE")="S" 92 S C0CXR("EXECUTION")="R" 93 S C0CXR("ACTIVITY")="IR" 94 S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result." 95 S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes" 96 S C0CXR("DESCR",2)="that has been assigned to a lab result. Allows queries to" 97 S C0CXR("DESCR",3)="retrieve the LOINC code associated with a specific test" 98 S C0CXR("DESCR",4)="result." 99 S C0CXR("SET")="S ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)=""""" 100 S C0CXR("KILL")="K ^AUPNVLAB(""ALR2"",X(1),X(2),X(3),X(4),X(5),DA)" 101 S C0CXR("WHOLE KILL")="K ^AUPNVLAB(""ALR2"")" 102 S C0CXR("VAL",1)=.02 103 S C0CXR("VAL",1,"SUBSCRIPT")=1 104 S C0CXR("VAL",1,"COLLATION")="F" 105 S C0CXR("VAL",2)=1201 106 S C0CXR("VAL",2,"SUBSCRIPT")=2 107 S C0CXR("VAL",2,"COLLATION")="F" 108 S C0CXR("VAL",3)=.06 109 S C0CXR("VAL",3,"SUBSCRIPT")=3 110 S C0CXR("VAL",3,"COLLATION")="F" 111 S C0CXR("VAL",4)=.01 112 S C0CXR("VAL",4,"SUBSCRIPT")=4 113 S C0CXR("VAL",4,"COLLATION")="F" 114 S C0CXR("VAL",5)=1113 115 S C0CXR("VAL",5,"SUBSCRIPT")=5 116 S C0CXR("VAL",5,"COLLATION")="F" 117 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") 118 ; 119 Q 120 ; 121 ; 122 ALR3 ; Installation of ALR3 cross-reference 123 ; 124 N C0CFLAG,C0CXR,C0CRES,C0COUT 125 ; 126 S C0CFLAG="" 127 ; 128 S C0CXR("FILE")=9000010.09 129 S C0CXR("NAME")="ALR3" 130 S C0CXR("TYPE")="R" 131 S C0CXR("USE")="S" 132 S C0CXR("EXECUTION")="F" 133 S C0CXR("ACTIVITY")="IR" 134 S C0CXR("SHORT DESCR")="X-ref for LOINC code related to test result - any patient" 135 S C0CXR("DESCR",1)="This cross-reference is used to identify the LOINC codes that has been assigned to a lab result. Allows queries" 136 S C0CXR("DESCR",2)="to retrieve the LOINC code associated with a specific test result. It allows any patient" 137 S C0CXR("DESCR",3)="lab results to be identified by LOINC" 138 S C0CXR("VAL",1)=1113 139 S C0CXR("VAL",1,"SUBSCRIPT")=1 140 S C0CXR("VAL",1,"COLLATION")="F" 141 ; 142 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") 143 ; 144 Q 145 ; 146 ; 147 ALR4 ; Installation of ALR4 cross-reference 148 ; 149 N C0CFLAG,C0CXR,C0CRES,C0COUT 150 ; 151 S C0CFLAG="" 152 ; 153 S C0CXR("FILE")=9000010.09 154 S C0CXR("NAME")="ALR4" 155 S C0CXR("TYPE")="R" 156 S C0CXR("USE")="S" 157 S C0CXR("EXECUTION")="R" 158 S C0CXR("ACTIVITY")="IR" 159 S C0CXR("SHORT DESCR")="X-ref by patient and collection date/time" 160 S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a" 161 S C0CXR("DESCR",2)="patient by collection date/time. This includes results that are only in" 162 S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA" 163 S C0CXR("DESCR",4)="file (#63)." 164 S C0CXR("VAL",1)=.02 165 S C0CXR("VAL",1,"SUBSCRIPT")=1 166 S C0CXR("VAL",1,"COLLATION")="F" 167 S C0CXR("VAL",2)=1201 168 S C0CXR("VAL",2,"SUBSCRIPT")=2 169 S C0CXR("VAL",2,"COLLATION")="F" 170 ; 171 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") 172 ; 173 Q 174 ; 175 ; 176 ALR5 ; Installation of ALR5 cross-reference 177 ; 178 N C0CFLAG,C0CXR,C0CRES,C0COUT 179 ; 180 S C0CFLAG="" 181 ; 182 S C0CXR("FILE")=9000010.09 183 S C0CXR("NAME")="ALR5" 184 S C0CXR("TYPE")="R" 185 S C0CXR("USE")="S" 186 S C0CXR("EXECUTION")="R" 187 S C0CXR("ACTIVITY")="IR" 188 S C0CXR("SHORT DESCR")="X-ref by patient and results availble date/time" 189 S C0CXR("DESCR",1)="This cross-reference is used to identify all lab results for a" 190 S C0CXR("DESCR",2)="patient by results available date/time. This includes results that are only in" 191 S C0CXR("DESCR",3)="this file and therefore do not have a corresponding entry in LAB DATA" 192 S C0CXR("DESCR",4)="file (#63)." 193 S C0CXR("VAL",1)=.02 194 S C0CXR("VAL",1,"SUBSCRIPT")=1 195 S C0CXR("VAL",1,"COLLATION")="F" 196 S C0CXR("VAL",2)=1212 197 S C0CXR("VAL",2,"SUBSCRIPT")=2 198 S C0CXR("VAL",2,"COLLATION")="F" 199 ; 200 D CREIXN^DDMOD(.C0CXR,C0CFLAG,.C0CRES,"C0COUT") 201 ; 202 Q 203 ; 204 ; 205 REINDEX ; Set data into indexes for current entries. 206 ; 207 ; 208 N C0CHLOG,DA,DIK,MSG 209 ; 210 S C0CHLOG("START")=$H 211 S MSG="Starting indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") 212 D BMES(MSG),SENDXQA(MSG) 213 ; 214 S DIK="^AUPNVLAB(" 215 S DIK(1)=".02^ALR1^ALR2^ALR4^ALR5" 216 D ENALL^DIK 217 ; 218 S C0CHLOG("END")=$H 219 S MSG="Finished indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z") 220 D BMES(MSG),SENDXQA(MSG) 221 ; 222 S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3) 223 D BMES(MSG) 224 ; 225 S C0CHLOG("START")=$H 226 S MSG="Starting indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") 227 D BMES(MSG),SENDXQA(MSG) 228 ; 229 K DA,DIK 230 S DIK="^AUPNVLAB(" 231 S DIK(1)="1113^ALR3" 232 D ENALL^DIK 233 ; 234 S C0CHLOG("END")=$H 235 S MSG="Finished indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("END"),"1Z") 236 D BMES(MSG),SENDXQA(MSG) 237 ; 238 S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3) 239 D BMES(MSG) 240 ; 241 Q 242 ; 243 ; 244 BMES(STR) ; Write BMES^XPDUTL statements 245 ; 246 D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM)) 247 ; 248 Q 249 ; 250 ; 251 251 SENDXQA(MSG) ; Send alert for reindex status 252 252 ; -
ccr/branches/ohum/p/C0CLA7Q.m
r1332 r1333 1 1 C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ; 4 4 ; -
ccr/branches/ohum/p/C0CLABS.m
r1332 r1333 1 1 C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 4 ;Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CMAIL.m
r1332 r1333 1 1 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr 2 V ;;0.1;C0C;nopatch;noreleasedate3 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 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 GETMSG(C0CDATA,C0CINPUT) 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 GATHER(DUZ,NAM,LST) 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 GETTYP(D0) 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 NAME(NM) 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 TIME(Y) 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 DETAIL(C0CDATA,C0CINPUT) 235 236 237 238 239 240 241 242 243 244 245 246 GETTYP2(D0) 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 DECODER 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 NORMAL(OUTXML,INXML) 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 2 V ;;0.1;C0C;nopatch;noreleasedate;Build 1 3 ;Copyright 2011 Chris Richardson, Richardson Computer Research 4 ; Modified 3110516@1818 5 ; rcr@rcresearch.us 6 ; Licensed under the terms of the GNU 7 ;General Public License See attached copy of the License. 8 ; 9 ;This program is free software; you can redistribute it and/or modify 10 ;it under the terms of the GNU General Public License as published by 11 ;the Free Software Foundation; either version 2 of the License, or 12 ;(at your option) any later version. 13 ; 14 ;This program is distributed in the hope that it will be useful, 15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 ;GNU General Public License for more details. 18 ; 19 ;You should have received a copy of the GNU General Public License along 20 ;with this program; if not, write to the Free Software Foundation, Inc., 21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 22 ; 23 ; ------------------ 24 ;Entry Points 25 ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) 26 ; Input: 27 ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL 28 ; or "*" for all boxes, default is "IN" if missing]" 29 ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", 30 ; "*" for All or 9,999 maximum 31 ; MALL?1.n = that number of the n most recent 32 ; Internally: 33 ; BNAM = Box Name 34 ; Output: 35 ; C0CDATA 36 ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket 37 ; (BNAM,"MSG",C0CIEN,"FROM")=Name 38 ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address 39 ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address 40 ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title 41 ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments 42 ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text 43 ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text 44 ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes 45 ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) 46 ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line 47 ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details 48 ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data 49 ; 50 ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments 51 ; Input; 52 ; D0 - The IEN for the message in file 3.9, MESSAGE global 53 ; Output 54 ; OUTBF - The array of your choice to save the expanded and decoded message. 55 ; 56 GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data 57 K:'$G(C0CDATA("KEEP")) C0CDATA 58 N U 59 S U="^" 60 D:$G(C0CINPUT) 61 . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL 62 . S INPUT=C0CINPUT 63 . S DUZ=+INPUT 64 . D:$D(^XMB(3.7,DUZ,0))#2 65 . . S MBLST=$P(INPUT,";",2) 66 . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag 67 . . S:MALL["*" MALL=99999 68 . . ; Only one of these can be correct 69 . . D 70 . . . ; If nul, make it "IN" only 71 . . . I MBLST="" D QUIT 72 . . . . S MBLST("IN")=0,I=0 73 . . . . D GATHER(DUZ,"IN",.LST) 74 . . . .QUIT 75 . . . ; 76 . . . ; If "*", Get all Mailboxes and look for New Messages 77 . . . I MBLST["*" D QUIT 78 . . . . N NAM,NUM 79 . . . . S NUM=0 80 . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D 81 . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) 82 . . . . . D GATHER(DUZ,NAM,.LST) 83 . . . . .QUIT 84 . . . .QUIT 85 . . . ; 86 . . . ; If comma separated, look for mailboxes with new messages 87 . . . I $L(MBLST,",")>1 D QUIT 88 . . . . S NAM="" 89 . . . . N T,V 90 . . . . F T=1:1:$L(MBLST,",") S V=$P(MBLST,",",T) I $L(V) D 91 . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) 92 . . . . . S:NAM="" NAM=V 93 . . . . . D GATHER(DUZ,NAM,.LST) 94 . . . . .QUIT 95 . . . .QUIT 96 . . . ; 97 . . . ; If only 1 mailbox named, go get it 98 . . . I $L(MBLST) D GATHER(DUZ,MBLST,.LST) QUIT 99 . . .QUIT 100 . . MERGE C0CDATA=LST 101 . .QUIT 102 .QUIT 103 QUIT 104 ; =================== 105 GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail 106 N I,J,K,L 107 S (I,K)=0 108 S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) 109 F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D 110 . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) 111 . D ; :L 112 . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails 113 . . S LST(NAM,"MSG",I)=L 114 . . D GETTYP(I) 115 . .QUIT 116 .QUIT 117 S LST(NAM,"NUMBER")=K 118 QUIT 119 ; =================== 120 ; D0 is the IEN into the Message Global ^XMB(3.9,D0) 121 ; The products of these emails are scanned to identify 122 ; the number of documents stored in the MIME package. 123 ; The protocol runs like this; 124 ; Line 1 is the --separator 125 ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD 126 ; Line n+2 thru t-1 where t does NOT have "Content-" 127 ; Line t is Next Section Terminator, or Message Terminator, --separator 128 ; Line t+1 should not exist in the data set if Message Terminator 129 ; CON = "Content-" 130 ; FLG = "--" 131 ; SEP = FLG+7 or more characters ; Separator 132 ; END = SEP+FLG 133 ; SGC = Segment Count 134 ; Note: separator is a string of specific characters of 135 ; indeterminate length 136 ; LST() the transfer array 137 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line 138 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data 139 ; 140 GETTYP(D0) ; Look for the goodies in the Mail 141 N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM 142 S CON="Content-" 143 S FLG="--" 144 S SEP="" ; Start SEP as null, so we can use this to help identify the type 145 S (BCN,CNT,D1,END,SGC)=0 146 S XX=$G(^XMB(3.9,D0,0)) 147 S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) 148 S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) 149 F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) 150 S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) 151 S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) 152 ; Get the folks the email is sent to. 153 S D1=0 154 F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D 155 . N T 156 . S T=+$G(^XMB(3.9,D0,1,D1,0)) 157 . S:T T=$P($G(^VA(200,+T,0)),"^") 158 . S LST("TO",D1)=T 159 . S T=$G(^XMB(3.9,D0,6,D1,0)) 160 . S:T T=$P($G(^VA(200,+T,0)),"^") 161 . S:T="" T="<Unknown>" 162 . S LST("TO NAME",D1)=T 163 .QUIT 164 ; Preload first Segment (0) with beginning on Line 1 165 ; if not a 64bit 166 S LST(NAM,"MSG",D0,"SEG",0)=1 167 S D1=.9999,SEP="--" 168 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D 169 . ; Clear any control characters (cr/lf/ff) off 170 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) 171 . ; Enter once to set the SEP to capture the separator 172 . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q 173 . . S SEP=X,END=X_FLG 174 . . S (CNT,SGC)=1,BCN=0 175 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 176 . .QUIT 177 . ; 178 . ; A new separator is set, process original 179 . I X=SEP D QUIT 180 . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN 181 . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) 182 . . S SGC=SGC+1,BCN=0 183 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 184 . .QUIT 185 . ; 186 . S BCN=BCN+$L(X) 187 . I X[CON D Q 188 . . S J=$P($P(X,";"),CON,2) 189 . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) 190 . .QUIT 191 . ; 192 . ; S LST(NAM,"MSG",D0,"SEG",D1)=X 193 .QUIT 194 QUIT 195 ; =================== 196 NAME(NM) ; Return the name of the Sender 197 N NAME 198 S NAME="<Unknown Sender>" 199 D 200 . ; Look first for a value to use with the NEW PERSON file 201 . ; 202 . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q 203 . ; 204 . I $L(NM) S NAME=NM Q 205 . ; 206 . ; Else, pull the data from the message and display the foreign source 207 . ; of the message. 208 . N T 209 . S VAL=$G(^XMB(3.9,D0,.7)) 210 . S:VAL T=$P(^VA(200,VAL,0),U) 211 . I $L($G(T)) S NAME=T Q 212 . ; 213 .QUIT 214 QUIT NAME 215 ; =================== 216 TIME(Y) ; The time and date of the sending 217 X ^DD("DD") 218 QUIT Y 219 ; =================== 220 ; Segments in Message need to be identified and decoded properly 221 ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message 222 ; ARRAY will have the details of this one call 223 ; 224 ; Inputs; 225 ; C0CINPUT - The IEN of the message to expand 226 ; Outputs; 227 ; C0CDATA - Carrier for the returned structure of the Message 228 ; C0CDATA(D0,"SEG")=number of SEGMENTS 229 ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details 230 ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details 231 ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details 232 ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details 233 ; 234 DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery 235 N LST,D0,D1,U 236 S U="^" 237 S D0=+$G(C0CINPUT) 238 I D0 D QUIT 239 . D GETTYP2(D0) 240 . I $D(LST) M C0CDATA(D0)=LST 241 .QUIT 242 QUIT 243 ; =================== 244 ; End note if needed 245 ; MSK - Set of characters that do not exist in 64 bit encoding 246 GETTYP2(D0) ; Try to get the types and MSK for the 247 N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM 248 S CON="Content-",U="^" 249 S FLG="--" 250 S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" 251 S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type 252 S (BCN,CNT,D1,END,SGC)=0 253 S XX=$G(^XMB(3.9,D0,0)) 254 ; S K=$P(^XMB(3.9,D0,2,0),U,3) 255 S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) 256 S LST("CREATED")=$$TIME($P(XX,U,3)) 257 F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) 258 S LST("FROM")=$$NAME(XXNM) 259 ; Get the folks the email is sent to. 260 S D1=0 261 F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" 262 . N I,T 263 . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) 264 . S:T T=$P($G(^VA(200,T,0)),"^") 265 . S LST("TO",+D1)=T 266 . S T=$G(^XMB(3.9,D0,6,+D1,0)) 267 . S:T="" T=$P($G(^VA(200,+T,0)),"^") 268 . S:T="" T="<Unknown>" 269 . S LST("TO NAME",D1)=T 270 .QUIT 271 ; Get the Header for the message 272 S D1=0 273 F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D 274 . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) 275 .QUIT 276 ; Start walking the different sections 277 S D1=.99999,SEP="--" 278 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D 279 . ; Clear any control characters (cr/lf/ff) off 280 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) 281 . ; Enter once to set the SEP to capture the separator 282 . I (SEP="--")&($E(X,1,2)=FLG)&($L(X,FLG)=2) D Q 283 . . S SEP=X,END=X_FLG 284 . . S (CNT,SGC)=1,BCN=0 285 . . S LST("SEG",SGC)=D1 286 . .QUIT 287 . ; 288 . ; A new SEGMENT separator is set, process original 289 . I X=SEP D QUIT 290 . . ; Save Current Values 291 . . S LST("SEG",SGC,"SIZE")=BCN 292 . . ; Close this Segment and prepare to start a New Segment 293 . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) 294 . . ; Put the result in LST("SEG",SGC,"XML") 295 . . I $L(BF) D 296 . . . S ZN=1 297 . . . N I,T,TBF 298 . . . S TBF=BF 299 . . . F I=1:1:($L(TBF,"=")) D 300 . . . . S BF=$P(TBF,"=",I)_"=" 301 . . . . I BF'="=" D DECODER 302 . . . .QUIT 303 . . . S BF="" 304 . . .QUIT 305 . . S SGC=SGC+1,BCN=0 306 . . ; Incriment SGC to start a new Segment 307 . . S LST("SEG",SGC)=D1 308 . .QUIT 309 . ; 310 . ; Accumulate the 64 bit encoding 311 . I X=$TR(X,MSK)&$L(X) D Q 312 . . S BF=BF_X 313 . . S BCN=BCN+$L(X) 314 . .QUIT 315 . ; 316 . ; Ending Condition, close out the Segment 317 . I X=END D QUIT 318 . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) 319 . . I $L(BF) S ZN=1 D DECODER S BF="" Q 320 . .QUIT 321 . ; 322 . S BCN=BCN+$L(X) 323 . ; Split out the Content Info 324 . I X[CON D Q 325 . . S J=$P(X,CON,2) 326 . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9) 327 . .QUIT 328 . ; 329 . ; Everything else is Text 330 . S LST("SEG",SGC,"TXT",D1)=X 331 .QUIT 332 QUIT 333 ; =================== 334 ; Break down the Buffer Array so it can be saved. 335 ; BF is passed in. 336 DECODER ; 337 N RCNT,TBF,ZBF,ZI,ZJ,ZK,ZSIZE 338 S ZBF=BF 339 ; Full Buffer, BF, now check for Encryption and Unpack 340 F RCNT=1:1:$L(ZBF,"=") D 341 . N BF 342 . S BF=$P(ZBF,"=",RCNT) 343 . ; Unpacking the 64 bit encoding 344 . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) 345 . D:$L(TBF) 346 . . N XBF 347 . . S BF=BF_"=" 348 . . D NORMAL(.XBF,.TBF) 349 . . M LST("SEG",SGC,"XML",RCNT)=XBF 350 . .QUIT 351 .QUIT 352 QUIT 353 ; =================== 354 ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT 355 ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT 356 ; >D NORMAL^C0CMAIL(.OUT,BF) 357 NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML 358 ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME 359 ; 360 N ZN,OUTBF 361 S ZN=1 362 S OUTBF(ZN)=$P(INXML,"><",ZN)_">" 363 F ZN=ZN+1:1 S OUTBF(ZN)="<"_$P(INXML,"><",ZN) Q:$P(INXML,"><",ZN+1)="" D ; 364 . S OUTBF(ZN)=OUTBF(ZN)_">" 365 .QUIT 366 M OUTXML=OUTBF 367 QUIT 368 ; =================== 369 ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv 370 ; End note if needed 371 QUIT 372 ; =================== -
ccr/branches/ohum/p/C0CMAIL2.m
r1332 r1333 1 1 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr 2 V ;;0.1;C0C;nopatch;noreleasedate 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 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 GETMSG(C0CDATA,C0CINPUT) 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 GATHER(DUZ,NAM,LST) 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 GETTYP(D0) 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 NAME(NM) 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 TIME(Y) 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 DETAIL(C0CDATA,C0CINPUT) 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 GETTYP2(D0) 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 DECODER 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 NORMAL(OUTXML,INXML) 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 UPPER(X) 435 436 437 438 ERROR(ER) 439 440 441 442 443 444 445 446 447 448 449 450 ER01 451 ER02 452 ER03 453 ER04 454 ER05 455 ER06 456 ER07 457 ER08 458 ER10 459 ER11 460 ER12 461 462 463 464 2 ;;0.1;C0C;nopatch;noreleasedate;Build 1 3 ;Copyright 2011 Chris Richardson, Richardson Computer Research 4 ; Modified 3110615@1040 5 ; rcr@rcresearch.us 6 ; Licensed under the terms of the GNU 7 ;General Public License See attached copy of the License. 8 ; 9 ;This program is free software; you can redistribute it and/or modify 10 ;it under the terms of the GNU General Public License as published by 11 ;the Free Software Foundation; either version 2 of the License, or 12 ;(at your option) any later version. 13 ; 14 ;This program is distributed in the hope that it will be useful, 15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 ;GNU General Public License for more details. 18 ; 19 ;You should have received a copy of the GNU General Public License along 20 ;with this program; if not, write to the Free Software Foundation, Inc., 21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 22 ; 23 ; ------------------ 24 ;Entry Points 25 ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments 26 ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) 27 ; Input: 28 ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL 29 ; or "*" for all boxes, default is "IN" if missing]" 30 ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", 31 ; "*" for All or 9,999 maximum 32 ; MALL?1.n = that number of the n most recent 33 ; Internally: 34 ; BNAM = Box Name 35 ; Output: 36 ; C0CDATA 37 ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket 38 ; (BNAM,"MSG",C0CIEN,"FROM")=Name 39 ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address 40 ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address 41 ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title 42 ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments 43 ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text 44 ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text 45 ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes 46 ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) 47 ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line 48 ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details 49 ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data 50 ; 51 ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments 52 ; Input; 53 ; D0 - The IEN for the message in file 3.9, MESSAGE global 54 ; Output 55 ; OUTBF - The array of your choice to save the expanded and decoded message. 56 ; 57 GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data 58 K:'$G(C0CDATA("KEEP")) C0CDATA 59 N U 60 S U="^" 61 D:$G(C0CINPUT) 62 . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL 63 . S INPUT=C0CINPUT 64 . S DUZ=+INPUT 65 . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q 66 . ; 67 . D:$D(^XMB(3.7,DUZ,0))#2 68 . . S MBLST=$P(INPUT,";",2) 69 . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag 70 . . S:MALL["*" MALL=99999 71 . . ; Only one of these can be correct 72 . . D 73 . . . ; If nul, make it "IN" only 74 . . . I MBLST="" D QUIT 75 . . . . S MBLST("IN")=0,I=0 76 . . . . D GATHER(DUZ,"IN",.LST) 77 . . . .QUIT 78 . . . ; 79 . . . ; If "*", Get all Mailboxes and look for New Messages 80 . . . I MBLST["*" D QUIT 81 . . . . N NAM,NUM 82 . . . . S NUM=0 83 . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D 84 . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) 85 . . . . . D GATHER(DUZ,NAM,.LST) 86 . . . . .QUIT 87 . . . .QUIT 88 . . . ; 89 . . . ; If comma separated, look for mailboxes with new messages 90 . . . I $L(MBLST,",")>1 D QUIT 91 . . . . S NAM="" 92 . . . . N TN,V 93 . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D 94 . . . . . I $L(V) D QUIT 95 . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) 96 . . . . . . S:NAM="" NAM=V 97 . . . . . . D GATHER(DUZ,NAM,.LST) 98 . . . . . .QUIT 99 . . . . . ; 100 . . . . . D ERROR("ER08") 101 . . . . .QUIT 102 . . . .QUIT 103 . . . ; 104 . . . ; If only 1 mailbox named, go get it 105 . . . I $L(MBLST) D QUIT 106 . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT 107 . . . . ; 108 . . . . D ERROR("ER07") 109 . . .QUIT 110 . . MERGE C0CDATA=LST 111 . .QUIT 112 .QUIT 113 QUIT 114 ; =================== 115 GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail 116 N I,J,K,L 117 S (I,K)=0 118 S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) 119 F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D 120 . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) 121 . D ; :L 122 . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails 123 . . S LST(NAM,"MSG",I)=L 124 . . D GETTYP(I) 125 . .QUIT 126 .QUIT 127 S LST(NAM,"NUMBER")=K 128 QUIT 129 ; =================== 130 ; D0 is the IEN into the Message Global ^XMB(3.9,D0) 131 ; The products of these emails are scanned to identify 132 ; the number of documents stored in the MIME package. 133 ; The protocol runs like this; 134 ; Line 1 is the --separator 135 ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD 136 ; Line n+2 thru t-1 where t does NOT have "Content-" 137 ; Line t is Next Section Terminator, or Message Terminator, --separator 138 ; Line t+1 should not exist in the data set if Message Terminator 139 ; CON = "Content-" 140 ; FLG = "--" 141 ; SEP = FLG+7 or more characters ; Separator 142 ; END = SEP+FLG 143 ; SGC = Segment Count 144 ; Note: separator is a string of specific characters of 145 ; indeterminate length 146 ; LST() the transfer array 147 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line 148 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data 149 ; 150 GETTYP(D0) ; Look for the goodies in the Mail 151 N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM 152 S CON="Content-" 153 S FLG="--" 154 S SEP="" ; Start SEP as null, so we can use this to help identify the type 155 S (BCN,CNT,D1,END,SGC)=0 156 S XX=$G(^XMB(3.9,D0,0)) 157 S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) 158 S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) 159 F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) 160 S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) 161 S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) 162 ; Get the folks the email is sent to. 163 S D1=0 164 F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D 165 . N T 166 . S T=+$G(^XMB(3.9,D0,1,D1,0)) 167 . S:T T=$P($G(^VA(200,+T,0)),"^") 168 . S LST("TO",D1)=T 169 . S T=$G(^XMB(3.9,D0,6,D1,0)) 170 . S:T T=$P($G(^VA(200,+T,0)),"^") 171 . S:T="" T="<Unknown>" 172 . S LST("TO NAME",D1)=T 173 .QUIT 174 ; Preload first Segment (0) with beginning on Line 1 175 ; if not a 64bit 176 S LST(NAM,"MSG",D0,"SEG",0)=1 177 S D1=.9999,SEP="@@" 178 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D 179 . ; Clear any control characters (cr/lf/ff) off 180 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) 181 . ; Enter once to set the SEP to capture the separator 182 . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q 183 . . S SEP=X,END=X_FLG 184 . . S (CNT,SGC)=1,BCN=0 185 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 186 . .QUIT 187 . ; 188 . ; A new separator is set, process original 189 . I X=SEP D QUIT 190 . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF) 191 . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) 192 . . S SGC=SGC+1,BCN=0 193 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 194 . .QUIT 195 . ; 196 . S BCN=BCN+$L(X) 197 . I X[CON D Q 198 . . S J=$P($P(X,";"),CON,2) 199 . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) 200 . .QUIT 201 . ; 202 . ; S LST(NAM,"MSG",D0,"SEG",D1)=X 203 .QUIT 204 QUIT 205 ; =================== 206 NAME(NM) ; Return the name of the Sender 207 N NAME 208 S NAME="<Unknown Sender>" 209 D 210 . ; Look first for a value to use with the NEW PERSON file 211 . ; 212 . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q 213 . ; 214 . I $L(NM) S NAME=NM Q 215 . ; 216 . ; Else, pull the data from the message and display the foreign source 217 . ; of the message. 218 . N T 219 . S VAL=$G(^XMB(3.9,D0,.7)) 220 . S:VAL T=$P(^VA(200,VAL,0),U) 221 . I $L($G(T)) S NAME=T Q 222 . ; 223 .QUIT 224 QUIT NAME 225 ; =================== 226 TIME(Y) ; The time and date of the sending 227 X ^DD("DD") 228 QUIT Y 229 ; =================== 230 ; Segments in Message need to be identified and decoded properly 231 ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message 232 ; ARRAY will have the details of this one call 233 ; 234 ; Inputs; 235 ; C0CINPUT - The IEN of the message to expand 236 ; Outputs; 237 ; C0CDATA - Carrier for the returned structure of the Message 238 ; C0CDATA(D0,"SEG")=number of SEGMENTS 239 ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type 240 ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details 241 ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details 242 ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details 243 ; 244 DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery 245 N LST,D0,D1,U 246 S U="^" 247 S D0=+$G(C0CINPUT) 248 I D0 D QUIT 249 . I $D(^XMB(3.9,D0))<10 D ERROR("ER01") QUIT 250 . ; 251 . D GETTYP2(D0) 252 . I $D(LST) M C0CDATA(D0)=LST Q 253 . ; 254 . D ERROR("ER02") 255 .QUIT 256 QUIT 257 ; =================== 258 ; End note if needed 259 ; MSK - Set of characters that do not exist in 64 bit encoding 260 GETTYP2(D0) ; Try to get the types and MSK for the 261 N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM 262 S CON="Content-",U="^" 263 S FLG="--" 264 S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" 265 S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type 266 S (BCN,CNT,D1,END,SGC)=0 267 S XX=$G(^XMB(3.9,D0,0)) 268 ; S K=$P(^XMB(3.9,D0,2,0),U,3) 269 S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) 270 S LST("CREATED")=$$TIME($P(XX,U,3)) 271 F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) 272 S LST("FROM")=$$NAME(XXNM) 273 ; Get the folks the email is sent to. 274 S D1=0 275 F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" 276 . N I,T 277 . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) 278 . S:T T=$P($G(^VA(200,T,0)),"^") 279 . S LST("TO",+D1)=T 280 . S T=$G(^XMB(3.9,D0,6,+D1,0)) 281 . S:T="" T=$P($G(^VA(200,+T,0)),"^") 282 . S:T="" T="<Unknown>" 283 . S LST("TO NAME",D1)=T 284 .QUIT 285 ; Get the Header for the message 286 S D1=0 287 F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D 288 . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) 289 .QUIT 290 ; Start walking the different sections 291 S D1=.99999,SEP="@@",SGC=0 292 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D 293 . ; Clear any control characters (cr/lf/ff) off 294 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) 295 . ; Enter once to set the SEP to capture the separator 296 . I (SEP="@@")&(X?2."--"5.AN.E) D Q 297 . . I $L(X,FLG)>2 D ERROR("ER10") 298 . . S SEP=X,END=X_FLG 299 . . S (CNT,SGC)=1,BCN=0 300 . . S LST("SEG",SGC)=D1 301 . .QUIT 302 . ; 303 . ; A new SEGMENT separator is set, process original 304 . I X=SEP D QUIT 305 . . ; Save Current Values 306 . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF) 307 . . ; Close this Segment and prepare to start a New Segment 308 . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1) 309 . . ; Put the result in LST("SEG",SGC,"XML") 310 . . I $L(BF) D 311 . . . S ZN=1 312 . . . N I,T,TBF 313 . . . S TBF=BF 314 . . . F I=1:1:($L(TBF,"=")) D 315 . . . . S BF=$P(TBF,"=",I)_"=" 316 . . . . I BF'="=" D DECODER 317 . . . .QUIT 318 . . . S BF="" 319 . . .QUIT 320 . . S SGC=SGC+1,BCN=0 321 . . ; Incriment SGC to start a new Segment 322 . . S LST("SEG",SGC)=D1 323 . .QUIT 324 . ; 325 . ; Accumulate the 64 bit encoding 326 . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT 327 . ; 328 . ; Ending Condition, close out the Segment 329 . I X=END D QUIT 330 . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) 331 . . I $L(BF) S ZN=1 D DECODER S BF="" Q 332 . .QUIT 333 . ; 334 . ; Accumulate the lengths of other lines of the message 335 . S BCN=BCN+$L(X) 336 . ; Split out the Content Info 337 . I X[CON D Q 338 . . S J=$P(X,CON,2) 339 . . I J[" boundary=" D 340 . . . S SEP=$P($P(J," boundary=",2),"""",2),END=SEP_FLG 341 . . . Q:SEP?2"-"5.ANP 342 . . . ; 343 . . . D ERROR("ER11") 344 . . . Q:SEP'[" " 345 . . . ; 346 . . . D ERROR("ER12") 347 . . .QUIT 348 . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9) 349 . .QUIT 350 . ; 351 . ; Everything else is Text, Check for CCR/CCD. 352 . N KK,UBF 353 . D 354 . . S UBF=$$UPPER(X) 355 . . I UBF["<CONTINUITYOFCARERECORD" S $P(LST("SEG",SGC),U,3)="CCR" Q 356 . . ; 357 . . I UBF["<CLINICALDOCUMENT" S $P(LST("SEG",SGC),U,3)="CCD" Q 358 . .QUIT 359 . ; Look for directives in the text before it gets published 360 . ; Look for "=3D" and replace it with a single "=". I can do more parsing 361 . ; but there may be situations where the line has been wrapped. 362 . D:X["=3D" 363 . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D" 364 . .QUIT 365 . S LST("SEG",SGC,"TXT",D1)=X 366 .QUIT 367 QUIT 368 ; =================== 369 ; Break down the Buffer Array so it can be saved. 370 ; BF is passed in. 371 DECODER ; 372 N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE 373 S ZBF=BF 374 ; Full Buffer, BF, now check for Encryption and Unpack 375 F RCNT=1:1:$L(ZBF,"=") D 376 . N BF 377 . S BF=$P(ZBF,"=",RCNT) 378 . ; Unpacking the 64 bit encoding 379 . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) 380 . D:$L(TBF) 381 . . N C,OK,OKCNT,KK,XBF,UBF 382 . . D 383 . . . S UBF=$$UPPER(TBF) 384 . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q 385 . . . ; 386 . . . I UBF["<CLINICALDOCUMENT XMLNS=" S $P(LST("SEG",SGC),U,3)="CCD" Q 387 . . .QUIT 388 . . ; Check for Bad Signature Decoding, after 100 bad characters 389 . . S OK=1,OKCNT=0 390 . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q 391 . . ; 392 . . D 393 . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q 394 . . . ; 395 . . . S BF=BF_"=" 396 . . . D NORMAL(.XBF,.TBF) 397 . . .QUIT 398 . . M LST("SEG",SGC,"XML",RCNT)=XBF 399 . .QUIT 400 .QUIT 401 QUIT 402 ; =================== 403 ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT 404 ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT 405 ; >D NORMAL^C0CMAIL(.OUT,BF) 406 NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML 407 ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME 408 ; 409 N ZN,OUTBF,XX,ZSEP 410 S INXML=$TR(INXML,$C(10,12,13)) 411 S ZN=1,ZSEP=">" 412 S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 413 F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" 414 . S XX=$P(INXML,"><",ZN) 415 . S:$E($RE(XX))=">" ZSEP="" 416 . Q:XX="" 417 . ; 418 . S XX="<"_XX_ZSEP 419 . D 420 . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q 421 . . ; 422 . . D ERROR("ER05") 423 . . F ZL=ZL+1:1 D Q:XX="" 424 . . . N XL 425 . . . S XL=$E(XX,1,4000) 426 . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters 427 . . . S OUTBF(ZL)=XL 428 . . .QUIT 429 . .QUIT 430 .QUIT 431 M OUTXML=OUTBF 432 QUIT 433 ; =================== 434 UPPER(X) ; Convert any lowercase letters to Uppercase letters 435 QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 436 ; =================== 437 ; EN is a counter that remains between error events 438 ERROR(ER) ; Error Handler 439 N TXXQ,XXXQ 440 S XXXQ="Unknown Error Encountered = "_ER 441 S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) 442 I TXXQ'="" D 443 . I TXXQ["_" X "S TXXQ="_TXXQ 444 . S XXXQ=TXXQ 445 .QUIT 446 S EN(ER)=$G(EN(ER))+1 447 S LST("ERR",ER,EN(ER))=XXXQ 448 QUIT 449 ; =================== 450 ER01 ;;Message Missing 451 ER02 ;;Message Text Missing 452 ER03 ;;Message Not Identifiable 453 ER04 ;;Segment is too large 454 ER05 ;;Mailbox Missing 455 ER06 ;;"User Missing = "_$G(DUZ) 456 ER07 ;;"Bad DUZ = "_DUZ 457 ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) 458 ER10 ;;"Bad Separator found = "_X 459 ER11 ;;"Non-Standard Separator Found:>"_$G(J) 460 ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) 461 ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv 462 ; End note if needed 463 QUIT 464 ; =================== -
ccr/branches/ohum/p/C0CMAIL3.m
r1332 r1333 1 1 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr 2 V ;;0.1;C0C;nopatch;noreleasedate 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 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 GETMSG(C0CDATA,C0CINPUT) 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 GATHER(DUZ,NAM,LST) 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 GETTYP(D0) 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 NAME(NM) 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 TIME(Y) 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 DETAIL(C0CDATA,C0CINPUT) 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 GETTYP2(D0) 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 CONTENT(D1) 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 BOUNDARY(X) 427 428 429 430 431 432 433 434 435 436 437 438 439 DECODER(BF,TYP) 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 NORMAL(OUTXML,INXML) 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 UPPER(X) 504 505 506 507 ERROR(ER) 508 509 510 511 512 513 514 515 516 517 518 519 ER01 520 ER02 521 ER03 522 ER04 523 ER05 524 ER06 525 ER07 526 ER08 527 ER10 528 ER11 529 ER12 530 ER13 531 532 533 534 2 ;;0.1;C0C;nopatch;noreleasedate;Build 1 3 ;Copyright 2011 Chris Richardson, Richardson Computer Research 4 ; Modified 3110619@2038 5 ; rcr@rcresearch.us 6 ; Licensed under the terms of the GNU 7 ;General Public License See attached copy of the License. 8 ; 9 ;This program is free software; you can redistribute it and/or modify 10 ;it under the terms of the GNU General Public License as published by 11 ;the Free Software Foundation; either version 2 of the License, or 12 ;(at your option) any later version. 13 ; 14 ;This program is distributed in the hope that it will be useful, 15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 ;GNU General Public License for more details. 18 ; 19 ;You should have received a copy of the GNU General Public License along 20 ;with this program; if not, write to the Free Software Foundation, Inc., 21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 22 ; 23 ; ------------------ 24 ;Entry Points 25 ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments 26 ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) 27 ; Input: 28 ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL 29 ; or "*" for all boxes, default is "IN" if missing]" 30 ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", 31 ; "*" for All or 9,999 maximum 32 ; MALL?1.n = that number of the n most recent 33 ; Internally: 34 ; BNAM = Box Name 35 ; Output: 36 ; C0CDATA 37 ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket 38 ; (BNAM,"MSG",C0CIEN,"FROM")=Name 39 ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address 40 ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address 41 ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title 42 ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments 43 ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text 44 ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text 45 ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes 46 ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) 47 ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line 48 ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details 49 ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data 50 ; 51 ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments 52 ; Input; 53 ; D0 - The IEN for the message in file 3.9, MESSAGE global 54 ; Output 55 ; OUTBF - The array of your choice to save the expanded and decoded message. 56 ; 57 GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data 58 K:'$G(C0CDATA("KEEP")) C0CDATA 59 N U 60 S U="^" 61 D:$G(C0CINPUT) 62 . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL 63 . S INPUT=C0CINPUT 64 . S DUZ=+INPUT 65 . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q 66 . ; 67 . D:$D(^XMB(3.7,DUZ,0))#2 68 . . S MBLST=$P(INPUT,";",2) 69 . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag 70 . . S:MALL["*" MALL=99999 71 . . ; Only one of these can be correct 72 . . D 73 . . . ; If nul, make it "IN" only 74 . . . I MBLST="" D QUIT 75 . . . . S MBLST("IN")=0,I=0 76 . . . . D GATHER(DUZ,"IN",.LST) 77 . . . .QUIT 78 . . . ; 79 . . . ; If "*", Get all Mailboxes and look for New Messages 80 . . . I MBLST["*" D QUIT 81 . . . . N NAM,NUM 82 . . . . S NUM=0 83 . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D 84 . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) 85 . . . . . D GATHER(DUZ,NAM,.LST) 86 . . . . .QUIT 87 . . . .QUIT 88 . . . ; 89 . . . ; If comma separated, look for mailboxes with new messages 90 . . . I $L(MBLST,",")>1 D QUIT 91 . . . . S NAM="" 92 . . . . N TN,V 93 . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D 94 . . . . . I $L(V) D QUIT 95 . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) 96 . . . . . . S:NAM="" NAM=V 97 . . . . . . D GATHER(DUZ,NAM,.LST) 98 . . . . . .QUIT 99 . . . . . ; 100 . . . . . D ERROR("ER08") 101 . . . . .QUIT 102 . . . .QUIT 103 . . . ; 104 . . . ; If only 1 mailbox named, go get it 105 . . . I $L(MBLST) D QUIT 106 . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT 107 . . . . ; 108 . . . . D ERROR("ER07") 109 . . .QUIT 110 . . MERGE C0CDATA=LST 111 . .QUIT 112 .QUIT 113 QUIT 114 ; =================== 115 GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail 116 N I,J,K,L 117 S (I,K)=0 118 S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) 119 F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D 120 . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) 121 . D ; :L 122 . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails 123 . . S LST(NAM,"MSG",I)=L 124 . . D GETTYP(I) 125 . .QUIT 126 .QUIT 127 S LST(NAM,"NUMBER")=K 128 QUIT 129 ; =================== 130 ; D0 is the IEN into the Message Global ^XMB(3.9,D0) 131 ; The products of these emails are scanned to identify 132 ; the number of documents stored in the MIME package. 133 ; The protocol runs like this; 134 ; Line 1 is the --separator 135 ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD 136 ; Line n+2 thru t-1 where t does NOT have "Content-" 137 ; Line t is Next Section Terminator, or Message Terminator, --separator 138 ; Line t+1 should not exist in the data set if Message Terminator 139 ; CON = "Content-" 140 ; FLG = "--" 141 ; SEP = FLG+7 or more characters ; Separator 142 ; END = SEP+FLG 143 ; SGC = Segment Count 144 ; Note: separator is a string of specific characters of 145 ; indeterminate length 146 ; LST() the transfer array 147 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line 148 ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data 149 ; 150 GETTYP(D0) ; Look for the goodies in the Mail 151 N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM 152 S CON="Content-" 153 S FLG="--" 154 S SEP="" ; Start SEP as null, so we can use this to help identify the type 155 S (BCN,CNT,D1,END,SGC)=0 156 S XX=$G(^XMB(3.9,D0,0)) 157 S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) 158 S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) 159 F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) 160 S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) 161 S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) 162 ; Get the folks the email is sent to. 163 S D1=0 164 F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D 165 . N T 166 . S T=+$G(^XMB(3.9,D0,1,D1,0)) 167 . S:T T=$P($G(^VA(200,+T,0)),"^") 168 . S LST("TO",D1)=T 169 . S T=$G(^XMB(3.9,D0,6,D1,0)) 170 . S:T T=$P($G(^VA(200,+T,0)),"^") 171 . S:T="" T="<Unknown>" 172 . S LST("TO NAME",D1)=T 173 .QUIT 174 ; Preload first Segment (0) with beginning on Line 1 175 ; if not a 64bit 176 S LST(NAM,"MSG",D0,"SEG",0)=1 177 S D1=.9999,SEP="@@" 178 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D 179 . ; Clear any control characters (cr/lf/ff) off 180 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) 181 . ; Enter once to set the SEP to capture the separator 182 . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q 183 . . S SEP=X,END=X_FLG 184 . . S (CNT,SGC)=1,BCN=0 185 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 186 . .QUIT 187 . ; 188 . ; A new separator is set, process original 189 . I X=SEP D QUIT 190 . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF) 191 . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) 192 . . S SGC=SGC+1,BCN=0 193 . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 194 . .QUIT 195 . ; 196 . S BCN=BCN+$L(X) 197 . I X[CON D Q 198 . . S J=$P($P(X,";"),CON,2) 199 . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) 200 . .QUIT 201 . ; 202 . ; S LST(NAM,"MSG",D0,"SEG",D1)=X 203 .QUIT 204 QUIT 205 ; =================== 206 NAME(NM) ; Return the name of the Sender 207 N NAME 208 S NAME="<Unknown Sender>" 209 D 210 . ; Look first for a value to use with the NEW PERSON file 211 . ; 212 . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q 213 . ; 214 . I $L(NM) S NAME=NM Q 215 . ; 216 . ; Else, pull the data from the message and display the foreign source 217 . ; of the message. 218 . N T 219 . S VAL=$G(^XMB(3.9,D0,.7)) 220 . S:VAL T=$P(^VA(200,VAL,0),U) 221 . I $L($G(T)) S NAME=T Q 222 . ; 223 .QUIT 224 QUIT NAME 225 ; =================== 226 TIME(Y) ; The time and date of the sending 227 X ^DD("DD") 228 QUIT Y 229 ; =================== 230 ; Segments in Message need to be identified and decoded properly 231 ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message 232 ; ARRAY will have the details of this one call 233 ; 234 ; Inputs; 235 ; C0CINPUT - The IEN of the message to expand 236 ; Outputs; 237 ; C0CDATA - Carrier for the returned structure of the Message 238 ; C0CDATA(D0,"SEG")=number of SEGMENTS 239 ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type 240 ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details 241 ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details 242 ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details 243 ; 244 DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery 245 N LST,D0,D1,U 246 S U="^" 247 S D0=+$G(C0CINPUT) 248 I D0 D QUIT 249 . I $D(^XMB(3.9,D0))<10 D ERROR("ER01") QUIT 250 . ; 251 . D GETTYP2(D0) 252 . I $D(LST) M C0CDATA(D0)=LST Q 253 . ; 254 . D ERROR("ER02") 255 .QUIT 256 QUIT 257 ; =================== 258 ; End note if needed 259 ; MSK - Set of characters that do not exist in 64 bit encoding 260 GETTYP2(D0) ; Try to get the types and MSK for the 261 N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM 262 S CON="Content-",U="^" 263 S FLG="--",MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" 264 S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type 265 S (BCN,CNT,D1,END,SGC)=0 266 S XX=$G(^XMB(3.9,D0,0)) 267 ; S K=$P(^XMB(3.9,D0,2,0),U,3) 268 S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) 269 S LST("CREATED")=$$TIME($P(XX,U,3)) 270 F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) 271 S LST("FROM")=$$NAME(XXNM) 272 ; Get the folks the email is sent to. 273 S D1=0 274 F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" 275 . N I,T 276 . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) 277 . S:T T=$P($G(^VA(200,T,0)),"^") 278 . S LST("TO",+D1)=T 279 . S T=$G(^XMB(3.9,D0,6,+D1,0)) 280 . S:T="" T=$P($G(^VA(200,+T,0)),"^") 281 . S:T="" T="<Unknown>" 282 . S LST("TO NAME",D1)=T 283 .QUIT 284 ; Get the Header for the message and store as "HDR" 285 S D1=0,SGC=0 286 F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D 287 . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) 288 .QUIT 289 N BNDRY,STKL,SEG 290 S STKL=0,SEG=0 291 ; Find boundaries and map them 292 S D1=0 293 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D 294 . ; Clear any control characters (cr/lf/ff) off 295 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) 296 . ; Look for " boundary=" in the various parts. Map the establishment and the 297 . ; terminator markers and the actual boundary markers. 298 . I X[" boundary=" D Q 299 . . S SEP=$P(X," boundary=",2) 300 . . S:$E(SEP)="""" SEP=$TR(SEP,"""") 301 . . S STKL=STKL+1 302 . . S END=SEP_FLG 303 . . S BNDRY(STKL,SEP)=0 304 . . S BNDRX(SEP)=STKL,BNDRZ(END)=0 305 . .QUIT 306 . ; 307 . ; Look for information as to how amy boudaries are present and where 308 . ; they terminate 309 . D:X'=""&($E(X,1,2)="--")&($E(X,$L(X)-1,9999)'="--") 310 . . ; Boundary Found 311 . . I $D(BNDRX(X)) D Q 312 . . . S SEG=SEG+1 313 . . . S BNDRE(X)=$G(BNDRE(X))_D1_";" 314 . . . S BND1(D1)=STKL_";B;"_SEG_";"_X 315 . . . S BNDR(X,D1,"B")=STKL 316 . . . I BNDRX(X)=X D ERROR("ER13") 317 . . .QUIT 318 . . ; 319 . . ; Boundary Terminator 320 . . I $D(BNDRZ(X)) D Q 321 . . . S BNDR(X,D1,"E")=STKL 322 . . . S BNDRZ(X)=BNDRZ(X)+1 323 . . . S BND1(D1)=STKL_";E;"_SEG_";"_X 324 . . . S SEG=SEG+1 325 . . . I BNDRX(X)=X D ERROR("ER14") 326 . . . S STKL=STKL-1 327 . . .QUIT 328 . .QUIT 329 .QUIT 330 ; Start walking the TEXT/XML/64-BIT ENCODING sections of the message 331 N A,B,C,STACK,STYP,SEG,AX 332 S D1=.99999,SGC=0 333 F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D 334 . ; Clear any control characters (cr/lf/ff) off 335 . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) 336 . ; 337 . D 338 . . I $D(BND1(D1)) D BOUNDARY(X) QUIT 339 . . ; 340 . . S DX=$O(BND1(D1)) 341 . . I DX="" D ERROR("ER15") Q 342 . . ; 343 . . ; Good situation, extract the parts for the section 344 . . S A=$G(BND1(DX)) 345 . . S STACK=+A,STYP=$P(A,";",2),SGC=$P(A,";",3),AX=$P(A,";",4,999) 346 . .QUIT 347 . ; Enter once to set the SEP to capture the separator 348 . ; 349 . ; A new SEGMENT separator is set, process original 350 . I $D(BND1(X)) D QUIT 351 . . ; Save Current Values 352 . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF) 353 . . ; Close this Segment and prepare to start a New Segment 354 . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1) 355 . . ; Put the result in LST("SEG",SGC,"XML") 356 . . I $L(BF) D 357 . . . S ZN=1 358 . . . N I,T,TBF 359 . . . S TBF=BF 360 . . . F I=1:1:($L(TBF,"=")) D 361 . . . . S BF=$P(TBF,"=",I)_"=" 362 . . . . I "="'[BF D DECODER(.BF,.TYP) 363 . . . .QUIT 364 . . . S BF="" 365 . . .QUIT 366 . . S SGC=SGC+1,BCN=0 367 . . ; Incriment SGC to start a new Segment 368 . . S LST("SEG",SGC)=D1 369 . .QUIT 370 . ; 371 . ; Accumulate the 64 bit encoding, no spaces, or other non-64bit characters 372 . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT 373 . ; 374 . ; Ending Condition, close out the Segment 375 . I $D(BNDRZ(X)) D QUIT 376 . . S $P(LST("SEG",SGC),"^",2)=D1-1 377 . . I $L(BF) S ZN=1 D DECODER(.BF,.TYP) S BF="" Q 378 . .QUIT 379 . ; 380 . ; Accumulate the content lines of the message 381 . S BCN=BCN+$L(X) 382 . ; Split out the Content Info 383 . I X[CON D Q 384 . . S J=$P(X,CON,2) 385 . . S TYP="CONTENT" 386 . . S LST("SEG",SGC,TYP,$P(J,":"))=$P(J,":",2,9) 387 . . D CONTENT(D1) 388 . .QUIT 389 . ; 390 . ; Everything else is Text, Check for CCR/CCD. 391 . N KK,UBF 392 . D 393 . . S UBF=$$UPPER(X) 394 . . I UBF["<CONTINUITYOFCARERECORD" S $P(LST("SEG",SGC),U,3)="CCR" Q 395 . . ; 396 . . I UBF["<CLINICALDOCUMENT" S $P(LST("SEG",SGC),U,3)="CCD" Q 397 . .QUIT 398 . ; Look for directives in the text before it gets published 399 . ; Look for "=3D" and replace it with a single "=". I can do more parsing 400 . ; but there may be situations where the line has been wrapped. 401 . D:X["=3D" 402 . . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D" 403 . .QUIT 404 . S LST("SEG",SGC,TYP,D1)=X 405 .QUIT 406 QUIT 407 ; =================== 408 CONTENT(D1) ; Try pulling Content Statements 409 N J,UP,X 410 S X=$G(^XMB(3.9,D0,2,D1,0)) 411 S J=$P(X,CON,2) 412 S UP=$TR($$UPPER(X),"""") 413 S:$G(TYP)="" TYP="TXT" 414 D 415 . I UP["NAME=",($L(UP,".")>1) S TYP=$P(UP,".",2) Q 416 . I UP["XML" S TYP="XML" Q 417 . I UP["P7S" S TYP="P7S" Q 418 . I J[" boundary=" D BOUNDARY(J) 419 .QUIT 420 S LIS("CON",SGC,D1)=X 421 S LIS("CON",SGC,D1,"TYP")=TYP 422 ; If there is a follow-on, look for another line after this. 423 I $E($RE(X),1)=";" D CONTENT(D1+1) 424 QUIT 425 ; =================== 426 BOUNDARY(X) ; Set an additional BOUNDARY, and activate another stack level 427 S SEP=$P($P(X," boundary=",2),"""",2),END=SEP_FLG 428 Q:SEP?2"-".ANP 429 ; 430 D ERROR("ER11") 431 Q:SEP'[" " 432 ; 433 D ERROR("ER12") 434 QUIT 435 ; =================== 436 ; Break down the Buffer Array so it can be saved. 437 ; BF is passed in. 438 ; TYP is the type of 439 DECODER(BF,TYP) ; 440 N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE 441 S:$G(TYP)="" TYP="XML" 442 S ZBF=BF 443 ; Full Buffer, BF, now check for Encryption and Unpack 444 F RCNT=1:1:$L(ZBF,"=") D 445 . N BF 446 . S BF=$P(ZBF,"=",RCNT) 447 . ; Unpacking the 64 bit encoding 448 . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) 449 . D:$L(TBF) 450 . . N C,OK,OKCNT,KK,XBF,UBF 451 . . D 452 . . . S UBF=$$UPPER(TBF) 453 . . . I UBF["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q 454 . . . ; 455 . . . I UBF["<CLINICALDOCUMENT XMLNS=" S $P(LST("SEG",SGC),U,3)="CCD" Q 456 . . .QUIT 457 . . ; Check for Bad Signature Decoding, after 100 bad characters 458 . . S OK=1,OKCNT=0 459 . . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q 460 . . ; 461 . . D 462 . . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" Q 463 . . . ; 464 . . . S BF=BF_"=" 465 . . . D NORMAL(.XBF,.TBF) 466 . . .QUIT 467 . . M LST("SEG",SGC,TYP,RCNT)=XBF 468 . .QUIT 469 .QUIT 470 QUIT 471 ; =================== 472 ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT 473 ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT 474 ; >D NORMAL^C0CMAIL(.OUT,BF) 475 NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML 476 ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME 477 ; 478 N ZN,OUTBF,XX,ZSEP 479 S INXML=$TR(INXML,$C(10,12,13)) 480 S ZN=1,ZSEP=">" 481 S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 482 F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" 483 . S XX=$P(INXML,"><",ZN) 484 . S:$E($RE(XX))=">" ZSEP="" 485 . Q:XX="" 486 . ; 487 . S XX="<"_XX_ZSEP 488 . D 489 . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q 490 . . ; 491 . . D ERROR("ER05") 492 . . F ZL=ZL+1:1 D Q:XX="" 493 . . . N XL 494 . . . S XL=$E(XX,1,4000) 495 . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters 496 . . . S OUTBF(ZL)=XL 497 . . .QUIT 498 . .QUIT 499 .QUIT 500 M OUTXML=OUTBF 501 QUIT 502 ; =================== 503 UPPER(X) ; Convert any lowercase letters to Uppercase letters 504 QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 505 ; =================== 506 ; EN is a counter that remains between error events 507 ERROR(ER) ; Error Handler 508 N TXXQ,XXXQ 509 S XXXQ="Unknown Error Encountered = "_ER 510 S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) 511 I TXXQ'="" D 512 . I TXXQ["_" X "S TXXQ="_TXXQ 513 . S XXXQ=TXXQ 514 .QUIT 515 S EN(ER)=$G(EN(ER))+1 516 S LST("ERR",ER,EN(ER))=XXXQ 517 QUIT 518 ; =================== 519 ER01 ;;Message Missing 520 ER02 ;;Message Text Missing 521 ER03 ;;Message Not Identifiable 522 ER04 ;;Segment is too large 523 ER05 ;;Mailbox Missing 524 ER06 ;;"User Missing = "_$G(DUZ) 525 ER07 ;;"Bad DUZ = "_DUZ 526 ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) 527 ER10 ;;"Bad Separator found = "_X 528 ER11 ;;"Non-Standard Separator Found:>"_$G(J) 529 ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) 530 ER13 ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X 531 ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv 532 ; End note if needed 533 QUIT 534 ; =================== -
ccr/branches/ohum/p/C0CMCCD.m
r1332 r1333 1 1 C0CMCCD ; GPL - MXML based CCD utilities;12/04/09 17:05 2 ;;0.1;C0C;nopatch;noreleasedate 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 PARSCCD(DOC,OPTION) 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 STARTELE(ELE,ATTR) 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 ISMULT(ZOID) 61 62 63 64 65 66 67 FIRST(ZOID) 68 69 70 PARENT(ZOID) 71 72 73 ATT(RTN,NODE) 74 75 76 77 78 79 TAG(ZOID) 80 81 82 83 84 85 86 87 88 NXTSIB(ZOID) 89 90 91 DATA(ZT,ZOID) 92 93 94 95 96 97 98 CLEANARY(OUTARY,INARY) 99 100 101 102 103 104 105 CLEAN(STR) 106 107 108 109 110 111 112 113 STRIPTXT(OUTARY,ZARY) 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 C0CBEGIN(ZA,LN) 133 134 135 136 137 138 139 140 C0CEND(ZB,LN) 141 142 143 144 145 146 147 SEPARATE(OUTARY,INARY) 148 149 150 151 152 153 154 155 156 157 158 159 FINDTID 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 FINDALT 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 ALTTAG(NODE) 213 214 215 216 217 SETCBK 218 219 220 221 OUTCCD(GARYIN) 222 223 224 225 226 227 228 229 230 231 232 233 234 235 GENXDS(ZD) 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 WHRUSD(ZD) 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 2 ;;0.1;C0C;nopatch;noreleasedate;Build 1 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU 4 ;General Public License See attached copy of the License. 5 ; 6 ;This program is free software; you can redistribute it and/or modify 7 ;it under the terms of the GNU General Public License as published by 8 ;the Free Software Foundation; either version 2 of the License, or 9 ;(at your option) any later version. 10 ; 11 ;This program is distributed in the hope that it will be useful, 12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ;GNU General Public License for more details. 15 ; 16 ;You should have received a copy of the GNU General Public License along 17 ;with this program; if not, write to the Free Software Foundation, Inc., 18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 19 ; 20 Q 21 ; 22 PARSCCD(DOC,OPTION) ; THIS WAS COPIED FROM EN^MXMLDOM TO CUSTIMIZE FOR 23 ; PROCESSING CCDS 24 N CBK,SUCCESS,LEVEL,NODE,HANDLE 25 K ^TMP("MXMLERR",$J) 26 L +^TMP("MXMLDOM",$J):5 27 E Q 0 28 S HANDLE=$O(^TMP("MXMLDOM",$J,""),-1)+1,^(HANDLE)="" 29 L -^TMP("MXMLDOM",$J) 30 S CBK("STARTELEMENT")="STARTELE^C0CMCCD" ; ONLY THIS ONE IS CHANGED ;GPL 31 S CBK("ENDELEMENT")="ENDELE^MXMLDOM" 32 S CBK("COMMENT")="COMMENT^MXMLDOM" 33 S CBK("CHARACTERS")="CHAR^MXMLDOM" 34 S CBK("ENDDOCUMENT")="ENDDOC^MXMLDOM" 35 S CBK("ERROR")="ERROR^MXMLDOM" 36 S (SUCCESS,LEVEL,LEVEL(0),NODE)=0,OPTION=$G(OPTION,"V1") 37 D EN^MXMLPRSE(DOC,.CBK,OPTION) 38 D:'SUCCESS DELETE^MXMLDOM(HANDLE) 39 Q $S(SUCCESS:HANDLE,1:0) 40 ; Start element 41 ; Create new child node and push info on stack 42 STARTELE(ELE,ATTR) ; COPIED FROM STARTELE^MXMLDOM AND MODIFIED TO TREAT 43 ; ATTRIBUTES AS SUBELEMENTS TO MAKE CCD XPATH PROCESSING EASIER 44 N PARENT 45 S PARENT=LEVEL(LEVEL),NODE=NODE+1 46 S:PARENT ^TMP("MXMLDOM",$J,HANDLE,PARENT,"C",NODE)=ELE 47 S LEVEL=LEVEL+1,LEVEL(LEVEL)=NODE,LEVEL(LEVEL,0)=ELE 48 S ^TMP("MXMLDOM",$J,HANDLE,NODE)=ELE,^(NODE,"P")=PARENT 49 ;M ^("A")=ATTR 50 N ZI S ZI="" ; INDEX FOR ATTR 51 F S ZI=$O(ATTR(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE 52 . N ELE,TXT ; ABOUT TO RECURSE 53 . S ELE=ZI ; TAG 54 . S TXT=ATTR(ZI) ; DATA 55 . D STARTELE(ELE,"") ; CREATE A NEW SUBNODE 56 . D TXT^MXMLDOM("T") ; INSERT DATA TO TAG 57 . D ENDELE^MXMLDOM(ELE) ; POP BACK UP A LEVEL 58 Q 59 ; 60 ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE 61 N ZN 62 ;I $$TAG(ZOID)["entry" B 63 S ZN=$$NXTSIB(ZOID) 64 I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG 65 Q 0 66 ; 67 FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID 68 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) 69 ; 70 PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID 71 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) 72 ; 73 ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID 74 S HANDLE=C0CDOCID 75 K @RTN 76 D GETTXT^MXMLDOM("A") 77 Q 78 ; 79 TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE 80 ;I ZOID=149 B ;GPLTEST 81 N X,Y 82 S Y="" 83 S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE 84 I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y 85 I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) 86 Q Y 87 ; 88 NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING 89 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) 90 ; 91 DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE 92 ;N ZT,ZN S ZT="" 93 ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) 94 ;Q $G(@C0CDOM@(ZOID,"T",1)) 95 S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) 96 Q 97 ; 98 CLEANARY(OUTARY,INARY) ; GOES THROUGH AN ARRAY AND CALLS CLEAN ON EACH NODE 99 ; INARY AND OUTARY PASSED BY NAME 100 N ZI S ZI="" 101 F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH NODE 102 . S @OUTARY@(ZI)=$$CLEAN(@INARY@(ZI)) ; CLEAN THE NODE 103 Q 104 ; 105 CLEAN(STR) ; extrinsic function; returns string 106 ;; Removes all non printable characters from a string. 107 ;; STR by Value 108 N TR,I 109 F I=0:1:31 S TR=$G(TR)_$C(I) 110 S TR=TR_$C(127) 111 QUIT $TR(STR,TR) 112 ; 113 STRIPTXT(OUTARY,ZARY) ; STRIPS THE "TEXT" PORTION OUT OF AN XML FILE 114 ; THIS IS USED TO DELETE THE NARATIVE HTML OUT OF THE CCD XML FILES BECAUSE 115 ; THEY DO NOT WORK RIGHT WITH THE PARSER 116 ;N ZWRK,ZBLD,ZI ; WORK ARRAY,BUILD ARRAY, AND COUNTER 117 S ZI=$O(@ZARY@("")) ; GET FIRST LINE NUMBER 118 D C0CBEGIN("ZWRK",ZI) ; INSERT FIRST LINE IN WORK ARRAY 119 F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH LINE OF THE ARRAY 120 . I $O(@ZARY@(ZI))="" D Q ; AT THE END 121 . . D C0CEND("ZWRK",ZI) ; INCLUDE LAST LINE IN WORK ARRAY 122 . I ZI=1 D C0CBEGIN("ZWRK",ZI) ; START WITH FIRST LINE 123 . I @ZARY@(ZI)["<text" D C0CEND("ZWRK",ZI-1) ;PREV LINE IS AN END 124 . I @ZARY@(ZI)["</text>" D C0CBEGIN("ZWRK",ZI+1) ;NEXT LINE IS A BEGIN 125 S ZI="" 126 F S ZI=$O(ZWRK(ZI)) Q:ZI="" D ; MAKE A BUILD LIST FROM THE WORK ARRAY 127 . D QUEUE^C0CXPATH("ZBLD",ZARY,$P(ZWRK(ZI),"^",1),$P(ZWRK(ZI),"^",2)) 128 D BUILD^C0CXPATH("ZBLD",OUTARY) ; BUILD NEW ARRAY WITHOUT TEXT SECTIONS 129 K @OUTARY@(0) ; GET RID OF THE LINE COUNT 130 Q 131 ; 132 C0CBEGIN(ZA,LN) ; INSERTS A BEGIN LINE LN INTO ARRAY ZWRK, PASSED BY NAME 133 N ZI 134 S ZI=$O(@ZA@(""),-1) 135 I ZI="" S ZI=1 136 E S ZI=ZI+1 ; INCREMENT COUNT IN WORK ARRAY 137 S $P(@ZA@(ZI),"^",1)=LN 138 Q 139 ; 140 C0CEND(ZB,LN) ; INSERTS AN END LINE LN INTO ARRAY ZWRK, PASSED BY NAME 141 N ZI 142 S ZI=$O(@ZB@(""),-1) 143 I ZI="" S ZI=1 144 S $P(@ZB@(ZI),"^",2)=LN 145 Q 146 ; 147 SEPARATE(OUTARY,INARY) ; SEPARATES XPATH VARIABLES ACCORDING TO THEIR 148 ; ROOT ; /Problems/etc/etc goes to @OUTARY@("Problems","/Problems/etc/etc") 149 S ZI="" 150 F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; FOR EACH ELEMENT OF THE ARRAY 151 . I $P(ZI,"//",2)'="" D ; FOR NON-BODY ENTRIES 152 . . S ZJ=$P(ZI,"/",4) ; things like From Patient Actor 153 . E D ; FOR BODY PARTS 154 . . S ZJ=$P(ZI,"/",2) ; 155 . . I ZJ="" S ZJ=$P(ZI,"/",3) ; 156 . S @OUTARY@(ZJ,ZI)=$G(@INARY@(ZI)) ;FIX THIS FOR MULTILINE COMMENTS