Changeset 1333
- Timestamp:
- Jan 4, 2012, 12:05:49 AM (13 years ago)
- Location:
- ccr/branches/ohum/p
- Files:
-
- 70 edited
-
C0CACTOR.m (modified) (1 diff)
-
C0CALERT.m (modified) (1 diff)
-
C0CBAT.m (modified) (1 diff)
-
C0CCCD.m (modified) (1 diff)
-
C0CCCD1.m (modified) (1 diff)
-
C0CCCR.m (modified) (3 diffs)
-
C0CCCR0.m (modified) (1 diff)
-
C0CCMT.m (modified) (1 diff)
-
C0CCPT.m (modified) (2 diffs)
-
C0CDIC.m (modified) (1 diff)
-
C0CDOM.m (modified) (1 diff)
-
C0CDPT.m (modified) (1 diff)
-
C0CENC.m (modified) (1 diff)
-
C0CENV.m (modified) (4 diffs)
-
C0CEVC.m (modified) (1 diff)
-
C0CEWD.m (modified) (1 diff)
-
C0CEWD1.m (modified) (1 diff)
-
C0CFM1.m (modified) (1 diff)
-
C0CFM2.m (modified) (1 diff)
-
C0CFM3.m (modified) (1 diff)
-
C0CIM2.m (modified) (1 diff)
-
C0CIMMU.m (modified) (1 diff)
-
C0CIN.m (modified) (1 diff)
-
C0CLA7DD.m (modified) (1 diff)
-
C0CLA7Q.m (modified) (1 diff)
-
C0CLABS.m (modified) (1 diff)
-
C0CMAIL.m (modified) (1 diff)
-
C0CMAIL2.m (modified) (1 diff)
-
C0CMAIL3.m (modified) (1 diff)
-
C0CMCCD.m (modified) (1 diff)
-
C0CMED.m (modified) (1 diff)
-
C0CMED1.m (modified) (2 diffs)
-
C0CMED2.m (modified) (1 diff)
-
C0CMED3.m (modified) (1 diff)
-
C0CMED4.m (modified) (1 diff)
-
C0CMED6.m (modified) (1 diff)
-
C0CMIME.m (modified) (1 diff)
-
C0CMXML.m (modified) (1 diff)
-
C0CMXMLB.m (modified) (1 diff)
-
C0CMXP.m (modified) (1 diff)
-
C0CNHIN.m (modified) (1 diff)
-
C0CNMED2.m (modified) (1 diff)
-
C0CNMED4.m (modified) (1 diff)
-
C0CORSLT.m (modified) (2 diffs)
-
C0CPARMS.m (modified) (2 diffs)
-
C0CPROBS.m (modified) (1 diff)
-
C0CPROC.m (modified) (1 diff)
-
C0CPXRM.m (modified) (1 diff)
-
C0CQRY1.m (modified) (1 diff)
-
C0CQRY2.m (modified) (1 diff)
-
C0CRIMA.m (modified) (1 diff)
-
C0CRNF.m (modified) (1 diff)
-
C0CRNFRP.m (modified) (1 diff)
-
C0CRPMS.m (modified) (1 diff)
-
C0CRXN.m (modified) (1 diff)
-
C0CRXNRD.m (modified) (1 diff)
-
C0CSNOA.m (modified) (1 diff)
-
C0CSOAP.m (modified) (1 diff)
-
C0CSUB1.m (modified) (1 diff)
-
C0CSYS.m (modified) (1 diff)
-
C0CUNIT.m (modified) (1 diff)
-
C0CUTIL.m (modified) (2 diffs)
-
C0CVA200.m (modified) (1 diff)
-
C0CVIT2.m (modified) (1 diff)
-
C0CVITAL.m (modified) (3 diffs)
-
C0CVOBX1.m (modified) (2 diffs)
-
C0CVORU.m (modified) (1 diff)
-
C0CXEWD.m (modified) (1 diff)
-
C0CXPAT0.m (modified) (1 diff)
-
C0CXPATH.m (modified) (1 diff)
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 157 Q 158 ; 159 FINDTID ; FIND TEMPLATE IDS IN DOM 1 160 S C0CDOCID=1 161 S ZD=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) 162 S ZN="" 163 S CURSEC="" 164 S TID="" 165 F S ZN=$O(@ZD@(ZN)) Q:ZN="" D ; 166 . I $$TAG(ZN)="root" D ; 167 . . I $$TAG($$PARENT(ZN))="templateId" D ; ONLY LOOKING FOR TEMPLATES 168 . . . S ZG=$$PARENT($$PARENT(ZN)) 169 . . . S ZG2=$$PARENT(ZG) ;COMPONENT THAT HOLDS THIS SECTION 170 . . . S CMT=$G(@ZD@(ZG,"X",1)) 171 . . . I CMT="" S CMT="?" 172 . . . I $$TAG(ZG)="section" D ;START OF A SECTION 173 . . . . S CURSEC=$$PARENT(ZG) 174 . . . . S SECCMT=$G(@ZD@(CURSEC,"X",1)) 175 . . . . I SECCMT="" S SECCMT="?" 176 . . . . S SECTID=$G(@ZD@(ZN,"T",1)) ;SECTION TEMPLATE ID 177 . . . S TID=$G(@ZD@(ZN,"T",1)) ;TEMPLATE ID 178 . . . I CURSEC'="" D ; IF WE ARE IN A SECTION 179 . . . . S CCDDIR(ZG2,CURSEC,$$TAG(ZG2),CMT,SECCMT)=TID 180 . . . . S DOMMAP(ZG2)=CURSEC_U_$$TAG(ZG2)_U_TID_U_SECTID 181 . . . W !,$$TAG(ZG2)," ",$G(@ZD@(ZG,"X",1)) 182 . . . W " root ",ZN," ",@ZD@(ZN,"T",1) 183 Q 184 ; 185 FINDALT ; PROCESS THE DOMMAP AND FIND THE ALT TAGS FOR COMPONENTS 186 ; 187 S ZI="" 188 F S ZI=$O(DOMMAP(ZI)) Q:ZI="" D ; FOR EACH NODE IN THE MAP 189 . S ZJ=DOMMAP(ZI) ; 190 . S PARNODE=$P(ZJ,U,1) ;PARENT NODE 191 . S TAG=$P(ZJ,U,2) ;THIS TAG 192 . S TID=$P(ZJ,U,3) ;THIS TEMPLATE ID 193 . S PARTID=$P(ZJ,U,4) ;PARENT TEMPLATE ID 194 . S ZIEN=$O(^C0CXDS(178.101,"TID",TID,"")) ;THIS NODE IEN 195 . S PARIEN=$O(^C0CXDS(178.101,"TID",PARTID,"")) ;PARENT NODE IEN 196 . I ZI=PARNODE D ; IF THIS IS A SECTION NODE 197 . . S ALTTAG=$$GET1^DIQ(178.101,PARIEN_",",.03) ;ALT TAG FIELD FOR PARENT 198 . . S NAME=$$GET1^DIQ(178.101,ZIEN_",",.01) ;NAME OF THIS NODE'S TEMPLATE 199 . . W ZI," ",TAG," ",ALTTAG," ",NAME,! 200 . . S C0CTAGS(ZI)=ALTTAG 201 . E D ; NOT A SECTION NODE 202 . . N ZJ S ZJ="" 203 . . S ZJ=$O(^C0CXDS(178.101,"D",PARIEN,ZIEN,"")) ;A WHEREUSED POINTER? 204 . . I ZJ'="" D ; THERE IS A NEW LABEL FOR THIS NODE 205 . . . N ZK 206 . . . S ZK=$$GET1^DIQ(178.111,ZJ_","_ZIEN_",",2) 207 . . . I ZK'="" D ; 208 . . . . W "FOUND ",ZK,! 209 . . . . S C0CTAGS(ZI)=ZK ; NEW TAG FOR INTERSECTION 210 Q 211 ; 212 ALTTAG(NODE) ; SET Y EQUAL TO THE ALT TAG FOUND IN C0CTAGS IF NODE IF FOUND 213 ; 214 S Y=$G(C0CTAGS(NODE)) 215 Q 216 ; 217 SETCBK ; SET THE TAG CALLBACK FOR XPATH PROCESSSING OF THE CCD 218 S C0CCBK("TAG")="D ALTTAG^C0CMCCD(ZOID)" 219 Q 220 ; 221 OUTCCD(GARYIN) ; OUTPUT THE PARSED CCD TO A TEXT FILE 222 ;D TEST3^C0CMXML 223 N ZT S ZT=$NA(^TMP("CCDOUT",$J)) 224 N ZI,ZJ 225 S ZI=1 S ZJ="" 226 K @ZT 227 F S ZJ=$O(GARYIN(ZJ)) Q:ZJ="" D ; 228 . S @ZT@(ZI)=ZJ_"^"_GARYIN(ZJ) 229 . S ZI=ZI+1 230 S ONAME=$NA(@ZT@(1)) 231 W $$OUTPUT^C0CXPATH(ONAME,"CCDOUT.txt","/home/vademo2/CCR") 232 K @ZT 233 Q 234 ; 235 GENXDS(ZD) ; GENERATE THE XDS PROTOTYPE RECORDS FROM A CCDDIR ARRAY 236 ; ARRAY ELEMENTS LOOK LIKE: 237 ; CCDDIR(1659,1634,"observation"," Result observaion template "," Vital signs section template ")="2.16.840.1.113883.10.20.1.31" 238 ;or CCDDIR(cur node,section node,cur tag,cur name,sec name)=templateId 239 S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE 240 S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT 241 S DONE=0 242 F Q:DONE D ; 243 . W @ZI,! 244 . S ZJ=$QS(ZI,5) 245 . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE 246 . S C0CFDA(ZF,"?+1,",.01)=ZJ 247 . S C0CFDA(ZF,"?+1,",.02)=$QS(ZI,4) ; TAG FOR THIS TEMPLATE 248 . S C0CFDA(ZF,"?+1,",1)=@ZI 249 . D UPDIE 250 . S ZI=$Q(@ZI) 251 . I ZI="" S DONE=1 252 Q 253 ; 254 WHRUSD(ZD) ; UPDATE THE C0C XDS FILE WITH WHERE USED DATA FROM 255 ; CCDDIR PASS BY NAME 256 ; ARRAY ELEMENTS LOOK LIKE: 257 ; CCDDIR(1634," Vital signs section template ",1659,"observation"," Result observaion template ")="2.16.840.1.113883.10.20.1.31" 258 ;or CCDDIR(section node,sec name, cur node,cur tag,cur name)=templateId 259 S ZF=178.101 ; FILE NUMBER FOR THE C0C XDS PROTOTYPE FILE 260 S ZSF=178.111 ; WHERE USED SUBFILE OF C0C XDS PROTOTYPE FILE 261 S ZI=$Q(@ZD@("")) ;FIRST ARRAY ELEMENT 262 S DONE=0 263 F Q:DONE D ; 264 . W @ZI 265 . S ZIEN=$O(^C0CXDS(178.101,"TID",@ZI,"")) ; IEN FOR THIS NODE'S TEMPLATE 266 . W " IEN:",ZIEN 267 . S ZJ=$QS(ZI,2) 268 . S ZJ=$E(ZJ,2,$L(ZJ)) ;STRIP THE LEADING SPACE 269 . S ZPIEN=$O(^C0CXDS(178.101,"B",ZJ,"")) ; PARENT IEN 270 . W " PARENT IEN:",ZPIEN 271 . S ZTAG=$QS(ZI,4) ; TAG FOR THIS TEMPLATE 272 . W " TAG:",ZTAG,! 273 . I ZIEN'=ZPIEN D ; ONLY FOR CHILD TEMPLATES 274 . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",.01)=ZPIEN ; NEW SUBFILE ENTRY WITH PAR PTR 275 . . S C0CFDA(ZSF,"?+1,"_ZIEN_",",1)=ZTAG ; TAG FOR NEW ENTRY 276 . . D UPDIE 277 . ;S C0CFDA(ZF,"?+1,",1)=@ZI 278 . ;D UPDIE 279 . S ZI=$Q(@ZI) 280 . I ZI="" S DONE=1 281 Q 282 ; 283 283 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 284 285 286 287 288 289 290 291 292 293 284 K ZERR 285 D CLEAN^DILF 286 D UPDATE^DIE("","C0CFDA","","ZERR") 287 I $D(ZERR) D ; 288 . W "ERROR",! 289 . ZWR ZERR 290 . B 291 K C0CFDA 292 Q 293 ; -
ccr/branches/ohum/p/C0CMED.m
r1332 r1333 1 1 C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 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 Sam Habiel. 4 4 ; Licensed under the terms of the GNU General Public License. -
ccr/branches/ohum/p/C0CMED1.m
r1332 r1333 1 1 C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;;Last modified Sat Jan 10 21:42:27 PST 2009 4 4 ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU … … 56 56 ; @(0) contains the number of meds or -1^NO DATA FOUND 57 57 ; If it is -1, we quit. 58 I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 Q UIT58 I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 Q 59 59 ZWRITE:$G(DEBUG) MEDS 60 60 N RXIEN S RXIEN=0 61 F S RXIEN=$O(MEDS(RXIEN)) Q: RXIEN="" D ; FOR EACH MEDICATION IN THE LIST61 F S RXIEN=$O(MEDS(RXIEN)) Q:$G(RXIEN)="" D ; FOR EACH MEDICATION IN THE LIST 62 62 . N MED M MED=MEDS(RXIEN) 63 63 . I 'ALL,ACTIVE,$P(MED(100),U,2)'="ACTIVE" QUIT -
ccr/branches/ohum/p/C0CMED2.m
r1332 r1333 1 1 C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;;Last Modified Sat Jan 10 21:41:14 PST 2009 4 4 ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU -
ccr/branches/ohum/p/C0CMED3.m
r1332 r1333 1 1 C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;;Last Modified: Sun Jan 11 05:45:03 UTC 2009 4 4 ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU -
ccr/branches/ohum/p/C0CMED4.m
r1332 r1333 1 C0CMED4 2 ;;0.1;CCDCCR;;; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 EXTRACT(MINXML,DFN,OUTXML) 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 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 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 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 1 C0CMED4 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 2 ;;0.1;CCDCCR;;;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 "NO ENTRY FROM TOP",! 21 Q 22 ; 23 EXTRACT(MINXML,DFN,OUTXML) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE 24 ; 25 ; MINXML is the Input XML Template, passed by name 26 ; DFN is Patient IEN 27 ; OUTXML is the resultant XML. 28 ; 29 ; MEDS is return array from API. 30 ; MED is holds each array element from MEDS, one medicine 31 ; MAP is a mapping variable map (store result) for each med 32 ; 33 ; Inpatient Meds will be extracted using this routine and and the one following. 34 ; Inpatient Meds Unit Dose is going to be C0CMED4 35 ; Inpatient Meds IVs is going to be C0CMED5 36 ; 37 ; We will use two Pharmacy ReEnginnering API's: 38 ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info 39 ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info 40 ; For more information, see the PRE documentation at: 41 ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf 42 ; 43 ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient 44 ; 45 N MEDS,MAP 46 K ^TMP($J) 47 D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*) 48 I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT ; No Meds - Quit 49 ; Otherwise, we go on... 50 M MEDS=^TMP($J,"UD") 51 I DEBUG ZWR MEDS 52 S MEDMAP=$NA(^TMP("GPLCCR",$J,"MEDMAP")) 53 N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array 54 N I S I=0 55 F S I=$O(MEDS("B",I)) Q:'I D ; For each medication in B index 56 . N MED M MED=MEDS(I) 57 . S MEDCOUNT=MEDCOUNT+1 58 . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter 59 . S MAP=$NA(^TMP("GPLCCR",$J,"MEDMAP",MEDCOUNT)) 60 . N RXIEN S RXIEN=MED(.01) ; Order Number 61 . I DEBUG W "RXIEN IS ",RXIEN,! 62 . I DEBUG W "MAP= ",MAP,! 63 . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN 64 . S @MAP@("MEDISSUEDATETXT")="Order Date" 65 . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT") 66 . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient 67 . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient 68 . S @MAP@("MEDRXNOTXT")="" ; For Outpatient 69 . S @MAP@("MEDRXNO")="" ; For Outpatient 70 . S @MAP@("MEDTYPETEXT")="Medication" 71 . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses 72 . S @MAP@("MEDSTATUSTEXT")="ACTIVE" 73 . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) 74 . S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) 75 . ; NDC is field 31 in the drug file. 76 . ; The actual drug entry in the drug file is not necessarily supplied. 77 . ; It' node 1, internal form. 78 . N MEDIEN S MEDIEN=MED(1,"I") 79 . S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") 80 . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") 81 . S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") 82 . S @MAP@("MEDBRANDNAMETEXT")="" 83 . I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") 84 . I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) 85 . S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") 86 . S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") 87 . ; Units, concentration, etc, come from another call 88 . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit 89 . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters 90 . ; NDF Entry IEN, and VA Product Name 91 . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") 92 . ; Documented in the same manual. 93 . N NDFDATA,CONCDATA 94 . I $L(MEDIEN) D 95 . . D NDF^PSS50(MEDIEN,,,,,"CONC") 96 . . M NDFDATA=^TMP($J,"CONC",MEDIEN) 97 . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) 98 . . N VAPROD S VAPROD=$P(NDFDATA(22),U) 99 . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" 100 . . ; and this will crash the call. So... 101 . . I NDFIEN="" S CONCDATA="" 102 . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) 103 . E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. 104 . S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") 105 . S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") 106 . S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") 107 . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. 108 . ; Oddly, there is no easy place to find the dispense unit. 109 . ; It's not included in the original call, so we have to go to the drug file. 110 . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") 111 . ; Node 14.5 is the Dispense Unit 112 . I $L(MEDIEN) D 113 . . D DATA^PSS50(MEDIEN,,,,,"QTY") 114 . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) 115 . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) 116 E S @MAP@("MEDQUANTITYUNIT")="" 117 . ; 118 . ; --- START OF DIRECTIONS --- 119 . ; Dosage is field 2, route is 3, schedule is 4 120 . ; These are all free text fields, and don't point to any files 121 . ; For that reason, I will use the field I never used before: 122 . ; MEDDIRECTIONDESCRIPTIONTEXT 123 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") 124 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. 125 . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" 126 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" 127 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" 128 . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" 129 . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" 130 . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" 131 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" 132 . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" 133 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" 134 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" 135 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" 136 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" 137 . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" 138 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" 139 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" 140 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" 141 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" 142 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" 143 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" 144 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" 145 . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" 146 . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" 147 . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" 148 . ; 149 . ; --- END OF DIRECTIONS --- 150 . ; 151 . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" 152 . S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field 153 . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field 154 . S @MAP@("MEDRFNO")="" 155 . N RESULT S RESULT=$NA(^TMP("GPLCCR",$J,"MAPPED")) 156 . K @RESULT 157 . D MAP^GPLXPATH(MINXML,MAP,RESULT) 158 . ; D PARY^GPLXPATH(RESULT) 159 . ; MAPPING DIRECTIONS 160 . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE 161 . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT 162 . D QUERY^GPLXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) 163 . D REPLACE^GPLXPATH(RESULT,"","//Medications/Medication/Directions") 164 . ; N MDZ1,MDZNA 165 . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS 166 . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION 167 . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) 168 . . . D MAP^GPLXPATH(DIRXML1,MDZNA,DIRXML2) 169 . . . D INSERT^GPLXPATH(RESULT,DIRXML2,"//Medications/Medication") 170 . D:MEDCOUNT=1 CP^GPLXPATH(RESULT,OUTXML) ; First one is a copy 171 . D:MEDCOUNT>1 INSINNER^GPLXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML 172 N MEDTMP,MEDI 173 D MISSING^GPLXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS 174 I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 175 . W "MEDICATION MISSING ",! 176 . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! 177 Q 178 ; -
ccr/branches/ohum/p/C0CMED6.m
r1332 r1333 1 C0CMED6 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) 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 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 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 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 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 245 246 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 1 C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09 2 ;;1.0;C0C;;May 19, 2009;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 "NO ENTRY FROM TOP",! 21 Q 22 ; 23 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE 24 ; 25 ; MINXML and OUTXML are passed by name so globals can be used 26 ; MINXML will contain only the medications skeleton of the overall template 27 ; MEDCOUNT is a counter passed by Reference. 28 ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool) 29 ; FLAGS are set-up in C0CMED. 30 ; 31 ; MEDS is return array from RPC. 32 ; MAP is a mapping variable map (store result) for each med 33 ; MED is holds each array element from MEDS(J), one medicine 34 ; J is a counter. 35 ; 36 ; GETRXS^BEHORXFN(ARRAYNAME,DFN,DAYS) will be the the API used. 37 ; This API has been developed by Medsphere for IHS for getting 38 ; Medications from RPMS. It has most of what we need. 39 ; API written by Doug Martin when he worked for Medsphere (thanks Doug!) 40 ; -- ARRAYNAME is passed by name (required) 41 ; -- DFN is passed by value (required) 42 ; -- DAYS is passed by value (optional; if not passed defaults to 365) 43 ; 44 ; Return: 45 ; ~Type^PharmID^Drug^InfRate^StopDt^RefRem^TotDose^UnitDose^OrderID 46 ; ^Status^LastFill^Chronic^Issued^Rx #^Provider^ 47 ; Status Reason^DEA Handling 48 ; 49 N MEDS,MEDS1,MAP 50 D GETRXS^BEHORXFN("MEDS1",DFN,$P($P(FLAGS,U,2),"-",2)) ; 2nd piece of FLAGS is # of days to retrieve, which comes in the form "T-360" 51 N ALL S ALL=+FLAGS 52 N ACTIVE S ACTIVE=$P(FLAGS,U,3) 53 N PENDING S PENDING=$P(FLAGS,U,4) 54 S @OUTXML@(0)=0 ;By default, no meds 55 ; If MEDS1 is not defined, then no meds 56 I '$D(MEDS1) QUIT 57 I DEBUG ZWR MEDS1,MINXML 58 N MEDCNT S MEDCNT=0 ; Med Count 59 ; The next line is a super line. It goes through the array return 60 ; and if the first characters are ~OP, it grabs the line. 61 ; This means that line is for a dispensed Outpatient Med. 62 ; That line has the metadata about the med that I need. 63 ; The next lines, however many, are the med and the sig. 64 ; I won't be using those because I have to get the sig parsed exactly. 65 N J S J="" F S J=$O(MEDS1(J)) Q:J="" I $E(MEDS1(J),1,3)="~OP" S MEDCNT=MEDCNT+1 S MEDS(MEDCNT)=MEDS1(J) 66 K MEDS1 67 S MEDCNT="" ; Initialize for $Order 68 F S MEDCNT=$O(MEDS(MEDCNT)) Q:MEDCNT="" D ; for each medication in the list 69 . I 'ALL,ACTIVE,$P(MEDS(MEDCNT),U,10)'="ACTIVE" QUIT 70 . I 'ALL,PENDING,$P(MEDS(MEDCNT),U,10)'="PENDING" QUIT 71 . I DEBUG W "MEDCNT IS ",MEDCNT,! 72 . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCNT)) 73 . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED 74 . I DEBUG W "MAP= ",MAP,! 75 . S @MAP@("MEDOBJECTID")="MED"_MEDCNT ; MEDCNT FOR ID 76 . S @MAP@("MEDISSUEDATETXT")="Issue Date" 77 . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,15),"DT") 78 . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" 79 . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MEDS(MEDCNT),U,11),"DT") 80 . S @MAP@("MEDRXNOTXT")="Prescription Number" 81 . S @MAP@("MEDRXNO")=$P(MEDS(MEDCNT),U,14) 82 . S @MAP@("MEDTYPETEXT")="Medication" 83 . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses 84 . S @MAP@("MEDSTATUSTEXT")=$P(MEDS(MEDCNT),U,10) 85 . ; Provider only provided in API as text, not DUZ. 86 . ; We need to get DUZ from filman file 52 (Prescription) 87 . ; Field 4; IEN is Piece 2 of Meds stripped of trailing characters. 88 . ; Note that I will use RXIEN several times later 89 . N RXIEN S RXIEN=+$P(MEDS(MEDCNT),U,2) 90 . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52,RXIEN,4,"I") 91 . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MEDS(MEDCNT),U,3) 92 . ; --- RxNorm Stuff 93 . ; 176.001 is the file for Concepts; 176.003 is the file for 94 . ; sources (i.e. for RxNorm Version) 95 . ; 96 . ; I use 176.001 for the Vista version of this routine (files 1-3) 97 . ; Since IHS does not have VUID's, I will be getting RxNorm codes 98 . ; using NDCs. My specially crafted index (sounds evil) named "NDC" 99 . ; is in file 176.002. The file is called RxNorm NDC to VUID. 100 . ; Except that I don't need the VUID, but it's there if I need it. 101 . ; 102 . ; We obviously need the NDC. That is easily obtained from the prescription. 103 . ; Field 27 in file 52 104 . N NDC S NDC=$$GET1^DIQ(52,RXIEN,27,"I") 105 . ; I discovered that file 176.002 might give you two codes for the NDC 106 . ; One for the Clinical Drug, and one for the ingredient. 107 . ; So the plan is to get the two RxNorm codes, and then find from 108 . ; file 176.001 which one is the Clinical Drug. 109 . ; ... I refactored this into GETRXN 110 . N RXNORM,SRCIEN,RXNNAME,RXNVER 111 . I +NDC,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. 112 . . S RXNORM=$$GETRXN(NDC) 113 . . S SRCIEN=$$FIND1^DIC(176.003,,,"RXNORM","B") 114 . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) 115 . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) 116 . ; 117 . E S (RXNORM,RXNNAME,RXNVER)="" 118 . ; End if/else block 119 . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM 120 . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME 121 . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER 122 . ; --- End RxNorm section 123 . ; 124 . ; Brand name is 52 field 6.5 125 . S @MAP@("MEDBRANDNAMETEXT")=$$GET1^DIQ(52,RXIEN,6.5) 126 . ; 127 . ; Next I need Med Form (tab, cap etc), strength (250mg) 128 . ; concentration for liquids (250mg/mL) 129 . ; Since IHS does not have any of the new calls that 130 . ; Vista has, I will be doing a crosswalk: 131 . ; File 52, field 6 is Drug IEN in file 50 132 . ; File 50, field 22 is VA Product IEN in file 50.68 133 . ; In file 50.68, I will get the following: 134 . ; -- 1: Dosage Form 135 . ; -- 2: Strength 136 . ; -- 3: Units 137 . ; -- 8: Dispense Units 138 . ; -- Conc is 2 concatenated with 3 139 . ; 140 . ; *** If Drug is not matched to NDF, then VA Product will be "" *** 141 . ; 142 . N MEDIEN S MEDIEN=$$GET1^DIQ(52,RXIEN,6,"I") ; Drug IEN in 50 143 . N VAPROD S VAPROD=$$GET1^DIQ(50,MEDIEN,22,"I") ; VA Product in file 50.68 144 . I +VAPROD D 145 . . S @MAP@("MEDSTRENGTHVALUE")=$$GET1^DIQ(50.68,VAPROD,2) 146 . . S @MAP@("MEDSTRENGTHUNIT")=$$GET1^DIQ(50.68,VAPROD,3) 147 . . S @MAP@("MEDFORMTEXT")=$$GET1^DIQ(50.68,VAPROD,1) 148 . . S @MAP@("MEDCONCVALUE")=@MAP@("MEDSTRENGTHVALUE") 149 . . S @MAP@("MEDCONCUNIT")=@MAP@("MEDSTRENGTHUNIT") 150 . E D 151 . . S @MAP@("MEDSTRENGTHVALUE")="" 152 . . S @MAP@("MEDSTRENGTHUNIT")="" 153 . . S @MAP@("MEDFORMTEXT")="" 154 . . S @MAP@("MEDCONCVALUE")="" 155 . . S @MAP@("MEDCONCUNIT")="" 156 . ; End Strengh/Conc stuff 157 . ; 158 . ; Quantity is in the prescription, field 7 159 . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52,RXIEN,7) 160 . ; Dispense unit is in the drug file, field 14.5 161 . S @MAP@("MEDQUANTITYUNIT")=$$GET1^DIQ(50,MEDIEN,14.5) 162 . ; 163 . ; --- START OF DIRECTIONS --- 164 . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... 165 . ; we want the components. 166 . ; It's in multiple 113 in the Prescription File (52) 167 . ; #.01 DOSAGE ORDERED [1F] "20" 168 . ; #1 DISPENSE UNITS PER DOSE [2N] "1" 169 . ; #2 UNITS [3P:50.607] "MG" 170 . ; #3 NOUN [4F] "TABLET" 171 . ; #4 DURATION [5F] "10D" 172 . ; #5 CONJUNCTION [6S] "AND" 173 . ; #6 ROUTE [7P:51.2] "ORAL" 174 . ; #7 SCHEDULE [8F] "BID" 175 . ; #8 VERB [9F] "TAKE" 176 . ; 177 . ; Will use GETS^DIQ to get fields. 178 . ; Data comes out like this: 179 . ; SAMINS(52.0113,"1,23,",.01)=20 180 . ; SAMINS(52.0113,"1,23,",1)=1 181 . ; SAMINS(52.0113,"1,23,",2)="MG" 182 . ; SAMINS(52.0113,"1,23,",3)="TABLET" 183 . ; SAMINS(52.0113,"1,23,",4)="5D" 184 . ; SAMINS(52.0113,"1,23,",5)="THEN" 185 . ; 186 . N RAWDATA 187 . D GETS^DIQ(52,RXIEN,"113*",,"RAWDATA","DIERR") 188 . D:$D(DIERR) ^%ZTER ; Log if there's an error in retrieving sig field 189 . ; none the less, continue; some parts are retrievable. 190 . N FMSIG M FMSIG=RAWDATA(52.0113) ; Merge into subfile... 191 . K RAWDATA 192 . N FMSIGNUM S FMSIGNUM="" ; Sigline number in fileman. 193 . ; FMSIGNUM gets outputted as "IEN,RXIEN,". 194 . ; DIRCNT is the proper Sigline numer. 195 . ; SIGDATA is the simplfied array. 196 . F S FMSIGNUM=$O(FMSIG(FMSIGNUM)) Q:FMSIGNUM="" D 197 . . N DIRCNT S DIRCNT=$P(FMSIGNUM,",") 198 . . N SIGDATA M SIGDATA=FMSIG(FMSIGNUM) 199 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. 200 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. 201 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$G(SIGDATA(8)) 202 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$G(SIGDATA(.01)) 203 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=$G(SIGDATA(2)) 204 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient 205 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient 206 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient 207 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$G(SIGDATA(6)) 208 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$G(SIGDATA(7)) 209 . . ; Invervals... again another call. 210 . . ; In the wisdom of the original programmers, the schedule is a free text field 211 . . ; However, it gets translated by a call to the administration schedule file 212 . . ; to see if that schedule exists. 213 . . ; That's the same thing I am going to do. 214 . . ; Search B index of 51.1 (Admin Schedule) with schedule 215 . . ; First, remove "PRN" if it exists (don't ask, that's how the file 216 . . ; works; I wouldn't do it that way). 217 . . N SCHNOPRN S SCHNOPRN=$G(SIGDATA(7)) 218 . . I SCHNOPRN["PRN" S SCHNOPRN=$E(SCHNOPRN,1,$F(SCHNOPRN,"PRN")-5) 219 . . ; Super call below: 220 . . ; 1=File 51.1 3=Field 2 (Frequency in Minutes) 221 . . ; 4=Packed format, Exact Match 5=Lookup Value 222 . . ; 6=# of entries to return 7=Index 10=Return Array 223 . . ; 224 . . ; I do not account for the fact that two schedules can be 225 . . ; spelled identically (ie duplicate entry). In that case, 226 . . ; I get the first. That's just a bad pharmacy pkg maintainer. 227 . . N C0C515 228 . . D FIND^DIC(51.1,,"@;2","PX",SCHNOPRN,1,"B",,,"C0C515") 229 . . N INTERVAL S INTERVAL="" ; Default 230 . . ; If there are entries found, get it 231 . . I +$G(C0C515("DILIST",0)) S INTERVAL=$P(C0C515("DILIST",1,0),U,2) 232 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL 233 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" 234 . . ; Duration is 10M minutes, 10H hours, 10D for Days 235 . . ; 10W for weeks, 10L for months. I smell $Select 236 . . ; But we don't need to do that if there isn't a duration 237 . . I +$G(SIGDATA(4)) D 238 . . . N DURUNIT S DURUNIT=$E(SIGDATA(4),$L(SIGDATA(4))) ; get last char 239 . . . N DURTXT S DURTXT=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"Days") 240 . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=+SIGDATA(4) 241 . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=DURTXT 242 . . E D 243 . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")="" 244 . . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" 245 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$G(SIGDATA(4))["PRN" 246 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" ; when avail 247 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" 248 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" 249 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" 250 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" 251 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" 252 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" 253 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; not stored 254 . . ; Another confusing line; I am pretty bad: 255 . . ; If there is another entry in the FMSIG array (i.e. another line 256 . . ; in the sig), set the direction count indicator. 257 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")="" ; Default 258 . . S:+$O(FMSIG(FMSIGNUM)) @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRCNT 259 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$G(SIGDATA(5)) 260 . ; 261 . ; --- END OF DIRECTIONS --- 262 . ; 263 . ; Med instructions is a WP field, thus the acrobatics 264 . ; Notice buffer overflow protection set at 10,000 chars 265 . ; -- 1. Med Patient Instructions 266 . N MEDPTIN1 S MEDPTIN1=$$GET1^DIQ(52,RXIEN,115,,"MEDPTIN1") 267 . N MEDPTIN2,J S (MEDPTIN2,J)="" 268 . I $L(MEDPTIN1) F S J=$O(@MEDPTIN1@(J)) Q:J="" Q:$L(MEDPTIN2)>10000 S MEDPTIN2=MEDPTIN2_@MEDPTIN1@(J)_" " 269 . S @MAP@("MEDPTINSTRUCTIONS")=MEDPTIN2 270 . K J 271 . ; -- 2. Med Provider Instructions 272 . N MEDPVIN1 S MEDPVIN1=$$GET1^DIQ(52,RXIEN,39,,"MEDPVIN1") 273 . N MEDPVIN2,J S (MEDPVIN2,J)="" 274 . I $L(MEDPVIN1) F S J=$O(@MEDPVIN1@(J)) Q:J="" Q:$L(MEDPVIN2)>10000 S MEDPVIN2=MEDPVIN2_@MEDPVIN1@(J)_" " 275 . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MEDPVIN2 276 . ; 277 . ; Remaining refills 278 . S @MAP@("MEDRFNO")=$P(MEDS(MEDCNT),U,6) 279 . ; ------ END OF MAPPING 280 . ; 281 . ; ------ BEGIN XML INSERTION 282 . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) 283 . K @RESULT 284 . D MAP^C0CXPATH(MINXML,MAP,RESULT) 285 . ; D PARY^C0CXPATH(RESULT) 286 . ; MAPPING DIRECTIONS 287 . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE 288 . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT 289 . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) 290 . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") 291 . ; N MDZ1,MDZNA 292 . N DIRCNT S DIRCNT="" 293 . I +$O(@MAP@("M","DIRECTIONS",DIRCNT)) D ; IF THERE ARE DIRCTIONS 294 . . F DIRCNT=$O(@MAP@("M","DIRECTIONS",DIRCNT)) D ; FOR EACH DIRECTION 295 . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",DIRCNT)) 296 . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) 297 . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") 298 . D:MEDCNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy 299 . D:MEDCNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML 300 . S MEDCOUNT=MEDCNT 301 N MEDTMP,MEDI 302 D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS 303 I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 304 . W "MEDICATION MISSING ",! 305 . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! 306 Q 307 ; 308 308 GETRXN(NDC) ; Extrinsic Function; PUBLIC; NDC to RxNorm 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 309 ;; Get RxNorm Concept Number for a Given NDC 310 ; 311 S NDC=$TR(NDC,"-") ; Remove dashes 312 N RXNORM,C0CZRXN,DIERR 313 D FIND^DIC(176.002,,"@;.01","PX",NDC,"*","NDC",,,"C0CZRXN","DIERR") 314 I $D(DIERR) D ^%ZTER BREAK 315 S RXNORM(0)=+C0CZRXN("DILIST",0) ; RxNorm(0) will be # of entries 316 N I S I=0 317 F S I=$O(C0CZRXN("DILIST",I)) Q:I="" S RXNORM(I)=$P(C0CZRXN("DILIST",I,0),U,2) 318 ; At this point, RxNorm(0) is # of entries; RxNorm(1...) are the entries 319 ; If RxNorm(0) is 1, then we only have one entry, and that's it. 320 I RXNORM(0)=1 QUIT RXNORM(1) ; RETURN RXNORM(1) 321 ; Otherwise, we need to find out which one is the semantic 322 ; clinical drug. I built an index on 176.001 (RxNorm Concepts) 323 ; for that purpose. 324 I RXNORM(0)>1 D 325 . S I=0 326 . F S I=$O(RXNORM(I)) Q:I="" D Q:$G(RXNORM) 327 . . N RXNIEN S RXNIEN=$$FIND1^DIC(176.001,,,RXNORM(I),"SCD") 328 . . I +$G(RXNIEN)=0 QUIT ; try the next entry... 329 . . E S RXNORM=RXNORM(I) QUIT ; We found the right code 330 QUIT +$G(RXNORM) ; RETURN RXNORM; if we couldn't find a clnical drug, return with 0 331 -
ccr/branches/ohum/p/C0CMIME.m
r1332 r1333 1 C0CMIME 2 ;;1.0;C0C;;Mar 8, 2011; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 TEST(ZDFN) 23 24 25 26 27 28 29 30 31 32 33 ENCODE(ZRTN,ZARY) 34 35 36 37 38 39 40 41 42 43 44 45 46 47 ENCODEOLD(IARY,LRNODE,LRSTR) 48 49 50 51 52 53 54 55 56 57 58 TESTMAIL 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 TESTMAIL2 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 LINE(C0CFILE,C0CTO) 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FNAME,FLAGS) 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 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 MAILSEND0(LRMSUBJ) 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 245 246 247 248 249 250 251 252 253 MAILSEND2(UDFN,ADDR) 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 SIMPLE 305 306 307 308 309 310 311 312 313 314 315 CHUNK(OUTXML,INXML,ZSIZE) 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 CLEAN(IARY) 333 334 335 336 337 338 339 1 C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm 2 ;;1.0;C0C;;Mar 8, 2011;Build 1 3 ;Copyright 2008 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(ZDFN) ; 23 D CCRRPC^C0CCCR(.ZCCR,ZDFN) ; GET A CCR TO WORK WITH 24 ;M ZCOPY=ZCCR 25 S ZCOPY(1)="" 26 N ZI S ZI=0 27 F S ZI=$O(ZCCR(ZI)) Q:ZI="" D ; FOR EACH LINE 28 . S ZCOPY(1)=ZCOPY(1)_ZCCR(ZI) 29 ;D ENCODE("ZCOPY",1,ZCOPY(1)) 30 S G(1)=$$ENCODE^RGUTUU(ZCOPY(1)) 31 D CHUNK("G2","G",45) 32 Q 33 ENCODE(ZRTN,ZARY) ; 34 ; ROUTINE TO ENCODE AN XML DOCUMENT FOR SENDING 35 ; ZARY IS PASSED BY NAME 36 ; ZRTN IS PASSED BY REFERENCE AND IS THE RETURN 37 ; 38 S ZCOPY(1)="" 39 N ZI S ZI=0 40 F S ZI=$O(@ZARY@(ZI)) Q:ZI="" D ; FOR EACH LINE 41 . S ZCOPY(1)=ZCOPY(1)_@ZARY@(ZI) 42 N G 43 S G(1)=$$ENCODE^RGUTUU(ZCOPY(1)) 44 D CHUNK(ZRTN,"G",45) 45 Q 46 ; THIS ROUTINE WAS COPIED FROM LRSRVR4 AND THEN MODIFIED . THANKS JOHN 47 ENCODEOLD(IARY,LRNODE,LRSTR) ; Encode a string, keep remainder for next line 48 ; Call with LRSTR by reference, Remainder returned in LRSTR 49 ; IARY IS PASSED BY NAME 50 S LRQUIT=0,LRLEN=$L(LRSTR) 51 F D Q:LRQUIT 52 . I $L(LRSTR)<45 S LRQUIT=1 Q 53 . S LRX=$E(LRSTR,1,45) 54 . S LRNODE=LRNODE+1,@IARY@(LRNODE)=$$UUEN^LRSRVR4(LRX) 55 . S LRSTR=$E(LRSTR,46,LRLEN) 56 Q 57 ; 58 TESTMAIL ; 59 ; TEST OF MAILSEND 60 ;S ZTO("glilly@glilly.net")="" 61 S ZTO("mish@nhin.openforum.opensourcevista.net")="" 62 ;S ZTO("martijn@djigzo.com")="" 63 ;S ZTO("profmish@gmail.com")="" 64 ;S ZTO("nanthracite@earthlink.net")="" 65 S ZFROM="ANTHRACITE.NANCY" 66 S ZATTACH=$NA(^GPL("CCR")) 67 I $G(@ZATTACH@(1))="" D ; NO CCR THERE 68 . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2 69 . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME 70 S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE" 71 D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,,ZATTACH) 72 ZWR GR 73 Q 74 ; 75 TESTMAIL2 ; 76 ; TEST OF MAILSEND TO gpl.mdc-crew.net 77 N C0CGM 78 S C0CGM(1)="This is a test message." 79 S C0CGM(2)="A Continuity of Care record is attached" 80 S C0CGM(3)="It contains no Protected Health Information (PHI)" 81 S C0CGM(4)="It is purely test data used for software development" 82 S C0CGM(5)="It does not represent information about any person living or dead" 83 ;S ZTO("glilly@glilly.net")="" 84 ;S ZTO("george.lilly@pobox.com")="" 85 ;S ZTO("george@nhin.openforum.opensourcevista.net")="" 86 ;S ZTO("mish@nhin.openforum.opensourcevista.net")="" 87 S ZTO("brooks.richard@securemail.opensourcevista.net")="" 88 ;S ZTO("LILLY.GEORGE@mdc-crew.net")="" 89 ;S ZTO("ncoal@live.com")="" 90 ;S ZTO("martijn@djigzo.com")="" 91 ;S ZTO("profmish@gmail.com")="" 92 ;S ZTO("nanthracite@earthlink.net")="" 93 S ZTO("gpl.doctortest@gmail.com")="" 94 S ZFROM="LILLY.GEORGE" 95 S ZATTACH=$NA(^GPL("CCR")) 96 I $G(@ZATTACH@(1))="" D ; NO CCR THERE 97 . D CCRRPC^C0CCCR(.GPL,2) ; GET ONE FROM PATIENT 2 98 . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME 99 S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE" 100 D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH,"CCR.xml") 101 ZWR GR 102 Q 103 ; 104 LINE(C0CFILE,C0CTO) ; read a file name passed in C0CFILE and send it to 105 ; the email address in C0CTO 106 ; the directory and the "from" are all hard coded 107 ; 108 N ZZFROM S ZZFROM="LILLY.GEORGE" 109 N GN S GN=$NA(^TMP("C0CMIME2",$J)) 110 N GN1 S GN1=$NA(@GN@(1)) 111 K @GN 112 I '$D(C0CFILE) Q ; NO FILENAME PASSED 113 I '$D(C0CTO) S C0CTO="brooks.richard@securemail.opensourcevista.net" 114 S ZZTO(C0CTO)="" 115 N ZMESS S ZMESS(1)="file transmission from wvehr3-09" 116 N GD S GD="/home/wvehr3-09/EHR/" ; directory 117 I '$$FTG^%ZISH(GD,C0CFILE,GN1,3) Q D ; 118 . W !,"error reading file",C0CFILE 119 D MAILSEND(.ZRTN,ZZFROM,"ZZTO",,"file transmission","ZMESS",GN,C0CFILE) 120 K @GN ; CLEAN UP 121 ;ZWR ZRTN 122 W !,$G(ZRTN(1)) 123 Q 124 ; 125 MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FNAME,FLAGS) ; MAIL SENDING INTERFACE 126 ; RTN IS THE RETURN ARRAY PASSED BY REFERENCE 127 ; FROM IS PASSED BY VALUE AND IS THE EMAIL ADDRESS OF THE SENDER 128 ; IF NULL, WILL SEND FROM THE CURRENT DUZ 129 ; TO AND CC ARE RECIEPIENT EMAIL ADDRESSES PASSED BY NAME 130 ; @TO@("addr1@domain1.net") 131 ; @CC@("addr2@domain2.com") both can be multiples 132 ; SUBJECT IS PASSED BY VALUE AND WILL GO IN THE SUBJECT LINE 133 ; MESSAGE IS PASSED BY NAME AND IS AN ARRAY OF TEXT 134 ; ATTACH IS PASSED BY NAME AND IS AN XML OR HTML FILE TO BE ATTACHED 135 ; FNAME IS THE FILENAME OF THE ATTACHMENT, DEFAULT IS ccr.xml 136 ; 137 I '$D(FNAME) S FNAME="ccr.xml" ; default filename 138 N GN 139 S GN=$NA(^TMP($J,"C0CMIME")) 140 K @GN 141 S GM(1)="MIME-Version: 1.0" 142 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" 143 S GM(3)="" 144 S GM(4)="" 145 ;S GM(5)="--123456788888" 146 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) 147 S GM(5)="--123456899999" 148 S GM(6)="Content-Type: text/xml; name="_FNAME 149 S GM(7)="Content-Transfer-Encoding: base64" 150 S GM(8)="Content-Disposition: attachment; filename="_FNAME 151 S GM(9)="" 152 S GM(10)="" ; FOR THE END 153 ;S GM(11)="--123456788888--" 154 S GM(11)="--123456899999--" 155 S GM(12)="" 156 S GM(13)="" 157 S GG(1)="--123456899999" 158 S GG(2)="Content-Type: text/plain; charset=ISO-8859-1; format=flowed" 159 S GG(3)="Content-Transfer-Encoding: 7bit" 160 S GG(4)="" 161 S GG(5)="This is a test message." 162 S GG(6)="A Continuity of Care record is attached" 163 S GG(7)="It contains no Protected Health Information (PHI)" 164 S GG(8)="It is purely test data used for software development" 165 S GG(9)="It does not represent information about any person living or dead" 166 S GG(10)="" 167 S GG(11)="--123456899999--" 168 ;S GG(11)="Content-Type: text/plain; charset=""us-ascii""" 169 S GG(12)="" 170 ;S GG(13)="This is a test message." 171 S GG(14)="A Continuity of Care record is attached" 172 S GG(15)="It contains no Protected Health Information (PHI)" 173 S GG(16)="It is purely test data used for software development" 174 S GG(17)="It does not represent information about any person living or dead" 175 S GG(18)="" 176 S GG(19)="--123456899999" 177 S GG(20)="--987654321--" 178 K GBLD 179 ;D QUEUE^C0CXPATH("GBLD","GGG",1,3) ; THE MESSAGE 180 ;D QUEUE^C0CXPATH("GBLD","GG",1,10) ; THE MESSAGE 181 I $D(MESSAGE)'="" D ; THERE IS A MESSAGE 182 . D QUEUE^C0CXPATH("GBLD","GG",1,4) ; THE MIME BOUNDARY 183 . D QUEUE^C0CXPATH("GBLD",MESSAGE,1,$O(@MESSAGE@(""),-1)) ;THE MESSAGE 184 . D QUEUE^C0CXPATH("GBLD","GG",10,10) ;A BLANK LINE 185 D QUEUE^C0CXPATH("GBLD","GM",5,9) 186 I $D(ATTACH)'="" D ; IF WE HAVE AN ATTACHMENT 187 . D ENCODE("G2",ATTACH) ; ENCODE FOR SENDING 188 . D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1)) 189 D QUEUE^C0CXPATH("GBLD","GM",11,12) 190 D BUILD^C0CXPATH("GBLD",GN) 191 ;S GGG=$NA(^GPL("MIME2")) 192 K @GN@(0) ; KILL THE LINE COUNT 193 K LRINSTR,LRTASK,LRTO,XMERR,XMZ 194 M LRTO=@TO 195 I $D(CC) M LRTO=@CC 196 S LRINSTR("ADDR FLAGS")="R" 197 S LRINSTR("FROM")=$G(FROM) 198 S LRMSUBJ=$G(SUBJECT) 199 S LRMSUBJ=$E(LRMSUBJ,1,65) 200 D SENDMSG^XMXAPI(DUZ,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK) 201 I $G(XMERR)=1 S RTN(1)="ERROR SENDING MESSAGE" Q ; 202 S RTN(1)="OK" 203 Q 204 ; 205 MAILSEND0(LRMSUBJ) ; Send extract back to requestor. 206 ; 207 ;D TEST 208 S GN=$NA(^TMP($J,"C0CMIME")) 209 K @GN 210 ;M @GN=G2 211 S GM(1)="MIME-Version: 1.0" 212 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" 213 S GM(3)="" 214 S GM(4)="" 215 S GM(5)="--1234567" 216 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) 217 S GM(6)="Content-Type: text/xml; name=""ccr.xml""" 218 S GM(7)="Content-Transfer-Encoding: base64" 219 S GM(8)="Content-Disposition: attachment; filename=""ccr.xml""" 220 ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml") 221 S GM(9)="" 222 S GM(10)="" ; FOR THE END 223 S GM(11)="--frontier--" 224 S GM(12)="." 225 S GM(13)="" 226 K GBLD 227 ;D QUEUE^C0CXPATH("GBLD","GM",1,9) 228 ;D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1)) 229 ;D QUEUE^C0CXPATH("GBLD","GM",10,13) 230 ;D BUILD^C0CXPATH("GBLD",GN) 231 S GGG=$NA(^GPL("MIME2")) 232 ;D QUEUE^C0CXPATH("GBLD","GM",1,1) 233 D QUEUE^C0CXPATH("GBLD",GGG,21,159) 234 D BUILD^C0CXPATH("GBLD",GN) 235 K @GN@(0) ; KILL THE LINE COUNT 236 K LRINSTR,LRTASK,LRTO,XMERR,XMZ 237 S XQSND="glilly@glilly.net" 238 ;S XQSND="nanthracite@earthlink.net" 239 ;S XQSND="dlefevre@orohosp.com" 240 ;S XQSND="gregwoodhouse@me.com" 241 ;S XQSND="rick.marshall@vistaexpertise.net" 242 S LRTO(XQSND)="" 243 S LRINSTR("ADDR FLAGS")="R" 244 S LRINSTR("FROM")="CCR_PACKAGE" 245 S LRMSUBJ="A SAMPLE CCR" 246 S LRMSUBJ=$E(LRMSUBJ,1,65) 247 D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK) 248 I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q ; 249 ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0" 250 ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9" 251 Q 252 ; 253 MAILSEND2(UDFN,ADDR) ; Send extract back to requestor. 254 ; 255 I +$G(UDFN)=0 S UDFN=2 ; 256 D TEST(UDFN) 257 S GN=$NA(^TMP($J,"C0CMIME")) 258 K @GN 259 ;M @GN=G2 260 S GM(1)="MIME-Version: 1.0" 261 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" 262 S GM(3)="" 263 S GM(4)="" 264 S GM(5)="--1234567" 265 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) 266 S GM(6)="Content-Type: text/xml; name=""ccr.xml""" 267 S GM(7)="Content-Transfer-Encoding: base64" 268 S GM(8)="Content-Disposition: attachment; filename=""ccr.xml""" 269 ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml") 270 S GM(9)="" 271 S GM(10)="" ; FOR THE END 272 S GM(11)="--1234567--" 273 S GM(12)="" 274 S GM(13)="" 275 K GBLD 276 D QUEUE^C0CXPATH("GBLD","GM",5,9) 277 D QUEUE^C0CXPATH("GBLD","G2",1,$O(G2(""),-1)) 278 D QUEUE^C0CXPATH("GBLD","GM",10,12) 279 D BUILD^C0CXPATH("GBLD",GN) 280 S GGG=$NA(^GPL("MIME2")) 281 ;D QUEUE^C0CXPATH("GBLD","GM",1,1) 282 ;D QUEUE^C0CXPATH("GBLD",GGG,21,159) 283 ;D BUILD^C0CXPATH("GBLD",GN) 284 K @GN@(0) ; KILL THE LINE COUNT 285 K LRINSTR,LRTASK,LRTO,XMERR,XMZ 286 I $G(ADDR)'="" S XQSND=ADDR 287 E S XQSND="glilly@glilly.net" 288 ;S XQSND="nanthracite@earthlink.net" 289 ;S XQSND="dlefevre@orohosp.com" 290 ;S XQSND="gregwoodhouse@me.com" 291 ;S XQSND="rick.marshall@vistaexpertise.net" 292 S LRTO(XQSND)="" 293 ;S LRTO("glilly@glilly.net")="" 294 S LRINSTR("ADDR FLAGS")="R" 295 S LRINSTR("FROM")="ANTHRACITE.NANCY" 296 S LRMSUBJ="Sending a CCR with Mailman" 297 S LRMSUBJ=$E(LRMSUBJ,1,65) 298 D SENDMSG^XMXAPI(9,LRMSUBJ,GN,.LRTO,.LRINSTR,.LRTASK) 299 I $G(XMERR)=1 W !,"ERROR SENDING MESSAGE" Q ; 300 ;S ^XMB(3.9,LRTASK,1,.1130590,0)="MIME-Version: 1.0" 301 ;S ^XMB(3.9,LRTASK,1,.1130591,0)="Content-type: multipart/mixed; boundary=000e0cd6ae026c3d4b049e7befe9" 302 Q 303 ; 304 SIMPLE ; 305 S GN(1)="SIMPLE TEST MESSAGE" 306 K LRINSTR,LRTASK,LRTO,XMERR,XMZ 307 S XQSND="glilly@glilly.net" 308 S LRTO(XQSND)="" 309 S LRINSTR("ADDR FLAGS")="R" 310 S LRINSTR("FROM")="CCR_PACKAGE" 311 S LRMSUBJ="A SAMPLE CCR" 312 S LRMSUBJ=$E(LRMSUBJ,1,65) 313 D SENDMSG^XMXAPI(9,LRMSUBJ,"GN",.LRTO,.LRINSTR,.LRTASK) 314 Q 315 CHUNK(OUTXML,INXML,ZSIZE) ; BREAKS INXML INTO ZSIZE BLOCKS 316 ; INXML IS AN ARRAY PASSED BY NAME OF STRINGS 317 ; OUTXML IS ALSO PASSED BY NAME 318 ; IF ZSIZE IS NOT PASSED, 1000 IS USED 319 I '$D(ZSIZE) S ZSIZE=1000 ; DEFAULT BLOCK SIZE 320 N ZB,ZI,ZJ,ZK,ZL,ZN 321 S ZB=ZSIZE-1 322 S ZN=1 323 S ZI=0 ; BEGINNING OF INDEX TO INXML 324 F S ZI=$O(@INXML@(ZI)) Q:+ZI=0 D ; FOR EACH STRING IN INXML 325 . S ZL=$L(@INXML@(ZI)) ; LENGTH OF THE STRING 326 . F ZJ=1:ZSIZE:ZL D ; 327 . . S ZK=$S(ZJ+ZB<ZL:ZJ+ZB,1:ZL) ; END FOR EXTRACT 328 . . S @OUTXML@(ZN)=$E(@INXML@(ZI),ZJ,ZK) ; PULL OUT THE PIECE 329 . . S ZN=ZN+1 ; INCREMENT OUT ARRAY INDEX 330 Q 331 ; 332 CLEAN(IARY) ; RUNS THROUGH AN ARRAY PASSED BY NAME AND STRIPS OUT $C(13) 333 ; 334 N ZI S ZI=0 335 F S ZI=$O(@IARY@(ZI)) Q:+ZI=0 D ; 336 . S @IARY@(ZI)=$TR(@IARY@(ZI),$C(13)) ; 337 . I $F(@IARY@(ZI)," <") S @IARY@(ZI)="<"_$P(@IARY@(ZI)," <",2) ; RM BLNKS 338 Q 339 ; -
ccr/branches/ohum/p/C0CMXML.m
r1332 r1333 1 1 C0CMXML ; GPL - MXML based XPath utilities;10/13/09 17:05 2 ;;0.1;C0C;nopatch;noreleasedate;Build 382 ;;0.1;C0C;nopatch;noreleasedate;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/C0CMXMLB.m
r1332 r1333 1 MXMLBLD 2 ;;8.0;KERNEL;; 3 4 5 6 7 8 START(DOC,DOCTYPE,FLAG,NO1ST) 9 10 11 12 13 14 15 16 END 17 18 19 20 21 22 ITEM(INDENT,TAG,ATT,VALUE) 23 24 25 26 27 28 29 MULTI(INDENT,TAG,ATT,DOITEM) 30 31 32 33 34 35 36 37 ATT(ATT) 38 39 40 41 42 43 44 Q(X) 45 46 47 48 49 50 51 52 53 54 XMLHDR() 55 56 57 OUTPUT(S) 58 59 60 61 62 63 CHARCHK(STR) 64 65 66 67 68 69 70 71 72 73 74 75 76 77 COMMENT(VAL) 78 79 80 81 82 83 84 85 86 PUSH(INDENT,TAG,ATT) 87 88 89 90 91 92 93 POP 94 95 96 97 98 99 100 BLS(I) 101 102 103 104 105 INDENT() 106 1 MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09 16:55 2 ;;8.0;KERNEL;;;Build 1 3 QUIT 4 ; 5 ;DOC - The top level tag 6 ;DOCTYPE - Want to include a DOCTYPE node 7 ;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J, 8 START(DOC,DOCTYPE,FLAG,NO1ST) ;Call this once at the begining. 9 K ^TMP("MXMLBLD",$J) 10 S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0 11 I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1 12 I $G(NO1ST)'=1 D OUTPUT($$XMLHDR) 13 D:$L($G(DOCTYPE)) OUTPUT("<!DOCTYPE "_DOCTYPE_">") D OUTPUT("<"_DOC_">") 14 Q 15 ; 16 END ;Call this once to close out the document 17 D OUTPUT("</"_$G(^TMP("MXMLBLD",$J,"DOC"))_">") 18 I '$G(^TMP("MXMLBLD",$J,"CNT")) K ^TMP("MXMLBLD",$J) 19 K ^TMP("MXMLBLD",$J,"DOC"),^("CNT"),^("STK") 20 Q 21 ; 22 ITEM(INDENT,TAG,ATT,VALUE) ;Output a Item 23 N I,X 24 S ATT=$G(ATT) 25 I '$D(VALUE) D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_" />") Q 26 D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">"_$$CHARCHK(VALUE)_"</"_TAG_">") 27 Q 28 ;DOITEM is a callback to output the lower level. 29 MULTI(INDENT,TAG,ATT,DOITEM) ;Output a Multipule 30 N I,X,S 31 S ATT=$G(ATT) 32 D PUSH($G(INDENT),TAG,.ATT) 33 D @DOITEM 34 D POP 35 Q 36 ; 37 ATT(ATT) ;Output a string of attributes 38 I $D(ATT)<9 Q "" 39 N I,S,V 40 S S="",I="" 41 F S I=$O(ATT(I)) Q:I="" S S=S_" "_I_"="_$$Q(ATT(I)) 42 Q S 43 ; 44 Q(X) ;Add Quotes - Changed by gpl to use single instead of double quotes 6/11 45 ;I X'[$C(34) Q $C(34)_X_$C(34) 46 I X'[$C(39) Q $C(39)_X_$C(39) 47 ;N Q,Y,I,Z S Q=$C(34),(Y,Z)="" 48 N Q,Y,I,Z S Q=$C(39),(Y,Z)="" 49 F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q 50 S Y=Y_$P(X,Q,$L(X,Q)) 51 ;Q $C(34)_Y_$C(34) 52 Q $C(39)_Y_$C(39) 53 ; 54 XMLHDR() ; -- provides current XML standard header 55 Q "<?xml version=""1.0"" encoding=""utf-8"" ?>" 56 ; 57 OUTPUT(S) ;Output 58 N C S C=$G(^TMP("MXMLBLD",$J,"CNT")) 59 I C S ^TMP("MXMLBLD",$J,C)=S,^TMP("MXMLBLD",$J,"CNT")=C+1 Q 60 W S,! 61 Q 62 ; 63 CHARCHK(STR) ; -- replace xml character limits with entities 64 N A,I,X,Y,Z,NEWSTR 65 S (Y,Z)="" 66 ;IF STR["&" SET NEWSTR=STR DO SET STR=Y_Z 67 ;. FOR X=1:1 SET Y=Y_$PIECE(NEWSTR,"&",X)_"&",Z=$PIECE(STR,"&",X+1,999) QUIT:Z'["&" 68 I STR["&" F I=1:1:$L(STR,"&")-1 S STR=$P(STR,"&",1,I)_"&"_$P(STR,"&",I+1,999) 69 I STR["<" F S STR=$PIECE(STR,"<",1)_"<"_$PIECE(STR,"<",2,99) Q:STR'["<" 70 I STR[">" F S STR=$PIECE(STR,">",1)_">"_$PIECE(STR,">",2,99) Q:STR'[">" 71 I STR["'" F S STR=$PIECE(STR,"'",1)_"'"_$PIECE(STR,"'",2,99) Q:STR'["'" 72 I STR["""" F S STR=$PIECE(STR,"""",1)_"""_$PIECE(STR,"""",2,99) Q:STR'["""" 73 ; 74 S STR=$TR(STR,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31)) 75 QUIT STR 76 ; 77 COMMENT(VAL) ;Add Comments 78 N I,L 79 ;I $D($G(VAL))=1 D OUTPUT("<!-- "_ATT_" -->") Q 80 I $D(VAL) D OUTPUT("<!-- "_ATT_" -->") Q ;CHANGED BY GPL FOR GTM 81 S I="",L="<!--" 82 F S I=$O(ATT(I)) Q:I="" D OUTPUT(L_ATT(I)) S L="" 83 D OUTPUT("-->") 84 Q 85 ; 86 PUSH(INDENT,TAG,ATT) ;Write a TAG and save. 87 N CNT 88 S ATT=$G(ATT) 89 D OUTPUT($$BLS($G(INDENT))_"<"_TAG_$$ATT(.ATT)_">") 90 S CNT=$G(^TMP("MXMLBLD",$J,"STK"))+1,^TMP("MXMLBLD",$J,"STK")=CNT,^TMP("MXMLBLD",$J,"STK",CNT)=INDENT_"^"_TAG 91 Q 92 ; 93 POP ;Write last pushed tag and pop 94 N CNT,TAG,INDENT,X 95 S CNT=$G(^TMP("MXMLBLD",$J,"STK")),X=^TMP("MXMLBLD",$J,"STK",CNT),^TMP("MXMLBLD",$J,"STK")=CNT-1 96 S INDENT=+X,TAG=$P(X,"^",2) 97 D OUTPUT($$BLS(INDENT)_"</"_TAG_">") 98 Q 99 ; 100 BLS(I) ;Return INDENT string 101 N S 102 S S="",I=$G(I) S:I>0 $P(S," ",I)=" " 103 Q S 104 ; 105 INDENT() ;Renturn indent level 106 Q +$G(^TMP("MXMLBLD",$J,"STK")) -
ccr/branches/ohum/p/C0CMXP.m
r1332 r1333 1 1 C0CMXP ; GPL - MXML based XPath utilities;12/04/09 17:05 2 ;;0.1;C0C;nopatch;noreleasedate;Build 382 ;;0.1;C0C;nopatch;noreleasedate;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/C0CNHIN.m
r1332 r1333 1 1 C0CNHIN ; GPL - PROCESSING FOR OUTPUT OF NHINV ROUTINES;6/3/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 EN(ZRTN,ZDFN,ZPART,KEEP) 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 PQRI(ZOUT,KEEP) 37 38 39 40 41 42 43 44 45 46 47 48 PQRI2(ZRTN) 49 50 51 52 53 54 55 PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP) 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 LOADSMRT 71 72 73 74 75 76 77 SMART 78 79 80 81 82 83 84 85 86 87 CCR 88 89 90 91 92 93 94 95 96 97 MED 98 99 100 101 102 103 104 105 106 107 CCD 108 109 110 111 112 113 114 115 116 117 TEST1 118 119 120 121 122 123 124 125 126 127 128 129 TEST2 130 131 132 133 134 135 136 137 138 TEST3 139 140 141 142 143 144 145 146 147 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 EN(ZRTN,ZDFN,ZPART,KEEP) ; GENERATE AN NHIN ARRAY FOR A PATIENT 22 ; 23 K GARY,GNARY,GIDX,C0CDOCID 24 N GN 25 K ^TMP("NHINV",$J) ; CLEAN UP FROM LAST CALL 26 K ^TMP("MXMLDOM",$J) ; CLEAN UP DOM 27 K ^TMP("MXMLERR",$J) ; CLEAN UP MXML ERRORS 28 D GET^NHINV(.GN,ZDFN,ZPART) ; CALL NHINV ROUTINES TO PULL XML 29 S GN=$P(GN,")",1)_")" ; CUT OFF THE REST OF LINE PROTOCOL 30 S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML 31 D DOMO^C0CDOM(C0CDOCID,"/","ZRTN","GIDX","GARY",,"/results/") ; BLD ARRAYS 32 I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 33 ;D PROCESS("ZRTN",GN,"/result/",$G(KEEP)) 34 Q 35 ; 36 PQRI(ZOUT,KEEP) ; RETURN THE NHIN ARRAY FOR THE PQRI XML TEMPLATE 37 ; 38 N ZG 39 S ZG=$NA(^TMP("PQRIXML",$J)) 40 K @ZG 41 D GETXML^C0CMXP(ZG,"PQRIXML") ; GET THE XML FROM C0C MISC XML 42 N C0CDOCID 43 S C0CDOCID=$$PARSE^C0CDOM(ZG,"PQRIXML") ; PARSE THE XML 44 D DOMO^C0CDOM(C0CDOCID,"/","ZOUT","GIDX","GARY",,"//submission") ; BLD ARRAYS 45 I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 46 Q 47 ; 48 PQRI2(ZRTN) ; RETURN THE NHIN ARRAY FOR PQRI ONE MEASURE 49 ; 50 ;N GG 51 D GETXML^C0CMXP("GG","PQRI ONE MEASURE") 52 D PROCESS(ZRTN,"GG","root",1) 53 Q 54 ; 55 PROCESS(ZRSLT,ZXML,ZREDUCE,KEEP) ; PARSE AND RUN DOMO ON XML 56 ; ZRTN IS PASSED BY REFERENCE 57 ; ZXML IS PASSED BY NAME 58 ; IF KEEP IS 1, GARY AND GIDX ARE NOT KILLED 59 ; 60 N GN 61 S GN=$NA(^TMP("C0CPROCESS",$J)) 62 K @GN 63 M @GN=@ZXML 64 S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML 65 K @GN 66 D DOMO^C0CDOM(C0CDOCID,"/","ZRSLT","GIDX","GARY",,$G(ZREDUCE)) ; BLD ARRAYS 67 I '$G(KEEP) K GIDX,GARY ; GET RID OF THE ARRAYS UNLESS KEEP=1 68 Q 69 ; 70 LOADSMRT ; 71 ; 72 K ^GPL("SMART") 73 S GN=$NA(^GPL("SMART",1)) 74 I $$FTG^%ZISH("/home/george/","alex-lewis2.xml",GN,2) W !,"SMART FILE LOADED" 75 Q 76 ; 77 SMART ; TRY IT WITH SMART 78 ; 79 S GN=$NA(^GPL("SMART")) 80 ;K ^TMP("MXMLDOM",$J) 81 K ^TMP("MXMLERR",$J) 82 S C0CDOCID=$$PARSE(GN,"SMART") 83 D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//rdf:RDF/") 84 ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG 85 Q 86 ; 87 CCR ; TRY IT WITH A CCR 88 ; 89 S GN=$NA(^GPL("CCR")) 90 ;K ^TMP("MXMLDOM",$J) 91 K ^TMP("MXMLERR",$J) 92 S C0CDOCID=$$PARSE(GN,"CCR") 93 D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ContinuityOfCareRecord/Body/") 94 ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG 95 Q 96 ; 97 MED ; TRY IT WITH A CCR MED SECTION 98 ; 99 S GN=$NA(^GPL("MED")) 100 K ^TMP("MXMLDOM",$J) 101 K ^TMP("MXMLERR",$J) 102 S C0CDOCID=$$PARSE(GN,"MED") 103 D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//Medications/") 104 ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG 105 Q 106 ; 107 CCD ; TRY IT WITH A CCD 108 ; 109 S GN=$NA(^GPL("CCD")) 110 ;K ^TMP("MXMLDOM",$J) 111 K ^TMP("MXMLERR",$J) 112 S C0CDOCID=$$PARSE(GN,"CCD") 113 D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"//ClinicalDocument/component/structuredBody/") 114 ;K ^TMP("MXMLDOM",$J) ;CLEAN UP... IT'S BIG 115 Q 116 ; 117 TEST1 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") 118 ; PARSED WITH MXML 119 ; RUN THROUGH XPATH 120 K GARY,GIDX,C0CDOCID 121 S GN=$NA(^GPL("NHIN")) 122 ;S GN=$NA(^GPL("DOMI")) 123 S C0CDOCID=$$PARSE(GN,"GPLTEST") 124 D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/") 125 K ^GPL("GNARY") 126 M ^GPL("GNARY")=GNARY 127 Q 128 ; 129 TEST2 ; PUT GNARY THROUGH DOMI AND STORE XML IN ^GPL("DOMI") 130 ; 131 S GN=$NA(^GPL("GNARY")) 132 S C0CDOCID=$$DOMI^C0CDOM(GN,,"results") 133 D OUTXML^C0CDOM("G",C0CDOCID) 134 K ^GPL("DOMI") 135 M ^GPL("DOMI")=G 136 Q 137 ; 138 TEST3 ; TEST NHINV OUTPUT IN ^GPL("NIHIN") 139 ; PARSED WITH MXML 140 ; RUN THROUGH XPATH 141 K GARY,GIDX,C0CDOCID 142 ;S GN=$NA(^GPL("NHIN")) 143 S GN=$NA(^GPL("DOMI")) 144 S C0CDOCID=$$PARSE(GN,"GPLTEST") 145 D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/") 146 Q 147 ; 148 148 DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE 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 ADDNARY(ZXP,ZVALUE) 193 194 195 196 197 198 199 200 201 202 203 204 205 206 149 ; THE XPATH INDEX ZXIDX, PASSED BY NAME 150 ; THE XPATH ARRAY XPARY, PASSED BY NAME 151 ; ZOID IS THE STARTING OID 152 ; ZPATH IS THE STARTING XPATH, USUALLY "/" 153 ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE 154 ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT 155 I $G(ZREDUX)="" S ZREDUX="" 156 N NEWPATH,NARY ; NEWPATH IS AN XPATH NARY IS AN NHIN MUMPS ARRAY 157 N NEWNUM S NEWNUM="" 158 I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" 159 S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE 160 I $G(ZREDUX)'="" D ; REDUX PROVIDED? 161 . N GT S GT=$P(NEWPATH,ZREDUX,2) 162 . I GT'="" S NEWPATH=GT 163 S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX 164 N GA D ATT("GA",ZOID) ; GET ATTRIBUTES FOR THIS NODE 165 I $D(GA) D ; PROCESS THE ATTRIBUTES 166 . N ZI S ZI="" 167 . F S ZI=$O(GA(ZI)) Q:ZI="" D ; FOR EACH ATTRIBUTE 168 . . N ZP S ZP=NEWPATH_"/"_ZI ; PATH FOR ATTRIBUTE 169 . . S @ZXPARY@(ZP)=GA(ZI) ; ADD THE ATTRIBUTE XPATH TO THE XP ARRAY 170 . . I GA(ZI)'="" D ADDNARY(ZP,GA(ZI)) ; ADD THE NHIN ARRAY VALUE 171 N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE 172 I $D(GD(2)) D ; 173 . M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY 174 E I $D(GD(1)) D ; 175 . S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY 176 . I GD(1)'="" D ADDNARY(NEWPATH,GD(1)) ; ADD TO NHIN ARRAY 177 N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD 178 I ZFRST'=0 D ; THERE IS A CHILD 179 . N ZNUM 180 . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE 181 . D DOMO(ZFRST,NEWPATH,ZNARY,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; THE CHILD 182 N GNXT S GNXT=$$NXTSIB(ZOID) 183 I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES 184 I GNXT'=0 D ; 185 . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? 186 . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES 187 . . N ZNUM S ZNUM=1 ; 188 . . D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB 189 . E D DOMO(GNXT,ZPATH,ZNARY,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; SIB 190 Q 191 ; 192 ADDNARY(ZXP,ZVALUE) ; ADD AN NHIN ARRAY VALUE TO ZNARY 193 ; 194 N ZZI,ZZJ,ZZN 195 S ZZI=$P(ZXP,"/",1) ; FIRST PIECE OF XPATH ARRAY 196 I ZZI="" Q ; DON'T ADD THIS ONE .. PROBABLY THE //results NODE 197 S ZZJ=$P(ZXP,ZZI_"/",2) ; REST OF XPATH ARRAY 198 S ZZJ=$TR(ZZJ,"/",".") ; REPLACE / WITH . 199 I ZZI'["]" D ; A SINGLETON 200 . S ZZN=1 201 E D ; THERE IS AN [x] OCCURANCE 202 . S ZZN=$P($P(ZZI,"[",2),"]",1) ; PULL OUT THE OCCURANCE 203 . S ZZI=$P(ZZI,"[",1) ; TAKE OUT THE [X] 204 I ZZJ'="" S @ZNARY@(ZZI,ZZN,ZZJ)=ZVALUE 205 Q 206 ; 207 207 PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME 208 209 210 211 212 208 ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW 209 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML 210 ;Q $$EN^MXMLDOM(INXML) 211 Q $$EN^MXMLDOM(INXML,"W") 212 ; 213 213 ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE 214 215 216 217 218 219 214 N ZN 215 ;I $$TAG(ZOID)["entry" B 216 S ZN=$$NXTSIB(ZOID) 217 I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG 218 Q 0 219 ; 220 220 FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID 221 222 221 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) 222 ; 223 223 PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID 224 225 224 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) 225 ; 226 226 ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID 227 228 229 230 231 227 S HANDLE=C0CDOCID 228 K @RTN 229 D GETTXT^MXMLDOM("A") 230 Q 231 ; 232 232 TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE 233 234 235 236 237 238 239 240 233 ;I ZOID=149 B ;GPLTEST 234 N X,Y 235 S Y="" 236 S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE 237 I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y 238 I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) 239 Q Y 240 ; 241 241 NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING 242 243 242 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) 243 ; 244 244 DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE 245 246 247 248 249 250 245 ;N ZT,ZN S ZT="" 246 ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) 247 ;Q $G(@C0CDOM@(ZOID,"T",1)) 248 S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) 249 Q 250 ; 251 251 OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM 252 253 254 255 256 257 258 259 260 252 ; 253 S C0CDOCID=INID 254 D START^C0CMXMLB($$TAG(1),,"G") 255 D NDOUT($$FIRST(1)) 256 D END^C0CMXMLB ;END THE DOCUMENT 257 M @ZRTN=^TMP("MXMLBLD",$J) 258 K ^TMP("MXMLBLD",$J) 259 Q 260 ; 261 261 NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE 262 263 264 265 266 267 268 269 270 271 272 273 274 275 WNHIN(ZDFN) 276 277 278 279 280 281 282 283 TESTNARY 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 PRE(ZNODE) 304 305 306 307 308 309 310 311 312 313 314 315 316 317 MNARY(ZRTN,ZHANDLE,ZOID) 318 319 320 321 322 323 262 N ZI S ZI=$$FIRST(ZOID) 263 I ZI'=0 D ; THERE IS A CHILD 264 . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT 265 . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN 266 E D ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT 267 . ;W "DOING",ZOID,! 268 . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA 269 . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES 270 . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN 271 I $$NXTSIB(ZOID)'=0 D ; THERE IS A SIBLING 272 . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS 273 Q 274 ; 275 WNHIN(ZDFN) ; WRITES THE XML OUTPUT OF GET^NHINV TO AN XML FILE 276 ; 277 N GN,GN2 278 D GET^NHINV(.GN,ZDFN) ; EXTRACT THE XML 279 S GN2=$NA(@GN@(1)) 280 W $$OUTPUT^C0CXPATH(GN2,"nhin_"_ZDFN_".xml","/home/wvehr3-09/") 281 Q 282 ; 283 TESTNARY ; TEST MAKING A NHIN ARRAY 284 N ZI S ZI="" 285 N ZH ; DOM HANDLE 286 D TEST1 ; PARSE AN NHIN RESULT INTO THE DOM 287 S ZH=C0CDOCID ; SET THE HANDLE 288 N ZD S ZD=$NA(^TMP("MXMLDOM",$J,ZH)) 289 F S ZI=$O(@ZD@(ZI)) Q:ZI="" D ; FOR EACH NODE 290 . N ZATT 291 . D MNARY(.ZATT,ZH,ZI) 292 . N ZPRE,ZN 293 . S ZPRE=$$PRE(ZI) 294 . S ZN=$P(ZPRE,",",2) 295 . S ZPRE=$P(ZPRE,",",1) 296 . ;I $D(ZATT) ZWR ZATT 297 . N ZJ S ZJ="" 298 . F S ZJ=$O(ZATT(ZJ)) Q:ZJ="" D ; FOR EACH ATTRIBUTE 299 . . W ZPRE_"["_ZN_"]"_$$TAG(ZI)_"."_ZJ_"="_ZATT(ZJ),! 300 . . S GOUT(ZPRE,ZN,$$TAG(ZI)_"."_ZJ)=ZATT(ZJ) 301 Q 302 ; 303 PRE(ZNODE) ; EXTRINSIC WHICH RETURNS THE PREFIX FOR A NODE 304 ; 305 N GI,GI2,GPT,GJ,GN 306 S GI=$$PARENT(ZNODE) ; PARENT NODE 307 I GI=0 Q "" ; NO PARENT 308 S GPT=$$TAG(GI) ; TAG OF PARENT 309 S GI2=$$PARENT(GI) ; PARENT OF PARENT 310 I (GI2'=0)&($$TAG(GI2)'="results") S GPT=$$TAG(GI2)_"."_GPT 311 S GJ=$$FIRST(GI) ; NODE OF FIRST SIB 312 I GJ=ZNODE Q:$$TAG(GI)_",1" 313 F GN=2:1 Q:GJ=ZNODE D ; 314 . S GJ=$$NXTSIB(GJ) ; NEXT SIBLING 315 Q GPT_","_GN 316 ; 317 MNARY(ZRTN,ZHANDLE,ZOID) ; MAKE A NHIN ARRAY FROM A DOM NODE 318 ; RETURNED IN ZRTN, PASSED BY REFERENCE 319 ; ZHANDLE IS THE DOM DOCUMENT ID 320 ; ZOID IS THE DOM NODE 321 D ATT("ZRTN",ZOID) 322 Q 323 ; -
ccr/branches/ohum/p/C0CNMED2.m
r1332 r1333 1 1 C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 EXTRACT(MEDXML,DFN,MEDOUTXML) 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 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 116 117 118 119 120 121 2 ;;1.0;C0C;;May 19, 2009;Build 1 3 ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel. 4 ; Licensed under the terms of the GNU General Public License. 5 ; See attached copy of the License. 6 ; 7 ; This program is free software; you can redistribute it and/or modify 8 ; it under the terms of the GNU General Public License as published by 9 ; the Free Software Foundation; either version 2 of the License, or 10 ; (at your option) any later version. 11 ; 12 ; This program is distributed in the hope that it will be useful, 13 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ; GNU General Public License for more details. 16 ; 17 ; You should have received a copy of the GNU General Public License along 18 ; with this program; if not, write to the Free Software Foundation, Inc., 19 ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 20 ; 21 ; --Revision History 22 ; July 2008 - Initial Version/GPL 23 ; July 2008 - March 2009 various revisions 24 ; March 2009 - Reconstruction of routine as driver for other med routines/SMH 25 ; June 2011 - Redone to support all meds using the FOIA NHIN routines/gpl 26 ; 27 Q 28 ; 29 ; THIS VERSION IS DEPRECATED BECAUSE IT DOES NOT GENEREATE XML IN 30 ; THE RIGHT ORDER... AND IT HAS TO BE IN THE RIGHT ORDER... :( 31 ; GPL 32 ; 33 EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template 34 ; DFN passed by reference 35 ; MEDXML and MEDOUTXML are passed by Name 36 ; MEDXML is the input template 37 ; MEDOUTXML is the output template 38 ; Both of them refer to ^TMP globals where the XML documents are stored 39 ; 40 N GN 41 D EN^C0CNHIN(.GN,DFN,"MED;",1) ; RETRIEVE NHIN ARRAY OF MEDS 42 ; this call uses GET^NHINV to retrieve xml of the meds and then 43 ; parses with MXML and uses DOMO^C0CDOM to extract an NHIN array 44 ; 45 ; we now create an NHIN Array of the Meds section of the CCR 46 ; 47 N ZI S ZI="" 48 F S ZI=$O(GN("med",ZI)) Q:ZI="" D ; for each med 49 . N GA S GA=$NA(GN("med",ZI)) 50 . N GM S GM="Medication" ; to keep the lines shorter 51 . S GC(GM,ZI,"CCRDataObjectID")="MED_"_ZI 52 . N ZD,ZD2 S ZD=$G(@GA@("ordered@value")) ; FILEMAN DATE 53 . I ZD="" S ZD=$G(@GA@("start@value")) ; for inpatient meds 54 . S ZD2=$$FMDTOUTC^C0CUTIL(ZD,"DT") 55 . S GC(GM,ZI,"DateTime[1].ExactDateTime")=ZD2 56 . S GC(GM,ZI,"DateTime[1].Type.Text")="Documented Date" 57 . ;S GC(GM,ZI,"DateTime[2].ExactDateTime")="" 58 . ;S GC(GM,ZI,"DateTime[2].Type.Text")="" 59 . N GSIG S GSIG=$G(@GA@("sig")) 60 . I GSIG["|" S GSIG=$P(GSIG,"|",2) ; eRx has name of drug separated by | 61 . S GC(GM,ZI,"Description.Text")=GSIG 62 . N GD S GD="Directions.Direction" ; MAKING THE STRINGS SHORTER 63 . ;S GC(GM,ZI,GD_".DeliveryMethod.Text")="@@MEDDELIVERYMETHOD@@" 64 . ;S GC(GM,ZI,GD_".Description.Text")="" 65 . ;S GC(GM,ZI,GD_".DirectionSequenceModifier")="@@MEDDIRSEQ@@" 66 . ;S GC(GM,ZI,GD_".Dose.Rate.Units.Unit")="@@MEDRATEUNIT@@" 67 . ;S GC(GM,ZI,GD_".Dose.Rate.Value")="@@MEDRATEVALUE@@" 68 . ;S GC(GM,ZI,GD_".Dose.Units.Unit")="@@MEDDOSEUNIT@@" 69 . ;S GC(GM,ZI,GD_".Dose.Value")="@@MEDDOSEVALUE@@" 70 . ;S GC(GM,ZI,GD_".DoseIndicator.Text")="@@MEDDOSEINDICATOR@@" 71 . ;S GC(GM,ZI,GD_".Duration.Units.Unit")="@@MEDDURATIONUNIT@@" 72 . ;S GC(GM,ZI,GD_".Duration.Value")="@@MEDDURATIONVALUE@@" 73 . ;S GC(GM,ZI,GD_".Frequency.Value")="@@MEDFREQUENCYVALUE@@" 74 . ;S GC(GM,ZI,GD_".Indication.PRNFlag.Text")="@@MEDPRNFLAG@@" 75 . ;S GC(GM,ZI,GD_".Indication.Problem.CCRDataObjectID")="" 76 . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.CodingSystem")="" 77 . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Value")="" 78 . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Version")="" 79 . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Text")="" 80 . ;S GC(GM,ZI,GD_".Indication.Problem.Source.Actor.ActorID")="" 81 . ;S GC(GM,ZI,GD_".Indication.Problem.Type.Text")="" 82 . ;S GC(GM,ZI,GD_".Interval.Units.Unit")="@@MEDINTERVALUNIT@@" 83 . ;S GC(GM,ZI,GD_".Interval.Value")="@@MEDINTERVALVALUE@@" 84 . ;S GC(GM,ZI,GD_".MultipleDirectionModifier.Text")="@@MEDMULDIRMOD@@" 85 . S GC(GM,ZI,GD_".Route.Text")=$G(@GA@("doses.dose@route")) 86 . ;S GC(GM,ZI,GD_".StopIndicator.Text")="@@MEDSTOPINDICATOR@@" 87 . ;S GC(GM,ZI,GD_".Vehicle.Text")="@@MEDVEHICLETEXT@@" 88 . ;S GC(GM,ZI,"FullfillmentInstructions.Text")="" 89 . ;S GC(GM,ZI,"IDs.ID")="@@MEDRXNO@@" 90 . ;S GC(GM,ZI,"IDs.Type.Text")="@@MEDRXNOTXT@@" 91 . ;S GC(GM,ZI,"PatientInstructions.Instruction.Text")="@@MEDPTINSTRUCTIONS@@" 92 . ;S GC(GM,ZI,"Product.BrandName.Text")="@@MEDBRANDNAMETEXT@@" 93 . S GC(GM,ZI,"Product.Concentration.Units.Unit")=$G(@GA@("doses.dose@units")) 94 . S GC(GM,ZI,"Product.Concentration.Value")=$G(@GA@("doses.dose@dose")) 95 . S GC(GM,ZI,"Product.Form.Text")=$G(@GA@("form@value")) 96 . N GV S GV=$G(@GA@("products.product.vaProduct@vuid")) 97 . N GR S GR=$$RXNCUI3^C0PLKUP(GV) 98 . S GC(GM,ZI,"Product.ProductName.Code.CodingSystem")=$S(GR:"RxNorm",1:"VUID") 99 . S GC(GM,ZI,"Product.ProductName.Code.Value")=$S(GR:GR,1:GV) 100 . S GC(GM,ZI,"Product.ProductName.Code.Version")="08AB_081201F" 101 . S GC(GM,ZI,"Product.ProductName.Text")=$G(@GA@("name@value")) 102 . S GC(GM,ZI,"Product.Strength.Units.Unit")=$G(@GA@("doses.dose@units")) 103 . S GC(GM,ZI,"Product.Strength.Value")=$G(@GA@("doses.dose@dose")) 104 . ;S GC(GM,ZI,"Quantity.Units.Unit")="@@MEDQUANTITYUNIT@@" 105 . ;S GC(GM,ZI,"Quantity.Value")="@@MEDQUANTITYVALUE@@" 106 . ;S GC(GM,ZI,"Refills.Refill.Number")="@@MEDRFNO@@" 107 . N GDUZ S GDUZ=$G(@GA@("orderingProvider@code")) ;PROVIDER DUZ 108 . S GC(GM,ZI,"Source.Actor.ActorID")="PROVIDER_"_GDUZ 109 . S GC(GM,ZI,"Status.Text")=$G(@GA@("status@value")) 110 . S GC(GM,ZI,"Type.Text")="Medication" 111 N C0CDOCID 112 S C0CDOCID=$$DOMI^C0CDOM("GC",,"Medications") ; insert to dom 113 D OUTXML^C0CDOM(MEDOUTXML,C0CDOCID,1) ; render the xml 114 N ZSIZE S ZSIZE=$O(@MEDOUTXML@(""),-1) 115 S @MEDOUTXML@(0)=ZSIZE ; RETURN STATUS IS NUMBER OF LINES OF XML 116 W !,MEDOUTXML 117 ;ZWR GN 118 ;ZWR GC 119 ;B 120 Q 121 ; -
ccr/branches/ohum/p/C0CNMED4.m
r1332 r1333 1 C0CMED4 2 ;;0.1;CCDCCR;;; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) 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 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 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 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 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 1 C0CMED4 ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 2 ;;0.1;CCDCCR;;;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 "NO ENTRY FROM TOP",! 21 Q 22 ; 23 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE 24 ; 25 ; this routine has be adapted to retrieve meds from GET^NHINV by gpl 6/2011 26 ; 27 ; MINXML is the Input XML Template, passed by name 28 ; DFN is Patient IEN 29 ; OUTXML is the resultant XML. 30 ; 31 ; MEDS is return array from API. 32 ; MED is holds each array element from MEDS, one medicine 33 ; MAP is a mapping variable map (store result) for each med 34 ; 35 ; Inpatient Meds will be extracted using this routine and and the one following. 36 ; Inpatient Meds Unit Dose is going to be C0CMED4 37 ; Inpatient Meds IVs is going to be C0CMED5 38 ; 39 ; We will use two Pharmacy ReEnginnering API's: 40 ; PSS431^PSS55(DFN,PO,PSDATE,PEDATE,LIST) - provides most info 41 ; PSS432^PSS55(DFN,PO,LIST) - provides schedule info 42 ; For more information, see the PRE documentation at: 43 ; http://www.va.gov/vdl/documents/Clinical/Pharm-Inpatient_Med/phar_1_api_r0807.pdf 44 ; 45 ; Med data is stored in Unit Dose multiple of file 55, pharmacy patient 46 ; 47 N MEDS,MAP 48 ;K ^TMP($J) 49 ;D PSS431^PSS55(DFN,,,,"UD") ; Output is in ^TMP($J,"UD",*) 50 ;I ^TMP($J,"UD",0)'>0 S @OUTXML@(0)=0 QUIT ; No Meds - Quit 51 ;; Otherwise, we go on... 52 D EN^C0CNHIN(.MEDS,DFN,"MED;") ; gpl get the NHIN Array of meds 53 I '$D(MEDS) Q ; no meds 54 N ZI S ZI="" 55 N ZCOUNT S ZCOUNT=0 56 F S ZI=$O(MEDS("med",ZI)) Q:ZI="" D ; for each returned med 57 . I $G(MEDS("med",ZI,"vaType@value"))="I" S ZCOUNT=ZCOUNT+1 58 IF ZCOUNT=0 Q ; no inpatient meds 59 ;M MEDS=^TMP($J,"UD") 60 I DEBUG ZWR MEDS 61 S MEDMAP=$NA(^TMP("C0CCCR",$J,"MEDMAP")) 62 ;N MEDCOUNT S MEDCOUNT=@MEDMAP@(0) ; We already have meds in the array 63 N I S I=0 64 F S I=$O(MEDS("med",I)) Q:'I D ; For each medication 65 . N MED M MED=MEDS("med",I) 66 . I $G(MED("vaType@value"))'="I" Q ; not inpatient 67 . S MEDCOUNT=MEDCOUNT+1 68 . S @MEDMAP@(0)=MEDCOUNT ; Update MedMap array counter 69 . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) 70 . ;N RXIEN S RXIEN=MED(.01) ; Order Number 71 . N RXIEN S RXIEN=$G(MED("orderID@value")) ; ien of the med 72 . I DEBUG W "RXIEN IS ",RXIEN,! 73 . I DEBUG W "MAP= ",MAP,! 74 . S @MAP@("MEDOBJECTID")="MED_INPATIENT_UD"_RXIEN 75 . S @MAP@("MEDISSUEDATETXT")="Order Date" 76 . ;S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(27),U),"DT") 77 . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($G(MED("start@value")),"DT") 78 . S @MAP@("MEDLASTFILLDATETXT")="" ; For Outpatient 79 . S @MAP@("MEDLASTFILLDATE")="" ; For Outpatient 80 . S @MAP@("MEDRXNOTXT")="" ; For Outpatient 81 . S @MAP@("MEDRXNO")="" ; For Outpatient 82 . S @MAP@("MEDTYPETEXT")="Medication" 83 . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses 84 . ;S @MAP@("MEDSTATUSTEXT")="ACTIVE" 85 . N C0CMST S C0CMST=$G(MED("vaStatus@value")) ; need to filter status 86 . I C0CMST="EXPIRED" S C0CMST="Prior History No Longer Active" 87 . I C0CMST="ACTIVE" S C0CMST="Active" ; 88 . S @MAP@("MEDSTATUSTEXT")=C0CMST 89 . ;S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) 90 . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$G(MED("orderingProvider@code")) 91 . ;S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) 92 . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value")) 93 . ; NDC is field 31 in the drug file. 94 . ; The actual drug entry in the drug file is not necessarily supplied. 95 . ; It' node 1, internal form. 96 . ;N MEDIEN S MEDIEN=MED(1,"I") 97 . ;S @MAP@("MEDPRODUCTNAMECODEVALUE")=$S($L(MEDIEN):$$GET1^DIQ(50,MEDIEN,31,"E"),1:"") 98 . N ZVUID S ZVUID=$G(MED("products.product.vaProduct@vuid")) ; VUID 99 . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION 100 . D ; 101 . . S ZC=$$CODE^C0CUTIL(ZVUID) 102 . . S ZCD=$P(ZC,"^",1) ; CODE TO USE 103 . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID 104 . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION 105 . ;N ZRXNORM S ZRXNORM="" 106 . ;S ZRXNORM=$$RXNCUI3^C0PLKUP(ZVUID) 107 . S @MAP@("MEDPRODUCTNAMECODEVALUE")=ZCD 108 . ;S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=$S($L(MEDIEN):"NDC",1:"") 109 . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=ZCDS 110 . ;S @MAP@("MEDPRODUCTNAMECODEVERSION")=$S($L(MEDIEN):"none",1:"") 111 . S @MAP@("MEDPRODUCTNAMECODEVERSION")=ZCDSV 112 . S @MAP@("MEDBRANDNAMETEXT")="" 113 . S @MAP@("MEDPRODUCTNAMETEXT")=$G(MED("name@value"))_" "_ZCDS_": "_ZCD 114 . ;I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") 115 . ;I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) 116 . ;S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") 117 . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("doses.dose@dose")) 118 . ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") 119 . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("doses.dose@units")) 120 . ; Units, concentration, etc, come from another call 121 . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit 122 . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters 123 . ; NDF Entry IEN, and VA Product Name 124 . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") 125 . ; Documented in the same manual. 126 . ;N NDFDATA,CONCDATA 127 . ;I $L(MEDIEN) D 128 . ;. D NDF^PSS50(MEDIEN,,,,,"CONC") 129 . ;. M NDFDATA=^TMP($J,"CONC",MEDIEN) 130 . ;. N NDFIEN S NDFIEN=$P(NDFDATA(20),U) 131 . ;. N VAPROD S VAPROD=$P(NDFDATA(22),U) 132 . ;. ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" 133 . ;. ; and this will crash the call. So... 134 . ;. I NDFIEN="" S CONCDATA="" 135 . ;. E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) 136 . ;E S (NDFDATA,CONCDATA)="" ; This line is defensive programming to prevent undef errors. 137 . ;S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") 138 . S @MAP@("MEDFORMTEXT")=$G(MED("form@value")) 139 . ;S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") 140 . S @MAP@("MEDCONCVALUE")=$G(MED("doses.dose@dose")) 141 . ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") 142 . S @MAP@("MEDCONCUNIT")=$G(MED("doses.does@units")) 143 . ;S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. 144 . S @MAP@("MEDQUANTITYVALUE")=$G(MED("doses.dose@unitsPerDose")) ; 145 . ; Oddly, there is no easy place to find the dispense unit. 146 . ; It's not included in the original call, so we have to go to the drug file. 147 . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") 148 . ; Node 14.5 is the Dispense Unit 149 . ;I $L(MEDIEN) D 150 . ;. D DATA^PSS50(MEDIEN,,,,,"QTY") 151 . ;. N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) 152 . ;. S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) 153 . ;E S @MAP@("MEDQUANTITYUNIT")="" 154 . S @MAP@("MEDQUANTITYUNIT")=$G(MED("dose.dose@unitsPerDose")) 155 . ; 156 . ; --- START OF DIRECTIONS --- 157 . ; Dosage is field 2, route is 3, schedule is 4 158 . ; These are all free text fields, and don't point to any files 159 . ; For that reason, I will use the field I never used before: 160 . ; MEDDIRECTIONDESCRIPTIONTEXT 161 . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") 162 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=$G(MED("sig")) 163 . ; $G(MED("products.product.vaProduct@name")) 164 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. 165 . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" 166 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" 167 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" 168 . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" 169 . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" 170 . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" 171 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" 172 . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" 173 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" 174 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" 175 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" 176 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" 177 . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" 178 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" 179 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" 180 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" 181 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" 182 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" 183 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" 184 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" 185 . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" 186 . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" 187 . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" 188 . ; 189 . ; --- END OF DIRECTIONS --- 190 . ; 191 . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" 192 . ;S @MAP@("MEDPTINSTRUCTIONS")=MED(10,1) ; WP Field 193 . S @MAP@("MEDPTINSTRUCTIONS")="" 194 . ;S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field 195 . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" 196 . S @MAP@("MEDRFNO")="" 197 . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) 198 . K @RESULT 199 . D MAP^C0CXPATH(MINXML,MAP,RESULT) 200 . ; D PARY^C0CXPATH(RESULT) 201 . ; MAPPING DIRECTIONS 202 . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE 203 . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT 204 . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) 205 . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") 206 . ; N MDZ1,MDZNA 207 . N DIRCNT S DIRCNT=1 ; THERE ARE ALWAYS DIRECTIONS 208 . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS 209 . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION 210 . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) 211 . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) 212 . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") 213 . D:MEDCOUNT=1 CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy 214 . D:MEDCOUNT>1 INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML 215 N MEDTMP,MEDI 216 D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS 217 I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 218 . W "MEDICATION MISSING ",! 219 . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! 220 Q 221 ; -
ccr/branches/ohum/p/C0CORSLT.m
r1332 r1333 1 C0CORSLT 2 ;;1.0;C0C;;Jan 21, 2010;Build 381 C0CORSLT ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11 2 ;;1.0;C0C;;Jan 21, 2010;Build 1 3 3 ;Copyright 2011 George Lilly. 4 4 ;Licensed under the terms of the GNU General Public License. … … 22 22 Q 23 23 ; 24 EN(ZVARS,DFN) 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 OLD 63 64 65 66 67 68 69 24 EN(ZVARS,DFN) ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS 25 ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE 26 ; AN EXAMPLE IS EKG RESULTS THAT ARE FOUND IN NOTES AND CONSULTS 27 ; THIS IS CREATED FOR MU CERTIFICATION BY GPL 28 D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE 29 N ZN ; RESULT NUMBER 30 S ZN=$O(@ZVARS@(""),-1) ; NEXT RESULT 31 N ZI S ZI="" 32 F S ZI=$O(VISIT(ZI)) Q:ZI="" D ; FOR EACH VISIT 33 . I $G(VISIT(ZI,"TEXT",1))["ECG DONE" D ; GOT AN ECG 34 . . S ZN=ZN+1 ; INCREMENT RESULT COUNT 35 . . N ZDATE,ZPRV,ZTXT 36 . . S ZDATE=$G(VISIT(ZI,"DATE",0)) ; DATE OF PROCEDURE 37 . . S ZPRV=$P($G(VISIT(ZI,"PRV",2)),"^",1) ;PROVIDER 38 . . S ZTXT=$P($G(VISIT(ZI,"TEXT",4)),"ECG RESULTS: ",2) 39 . . S @ZVARS@(ZN,"RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") 40 . . S @ZVARS@(ZN,"RESULTCODE")="34534-8" 41 . . S @ZVARS@(ZN,"RESULTCODINGSYSTEM")="LOINC" 42 . . S @ZVARS@(ZN,"RESULTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" 43 . . S @ZVARS@(ZN,"RESULTOBJECTID")="RESULT"_ZN 44 . . S @ZVARS@(ZN,"RESULTSOURCEACTORID")="ACTORPROVIDER_"_ZPRV 45 . . S @ZVARS@(ZN,"RESULTSTATUS")="" 46 . . S @ZVARS@(ZN,"M","TEST",0)=1 47 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODEVALUE")="34534-8" 48 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODINGSYSTEM")="LOINC" 49 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") 50 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" 51 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTFLAG")="" 52 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALDESCTEXT")="" 53 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALSOURCEACTORID")="ACTORORGANIZATION_VASTANUM" 54 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTOBJECTID")="RESULTTEST_ECG_"_ZN 55 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSOURCEACTORID")="ACTORPROVIDER"_ZPRV 56 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSTATUSTEXT")="F" 57 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTUNITS")="" 58 . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTVALUE")=ZTXT 59 . . S @ZVARS@(0)=ZN ; UPDATE RESULTS COUNT 60 Q 61 ; 62 OLD ; OLD CODE FOR OTHER WAYS OF DOING THE ECG 63 ; FOR CERTIFICATION - SAVE EKG RESULTS gpl 64 W !,"CPT=",ZCPT 65 I ZCPT["93000" D ; THIS IS AN EKG 66 . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS 67 . M ^GPL("RNF2")=@C0CPRSLT 68 Q 69 ; -
ccr/branches/ohum/p/C0CPARMS.m
r1332 r1333 1 1 C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. … … 38 38 ; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS 39 39 ; IF THEY FAIL, THE FOLLOWING WILL BE HARDCODED DEFAULTS 40 I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH 40 ;OHUM/RUT commented the hardcoded limits 41 ;I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH 42 ;I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY 43 ;I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS 44 ;I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY 45 ;I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY 46 ;I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS 47 ;I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES 48 ;I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO 49 ;I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE 50 S @C0CPARMS@("LABLIMIT")=^TMP("C0CCCR","LABLIMIT"),@C0CPARMS@("VITLIMIT")=^TMP("C0CCCR","VITLIMIT"),@C0CPARMS@("TIULIMIT")=^TMP("C0CCCR","TIULIMIT"),@C0CPARMS@("MEDLIMIT")=^TMP("C0CCCR","MEDLIMIT") 41 51 I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY 42 I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS43 52 I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY 44 53 I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY 45 I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS46 54 I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES 47 55 I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO 48 I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE 56 I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=1 ; NON-PENDING NON-ACTIVE 57 ;I '$D(@C0CPARMS@("RALIMIT")) S @C0CPARMS@("RALIMIT")="T-36500" ;ONE YR WORTH 58 ;I '$D(@C0CPARMS@("RASTART")) S @C0CPARMS@("RASTART")="T" ;TODAY 59 I '$D(@C0CPARMS@("TIUSTART")) S @C0CPARMS@("TIUSTART")="T" ;TODAY 60 ;OHUM/RUT 49 61 Q 50 62 ; -
ccr/branches/ohum/p/C0CPROBS.m
r1332 r1333 1 1 C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 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/C0CPROC.m
r1332 r1333 1 1 C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10 2 ;;1.0;C0C;;Jan 21, 2010;Build 382 ;;1.0;C0C;;Jan 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/C0CPXRM.m
r1332 r1333 1 C0CPXRM ; 2 ;;; 3 DOIT ; 4 S G="PXRMXSEPCLINIC3110302.224804" ZWR ^XTMP(G,*) 5 S G="PXRMXSEPCLINIC3110302.223957" ZWR ^XTMP(G,*) 6 S G="PXRMXSEPCLINIC3110302.223738" ZWR ^XTMP(G,*) 7 S G="PXRMXSEPCLINIC3110302.223516" ZWR ^XTMP(G,*) 8 S G="PXRMXSEPCLINIC3110302.222158" ZWR ^XTMP(G,*) 9 S G="PXRMXSEPCLINIC3110302.213944" ZWR ^XTMP(G,*) 10 S G="PXRMXSEPCLINIC3110302.212219" ZWR ^XTMP(G,*) 11 S G="PXRMXSEPCLINIC3110302.211506" ZWR ^XTMP(G,*) 12 S G="PXRMXSEPCLINIC3110302.002714" ZWR ^XTMP(G,*) 13 S G="PXRMXSEPCLINIC3110302.001841" ZWR ^XTMP(G,*) 14 S G="PXRMXSEPCLINIC3110302.000846" ZWR ^XTMP(G,*) 15 S G="PXRMXSEPCLINIC3110115.141918" ZWR ^XTMP(G,*) 16 S G="PXRMXSEPCLINIC3110115.132312" ZWR ^XTMP(G,*) 17 S G="PXRMXSEPCLINIC3110115.131653" ZWR ^XTMP(G,*) 18 S G="PXRMXSEPCLINIC3110115.131008" ZWR ^XTMP(G,*) 19 S G="PXRM PXK EVENT988 3110224.210456" ZWR ^XTMP(G,*) 20 S G="PXRM PXK EVENT986 3110224.210456" ZWR ^XTMP(G,*) 21 S G="PXRM PXK EVENT932 3110224.210456" ZWR ^XTMP(G,*) 22 S G="PXRM PXK EVENT932 3110224.210455" ZWR ^XTMP(G,*) 23 S G="PXRM PXK EVENT8015 3110301.215142" ZWR ^XTMP(G,*) 24 S G="PXRM PXK EVENT8015 3110301.215141" ZWR ^XTMP(G,*) 25 S G="PXRM PXK EVENT5265 3110309.124047" ZWR ^XTMP(G,*) 26 S G="PXRM PXK EVENT5265 3110309.124046" ZWR ^XTMP(G,*) 27 S G="PXRM PXK EVENT4742 3101129.221201" ZWR ^XTMP(G,*) 28 S G="PXRM PXK EVENT4742 3101129.215741" ZWR ^XTMP(G,*) 29 S G="PXRM PXK EVENT4710 3101129.215701" ZWR ^XTMP(G,*) 30 S G="PXRM PXK EVENT3297 3101127.123134" ZWR ^XTMP(G,*) 31 S G="PXRM PXK EVENT32495 3110224.194246" ZWR ^XTMP(G,*) 32 S G="PXRM PXK EVENT32493 3110224.194246" ZWR ^XTMP(G,*) 33 S G="PXRM PXK EVENT32354 3110224.194246" ZWR ^XTMP(G,*) 34 S G="PXRM PXK EVENT32354 3110224.194245" ZWR ^XTMP(G,*) 35 S G="PXRM PXK EVENT31106 3110224.175105" ZWR ^XTMP(G,*) 36 S G="PXRM PXK EVENT31090 3110224.175105" ZWR ^XTMP(G,*) 37 S G="PXRM PXK EVENT30339 3110224.175105" ZWR ^XTMP(G,*) 38 S G="PXRM PXK EVENT30339 3110224.175103" ZWR ^XTMP(G,*) 39 S G="PXRM PXK EVENT2761 3110115.174109" ZWR ^XTMP(G,*) 40 S G="PXRM PXK EVENT2761 3110115.174108" ZWR ^XTMP(G,*) 41 S G="PXRM PXK EVENT27327 3110227.013658" ZWR ^XTMP(G,*) 42 S G="PXRM PXK EVENT27327 3110227.013657" ZWR ^XTMP(G,*) 43 S G="PXRM PXK EVENT27327 3110227.013523" ZWR ^XTMP(G,*) 44 S G="PXRM PXK EVENT27327 3110227.013522" ZWR ^XTMP(G,*) 45 S G="PXRM PXK EVENT27253 3110227.012747" ZWR ^XTMP(G,*) 46 S G="PXRM PXK EVENT27253 3110227.012746" ZWR ^XTMP(G,*) 47 S G="PXRM PXK EVENT2559 3110115.170835" ZWR ^XTMP(G,*) 48 S G="PXRM PXK EVENT25549 3110228.231135" ZWR ^XTMP(G,*) 49 S G="PXRM PXK EVENT25549 3110228.231134" ZWR ^XTMP(G,*) 50 S G="PXRM PXK EVENT2205 3101129.215343" ZWR ^XTMP(G,*) 51 S G="PXRM PXK EVENT21092 3110114.195621" ZWR ^XTMP(G,*) 52 S G="PXRM PXK EVENT21092 3110114.193803" ZWR ^XTMP(G,*) 53 S G="PXRM PXK EVENT19640 3110226.032943" ZWR ^XTMP(G,*) 54 S G="PXRM PXK EVENT19640 3110226.032941" ZWR ^XTMP(G,*) 55 S G="PXRM PXK EVENT19353 3101212.162833" ZWR ^XTMP(G,*) 56 S G="PXRM PXK EVENT18780 3110221.215603" ZWR ^XTMP(G,*) 57 S G="PXRM PXK EVENT18156 3101212.152654" ZWR ^XTMP(G,*) 58 S G="PXRM PXK EVENT17800 3110315.202432" ZWR ^XTMP(G,*) 59 S G="PXRM PXK EVENT1650 3110220.192925" ZWR ^XTMP(G,*) 60 S G="PXRM PXK EVENT16110 3110313.224636" ZWR ^XTMP(G,*) 61 S G="PXRM PXK EVENT16004 3110317.151215" ZWR ^XTMP(G,*) 62 S G="PXRM PXK EVENT16004 3110317.150834" ZWR ^XTMP(G,*) 63 S G="PXRM PXK EVENT14955 3110315.165018" ZWR ^XTMP(G,*) 64 S G="PXRM PXK EVENT14816 3110315.164839" ZWR ^XTMP(G,*) 65 S G="PXRM PXK EVENT14816 3110315.164512" ZWR ^XTMP(G,*) 66 S G="PXRM PXK EVENT12415 3110315.135514" ZWR ^XTMP(G,*) 67 S G="PXRM PXK EVENT11797 3110315.131141" ZWR ^XTMP(G,*) 68 S G="PXRM PXK EVENT11573 3110315.131811" ZWR ^XTMP(G,*) 69 S G="PXRM PXK EVENT10728 3110114.025022" ZWR ^XTMP(G,*) 70 S G="PXRM PXK EVENT10578 3110114.021524" ZWR ^XTMP(G,*) 71 S G="PXRM PXK EVENT10243 3110114.020338" ZWR ^XTMP(G,*) 72 S G="PXRM PXK EVENT10105 3101204.230554" ZWR ^XTMP(G,*) 73 Q 74 ; 1 C0CPXRM ; 2 DOIT ; 3 S G="PXRMXSEPCLINIC3110302.224804" ZWR ^XTMP(G,*) 4 S G="PXRMXSEPCLINIC3110302.223957" ZWR ^XTMP(G,*) 5 S G="PXRMXSEPCLINIC3110302.223738" ZWR ^XTMP(G,*) 6 S G="PXRMXSEPCLINIC3110302.223516" ZWR ^XTMP(G,*) 7 S G="PXRMXSEPCLINIC3110302.222158" ZWR ^XTMP(G,*) 8 S G="PXRMXSEPCLINIC3110302.213944" ZWR ^XTMP(G,*) 9 S G="PXRMXSEPCLINIC3110302.212219" ZWR ^XTMP(G,*) 10 S G="PXRMXSEPCLINIC3110302.211506" ZWR ^XTMP(G,*) 11 S G="PXRMXSEPCLINIC3110302.002714" ZWR ^XTMP(G,*) 12 S G="PXRMXSEPCLINIC3110302.001841" ZWR ^XTMP(G,*) 13 S G="PXRMXSEPCLINIC3110302.000846" ZWR ^XTMP(G,*) 14 S G="PXRMXSEPCLINIC3110115.141918" ZWR ^XTMP(G,*) 15 S G="PXRMXSEPCLINIC3110115.132312" ZWR ^XTMP(G,*) 16 S G="PXRMXSEPCLINIC3110115.131653" ZWR ^XTMP(G,*) 17 S G="PXRMXSEPCLINIC3110115.131008" ZWR ^XTMP(G,*) 18 S G="PXRM PXK EVENT988 3110224.210456" ZWR ^XTMP(G,*) 19 S G="PXRM PXK EVENT986 3110224.210456" ZWR ^XTMP(G,*) 20 S G="PXRM PXK EVENT932 3110224.210456" ZWR ^XTMP(G,*) 21 S G="PXRM PXK EVENT932 3110224.210455" ZWR ^XTMP(G,*) 22 S G="PXRM PXK EVENT8015 3110301.215142" ZWR ^XTMP(G,*) 23 S G="PXRM PXK EVENT8015 3110301.215141" ZWR ^XTMP(G,*) 24 S G="PXRM PXK EVENT5265 3110309.124047" ZWR ^XTMP(G,*) 25 S G="PXRM PXK EVENT5265 3110309.124046" ZWR ^XTMP(G,*) 26 S G="PXRM PXK EVENT4742 3101129.221201" ZWR ^XTMP(G,*) 27 S G="PXRM PXK EVENT4742 3101129.215741" ZWR ^XTMP(G,*) 28 S G="PXRM PXK EVENT4710 3101129.215701" ZWR ^XTMP(G,*) 29 S G="PXRM PXK EVENT3297 3101127.123134" ZWR ^XTMP(G,*) 30 S G="PXRM PXK EVENT32495 3110224.194246" ZWR ^XTMP(G,*) 31 S G="PXRM PXK EVENT32493 3110224.194246" ZWR ^XTMP(G,*) 32 S G="PXRM PXK EVENT32354 3110224.194246" ZWR ^XTMP(G,*) 33 S G="PXRM PXK EVENT32354 3110224.194245" ZWR ^XTMP(G,*) 34 S G="PXRM PXK EVENT31106 3110224.175105" ZWR ^XTMP(G,*) 35 S G="PXRM PXK EVENT31090 3110224.175105" ZWR ^XTMP(G,*) 36 S G="PXRM PXK EVENT30339 3110224.175105" ZWR ^XTMP(G,*) 37 S G="PXRM PXK EVENT30339 3110224.175103" ZWR ^XTMP(G,*) 38 S G="PXRM PXK EVENT2761 3110115.174109" ZWR ^XTMP(G,*) 39 S G="PXRM PXK EVENT2761 3110115.174108" ZWR ^XTMP(G,*) 40 S G="PXRM PXK EVENT27327 3110227.013658" ZWR ^XTMP(G,*) 41 S G="PXRM PXK EVENT27327 3110227.013657" ZWR ^XTMP(G,*) 42 S G="PXRM PXK EVENT27327 3110227.013523" ZWR ^XTMP(G,*) 43 S G="PXRM PXK EVENT27327 3110227.013522" ZWR ^XTMP(G,*) 44 S G="PXRM PXK EVENT27253 3110227.012747" ZWR ^XTMP(G,*) 45 S G="PXRM PXK EVENT27253 3110227.012746" ZWR ^XTMP(G,*) 46 S G="PXRM PXK EVENT2559 3110115.170835" ZWR ^XTMP(G,*) 47 S G="PXRM PXK EVENT25549 3110228.231135" ZWR ^XTMP(G,*) 48 S G="PXRM PXK EVENT25549 3110228.231134" ZWR ^XTMP(G,*) 49 S G="PXRM PXK EVENT2205 3101129.215343" ZWR ^XTMP(G,*) 50 S G="PXRM PXK EVENT21092 3110114.195621" ZWR ^XTMP(G,*) 51 S G="PXRM PXK EVENT21092 3110114.193803" ZWR ^XTMP(G,*) 52 S G="PXRM PXK EVENT19640 3110226.032943" ZWR ^XTMP(G,*) 53 S G="PXRM PXK EVENT19640 3110226.032941" ZWR ^XTMP(G,*) 54 S G="PXRM PXK EVENT19353 3101212.162833" ZWR ^XTMP(G,*) 55 S G="PXRM PXK EVENT18780 3110221.215603" ZWR ^XTMP(G,*) 56 S G="PXRM PXK EVENT18156 3101212.152654" ZWR ^XTMP(G,*) 57 S G="PXRM PXK EVENT17800 3110315.202432" ZWR ^XTMP(G,*) 58 S G="PXRM PXK EVENT1650 3110220.192925" ZWR ^XTMP(G,*) 59 S G="PXRM PXK EVENT16110 3110313.224636" ZWR ^XTMP(G,*) 60 S G="PXRM PXK EVENT16004 3110317.151215" ZWR ^XTMP(G,*) 61 S G="PXRM PXK EVENT16004 3110317.150834" ZWR ^XTMP(G,*) 62 S G="PXRM PXK EVENT14955 3110315.165018" ZWR ^XTMP(G,*) 63 S G="PXRM PXK EVENT14816 3110315.164839" ZWR ^XTMP(G,*) 64 S G="PXRM PXK EVENT14816 3110315.164512" ZWR ^XTMP(G,*) 65 S G="PXRM PXK EVENT12415 3110315.135514" ZWR ^XTMP(G,*) 66 S G="PXRM PXK EVENT11797 3110315.131141" ZWR ^XTMP(G,*) 67 S G="PXRM PXK EVENT11573 3110315.131811" ZWR ^XTMP(G,*) 68 S G="PXRM PXK EVENT10728 3110114.025022" ZWR ^XTMP(G,*) 69 S G="PXRM PXK EVENT10578 3110114.021524" ZWR ^XTMP(G,*) 70 S G="PXRM PXK EVENT10243 3110114.020338" ZWR ^XTMP(G,*) 71 S G="PXRM PXK EVENT10105 3101204.230554" ZWR ^XTMP(G,*) 72 Q 73 ; -
ccr/branches/ohum/p/C0CQRY1.m
r1332 r1333 1 LA7QRY1 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 313 4 5 6 CHKSC 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 SPEC 24 25 26 27 28 29 30 31 32 33 34 BUILDMSG 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 PID 64 65 66 67 68 69 70 71 72 73 74 75 76 ORC 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 OBR 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 OBX 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 1 LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99 13:48 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 1 3 ; 4 Q 5 ; 6 CHKSC ; Check search NLT/LOINC codes 7 ; 8 N J 9 ; 10 S J=0 11 F S J=$O(LA7SC(J)) Q:'J D 12 . N X 13 . S X=LA7SC(J) 14 . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D Q 15 . . S ^TMP("LA7-NLT",$J,$P(X,"^"))="" 16 . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D Q 17 . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))="" 18 . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed" 19 . K LA7SC(J) 20 Q 21 ; 22 ; 23 SPEC ; Convert HL7 Specimen Codes to File #61, Topography codes 24 ; Find all topographies that use this HL7 specimen code 25 N J,K,L 26 ; 27 S J=0 28 F S J=$O(LA7SPEC(J)) Q:'J D 29 . S K=LA7SPEC(J),L=0 30 . F S L=$O(^LAB(61,"HL7",K,L)) Q:'L S ^TMP("LA7-61",$J,L)="" 31 Q 32 ; 33 ; 34 BUILDMSG ; Build HL7 message with result of query 35 ; 36 N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X 37 ; 38 I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&" 39 S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5) 40 S (HLQ,HL("Q"))="""""" 41 ; Set flag to not send HL7 message 42 S LA7NOMSG=1 43 ; Create dummy MSH to pass HL7 delimiters 44 S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS 45 D FILESEG^LA7VHLU(GBL,.LA7MSH) 46 ; 47 F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)="" 48 ; 49 ; Take search results and put in HL7 message structure 50 S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0 51 ; F S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT D ;change per John M 52 F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" D Q:LA7QUIT 53 . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q 54 . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0 55 . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR 56 . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR 57 . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR 58 . D OBX 59 ; 60 Q 61 ; 62 ; 63 PID ; Build PID segment 64 ; 65 N LA7PID 66 ; 67 S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3) 68 S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) 69 D DEM^LRX 70 D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL) 71 D FILESEG^LA7VHLU(GBL,.LA7PID) 72 S (LA("LRIDT"),LA("SUB"))="" 73 Q 74 ; 75 ; 76 ORC ; Build ORC segment 77 ; 78 N X 79 ; 80 S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5) 81 S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) 82 S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")) 83 S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4) 84 I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6) 85 S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0 86 D ORC^LA7VORU 87 S LA("NLT")="" 88 ; 89 Q 90 ; 91 ; 92 OBR ; Build OBR segment 93 ; 94 N LA764,LA7NLT 95 ; 96 S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))="" 97 I $L(LA7NLT) D 98 . S LA764=+$O(^LAM("E",LA7NLT,0)) 99 . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01) 100 I LA("SUB")="CH" D 101 . D OBR^LA7VORU 102 . D NTE^LA7VORU 103 . S LA7OBXSN=0 104 ; 105 Q 106 ; 107 ; 108 OBX ; Build OBX segment 109 ; 110 N LA7DATA,LA7VT 111 ; 112 S LA7NTESN=0 113 I LA("SUB")="MI" D MI^LA7VORU1 Q 114 I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q 115 ; 116 S LA7VT=$QS(LA7ROOT,7) 117 D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH) 118 I '$D(LA7DATA) Q 119 D FILESEG^LA7VHLU(GBL,.LA7DATA) 120 ; Send any test interpretation from file #60 121 D INTRP^LA7VORUA 122 ; 123 Q -
ccr/branches/ohum/p/C0CQRY2.m
r1332 r1333 1 LA7QRY2 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994 3 4 5 6 7 PATID 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 BCD 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 BRAD 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 83 84 85 86 SEARCH 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 CHSS 115 116 117 118 119 120 121 122 123 124 125 126 127 128 MISS 129 130 131 132 133 134 135 136 137 138 139 140 APSS 141 142 143 144 145 146 147 148 149 150 151 152 BBSS 153 154 155 156 157 CHECK 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 STORE 176 177 178 179 180 181 SETDFN(LA7X) 182 183 184 1 LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 04/13/09 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994;Build 1 3 ; JMC - mods to check for IHS V LAB file 4 ; 5 Q 6 ; 7 PATID ; Resolve patient id and establish patient environment 8 ; 9 N LA7X 10 ; 11 S (DFN,LRDFN)="",LA7PTYP=0 12 ; 13 ; SSN passed as patient identifier 14 I LA7PTID?9N.1A D 15 . S LA7PTYP=1 16 . S LA7X=$O(^DPT("SSN",LA7PTID,0)) 17 . I LA7X>0 D SETDFN(LA7X) 18 ; 19 ; MPI/ICN (integration control number) passed as patient identifier 20 I LA7PTID?10N1"V"6N D 21 . S LA7PTYP=2 22 . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V")) 23 . I LA7X>0 D SETDFN(LA7X) 24 ; 25 ; If no patient identified/no laboratory record - return exception message 26 I 'LA7PTYP S LA7ERR(1)="Invalid patient identifier passed" 27 I 'DFN S LA7ERR(2)="No patient found with requested identifier" 28 I DFN,'LRDFN S LA7ERR(3)="No laboratory record for requested patient" 29 I LRDFN,'$D(^LR(LRDFN)) S LA7ERR(4)="Database error - missing laboratory record for requested patient" 30 Q 31 ; 32 ; 33 BCD ; Search by specimen collection date. 34 ; 35 N LA763,LA7QUIT 36 ; 37 S (LA7SDT(0),LA7EDT(0))=0 38 I LA7SDT S LA7SDT(0)=9999999-LA7SDT 39 I LA7EDT S LA7EDT(0)=9999999-LA7EDT 40 ; 41 F LRSS="CH","MI","SP" D 42 . S (LA7QUIT,LRIDT)=0 43 . I LA7EDT(0) S LRIDT=$O(^LR(LRDFN,LRSS,LA7EDT(0)),-1) 44 . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:LA7QUIT D 45 . . ; Quit if reached end of data or outside date criteria 46 . . I 'LRIDT!(LRIDT>LA7SDT(0)) S LA7QUIT=1 Q 47 . . D SEARCH 48 ; 49 Q 50 ; 51 ; 52 BRAD ; Search by results available date (completion date). 53 ; Assumes cross-references still exist for dates in LRO(69) global. 54 ; Collects specimen date/time values for a given LRDFN and completion date. 55 ; Cross-reference is by date only, time stripped from start date. 56 ; Uses cross-reference ^LRO(69,DT,1,"AN",'LOCATION',LRDFN,LRIDT)="" 57 ; 58 N LA763,LA7DT,LA7ROOT,LA7SRC,X 59 ; 60 ; Check if orders still exist Iin file #69 for search range 61 S LA7SDT(1)=(LA7SDT\1)-.0000000001,LA7EDT(1)=(LA7EDT\1)+.24,LA7SRC=0 62 S X=$O(^LRO(69,LA7SDT(1))) 63 I X,X<LA7EDT(1) S LA7SRC=1 64 ; 65 ; Search "AN" cross-reference in file #69. 66 I LA7SRC D 67 . S LA7DT=LA7SDT(1) 68 . F S LA7DT=$O(^LRO(69,LA7DT)) Q:'LA7DT!(LA7DT>LA7EDT(1)) D 69 . . S LA7ROOT="^LRO(69,LA7DT,1,""AN"")" 70 . . F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT=""!($QS(LA7ROOT,2)'=LA7DT)!($QS(LA7ROOT,4)'="AN") D 71 . . . I $QS(LA7ROOT,6)'=LRDFN Q 72 . . . S LRIDT=$QS(LA7ROOT,7) 73 . . . F LRSS="CH","MI","SP" D SEARCH 74 ; 75 ; If no orders in #69 then do long search through file #63. 76 I 'LA7SRC D 77 . F LRSS="CH","MI","SP" D 78 . . S LRIDT=0 79 . . F S LRIDT=$O(^LR(LRDFN,LRSS,LRIDT)) Q:'LRIDT D 80 . . . S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) 81 . . . I $P(LA763(0),"^",3)>LA7SDT(1),$P(LA763(0),"^",3)<LA7EDT(1) D SEARCH 82 ; 83 Q 84 ; 85 ; 86 SEARCH ; Search subscript for a specific collection date/time 87 ; 88 K LA763 89 S LA763(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) 90 ; 91 ; Only CH, MI, and BB subscripts store pointer to file #61 in 5th piece of zeroth node. 92 ; Quit if specific specimen codes and they do not match 93 I "CHMIBB"[LRSS S LA761=+$P(LA763(0),"^",5) 94 E S LA761=0 95 I LA761,$D(^TMP("LA7-61",$J)),'$D(^TMP("LA7-61",$J,LA761)) Q 96 ; 97 ; --- Chemistry 98 I LRSS="CH" D CHSS Q 99 ; --- Microbiology 100 I LRSS="MI" D MISS Q 101 ; --- Surgical pathology 102 I LRSS="SP" D APSS Q 103 ; --- Cytology 104 I LRSS="CY" D APSS Q 105 ; --- Electron Micrscopsy 106 I LRSS="EM" D APSS Q 107 ; --- Autopsy 108 I LRSS="AU" D APSS Q 109 ; --- Blood Bank 110 I LRSS="BB" D BBSS Q 111 Q 112 ; 113 ; 114 CHSS ; Search "CH" datanames for matching codes 115 ; 116 N LA7X,LRSB 117 ; 118 S LRSB=1 119 F S LRSB=$O(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q:'LRSB D 120 . S LA7X=$G(^LR(LRDFN,LRSS,LRIDT,LRSB)) 121 . I $D(^AUPNVLAB) D LNCHK^C0CLA7Q ; WV check for IHS. 122 . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,$P(LA7X,"^",3),LA761) 123 . D CHECK 124 ; 125 Q 126 ; 127 ; 128 MISS ; Search "MI" subscripts for matching codes 129 ; 130 N LA7ND,LRSB 131 ; 132 S LA7ND=0 133 F LA7ND=1,5,8,11,16 I $D(^LR(LRDFN,LRSS,LRIDT,LA7ND)) D 134 . S LRSB=$S(LA7ND=1:11,LA7ND=5:14,LA7ND=8:18,LA7ND=11:22,LA7ND=16:33,1:11) 135 . S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"",LA761) 136 . D CHECK 137 Q 138 ; 139 ; 140 APSS ; Search AP subscripts for matching codes 141 ; AP results are currently not coded - use defaults 142 ; 143 N LA7CODE,LRSB 144 ; 145 S LRSB=.012 146 S LA7CODE=$$DEFCODE^LA7VHLU5(LRSS,LRSB,"","") 147 D CHECK 148 ; 149 Q 150 ; 151 ; 152 BBSS ; Search BB subscript for matching codes 153 ; *** This subscript currently not supported *** 154 Q 155 ; 156 ; 157 CHECK ; Check NLT order/result and LOINC codes. 158 ; 159 N LA7QUIT 160 ; 161 ; If wildcard then store 162 ; Otherwise check for specific NLT order/result and LOINC codes 163 I LA7SC="*" D STORE Q 164 S LA7QUIT=0 165 F I=1:1:3 D Q:LA7QUIT 166 . ; If no test code then skip 167 . I '$L($P(LA7CODE,"!",I)) Q 168 . ; If test code does not match a search code then quit 169 . I '$D(^TMP($S(I=3:"LA7-LN",1:"LA7-NLT"),$J,$P(LA7CODE,"!",I))) Q 170 . D STORE S LA7QUIT=1 171 ; 172 Q 173 ; 174 ; 175 STORE ; Store entry for building in HL7 message 176 ; 177 S ^TMP("LA7-QRY",$J,LRDFN,LRIDT,LRSS,LA7CODE,LRSB)="" 178 Q 179 ; 180 ; 181 SETDFN(LA7X) ; Setup DFN and other lab variables. 182 ; 183 S DFN=LA7X,LRDFN=$P($G(^DPT(DFN,"LR")),"^") 184 Q -
ccr/branches/ohum/p/C0CRIMA.m
r1332 r1333 1 1 C0CRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 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/C0CRNF.m
r1332 r1333 1 1 C0CRNF ; CCDCCR/GPL - Reference Name Format (RNF) 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/C0CRNFRP.m
r1332 r1333 1 C0CRNFRPC 2 ;;1.0;C0C;;Dec 9, 2009; 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 FIELDS(C0CFRTN,C0CFILE) 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 GETNOLD(GRTN,GFILE,GIEN,GNN) 58 59 60 61 62 63 GETN(C0CGRTN,GFILE,GREF,GNDX,GNN) 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 116 117 118 119 GETN1(GRTN,GFILE,GREF,GNDX,GNN) 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 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 GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) 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 ADDNV(GNV,GNVN,GNVF,GNVV) 218 219 220 221 222 223 RNF2CSV(RNRTN,RNIN,RNSTY) 224 225 226 227 228 229 230 231 232 233 234 235 236 NV(RNRTN,RNIN) 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 VN(RNRTN,RNIN) 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 READCSV(PATH,NAME,GLB) 281 282 283 284 FILE2CSV(FNUM,FVN) 285 286 287 288 289 290 291 292 293 294 295 296 297 FILEOUT(FOARY,FONAM) 298 299 300 301 302 FILEREF(FNUM) 303 304 305 306 307 308 309 310 SKIP 311 312 313 314 315 316 317 318 319 320 321 ZFILE(ZFN,ZTAB) 322 323 324 325 326 ZFIELD(ZFN,ZTAB) 327 328 329 330 331 ZVALUE(ZFN,ZTAB) 332 333 334 335 336 337 ZVALUEI(ZFN,ZTAB) 338 339 340 341 342 1 C0CRNFRPC ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09 2 ;;1.0;C0C;;Dec 9, 2009;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 Reference Name Format (RNF) RPC Library ",! 21 W ! 22 Q 23 ; 24 ;This routine will be mirroring C0CRNF and transform the output 25 ;of the tags into an RPC friendly format 26 ;The tags will be exactly as they are in C0CRNF 27 FIELDS(C0CFRTN,C0CFILE) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF, 28 ;C0CFRTN IS PASSED BY REFERENCE, C0CF IS PASSED BY VALUE 29 ;RETURN FORMAT: 30 ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS 31 ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER" 32 ; 33 ;SAMPLE OUTPUT FROM FIELDS^C0CRNF: 34 ;C0CRNFFIELDS("*AMOUNT OF MILITARY RETIREMENT")="2^.3625" 35 ; 36 ;FORMAT APPEARS TO BE: 37 ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER" 38 ; 39 ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON 40 S DEBUG=0 41 ;SET RETURN VALUE 42 S C0CFRTN=$NA(^TMP("C0CRNF",$J)) 43 K @C0CFRTN 44 ;RUN WRAPPED CALL 45 D FIELDS^C0CRNF("C0CRTN",C0CFILE) 46 S J="" 47 S I=1 48 ;FORMAT RETURN 49 F S J=$O(C0CRTN(J)) Q:J="" D ; FOR EACH FIELD IN THE ARRAY 50 . S @C0CFRTN@(I)=J_"^"_C0CRTN(J) 51 . S I=I+1 52 S @C0CFRTN@(0)=I-1 53 ;CLEAN UP 54 K J,I 55 Q 56 ; 57 GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME 58 ; GRTN IS PASSED BY NAME 59 ; 60 ; OLD TAG DO NOT USE! 61 Q 62 ; 63 GETN(C0CGRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP 64 ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL 65 ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP 66 ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" 67 ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP 68 ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE 69 ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP 70 ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP 71 ; .. NULL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE 72 ; IF GREF IS "" THE FIRST RECORD IS OBTAINED 73 ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE 74 ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN 75 ; GREF IS THE VALUE FOR THE INDEX 76 ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED 77 ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN 78 ; 79 ; 80 ;RETURN FORMAT: 81 ;^TMP("C0CRNF",$J,0)="NUMBER_OF_RESULTS^FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ_$C(30)" 82 ;^TMP("C0CRNF",$J,I)="FIELD_NAME^FILE_NUMBER^FIELD_NUMBER^VALUE^INTERNAL_VALUE_$C(30)" 83 ; 84 ;SAMPLE OUTPUT FROM FIELDS^C0CRNF: 85 ;C0CRNFGETN(0)="2^RNF1^5095^3091209^2908^3268" 86 ;C0CRNFGETN("1U4N")="2^.0905^H5369" 87 ;C0CRNFGETN("1U4N","I")="^^H5369" 88 ;C0CRNFGETN("ADDRESS CHANGE DT/TM")="2^.118^OCT 21,2009@08:03:26" 89 ;C0CRNFGETN("ADDRESS CHANGE DT/TM","I")="^^3091021.080326" 90 ; 91 ;FORMAT APPEARS TO BE: 92 ;VARIABLENAME(0)="FILE_NUMBER^RNF1^IEN^CURRENT_DATE^$J^DUZ" 93 ;VARIABLENAME("FIELD_NAME")="FILE_NUMBER^FIELD_NUMBER^VALUE" 94 ;VARIABLENAME("FIELD_NAME","I")="^^INTERNAL_VALUE" 95 ; 96 ;SET DEBUG VALUE - REQUIRED - 0=OFF 1=ON 97 S DEBUG=0 98 ;SET RETURN VALUE 99 S C0CGRTN=$NA(^TMP("C0CRNF",$J)) 100 K @C0CGRTN 101 ;RUN WRAPPED CALL 102 D GETN^C0CRNF("C0CRTN",$G(GFILE),$G(GREF),$G(GNDX),$G(GNN)) 103 S J="" 104 S I=1 105 ;FORMAT RETURN 106 F S J=$O(C0CRTN(J)) Q:J="" D ; FOR EACH FIELD IN THE ARRAY 107 . I J=0 S J=$O(C0CRTN(J)) ; SKIP THE 0 NODE 108 . S @C0CGRTN@(I)=J_"^"_C0CRTN(J)_"^" ; GETS THE FIRST LINE 109 . ;S J=$O(C0CRTN(J)) ; INCREMENT J SO WE CAN GET THE INTERNAL DATA 110 . ;TEST TO SEE IF INTERNAL DATA EXISTS 111 . I $D(C0CRTN(J,"I"))=1 D 112 . . S @C0CGRTN@(I)=@C0CGRTN@(I)_$P(C0CRTN(J,"I"),U,3) ; GETS THE INTERNAL VALUE PIECE 3 113 . S I=I+1 114 S @C0CGRTN@(0)=I-1_"^"_C0CRTN(0) 115 ;CLEAN UP 116 K J,I 117 Q 118 ; 119 GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP 120 ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 121 ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL 122 ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN 123 ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP 124 ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" 125 ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP 126 ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE 127 ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE 128 ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP 129 ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP 130 ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE 131 ; IF GREF IS "" THE FIRST RECORD IS OBTAINED 132 ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE 133 ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN 134 ; GREF IS THE VALUE FOR THE INDEX 135 ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED 136 ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN 137 ; 138 ; 139 N GIEN,GF 140 S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE 141 I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN 142 E D ; WE ARE USING AN INDEX 143 . ;N ZG 144 . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX 145 . I ZG'="" D ; 146 . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? 147 . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN 148 . . E S GIEN="" ; NOT FOUND IN INDEX 149 . E S GIEN="" ; 150 ;W "IEN: ",GIEN,! 151 ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME 152 I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) 153 E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) 154 S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE 155 D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP 156 K C0CTMP 157 D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") 158 D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE 159 S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE 160 S (C0CI,C0CJ)="" 161 F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES 162 . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE 163 . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS 164 . . ;W C0CJ," ",C0CI,! 165 . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME 166 . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; 167 . . I C0CVALUE["C0CTMP" D ; WP FIELD 168 . . . N ZT,ZWP S ZWP=0 ;ITERATOR 169 . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE 170 . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE 171 . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; 172 . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP 173 . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " 174 . . . . S C0CVALUE=C0CVALUE_ZT ; 175 . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 176 . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) 177 I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED 178 . S C0CI="" 179 . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY 180 . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES 181 Q 182 ; 183 GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES 184 ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP 185 ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#" 186 ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP 187 ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE 188 ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES 189 ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE 190 ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP 191 ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP 192 ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE 193 ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE 194 ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN 195 ; .. OF THE FILE WILL BE USED 196 ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE 197 ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED 198 ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE 199 ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD 200 ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED 201 ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL 202 ;N GATMP,GAI,GAF 203 S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE 204 I '$D(GAIDX) S GAIDX="" ;DEFAULT 205 I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED 206 I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX 207 W GAF,! 208 W $O(@GAF@(0)) ; 209 S GAI=0 ;ITERATOR 210 F S GAI=$O(@GAF@(GAI)) Q:GAI="" D ; 211 . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD 212 . N GAX S GAX=0 213 . F S GAX=$O(GATMP(GAX)) Q:GAX="" D ;PULL OUT THE FIELDS 214 . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN 215 Q 216 ; 217 ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX 218 ; 219 S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD# 220 S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE 221 Q 222 ; 223 RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT 224 ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES 225 ; RNSTY IS STYLE OF THE OUTPUT - 226 ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES 227 ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES 228 ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES 229 N RNR,RNC ;ROW ROOT,COL ROOT 230 N RNI,RNJ,RNX 231 I '$D(RNSTY) S RNSTY="NV" ;DEFAULT 232 I RNSTY="NV" D NV(RNRTN,RNIN) ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION 233 E D VN(RNRTN,RNIN) ; 234 Q 235 ; 236 NV(RNRTN,RNIN) ; 237 S RNR=$NA(@RNIN@("F")) 238 S RNC=$NA(@RNIN@("V")) 239 ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER 240 S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD" 241 S RNI="" 242 F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN 243 . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA 244 S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA 245 D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS 246 S RNI="" 247 F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW 248 . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD 249 . S RNJ="" 250 . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL 251 . . I $D(@RNC@(RNJ,RNI,1)) D ; THIS ROW HAS THIS COLUMN 252 . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA 253 . . E S RNX=RNX_"," ; NUL COLUMN 254 . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA 255 . D PUSH^GPLXPATH(RNRTN,RNX) 256 Q 257 ; 258 VN(RNRTN,RNIN) ; 259 S RNR=$NA(@RNIN@("V")) 260 S RNC=$NA(@RNIN@("F")) 261 ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER 262 S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD" 263 S RNI="" 264 F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN 265 . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA 266 S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA 267 D PUSH^GPLXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS 268 S RNI="" 269 F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW 270 . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD 271 . S RNJ="" 272 . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL 273 . . I $D(@RNR@(RNI,RNJ,1)) D ; THIS ROW HAS THIS COLUMN 274 . . . S RNX=RNX_""""_@RNR@(RNI,RNJ,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA 275 . . E S RNX=RNX_"," ; NUL COLUMN 276 . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA 277 . D PUSH^GPLXPATH(RNRTN,RNX) 278 Q 279 ; 280 READCSV(PATH,NAME,GLB) ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME 281 ; 282 Q $$FTG^%ZISH(PATH,NAME,GLB,1) 283 ; 284 FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV 285 ; 286 ;N G1,G2 287 I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE 288 S G1=$NA(^TMP($J,"C0CCSV",1)) 289 S G2=$NA(^TMP($J,"C0CCSV",2)) 290 D GETN2(G1,FNUM) ; GET THE MATRIX 291 D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE 292 K @G1 293 D FILEOUT(G2,"FILE_"_FNUM_".csv") 294 K @G2 295 Q 296 ; 297 FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE 298 ; 299 W $$OUTPUT^GPLXPATH($NA(@FOARY@(1)),FONAM,^TMP("GPLCCR","ODIR")) 300 Q 301 ; 302 FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM 303 ; 304 N C0CF 305 S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE 306 S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT 307 I C0CF["()" S C0CF=$P(C0CF,"()",1) 308 Q C0CF 309 ; 310 SKIP ; 311 N TXT,DIERR 312 S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT") 313 I $D(DIERR) D CLEAN^DILF Q 314 W " report_text:",! ;Progress Note Text 315 N LN S LN=0 316 F S LN=$O(TXT(LN)) Q:'LN D 317 . W " text"_LN_": "_TXT(LN),! 318 . Q 319 Q 320 ; 321 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 322 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN) 323 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 324 I '$D(ZTAB) S ZTAB="C0CA" 325 Q $P(@ZTAB@(ZFN),"^",1) 326 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 327 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN) 328 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 329 I '$D(ZTAB) S ZTAB="C0CA" 330 Q $P(@ZTAB@(ZFN),"^",2) 331 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 332 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) 333 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 334 I '$D(ZTAB) S ZTAB="C0CA" 335 Q $P($G(@ZTAB@(ZFN)),"^",3) 336 ; 337 ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED 338 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) 339 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 340 I '$D(ZTAB) S ZTAB="C0CA" 341 Q $P($G(@ZTAB@(ZFN,"I")),"^",3) 342 ; -
ccr/branches/ohum/p/C0CRPMS.m
r1332 r1333 1 C0CRPMS 2 ;;0.1;CCDCCR;;JUL 16,2008;Build 7 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 DISPLAY 24 25 26 27 VTYPES 28 29 30 31 32 VISITS(C0CDFN,C0CCNT) 33 34 35 36 37 38 39 40 41 42 VISITS2(C0CDFN,C0CCNT) 43 44 45 46 47 48 49 50 51 52 53 NEXTV(C0CDFN,C0CVDT) 54 55 56 57 58 59 60 61 62 63 GETV(C0CDFN,C0CVDT) 64 65 66 67 68 69 70 71 72 73 74 GETNV(C0CDFN) 75 76 77 78 79 80 81 82 83 84 85 86 GETTBL(C0CTBL) 87 88 89 90 91 92 93 94 95 96 97 98 CMPDRG 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 CMPDRG2 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 1 C0CRPMS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR RPMS ;1/14/09 14:33 2 ;;0.1;CCDCCR;;JUL 16,2008;Build 1 3 ;Copyright 2008 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 "NO ENTRY FROM TOP",! 21 Q 22 ; 23 DISPLAY ; RUN THE PCC DISPLAY ROUTINE 24 D ^APCDDISP 25 Q 26 ; 27 VTYPES ; 28 D GETN2^C0CRNF("G1",9999999.07) 29 ZWR G1 30 Q 31 ; 32 VISITS(C0CDFN,C0CCNT) ;LIST VISIT DATES FOR PATIENT DFN 33 ; C0CCNT IS A LIMIT ON HOW MANY VISITS TO DISPLAY ; DEFAULTS TO ALL 34 I '$D(C0CCNT) S C0CCNT=999999999 35 N G,GN 36 S G="" S GN=0 37 F S G=$O(^AUPNVSIT("AA",C0CDFN,G)) Q:(G="")!(GN>C0CCNT) D ; 38 . S GN=GN+1 39 . W $$FMDTOUTC^C0CUTIL(9999999-G),! 40 Q 41 ; 42 VISITS2(C0CDFN,C0CCNT) ;SECOND VERSION USING NEXTV 43 ; 44 N C0CG,GN 45 S C0CG="" 46 S GN=0 47 I '$D(C0CCNT) S C0CCNT=99999999 48 F S C0CG=$$NEXTV(C0CDFN,C0CG) Q:(C0CG="")!(GN'<C0CCNT) D ; 49 . S GN=GN+1 50 . W $$FMDTOUTC^C0CUTIL(C0CG),! 51 Q 52 ; 53 NEXTV(C0CDFN,C0CVDT) ;EXTRINSIC WHICH RETURNS THE NEXT VISIT DATE 54 ;FOR PATIENT C0CDFN IN REVERSE TIME ORDER; PASS "" TO GET THE MOST 55 ; RECENT VISIT 56 N G 57 S G=C0CVDT 58 I G'="" S G=9999999-C0CVDT ;INVERT FOR INDEX 59 S G=$O(^AUPNVSIT("AA",C0CDFN,G)) 60 I G="" Q "" 61 E Q 9999999-G 62 ; 63 GETV(C0CDFN,C0CVDT) ; GET VISIT USING DATE C0CVDT . IF C0CVDT IS NULL, 64 ; GET MOST RECENT VISIT 65 N C0CG 66 I '$D(C0CVDT) S C0CVDT=$$NEXTV(C0CDFN,"") 67 S APCDVLDT=C0CVDT 68 S APCDPAT=C0CDFN 69 D ^APCDVLK 70 D ^APCDVD 71 ;K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE 72 Q 73 ; 74 GETNV(C0CDFN) ;GET MANY VISITS 75 ; 76 S APCDPAT=C0CDFN ; 77 N C0CG S C0CG="" 78 F S C0CG=$$NEXTV(C0CDFN,C0CG) Q:C0CG="" D ; LOOP BACKWARD THROUGH VISITS 79 . W C0CG," ",$$FMDTOUTC^C0CUTIL(C0CG),! 80 . S APCDVLDT=C0CG 81 . D ^APCDVLK 82 . D ^APCDVD 83 . K APCDCLN,APCDCAT,APCDDATE,APCDLOC,APCDVSIT,APCDLOOK,APCDTYPE 84 Q 85 ; 86 GETTBL(C0CTBL) ; SCAN FOR AND DISPLAY PATIENTS IN A RIMTBL, PASSED BY VALUE 87 ; 88 N ZG S ZG=$NA(^TMP("GPLRIM","RIMTBL","PATS",C0CTBL)) 89 N C0CG S C0CG="" 90 N C0CQ S C0CQ=0 91 F S C0CG=$O(@ZG@(C0CG),-1) Q:(C0CG="") D ; 92 . W "PAT: ",C0CG,! 93 . D GETNV^C0CRPMS(C0CG) 94 . K X R X 95 . I X="Q" S C0CQ=1 ; QUIT IF Q 96 Q 97 ; 98 CMPDRG ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES 99 ; 100 S C0CZI=0 ; 101 F S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI="" D ;ALL DRUGS IN RPMS DRUG FILE 102 . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE 103 . ;W "C0CZI:",C0CZI 104 . F S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ="" D ; 105 . . ;W " C0CZJ:",C0CZJ 106 . . N C0CZN,C0CZV ; 107 . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE 108 . . ;W " C0CZN:",C0CZN,! 109 . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF 110 . . I $D(C0CZV) D ;FOUND A MATCH 111 . . . S C0CVO="FOUND:^"_C0CZI_"^"_C0CZJ_"^"_C0CZN 112 . . . S C0CVO=C0CVO_"^RXNORM:^"_$$ZVALUE^C0CRNF("MEDIATION CODE","C0CZV") 113 . . . D PUSH^GPLXPATH("^C0CZRX",C0CVO) 114 . . . W C0CVO,! 115 Q 116 ; 117 CMPDRG2 ; COMPARE THE DRUG FILE TO THE VA VUID MAPPING FILE FOR MATCHES 118 ; 119 S C0CZI=0 ; 120 F S C0CZI=$O(^C0CDRUG("V",C0CZI)) Q:C0CZI="" D ;ALL DRUGS IN RPMS DRUG FILE 121 . S C0CZJ="" ; FOR EVERY FIELD AND SUBFIELD IN THE DRUG FILE 122 . W "C0CZI:",C0CZI 123 . F S C0CZJ=$O(^C0CDRUG("V",C0CZI,C0CZJ)) Q:C0CZJ="" D ; 124 . . W " C0CZJ:",C0CZJ 125 . . N C0CZN,C0CZV ; 126 . . S C0CZN=^C0CDRUG("V",C0CZI,C0CZJ,1) ; EVERY FIELD VALUE 127 . . W " C0CZN:",C0CZN,! 128 . . D GETN1^C0CRNF("C0CZV",176.112,C0CZN,"C") ;LOOK IN C XREF 129 . . I $D(C0CZV) D ;FOUND A MATCH 130 . . . W "FOUND: ",C0CZI," ",C0CZJ," ",C0CZN 131 . . . W " VUID:",$$ZVALUE^C0CRNF("VUID","C0CZV"),! 132 Q 133 ; -
ccr/branches/ohum/p/C0CRXN.m
r1332 r1333 1 1 C0CRXN ; CCDCCR/GPL - CCR RXN 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/C0CRXNRD.m
r1332 r1333 1 C0CRXNRD 2 ;;0.1;C0C;nopatch;noreleasedate 3 4 IMPORT(PATH) 5 6 7 8 9 DELFILED(FN) 10 11 12 13 14 15 16 17 18 19 GETLINES(PATH,FILENAME) 20 21 22 23 24 25 26 READCON(PATH,INCRES) 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 67 68 69 70 71 72 73 EX 74 75 READNDC(PATH) 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 EX2 99 100 READSRC(PATH) 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 134 135 136 137 138 139 140 141 EX3 142 143 1 C0CRXNRD ; WV/SMH - CCR/CCD PROJECT: Routine to Read RxNorm files;11/15/08 2 ;;0.1;C0C;nopatch;noreleasedate;Build 1 3 W "No entry from top" Q 4 IMPORT(PATH) 5 I PATH="" QUIT 6 D READSRC(PATH),READCON(PATH),READNDC(PATH) 7 QUIT 8 ; 9 DELFILED(FN) ; Delete file data; PEP procedure; only for RxNorm files 10 ; FN is Filenumber passed by Value 11 QUIT:$E(FN,1,3)'=176 ; Quit if not RxNorm files 12 D CLEAN^DILF ; Clean FM variables 13 N ROOT S ROOT=$$ROOT^DILFD(FN,"",1) ; global root 14 N ZERO S ZERO=@ROOT@(0) ; Save zero node 15 S $P(ZERO,U,3,9999)="" ; Remove entry # and last edited 16 K @ROOT ; Kill the file -- so sad! 17 S @ROOT@(0)=ZERO ; It riseth again! 18 QUIT 19 GETLINES(PATH,FILENAME) ; Get number of lines in a file 20 D OPEN^%ZISH("FILE",PATH,FILENAME,"R") 21 U IO 22 N I 23 F I=1:1 R LINE Q:$$STATUS^%ZISH 24 D CLOSE^%ZISH("FILE") 25 Q I-1 26 READCON(PATH,INCRES) ; Open and read concepts file: RXNCONSO.RRF; EP 27 ; PATH ByVal, path of RxNorm files 28 ; INCRES ByVal, include restricted sources. 1 for yes, 0 for no 29 I PATH="" QUIT 30 S INCRES=+$G(INCRES) ; if not passed, becomes zero. 31 N FILENAME S FILENAME="RXNCONSO.RRF" 32 D DELFILED(176.001) ; delete data 33 N LINES S LINES=$$GETLINES(PATH,FILENAME) 34 D OPEN^%ZISH("FILE",PATH,FILENAME,"R") 35 IF POP D EN^DDIOL("Error reading file..., Please check...") G EX 36 N C0CCOUNT 37 F C0CCOUNT=1:1 D Q:$$STATUS^%ZISH 38 . U IO 39 . N LINE R LINE 40 . IF $$STATUS^%ZISH QUIT 41 . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000 42 . N RXCUI,RXAUI,SAB,TTY,CODE,STR ; Fileman fields numbers below 43 . S RXCUI=$P(LINE,"|",1) ; .01 44 . S RXAUI=$P(LINE,"|",8) ; 1 45 . S SAB=$P(LINE,"|",12) ; 2 46 . ; If the source is a restricted source, decide what to do based on what's asked. 47 . N SRCIEN S SRCIEN=$$FIND1^DIC(176.003,"","QX",SAB,"B") ; SrcIEN in RXNORM SOURCES file 48 . N RESTRIC S RESTRIC=$$GET1^DIQ(176.003,SRCIEN,14,"I") ; 14 is restriction field; values 0-4 49 . ; If RESTRIC is zero, then it's unrestricted. Everything else is restricted. 50 . ; If user didn't ask to include restricted sources, and the source is restricted, then quit 51 . I 'INCRES,RESTRIC QUIT 52 . S TTY=$P(LINE,"|",13) ; 3 53 . S CODE=$P(LINE,"|",14) ; 4 54 . S STR=$P(LINE,"|",15) ; 5 55 . ; Remove embedded "^" 56 . S STR=$TR(STR,"^") 57 . ; Convert STR into an array of 80 characters on each line 58 . N STRLINE S STRLINE=$L(STR)\80+1 59 . ; In each line, chop 80 characters off, reset STR to be the rest 60 . N J F J=1:1:STRLINE S STR(J)=$E(STR,1,80) S STR=$E(STR,81,$L(STR)) 61 . ; Now, construct the FDA array 62 . N RXNFDA 63 . S RXNFDA(176.001,"+1,",.01)=RXCUI 64 . S RXNFDA(176.001,"+1,",1)=RXAUI 65 . S RXNFDA(176.001,"+1,",2)=SAB 66 . S RXNFDA(176.001,"+1,",3)=TTY 67 . S RXNFDA(176.001,"+1,",4)=CODE 68 . N RXNIEN S RXNIEN(1)=C0CCOUNT 69 . D UPDATE^DIE("","RXNFDA","RXNIEN") 70 . I $D(^TMP("DIERR",$J)) D EN^DDIOL("ERROR") G EX 71 . ; Now, file WP field STR 72 . D WP^DIE(176.001,C0CCOUNT_",",5,,$NA(STR)) 73 EX D CLOSE^%ZISH("FILE") 74 QUIT 75 READNDC(PATH) ; Open and read NDC/RxNorm/VANDF relationship file: RXNSAT.RRF 76 I PATH="" QUIT 77 N FILENAME S FILENAME="RXNSAT.RRF" 78 D DELFILED(176.002) ; delete data 79 N LINES S LINES=$$GETLINES(PATH,FILENAME) 80 D OPEN^%ZISH("FILE",PATH,FILENAME,"R") 81 IF POP W "Error reading file..., Please check...",! G EX2 82 F C0CCOUNT=1:1 Q:$$STATUS^%ZISH D 83 . U IO 84 . N LINE R LINE 85 . IF $$STATUS^%ZISH QUIT 86 . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000 87 . IF LINE'["NDC|RXNORM" QUIT 88 . ; Otherwise, we are good to go 89 . N RXCUI,NDC ; Fileman fields below 90 . S RXCUI=$P(LINE,"|",1) ; .01 91 . S NDC=$P(LINE,"|",11) ; 2 92 . ; Using classic call to update. 93 . N DIC,X,DA,DR 94 . K DO 95 . S DIC="^C0CRXN(176.002,",DIC(0)="F",X=RXCUI,DIC("DR")="2////"_NDC 96 . D FILE^DICN 97 . I Y<1 U $P W !,"THERE IS TROUBLE IN RIVER CITY",! G EX2 98 EX2 D CLOSE^%ZISH("FILE") 99 QUIT 100 READSRC(PATH) ; Open the read RxNorm Sources file: RXNSAB.RRF 101 I PATH="" QUIT 102 N FILENAME S FILENAME="RXNSAB.RRF" 103 D DELFILED(176.003) ; delete data 104 D OPEN^%ZISH("FILE",PATH,FILENAME,"R") 105 IF POP W "Error reading file..., Please check...",! G EX3 106 F I=1:1 Q:$$STATUS^%ZISH D 107 . U IO 108 . N LINE R LINE 109 . IF $$STATUS^%ZISH QUIT 110 . U $P W I,! U IO ; Write I to the screen, then go back to reading the file 111 . N VCUI,RCUI,VSAB,RSAB,SON,SF,SVER,SRL,SCIT ; Fileman fields numbers below 112 . S VCUI=$P(LINE,"|",1) ; .01 113 . S RCUI=$P(LINE,"|",2) ; 2 114 . S VSAB=$P(LINE,"|",3) ; 3 115 . S RSAB=$P(LINE,"|",4) ; 4 116 . S SON=$P(LINE,"|",5) ; 5 117 . S SF=$P(LINE,"|",6) ; 6 118 . S SVER=$P(LINE,"|",7) ; 7 119 . S SRL=$P(LINE,"|",14) ; 14 120 . S SCIT=$P(LINE,"|",25) ; 25 121 . ; Remove embedded "^" 122 . S SCIT=$TR(SCIT,"^") 123 . ; Convert SCIT into an array of 80 characters on each line 124 . ; In each line, chop 80 characters off, reset SCIT to be the rest 125 . N SCITLINE S SCITLINE=$L(SCIT)\80+1 126 . F J=1:1:SCITLINE S SCIT(J)=$E(SCIT,1,80) S SCIT=$E(SCIT,81,$L(SCIT)) 127 . ; Now, construct the FDA array 128 . N RXNFDA 129 . S RXNFDA(176.003,"+"_I_",",.01)=VCUI 130 . S RXNFDA(176.003,"+"_I_",",2)=RCUI 131 . S RXNFDA(176.003,"+"_I_",",3)=VSAB 132 . S RXNFDA(176.003,"+"_I_",",4)=RSAB 133 . S RXNFDA(176.003,"+"_I_",",5)=SON 134 . S RXNFDA(176.003,"+"_I_",",6)=SF 135 . S RXNFDA(176.003,"+"_I_",",7)=SVER 136 . S RXNFDA(176.003,"+"_I_",",14)=SRL 137 . D UPDATE^DIE("","RXNFDA") 138 . I $D(^TMP("DIERR",$J)) U $P W "ERR" G EX 139 . ; Now, file WP field SCIT 140 . D WP^DIE(176.003,I_",",25,,$NA(SCIT)) 141 EX3 D CLOSE^%ZISH("FILE") 142 Q 143 -
ccr/branches/ohum/p/C0CSNOA.m
r1332 r1333 1 C0CSNOA 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 ANALYZE(BEGIEN,IENCNT) 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 TEXTRPC(ORTN,ITEXT) 66 67 68 69 70 71 72 ASETUP 73 74 75 76 77 78 79 80 AINIT 81 82 83 84 85 86 87 88 89 APOST(PRSLT,PTBL,PVAL) 90 91 92 93 94 95 96 97 98 99 100 SETATTR(SDFN) 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 RESET 124 125 126 127 128 CLIST 129 130 131 132 133 134 135 136 137 138 139 140 141 142 CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) 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 REUSE 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 1 C0CSNOA ; CCDCCR/GPL - SNOMED CT ANALYSIS ROUTINES; 10/14/08 2 ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 3 ;Copyright 2008,2009 George Lilly, University of Minnesota. 4 ;Licensed under the terms of the GNU General Public License. 5 ;See attached copy of the License. 6 ; 7 ;This program is free software; you can redistribute it and/or modify 8 ;it under the terms of the GNU General Public License as published by 9 ;the Free Software Foundation; either version 2 of the License, or 10 ;(at your option) any later version. 11 ; 12 ;This program is distributed in the hope that it will be useful, 13 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ;GNU General Public License for more details. 16 ; 17 ;You should have received a copy of the GNU General Public License along 18 ;with this program; if not, write to the Free Software Foundation, Inc., 19 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 20 ; 21 ; THESE ROUTINES ANALYZE THE POTENTIAL RETRIEVAL OF SNOMED CT CODES 22 ; FOR PATIENT DRUG ALLERGIES FOR INCLUSION IN THE CCR OR CCD 23 ; USING THE VISTA LEXICON ^LEX 24 ; 25 ANALYZE(BEGIEN,IENCNT) ; SNOMED RETRIEVAL ANALYSIS ROUTINE 26 ; BEGINS AT BEGIEN AND GOES FOR IENCNT DRUGS IN GMRD 27 ; TO RESUME AT NEXT DRUG, USE BEGIEN="" 28 ; USE RESET^C0CSNOA TO RESET TO TOP OF DRUG LIST 29 ; 30 N SNOARY,SNOTMP,SNOI,SNOIEN,RATTR 31 N CCRGLO 32 D ASETUP ; SET UP VARIABLES AND GLOBALS 33 D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE 34 I '$D(@SNOBASE@("RESUME")) S @SNOBASE@("RESUME")=$O(@GMRBASE@(1)) ;1ST TME 35 S RESUME=@SNOBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN 36 S SNOIEN=BEGIEN ; BEGIN WITH THE BEGIEN RECORD 37 I SNOIEN="" S SNOIEN=RESUME 38 I +SNOIEN=0 D Q ; AT THE END OF THE ALLERGY LIST 39 . W "END OF DRUG LIST, CALL RESET^C0CSNOA",! 40 F SNOI=1:1:IENCNT D Q:+SNOIEN=0 ; FOR IENCNT NUMBER OF PATIENTS OR END 41 . ;D CCRRPC^C0CCCR(.CCRGLO,SNOIEN,"CCR","","","") ;PROCESS THE CCR 42 . W SNOIEN,@GMRBASE@(SNOIEN,0),! 43 . N SNORTN,TTERM ; RETURN ARRAY 44 . S TTERM=$P(@GMRBASE@(SNOIEN,0),"^",1)_" ALLERGY" 45 . D TEXTRPC(.SNORTN,TTERM) 46 . I $D(SNORTN) ZWR SNORTN 47 . K @SNOBASE@("VARS",SNOIEN) ; CLEAR OUT OLD VARS 48 . I $P(TTMP,"^",1)=1 S @SNOBASE@("VARS",SNOIEN)=TTERM_"^"_TTMP_"^"_SNORTN(0) 49 . ; 50 . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP 51 . ; 52 . S RATTR=$$SETATTR(SNOIEN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS 53 . S @SNOBASE@("ATTR",SNOIEN)=RATTR ; SAVE THE ATRIBUTES FOR THIS DRUG 54 . ; 55 . N CATNAME,CATTBL 56 . S CATNAME="" 57 . D CPUSH(.CATNAME,SNOBASE,"SNOTBL",SNOIEN,RATTR) ; ADD TO CATEGORY 58 . ; W "CATEGORY NAME: ",CATNAME,! 59 . ; 60 . S SNOIEN=$O(@GMRBASE@(SNOIEN)) ; NEXT RECORD 61 . S @SNOBASE@("RESUME")=SNOIEN ; WHERE WE ARE LEAVING OFF THIS RUN 62 ; D PARY^C0CXPATH(@SNOBASE@("ATTRTBL")) 63 Q 64 ; 65 TEXTRPC(ORTN,ITEXT) ; CALL THE LEXICON WITH ITEXT AND RETURN RESULTS IN ORTN 66 ; 67 ;N TTMP 68 W ITEXT,! 69 S TTMP=$$TEXT^LEXTRAN(ITEXT,"","","SCT","ORTN") 70 Q 71 ; 72 ASETUP ; SET UP GLOBALS AND VARS SNOBASE AND SNOTBL 73 I '$D(SNOBASE) S SNOBASE=$NA(^TMP("C0CSNO")) 74 I '$D(@SNOBASE) S @SNOBASE="" 75 I '$D(GMRBASE) S GMRBASE=$NA(^GMRD(120.82)) 76 I '$D(SNOTBL) S SNOTBL=$NA(^TMP("C0CSNO","SNOTBL","TABLE")) ; ATTR TABLE 77 S ^TMP("C0CSNO","TABLES","SNOTBL")=SNOTBL ; TABLE OF TABLES 78 Q 79 ; 80 AINIT ; INITIALIZE ATTRIBUTE TABLE 81 I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS 82 K @SNOTBL 83 D APUSH^C0CRIMA(SNOTBL,"CODE") 84 D APUSH^C0CRIMA(SNOTBL,"NOCODE") 85 D APUSH^C0CRIMA(SNOTBL,"MULTICODE") 86 D APUSH^C0CRIMA(SNOTBL,"SUBMULTI") 87 D APUSH^C0CRIMA(SNOTBL,"DONE") 88 Q 89 APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL 90 ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING 91 ; PTBL IS THE NAME OF A TABLE IN @SNOBASE@("TABLES") - "SNOTBL"=ALL VALUES 92 ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) 93 I '$D(SNOBASE) D ASETUP ; FOR COMMANDLINE PROCESSING 94 N USETBL 95 I '$D(@SNOBASE@("TABLES",PTBL)) D Q ; NO TABLE 96 . W "ERROR NO SUCH TABLE",! 97 S USETBL=@SNOBASE@("TABLES",PTBL) 98 S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL 99 Q 100 SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS 101 N SBASE,SATTR 102 S SBASE=$NA(@SNOBASE@("VARS",SDFN)) 103 D APOST("SATTR","SNOTBL","DONE") 104 I $P(TTMP,"^",1)=1 D APOST("SATTR","SNOTBL","CODE") 105 I $P(TTMP,"^",1)=-1 D APOST("SATTR","SNOTBL","NOCODE") 106 Q SATTR ; C0C 107 I $D(@SBASE@("PROBLEMS",1)) D ; 108 . D APOST("SATTR","SNOTBL","PROBLEMS") 109 . ; W "POSTING PROBLEMS",! 110 I $D(@SBASE@("VITALS",1)) D APOST("SATTR","SNOTBL","VITALS") 111 I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES 112 . D APOST("SATTR","SNOTBL","MEDS") 113 . N ZR,ZI 114 . D GETPA^C0CRIMA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES 115 . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN 116 . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS 117 . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","SNOTBL","MEDSCODE") ;CODES 118 . ; D PATD^C0CSNOA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES 119 D APOST("SATTR","SNOTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED 120 ; W "ATTRIBUTES: ",SATTR,! 121 Q SATTR 122 ; 123 RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL SNO TMP VALUES 124 K ^TMP("C0CSNO","RESUME") 125 K ^TMP("C0CSNO") 126 Q 127 ; 128 CLIST ; LIST THE CATEGORIES 129 ; 130 I '$D(SNOBASE) D ASETUP ; FOR COMMAND LINE CALLS 131 N CLBASE,CLNUM,ZI,CLIDX 132 S CLBASE=$NA(@SNOBASE@("SNOTBL","CATS")) 133 S CLNUM=@CLBASE@(0) 134 F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES 135 . S CLIDX=@CLBASE@(ZI) 136 . W "(",$P(@CLBASE@(CLIDX),"^",1) 137 . W ":",$P(@CLBASE@(CLIDX),"^",2),") " 138 . W CLIDX,! 139 ; D PARY^C0CXPATH(CLBASE) 140 Q 141 ; 142 CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES 143 ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT 144 ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE 145 ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME 146 ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, 147 ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" 148 ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES 149 ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY 150 ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING 151 ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY 152 ; NUMBER IE CTBL_X(CDFN)="" 153 ; 154 ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST 155 S CCTBL=$NA(@CBASE@(CTBL,"CATS")) 156 ; W "CBASE: ",CCTBL,! 157 ; 158 I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY 159 . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY 160 . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY 161 . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT 162 . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY 163 . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME 164 . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 165 ; 166 S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY 167 S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT 168 S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK 169 ; 170 S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED 171 ; 172 S CPATLIST=$NA(@CBASE@(CTBL,"IENS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT 173 ; W "IENS BASE: ",CPATLIST,! 174 S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST 175 ; 176 Q 177 ; 178 REUSE ; GET SAVED VALUES FROM ^TMP("C0CSAV") AND PUT THEM IN A DATABASE 179 ; 180 D ASETUP 181 D AINIT 182 N SNOI,SNOJ,SNOK,SNOSNO,SNOSEC,SNOIEN,SNOOLD,SNOSRCH 183 S SAVBASE=$NA(^TMP("C0CSAV","VARS")) 184 S SNOI="" 185 F D Q:$O(@SAVBASE@(SNOI))="" ;THE WHOLE LIST 186 . S SNOI=$O(@SAVBASE@(SNOI)) 187 . S SNOJ=@SAVBASE@(SNOI) 188 . S SNOK=$P($P(SNOJ,"^",1)," ALLERGY",1) 189 . S SNOSRCH=$P(SNOJ,"^",1) ;SEARCH TERM USED TO OBTAIN SNOMED CODE 190 . S SNOIEN=$P(SNOJ,"^",3) ; IEN OF ELEMENT IN LEXICON 191 . S SNOSNO=$P(SNOJ,"^",4) ; SNOMED CODE 192 . S SNOSEC=$P(SNOJ,"^",5) ; SECTION OF SNOMED FOR THIS CODE 193 . S SNOOLD=$P(SNOJ,"^",7) ; OLD NUMBER FOR THIS CODE 194 . W "SEARCH:",SNOSRCH," IEN:",SNOIEN," CODE:",SNOSNO," SEC:",SNOSEC," OLD:",SNOOLD,! 195 . W SNOK,! 196 . W SNOJ,! 197 Q 198 ; -
ccr/branches/ohum/p/C0CSOAP.m
r1332 r1333 1 1 C0CSOAP ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CSUB1.m
r1332 r1333 1 1 C0CSUB1 ; CCDCCR/GPL - CCR SUBSCRIPTION 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/C0CSYS.m
r1332 r1333 1 1 C0CSYS ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU 4 4 ; General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CUNIT.m
r1332 r1333 1 1 C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CUTIL.m
r1332 r1333 1 1 C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08 2 ;;0.1;C0C;;Jun 15, 2008;Build 382 ;;0.1;C0C;;Jun 15, 2008;Build 1 3 3 ;Copyright 2008-2009 Sam Habiel & George Lilly. 4 4 ;Licensed under the terms of the GNU … … 136 136 ; 137 137 RXNFN() Q 1130590011.001 ; RxNorm Concepts file number 138 139 CODE(ZVUID) 140 141 142 143 144 145 146 147 148 149 150 151 NISTMAP(ZRXN) 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 138 ; 139 CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF 140 ; THE VUID - RETURNS CODE^SYSTEM^VERSION TO USE IN THE CCR 141 N ZRSLT S ZRSLT=ZVUID_"^"_"VUID"_"^" ; DEFAULT 142 I $G(ZVUID)="" Q "" 143 I '$D(^C0P("RXN")) Q ZRSLT ; ERX NOT INSTALLED 144 N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID") 145 S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES 146 N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01) 147 S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED 148 I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F" 149 Q ZRSLT 150 ; 151 NISTMAP(ZRXN) ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO 152 ; CONFORM TO NIST REQUIREMENTS 153 ;INPATIENT CERTIFICATION 154 I ZRXN=309362 S ZRXN=213169 155 I ZRXN=855318 S ZRXN=855320 156 I ZRXN=197361 S ZRXN=212549 157 ;OUTPATIENT CERTIFICATION 158 I ZRXN=310534 S ZRXN=205875 159 I ZRXN=617312 S ZRXN=617314 160 I ZRXN=310429 S ZRXN=200801 161 I ZRXN=628953 S ZRXN=628958 162 I ZRXN=745679 S ZRXN=630208 163 I ZRXN=311564 S ZRXN=979334 164 I ZRXN=836343 S ZRXN=836370 165 Q ZRXN 166 ; 167 167 RPMS() ; Are we running on an RPMS system rather than Vista? 168 168 Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service -
ccr/branches/ohum/p/C0CVA200.m
r1332 r1333 1 1 C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008 Sam Habiel. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CVIT2.m
r1332 r1333 1 1 C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 2 ;;1.0;C0C;;Feb 16, 2010;Build 382 ;;1.0;C0C;;Feb 16, 2010;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/C0CVITAL.m
r1332 r1333 1 1 C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/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. … … 72 72 . . I DEBUG W $P(VITPTMP,U,4),! 73 73 . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID 74 75 76 77 74 . . ;B ;gpl 75 . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6) 76 . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; 77 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" 78 78 . . I $P(VITPTMP,U,2)="HT" D 79 79 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" … … 203 203 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 204 204 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN" 205 206 205 . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; 206 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ; 207 207 . . S VITARYTMP=$NA(@VITTARYTMP@(J)) 208 208 . . K @VITARYTMP -
ccr/branches/ohum/p/C0CVOBX1.m
r1332 r1333 1 LA7VOBX1 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994 3 4 5 CH 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 1 LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994;Build 1 3 ; JMC - mods to check for IHS V LAB file 4 ; 5 CH ; Observation/Result segment for "CH" subscript results. 6 ; Called by LA7VOBX 7 ; 8 N LA76304,LA7ALT,LA7DIV,LA7I,LA7X,LA7Y,X 9 ; 10 ; "CH" subscript requires a dataname 11 I '$G(LRSB) Q 12 ; 13 ; get result node from LR global. 14 S LA76304(0)=$G(^LR(LRDFN,LRSS,LRIDT,0)) 15 S LA7VAL=$G(^LR(LRDFN,LRSS,LRIDT,LRSB)) 16 ; 17 ; Check if test is OK to send - (O)utput or (B)oth 18 S LA7X=$P(LA7VAL,"^",12) 19 I LA7X]"","BO"'[LA7X Q 20 I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q 21 21 ; 22 22 ; If no result NLT or LOINC try to determine from file #60 … … 27 27 I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5)) 28 28 ; No result NLT code - log error 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 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 29 I $P($P(LA7VAL,"^",3),"!",2)="" D 30 . N LA7X 31 . S LA7X="["_LRSB_"]"_$$GET1^DID(63.04,LRSB,"","LABEL") 32 . D CREATE^LA7LOG(36) 33 ; 34 ; something missing - No NLT code, etc. 35 I LA7VAL="" Q 36 ; 37 ; Check for missing units/reference ranges 38 S LA7X=$P(LA7VAL,"^",5) 39 ; 40 ; Results missing units, lookup in file #60 41 I $P(LA7X,"!",7)="" S $P(LA7X,"!",7)=$P($$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)),"^",3) 42 ; 43 ; If results missing reference ranges, use values from file #60. 44 I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="",$P(LA7X,"!",11)="",$P(LA7X,"!",12)="" D 45 . S LA7Y=$$REFUNIT^LA7VHLU1(LRSB,$P(LA76304(0),"^",5)) 46 . S $P(LA7X,"!",2)=$P(LA7Y,"^") 47 . S $P(LA7X,"!",3)=$P(LA7Y,"^",2) 48 . S $P(LA7X,"!",11)=$P(LA7Y,"^",6) 49 . S $P(LA7X,"!",12)=$P(LA7Y,"^",7) 50 ; Use therapeutic low/high if low/high missing. 51 I $P(LA7X,"!",2)="",$P(LA7X,"!",3)="" D 52 . S $P(LA7X,"!",2)=$P(LA7X,"!",11) 53 . S $P(LA7X,"!",3)=$P(LA7X,"!",12) 54 ; 55 ; Evaluate low/high reference ranges in case M code in these fields. 56 S:$G(SEX)="" SEX="M" S:$G(AGE)="" AGE=99 57 F LA7I=2,3 I $E($P(LA7X,"!",LA7I),1,3)="$S(" D 58 . S @("X="_$P(LA7X,"!",LA7I)) 59 . S $P(LA7X,"!",LA7I)=X 60 ; 61 ; Put units/reference ranges back in variable LA7VAL 62 S $P(LA7VAL,"^",5)=LA7X 63 ; 64 ; Initialize OBX segment 65 S LA7OBX(0)="OBX" 66 S LA7OBX(1)=$$OBX1^LA7VOBX(.LA7OBXSN) 67 ; 68 ; Value type 69 S LA7OBX(2)=$$OBX2^LA7VOBX(63.04,LRSB) 70 ; 71 ; Observation identifer 72 ; build alternate code based on dataname from file #63 in case it's needed 73 S LA7X=$P(LA7VAL,"^",3) 74 S LA7ALT="CH"_LRSB_"^"_$$GET1^DID(63.04,LRSB,"","LABEL")_"^"_"99VA63" 75 S LA7OBX(3)=$$OBX3^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7ALT,LA7FS,LA7ECH) 76 ; 77 ; Test value 78 S LA7OBX(5)=$$OBX5^LA7VOBX($P(LA7VAL,"^"),LA7OBX(2),LA7FS,LA7ECH) 79 ; 80 ; Units - remove leading and trailing spaces 81 S LA7X=$P(LA7VAL,"^",5),LA7X=$$TRIM^XLFSTR(LA7X,"LR"," ") 82 S LA7OBX(6)=$$OBX6^LA7VOBX($P(LA7X,"!",7),"",LA7FS,LA7ECH) 83 ; 84 ; Reference range 85 S LA7OBX(7)=$$OBX7^LA7VOBX($P(LA7X,"!",2),$P(LA7X,"!",3),LA7FS,LA7ECH) 86 ; 87 ; Abnormal flags 88 S LA7OBX(8)=$$OBX8^LA7VOBX($P(LA7VAL,U,2)) 89 ; 90 ; "P"artial or "F"inal results 91 S LA7OBX(11)=$$OBX11^LA7VOBX($S("canccommentpending"[$P(LA7VAL,"^"):$P(LA7VAL,"^"),1:"F")) 92 ; 93 ; Observation date/time - collection date/time per HL7 standard 94 I $P(LA76304(0),"^") S LA7OBX(14)=$$OBX14^LA7VOBX($P(LA76304(0),"^")) 95 ; 96 S LA7DIV=$P(LA7VAL,"^",9) 97 I LA7DIV="",$$DIV4^XUSER(.LA7DIV,$P(LA7VAL,"^",4)) S LA7DIV=$O(LA7DIV(0)) 98 ; 99 ; Facility that performed the testing 100 S LA7OBX(15)=$$OBX15^LA7VOBX(LA7DIV,LA7FS,LA7ECH) 101 ; 102 ; Person that verified the test 103 S LA7OBX(16)=$$OBX16^LA7VOBX($P(LA7VAL,"^",4),LA7DIV,LA7FS,LA7ECH) 104 ; 105 ; Observation method 106 S LA7X=$P($P(LA7VAL,"^",3),"!",4) 107 I LA7X S LA7OBX(17)=$$OBX17^LA7VOBX(LA7X,LA7FS,LA7ECH) 108 ; 109 ; Equipment entity identifier 110 I $L($P(LA7VAL,"^",11)) S LA7OBX(18)=$$OBX18^LA7VOBX($P(LA7VAL,"^",11),LA7FS,LA7ECH) 111 ; 112 D BUILDSEG^LA7VHLU(.LA7OBX,.LA7ARRAY,LA7FS) 113 ; 114 Q -
ccr/branches/ohum/p/C0CVORU.m
r1332 r1333 1 C0C7VORU 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994 3 4 EN(LA) 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 CH 43 44 45 46 47 48 49 50 51 52 ORC 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 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 OBR 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 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 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 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 OBX 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 268 269 270 271 NTE 272 273 274 1 C0C7VORU ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 2009 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994;Build 1 3 ; 4 EN(LA) ; called from C0CVLAB 5 ; variables 6 ; LA("HUID") - Host Unique ID from the local ACCESSION file (#68) 7 ; LA("SITE") - Ordering site IEN in the INSTITUTION file (#4) 8 ; LA("RUID") - Remote sites Unique ID from ACCESSION file (#68) 9 ; LA("ORD") - Free text ordered test name from WKLD CODE file (#64) 10 ; LA("NLT") - National Laboratory test code from WKLD CODE file (#64) 11 ; LA("LRIDT") - Inverse date/time the lab arrival time (accession date/time) 12 ; LA("SUB") - test subscript defined in LABORATORY TEST file (#60) 13 ; LA("LRDFN") - IEN in LAB DATA file (#63) 14 ; LA("ORD"), LA("NLT"), and LA("SUB") are sent for specific lab results. 15 ; LA("AUTO-INST") - Auto-Instrument 16 ; 17 N LA763,LA7NLT,LA7NVAF,LA7X,PRIMARY 18 ; 19 S PRIMARY=$$PRIM^VASITE(DT),LA("AUTO-INST")="" 20 I $G(PRIMARY)'="" D 21 . S PRIMARY=$$SITE^VASITE(DT,PRIMARY) 22 . S PRIMARY=$P(PRIMARY,U,3) 23 . S LA("AUTO-INST")="LA7V HOST "_PRIMARY 24 ; 25 I '$O(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) D Q 26 . ; need to add error logging when no entry in 63. 27 ; 28 ; Get zeroth node of entry in #63. 29 S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) 30 S LA7NLT=$G(LA("NLT")) 31 ; 32 S LA7NVAF=$$NVAF^LA7VHLU2(+LA("SITE")) 33 S LA7NTESN=0 34 D ORC 35 ; 36 I $G(LA("SUB"))="CH" D CH 37 ;I $G(LA("SUB"))="MI" D MI^LA7VORU1 38 ;I "SPCYEM"[$G(LA("SUB")) D AP^LA7VORU2 39 Q 40 ; 41 ; 42 CH ; Build segments for "CH" subscript 43 ; 44 D OBR 45 D NTE 46 S LA7OBXSN=0 47 D OBX 48 ; 49 Q 50 ; 51 ; 52 ORC ; Build ORC segment 53 ; 54 N LA763,LA7696,LA7DATA,LA7SM,LA7X,LA7Y,ORC 55 ; 56 S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) 57 ; 58 S ORC(0)="ORC" 59 ; 60 ; Order control 61 S ORC(1)=$$ORC1^LA7VORC("RE") 62 ; 63 ; Remote UID 64 S ORC(2)=$$ORC2^LA7VORC(LA("RUID"),LA7FS,LA7ECH) 65 ; 66 ; Host UID 67 S ORC(3)=$$ORC3^LA7VORC(LA("HUID"),LA7FS,LA7ECH) 68 ; 69 ; Return shipping manifest if found 70 S LA7SM="",LA7696=0 71 I LA("SITE")'="",LA("RUID")'="" S LA7696=$O(^LRO(69.6,"RST",LA("SITE"),LA("RUID"),0)) 72 I LA7696 S LA7SM=$P($G(^LRO(69.6,LA7696,0)),U,14) 73 I LA7SM'="" S ORC(4)=$$ORC4^LA7VORC(LA7SM,LA7FS,LA7ECH) 74 ; 75 ; Order status 76 ; DoD/CHCS requires ORC-5 valued otherwise will not process message 77 I LA7NVAF=1 S ORC(5)=$$ORC5^LA7VORC("CM",LA7FS,LA7ECH) 78 ; 79 ; Ordering provider 80 S (LA7X,LA7Y)="" 81 ; "CH" subscript stores requesting provider and requesting div/location. 82 I LA("SUB")="CH" D 83 . N LA7J 84 . S LA7J=$P(LA763(0),"^",13) 85 . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") 86 . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") 87 . S LA7X=$P(LA763(0),"^",10) 88 ; 89 ; Other subscripts only store requesting provider 90 I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) 91 ; Get default institution from MailMan Site Parameters file 92 I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") 93 S ORC(12)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) 94 ; 95 ; Entering organization 96 S ORC(17)=$$ORC17^LA7VORC(LA7Y,LA7FS,LA7ECH) 97 ; 98 D BUILDSEG^LA7VHLU(.ORC,.LA7DATA,LA7FS) 99 D FILESEG^LA7VHLU(GBL,.LA7DATA) 100 ; 101 ; Check for flag to only build message but do not file 102 I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249P,.LA7DATA) 103 ; 104 Q 105 ; 106 ; 107 OBR ;Observation Request segment for Lab Order 108 ; 109 N LA761,LA762,LA7DATA,LA7PLOBR,LA7X,LA7Y,OBR 110 ; 111 ; Retrieve placer's OBR information stored in #69.6 112 D RETOBR^LA7VHLU(LA("SITE"),LA("RUID"),LA("NLT"),.LA7PLOBR) 113 ; 114 ; Initialize OBR segment 115 S OBR(0)="OBR" 116 S OBR(1)=$$OBR1^LA7VOBR(.LA7OBRSN) 117 ; 118 ; Remote UID 119 S OBR(2)=$$OBR2^LA7VOBR(LA("RUID"),LA7FS,LA7ECH) 120 ; 121 ; Host UID 122 S OBR(3)=$$OBR3^LA7VOBR(LA("HUID"),LA7FS,LA7ECH) 123 ; 124 ; Universal service ID, build from info stored in #69.6 125 S LA7X="" 126 I $G(LA7PLOBR("OBR-4"))'="" S OBR(4)=$$CNVFLD^LA7VHLU3(LA7PLOBR("OBR-4"),LA7PLOBR("ECH"),LA7ECH) 127 E S OBR(4)=$$OBR4^LA7VOBR(LA7NLT,"",LA7X,LA7FS,LA7ECH) 128 ; 129 ; Collection D/T 130 S OBR(7)=$$OBR7^LA7VOBR($P(LA763(0),U)) 131 ; 132 ; Specimen action code 133 ; If no OBR from PENDING ORDER file (#69.6) then assume added test. 134 I $G(LA7INTYP)=10,$G(LA7PLOBR("OBR-4"))="" S OBR(11)=$$OBR11^LA7VOBR("A") 135 ; 136 ; Infection Warning 137 S OBR(12)=$$OBR12^LA7VOBR(LRDFN,LA7FS,LA7ECH) 138 ; 139 ; Lab Arrival Time 140 ; "CH" subscript does not store lab arrival time, use collection time. 141 ; Other subscripts do store lab arrival time (date/time received). 142 I "CYEMMISP"[LA("SUB") S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^",10)) 143 I LA("SUB")="CH" S OBR(14)=$$OBR14^LA7VOBR($P(LA763(0),"^")) 144 ; 145 ; Specimen source 146 S (LA761,LA762)="" 147 I "CHMI"[LA("SUB") D 148 . S LA761=$P(LA763(0),U,5) 149 . I LA761="" D CREATE^LA7LOG(27) 150 . I LA("SUB")="MI" S LA762=$P(LA763(0),U,11) 151 S OBR(15)=$$OBR15^LA7VOBR(LA761,LA762,"",LA7FS,LA7ECH) 152 ; 153 ; Ordering provider 154 S (LA7X,LA7Y)="" 155 ; "CH" subscript stores requesting provider and requesting div/location. 156 I LA("SUB")="CH" D 157 . N LA7J 158 . S LA7J=$P(LA763(0),"^",13) 159 . I $P(LA7J,";",2)="SC(" S LA7Y=$$GET1^DIQ(44,$P(LA7J,";")_",",3,"I") 160 . I $P(LA7J,";",2)="DIC(4," S LA7Y=$P(LA7J,";") 161 . S LA7X=$P(LA763(0),"^",10) 162 ; 163 ; Other subscripts only store requesting provider 164 I "CYEMMISP"[LA("SUB") S LA7X=$P(LA763(0),"^",7) 165 ; Get default institution from MailMan Site Parameters file 166 I LA7Y="" S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") 167 S OBR(16)=$$ORC12^LA7VORC(LA7X,LA7Y,LA7FS,LA7ECH) 168 ; 169 ; Placer Field #1 (remote auto-inst) 170 ; Build from info stored in #69.6 171 I $G(LA7PLOBR("OBR-18"))'="" D 172 . S OBR(18)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-18"),LA7FS_LA7ECH) 173 ; Else build "auto instrument" if sending to VA facility 174 I $G(LA7PLOBR("OBR-18"))="",'LA7NVAF D 175 . N LA7X 176 . S LA7X(1)=LA("AUTO-INST") 177 . S OBR(18)=$$OBR18^LA7VOBR(.LA7X,LA7FS,LA7ECH) 178 ; 179 ; Placer Field #2 180 I $G(LA7PLOBR("OBR-19"))'="" D 181 . S OBR(19)=$$CHKDATA^LA7VHLU3(LA7PLOBR("OBR-19"),LA7FS_LA7ECH) 182 ; Else build collecting UID if sending to VA facility 183 I $G(LA7PLOBR("OBR-19"))="",'LA7NVAF,LA("RUID")'="" D 184 . K LA7X 185 . S LA7X(7)=LA("RUID") 186 . S OBR(19)=$$OBR19^LA7VOBR(.LA7X,LA7FS,LA7ECH) 187 ; 188 ; Filler Field #1 189 ; Send file #63 ien info - used by HDR to track patient/specimen 190 K LA7X 191 S LA7X(1)=LA("LRDFN") 192 S LA7X(2)=LA("SUB") 193 S LA7X(3)=LA("LRIDT") 194 S OBR(20)=$$OBR20^LA7VOBR(.LA7X,LA7FS,LA7ECH) 195 ; 196 ; Date Report Completed 197 I $P(LA763(0),"^",3) S OBR(22)=$$OBR22^LA7VOBR($P(LA763(0),"^",3)) 198 ; 199 ; Diagnostic service id 200 S OBR(24)=$$OBR24^LA7VOBR(LA("SUB")_"^"_$G(LRSB)) 201 ; 202 ; Parent Result and Parent 203 I $D(LA7PARNT) D 204 . S OBR(26)=$$OBR26^LA7VOBR(LA7PARNT(1),LA7PARNT(2),LA7PARNT(3),LA7FS,LA7ECH) 205 . S OBR(29)=$$OBR29^LA7VOBR(LA("RUID"),LA("HUID"),LA7FS,LA7ECH) 206 ; 207 ; Principle result interpreter 208 ; Get default institution from MailMan Site Parameters file 209 I "CYEMMISP"[LA("SUB") D 210 . I LA("SUB")="MI" S LA7X=$P(LA763(0),"^",4) 211 . E S LA7X=$P(LA763(0),"^",2) 212 . S LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") 213 . S OBR(32)=$$OBR32^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) 214 ; 215 ; Assistant result interpreter 216 ; Get default institution from MailMan Site Parameters file 217 I "EMSP"[LA("SUB") D 218 . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") 219 . S OBR(33)=$$OBR33^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) 220 ; 221 ; Technician 222 ; Get default institution from MailMan Site Parameters file 223 I "CYEM"[LA("SUB") D 224 . S LA7X=$P(LA763(0),"^",4),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") 225 . S OBR(34)=$$OBR34^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) 226 ; 227 ; Typist - VistA stores as free text 228 ; Get default institution from MailMan Site Parameters file 229 I "CYEMSP"[LA("SUB") D 230 . S LA7X=$P(LA763(0),"^",9),LA7Y=$$GET1^DIQ(4.3,"1,",217,"I") 231 . S OBR(35)=$$OBR35^LA7VOBR(LA7X,LA7Y,LA7FS,LA7ECH) 232 ; 233 D BUILDSEG^LA7VHLU(.OBR,.LA7DATA,LA7FS) 234 D FILESEG^LA7VHLU(GBL,.LA7DATA) 235 ; 236 ; Check for flag to only build message but do not file 237 I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) 238 ; 239 Q 240 ; 241 ; 242 OBX ;Observation/Result segment for Lab Results 243 ; 244 N LA7953,LA7DATA,LA7VT,LA7VTIEN,LA7X 245 ; 246 S LA7VTIEN=0 247 F S LA7VTIEN=$O(^LAHM(62.49,LA(62.49),1,LA7VTIEN)) Q:'LA7VTIEN D 248 . S LA7VT=$P(^LAHM(62.49,LA(62.49),1,LA7VTIEN,0),"^",1,2) 249 . ; Build OBX segment 250 . K LA7DATA 251 . D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^",1,2),.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH,$G(LA7NVAF)) 252 . ; If OBX failed to build then don't store 253 . I '$D(LA7DATA) Q 254 . ; 255 . D FILESEG^LA7VHLU(GBL,.LA7DATA) 256 . I '$G(LA7NOMSG) D FILE6249^LA7VHLU(LA76249,.LA7DATA) 257 . ; 258 . ; Send performing lab comment and interpretation from file #60 259 . S LA7NTESN=0 260 . I LA7NVAF=1 D PLC^LA7VORUA 261 . D INTRP^LA7VORUA 262 . ; 263 . ; Mark result as sent - set to 1, if corrected results set to 2 264 . I LA("SUB")="CH" D 265 . . I $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)>1 Q 266 . . S $P(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),$P(LA7VT,"^")),"^",10)=$S($P(LA7VT,"^",2)="C":2,1:1) 267 ; 268 Q 269 ; 270 ; 271 NTE ; Build NTE segment 272 ; 273 D NTE^LA7VORUA 274 Q -
ccr/branches/ohum/p/C0CXEWD.m
r1332 r1333 1 C0CXEWD 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 TEST 23 24 25 26 TEST2 27 28 29 30 31 XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) 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 PARSE(INXML,INDOC) 61 62 63 64 65 66 67 68 ISMULT(ZOID) 69 70 71 72 73 74 DETAIL(ZRTN,ZOID) 75 76 77 78 79 80 ID(ZNAME) 81 82 83 NAME(ZOID) 84 85 86 FIRST(ZOID) 87 88 89 90 91 92 93 94 HASCHILD(ZOID) 95 96 97 CHILDREN(ZRTN,ZOID) 98 99 100 101 102 103 TAG(ZOID) 104 105 106 NXTSIB(ZOID) 107 108 109 NXTCHLD(ZOID) 110 111 112 113 114 115 116 PARENT(ZOID) 117 118 119 DATA(ZT,ZOID) 120 121 122 123 124 125 126 1 C0CXEWD ; C0C/GPL - EWD based XPath utilities; 10/11/09 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 TEST ; 23 D XPATH($$FIRST($$ID("CCR1")),"/","GIDX","GARY") 24 Q 25 ; 26 TEST2 ; 27 S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail" 28 D XPATH($$FIRST($$ID("gpl")),"/","GIDX","GARY","",REDUX) 29 Q 30 ; 31 XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE 32 ; THE XPATH INDEX ZXIDX, PASSED BY NAME 33 ; THE XPATH ARRAY XPARY, PASSED BY NAME 34 ; ZOID IS THE STARTING OID 35 ; ZPATH IS THE STARTING XPATH, USUALLY "/" 36 ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE 37 ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT 38 I '$D(ZREDUX) S ZREDUX="" 39 N NEWPATH 40 N NEWNUM S NEWNUM="" 41 I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" 42 S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE 43 I $G(ZREDUX)'="" D ; REDUX PROVIDED? 44 . N GT S GT=$P(NEWPATH,ZREDUX,2) 45 . I GT'="" S NEWPATH=GT 46 S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX 47 N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE 48 I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY 49 E I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY 50 I GD'="" S @ZXPARY@(NEWPATH)=GD ; IF YES, ADD IT TO THE XPATH ARRAY 51 N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD 52 I ZFRST'="" D ; THERE IS A CHILD 53 . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE 54 . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD 55 N GNXT S GNXT=$$NXTSIB(ZOID) 56 I GNXT'="" D ; MOVE ON TO THE NEXT SIBLING 57 . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB 58 Q 59 ; 60 PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME 61 ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD 62 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD 63 N ZR 64 M ^CacheTempEWD($j)=@INXML ; 65 S ZR=$$parseDocument^%zewdHTMLParser(INDOC) 66 Q ZR 67 ; 68 ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE 69 N ZN 70 S ZN=$$NXTSIB(ZOID) 71 I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG 72 Q 0 73 ; 74 DETAIL(ZRTN,ZOID) ; RETURNS DETAIL FOR NODE ZOID IN ZRTN, PASSED BY NAME 75 N DET 76 D getElementDetails^%zewdXPath(ZOID,.DET) 77 M @ZRTN=DET 78 Q 79 ; 80 ID(ZNAME) ;RETURNS THE docOID OF THE DOCUMENT NAMED ZNAME 81 Q $$getDocumentNode^%zewdDOM(ZNAME) 82 ; 83 NAME(ZOID) ;RETURNS THE NAME OF THE DOCUMENAT WITH docOID ZOID 84 Q $$getDocumentName^%zewdDOM(ZOID) 85 ; 86 FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID 87 N GOID 88 S GOID=ZOID 89 S GOID=$$getFirstChild^%zewdDOM(GOID) 90 I GOID="" Q "" 91 I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID) 92 Q GOID 93 ; 94 HASCHILD(ZOID) ; RETURNS TRUE IF ZOID HAS CHILD NODES 95 Q $$hasChildNodes^%zewdDOM(ZOID) 96 ; 97 CHILDREN(ZRTN,ZOID) ;RETURNS CHILDREN OF ZOID IN ARRAY ZRTN, PASSED BY NAME 98 N childArray 99 d getChildrenInOrder^%zewdDOM(ZOID,.childArray) 100 m @ZRTN=childArray 101 q 102 ; 103 TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE 104 Q $$getName^%zewdDOM(ZOID) 105 ; 106 NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING 107 Q $$getNextSibling^%zewdDOM(ZOID) 108 ; 109 NXTCHLD(ZOID) ; RETURNS THE NEXT CHILD IN PARENT ZPAR 110 N GOID 111 S GOID=$$getNextChild^%zewdDOM($$PARENT(ZOID),ZOID) 112 I GOID="" Q "" 113 I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID) 114 Q GOID 115 ; 116 PARENT(ZOID) ; RETURNS PARENT OF ZOID 117 Q $$getParentNode^%zewdDOM(ZOID) 118 ; 119 DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE 120 N ZT2 121 S ZT2=$$getElementText^%zewdDOM(ZOID,.ZT2) 122 M @ZT=ZT2 123 Q 124 ;Q $$getTextValue^%zewdXPath(ZOID) 125 ;Q $$getData^%zewdDOM(ZOID,.ZT) 126 ; -
ccr/branches/ohum/p/C0CXPAT0.m
r1332 r1333 1 1 C0CXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. -
ccr/branches/ohum/p/C0CXPATH.m
r1332 r1333 1 1 C0CXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 2 ;;1.0;C0C;;May 19, 2009;Build 382 ;;1.0;C0C;;May 19, 2009;Build 1 3 3 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License.
Note:
See TracChangeset
for help on using the changeset viewer.
