Changeset 1428 for ccr/branches
- Timestamp:
- May 11, 2012, 6:06:25 PM (13 years ago)
- Location:
- ccr/branches/ohum/p
- Files:
-
- 9 added
- 70 edited
Legend:
- Unmodified
- Added
- Removed
-
ccr/branches/ohum/p/C0CACTOR.m
r1342 r1428 1 C0CACTOR 2 ;;1.0;C0C;;May 19, 2009;Build 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 EXTRACT(IPXML,ALST,AXML) 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 PATIENT(INXML,AIEN,AOID,OUTXML) 86 87 88 89 90 91 92 93 94 95 96 97 98 99 DEIDENT(GPL,ZDFN) 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 PEXTRACT(AMAP,AIEN,AOID) 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 MAP(INXML,AMAP,OUTXML) 185 186 187 188 SYSTEM(INXML,AIEN,AOID,OUTXML) 189 190 191 192 193 194 195 196 197 198 199 200 NOK(INXML,AIEN,AOID,OUTXML) 201 202 203 204 205 206 207 208 209 210 211 212 213 ORG(INXML,AIEN,AOID,OUTXML) 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 PROVIDER(INXML,AIEN,AOID,OUTXML) 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 1 C0CACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 ; PROCESS THE ACTORS SECTION OF THE CCR 22 ; 23 ; ===Revision History=== 24 ; 0.1 Initial Writing of Skeleton--GPL 25 ; 0.2 Patient Data Extraction--SMH 26 ; 0.3 Information System Info Extraction--SMH 27 ; 0.4 Patient data rouine refactored; adjustments here--SMH 28 ; 29 EXTRACT(IPXML,ALST,AXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE 30 ; IPXML is the Input Actor Template into which we substitute values 31 ; This is straight XML. Values to be substituted are in @@VAL@@ format. 32 ; ALST is the actor list global generated by ACTLST^C0CCCR and has format: 33 ; ^TMP(7542,1,"ACTORS",0)=Count 34 ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN" 35 ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM" 36 ; AXML is the output arrary, to contain XML. 37 ; 38 N I,J,AMAP,AOID,ATYP,AIEN 39 D CP^C0CXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML 40 D REPLACE^C0CXPATH(AXML,"","//Actors") ; DELETE THE INSIDES 41 I DEBUG W "PROCESSING ACTORS ",! 42 F I=1:1:@ALST@(0) D ; PROCESS ALL ACTORS IN THE LIST 43 . I @ALST@(I)["@@" Q ; NOT A VALID ACTOR 44 . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID 45 . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE 46 . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER 47 . I AIEN="" D Q ; IEN CAN'T BE NULL 48 . . W "WARING NUL ACTOR: ",ATYP,! 49 . I ATYP="" Q ; NOT A VALID ACTOR 50 . ; 51 . I DEBUG W AOID_" "_ATYP_" "_AIEN,! 52 . I ATYP="PATIENT" D ; PATIENT ACTOR TYPE 53 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP") 54 . . D PATIENT("ATMP",AIEN,AOID,"ATMP2") 55 . ; 56 . I ATYP="SYSTEM" D ; SYSTEM ACTOR TYPE 57 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP") 58 . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2") 59 . ; 60 . I ATYP="NOK" D ; NOK ACTOR TYPE 61 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP") 62 . . D NOK("ATMP",AIEN,AOID,"ATMP2") 63 . ; 64 . I ATYP="PROVIDER" D ; PROVIDER ACTOR TYPE 65 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP") 66 . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2") 67 . ; 68 . I ATYP="ORGANIZATION" D ; PROVIDER ACTOR TYPE 69 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP") 70 . . D ORG("ATMP",AIEN,AOID,"ATMP2") 71 . ; 72 . W "PROCESSING:",ATYP," ",AIEN,! 73 . ;I @ATMP2@(0)=0 Q ; NOTHING RETURNED, SKIP THIS ONE 74 . D INSINNER^C0CXPATH(AXML,"ATMP2") ; INSERT INTO ROOT 75 . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE 76 ; 77 N ACTTMP 78 D MISSING^C0CXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS 79 I ACTTMP(0)>0 D ; IF THERE ARE MISSING VARS - 80 . ; STRINGS MARKED AS @@X@@ 81 . W "ACTORS Missing list: ",! 82 . F I=1:1:ACTTMP(0) W ACTTMP(I),! 83 Q 84 ; 85 PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR 86 I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,! 87 ;GPL SEPARATED EXTRACT FROM MAP FOR PROCESSING PATIENTS - TO MAKE 88 ; CODE REUSABLE FROM ERX 89 N AMAP 90 S AMAP=$NA(^TMP($J,"AMAP")) 91 K @AMAP 92 D PEXTRACT(AMAP,AIEN,AOID) ;EXTRACT THE PATIENT ACTOR 93 I $P($$SITE^VASITE(),U,2)="OROVILLE HOSPITAL" S C0CDE=1 94 I $G(C0CDE)'="" D DEIDENT(AMAP,AIEN) ; DEIDENTIFY THE CCR 95 D MAP(INXML,AMAP,OUTXML) ;MAP TO XML 96 K @AMAP ; CLEAN UP BEHIND US 97 Q 98 ; 99 DEIDENT(GPL,ZDFN) ; QUICK WAY TO DEIDENTIFY THE CCR 100 S @GPL@("ACTORADDRESSCITY")="ALTON" 101 S @GPL@("ACTORADDRESSLINE1")="1234 Somewhere Lane" 102 S @GPL@("ACTORADDRESSLINE2")="" 103 S @GPL@("ACTORADDRESSSOURCEID")="ACTORPATIENT_"_ZDFN 104 S @GPL@("ACTORADDRESSSTATE")="KANSAS" 105 S @GPL@("ACTORADDRESSTYPE")="Home" 106 S @GPL@("ACTORADDRESSZIPCODE")=67623 107 S @GPL@("ACTORCELLTEL")="" 108 S @GPL@("ACTORCELLTELTEXT")="" 109 S @GPL@("ACTORDATEOFBIRTH")="1957-12-25" 110 S @GPL@("ACTOREMAIL")="" 111 S @GPL@("ACTORFAMILYNAME")="ZZ PATIENT"_ZDFN 112 ;S @GPL@("ACTORGENDER")="MALE" 113 S @GPL@("ACTORGIVENNAME")="TEST"_ZDFN 114 S @GPL@("ACTORIEN")=2 115 S @GPL@("ACTORMIDDLENAME")="TWO" 116 S @GPL@("ACTOROBJECTID")="ACTORPATIENT_"_ZDFN 117 S @GPL@("ACTORRESTEL")="888-555-1212" 118 S @GPL@("ACTORRESTELTEXT")="Residential Telephone" 119 S @GPL@("ACTORSOURCEID")="ACTORSYSTEM_1" 120 S @GPL@("ACTORSSN")="769122557P" 121 S @GPL@("ACTORSSNSOURCEID")="ACTORPATIENT_"_ZDFN 122 S @GPL@("ACTORSSNTEXT")="SSN" 123 S @GPL@("ACTORSUFFIXNAME")="" 124 S @GPL@("ACTORWORKTEL")="888-121-1212" 125 S @GPL@("ACTORWORKTELTEXT")="Work Telephone" 126 Q 127 ; 128 PEXTRACT(AMAP,AIEN,AOID) ; EXTRACT TO RETURN ARRAY RARY PASSED BY NAME 129 N ZX 130 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID 131 S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CDPT(AIEN) 132 S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CDPT(AIEN) 133 S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CDPT(AIEN) 134 S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^C0CDPT(AIEN) 135 S @AMAP@("ACTORGENDER")=$P($$GENDER^C0CDPT(AIEN),U,2) 136 S @AMAP@("ACTORGENDERCODE")=$P($$GENDER^C0CDPT(AIEN),U,1) 137 S @AMAP@("ACTORSSN")="" 138 S @AMAP@("ACTORSSNTEXT")="" 139 S @AMAP@("ACTORSSNSOURCEID")="" 140 S X="MSCDPTID" ; ROUTINE TO TEST FOR MRN ON OPENVISTA 141 X ^%ZOSF("TEST") ; TEST TO SEE IF THE ROUTINE EXISTS 142 I $T S MRN=$$^MSCDPTID(DFN) ;TEST FOR MRN ON OPENVISTA ;GPL 143 I $G(MRN)'="" D ; IF MRN IS PRESENT 144 . S @AMAP@("ACTORSSN")=MRN 145 . S @AMAP@("ACTORSSNTEXT")="MRN" 146 . S @AMAP@("ACTORSSNSOURCEID")=AOID 147 E D ; NO MRN, USE SSN 148 . S ZX=$$SSN^C0CDPT(AIEN) 149 . I ZX'="" D ; IF THERE IS A SSN IN THE RECORD 150 . . S @AMAP@("ACTORSSN")=ZX 151 . . S @AMAP@("ACTORSSNTEXT")="SSN" 152 . . S @AMAP@("ACTORSSNSOURCEID")=AOID 153 S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^C0CDPT(AIEN) 154 S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^C0CDPT(AIEN) 155 S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^C0CDPT(AIEN) 156 S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CDPT(AIEN) 157 S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CDPT(AIEN) 158 S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^C0CDPT(AIEN) 159 S @AMAP@("ACTORRESTEL")="" 160 S @AMAP@("ACTORRESTELTEXT")="" 161 S ZX=$$RESTEL^C0CDPT(AIEN) 162 I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD 163 . S @AMAP@("ACTORRESTEL")=ZX 164 . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone" 165 S @AMAP@("ACTORWORKTEL")="" 166 S @AMAP@("ACTORWORKTELTEXT")="" 167 S ZX=$$WORKTEL^C0CDPT(AIEN) 168 I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD 169 . S @AMAP@("ACTORWORKTEL")=ZX 170 . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone" 171 S @AMAP@("ACTORCELLTEL")="" 172 S @AMAP@("ACTORCELLTELTEXT")="" 173 S ZX=$$CELLTEL^C0CDPT(AIEN) 174 I ZX'="" D ; IF THERE IS A CELL PHONE IN THE RECORD 175 . S @AMAP@("ACTORCELLTEL")=ZX 176 . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone" 177 S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CDPT(AIEN) 178 S @AMAP@("ACTORADDRESSSOURCEID")=AOID 179 S @AMAP@("ACTORIEN")=AIEN 180 S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX 181 S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE 182 Q 183 ; 184 MAP(INXML,AMAP,OUTXML) ;MAP ANY ACTOR TO XML 185 D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE 186 Q 187 ; 188 SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR 189 ; 190 ; N AMAP 191 S AMAP=$NA(^TMP($J,"AMAP")) 192 K @AMAP 193 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID 194 S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^C0CSYS 195 S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^C0CSYS 196 S @AMAP@("ACTORINFOSYSSOURCEID")=AOID 197 D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE 198 Q 199 ; 200 NOK(INXML,AIEN,AOID,OUTXML) ; PROCESS A NEXT OF KIN TYPE ACTOR 201 ; 202 ; N AMAP 203 S AMAP=$NA(^TMP($J,"AMAP")) 204 K @AMAP 205 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID 206 S @AMAP@("ACTORDISPLAYNAME")="" 207 S @AMAP@("ACTORRELATION")="" 208 S @AMAP@("ACTORRELATIONSOURCEID")="" 209 S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE 210 D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE 211 Q 212 ; 213 ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR 214 ; 215 N AMAP,ZIEN,ZSITE 216 S AMAP=$NA(^TMP($J,"AMAP")) 217 K @AMAP 218 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID 219 S ZSITE=$$SITE^VASITE ; SITE FORMAT IEN^NAME^DATE 220 S ZIEN=$P(ZSITE,"^",1) 221 S @AMAP@("ORGANIZATIONNAME")=$P(ZSITE,U,2) 222 S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" 223 S @AMAP@("ACTORADDRESSTYPE")="Office" 224 S @AMAP@("ACTORADDRESSLINE1")=$$GET1^DIQ(4,ZIEN_",",1.01) 225 S @AMAP@("ACTORADDRESSLINE2")=$$GET1^DIQ(4,ZIEN_",",1.02) 226 S @AMAP@("ACTORADDRESSCITY")=$$GET1^DIQ(4,ZIEN_",",1.03) 227 S @AMAP@("ACTORADDRESSSTATE")=$$GET1^DIQ(4,ZIEN_",",.02) 228 S @AMAP@("ACTORPOSTALCODE")=$$GET1^DIQ(4,ZIEN_",",1.04) 229 S @AMAP@("ACTORTELEPHONE")="" 230 S @AMAP@("ACTORTELEPHONETYPE")="" 231 S ZX=$$GET1^DIQ(4.03,"1,"_ZIEN_",",.03) 232 I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE 233 . S @AMAP@("ACTORTELEPHONE")=ZX 234 . S @AMAP@("ACTORTELEPHONETYPE")="Office" 235 D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE 236 K @AMAP 237 Q 238 ; 239 PROVIDER(INXML,AIEN,AOID,OUTXML) ; PROCESS A PROVIDER TYPE ACTOR 240 ; 241 ; N AMAP 242 S AMAP=$NA(^TMP($J,"AMAP")) 243 K @AMAP 244 I '$D(^VA(200,AIEN,0)) D Q ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN) 245 . W "WARNING - MISSING PROVIDER: ",AIEN,! 246 . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT 247 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID 248 S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CVA200(AIEN) 249 S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CVA200(AIEN) 250 S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CVA200(AIEN) 251 S @AMAP@("ACTORTITLE")=$$TITLE^C0CVA200(AIEN) 252 S @AMAP@("IDTYPE")=$P($$NPI^C0CVA200(AIEN),U,1) 253 S @AMAP@("ID")=$P($$NPI^C0CVA200(AIEN),U,2) 254 S @AMAP@("IDDESC")=$P($$NPI^C0CVA200(AIEN),U,3) 255 S @AMAP@("ACTORSPECIALITY")=$$SPEC^C0CVA200(AIEN) 256 S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^C0CVA200(AIEN) 257 S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^C0CVA200(AIEN) 258 S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CVA200(AIEN) 259 S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CVA200(AIEN) 260 S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^C0CVA200(AIEN) 261 S @AMAP@("ACTORTELEPHONE")="" 262 S @AMAP@("ACTORTELEPHONETYPE")="" 263 S ZX=$$TEL^C0CVA200(AIEN) 264 I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE 265 . S @AMAP@("ACTORTELEPHONE")=ZX 266 . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^C0CVA200(AIEN) 267 S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CVA200(AIEN) 268 S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1" 269 S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE 270 S @AMAP@("ACTORORGLINK")="ACTORORGANIZATION_1" 271 D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE 272 Q 273 ; -
ccr/branches/ohum/p/C0CALERT.m
r1342 r1428 1 C0CALERT 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(ALTXML,DFN,ALTOUTXML,CALLBK) 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 PRSGLB(INGLB) 130 131 132 1 C0CALERT ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;Copyright 2008,2009 George Lilly, University of Minnesota and others. 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 W "NO ENTRY FROM TOP",! 22 Q 23 ; 24 EXTRACT(ALTXML,DFN,ALTOUTXML,CALLBK) ; EXTRACT ALERTS INTO XML TEMPLATE 25 ; CALLBACK IF PROVIDED IS CALLED FOR EACH ALLERGY BEFORE MAPPING 26 ; ALTXML AND ALTOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED 27 ; 28 ; GET ADVERSE REACTIONS AND ALLERGIES 29 ; N GMRA,GMRAL ; FOR DEBUGGING, DON'T NEW THESE VARIABLES 30 S GMRA="0^0^111" 31 D EN1^GMRADPT 32 I $G(GMRAL)'=1 D Q ; NO ALLERGIES FOUND THUS *QUIT* 33 . S @ALTOUTXML@(0)=0 34 ; DEFINE MAPPING 35 N ALTTVMAP,ALTVMAP,ALTTARYTMP,ALTARYTMP 36 S ALTTVMAP=$NA(^TMP("C0CCCR",$J,"ALERTS")) 37 S ALTTARYTMP=$NA(^TMP("C0CCCR",$J,"ALERTSARYTMP")) 38 K @ALTTVMAP,@ALTTARYTMP 39 N ALTTMP,ALTCNT S ALTG=$NA(GMRAL),ALTCNT=1 40 S ALTTMP="" ; 41 F S ALTTMP=$O(@ALTG@(ALTTMP)) Q:ALTTMP="" D ; CHANGED TO $O BY GPL 42 . W "ALTTMP="_ALTTMP,! 43 . ; I $QS(ALTTMP,2)="S" W !,"S FOUND",! Q 44 . S ALTVMAP=$NA(@ALTTVMAP@(ALTCNT)) 45 . K @ALTVMAP 46 . S @ALTVMAP@("ALERTOBJECTID")="ALERT"_ALTCNT 47 . N A1 S A1=@ALTG@(ALTTMP) ; ALL THE PIECES 48 . I $D(CALLBK) D @CALLBK ;CALLBACK FOR EPRESCRIBING 49 . N A2 S A2=$$GET1^DIQ(120.8,ALTTMP,"MECHANISM","I") ; MECHANISM 50 . N A3 S A3=$P(A1,U,5) ; ADVERSE FLAG 51 . N ADT S ADT="Patient has an " ; X $ZINT H 5 52 . S ADT=ADT_$S(A2="P":"ADVERSE",A2="A":"ALLERGIC",1:"UNKNOWN") 53 . S ADT=ADT_" reaction to "_$P(@ALTG@(ALTTMP),U,2)_"." 54 . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT 55 . N ADTY S ADTY=$S(A2="P":"Adverse Reaction",A2="A":"Allergy",1:"") ; 56 . S @ALTVMAP@("ALERTTYPE")=ADTY ; type of allergy 57 . N ALTCDE ; SNOMED CODE THE THE ALERT 58 . S ALTCDE=$S(A2="P":"282100009",A2="A":"416098002",1:"") ; IF NOT ADVERSE, IT IS ALLERGIC 59 . S @ALTVMAP@("ALERTCODEVALUE")=ALTCDE ; 60 . ; WILL USE 418634005 FOR ALLERGIC REACTION TO A SUBSTANCE 61 . ; AND 282100009 FOR ADVERSE REACTION TO A SUBSTANCE 62 . I ALTCDE'="" D ; IF THERE IS A CODE 63 . . S @ALTVMAP@("ALERTCODESYSTEM")="SNOMED CT" 64 . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="2008" 65 . E D ; SET TO NULL 66 . . S @ALTVMAP@("ALERTCODESYSTEM")="" 67 . . S @ALTVMAP@("ALERTCODESYSTEMVERSION")="" 68 . S @ALTVMAP@("ALERTSTATUSTEXT")="" ; WHERE DO WE GET THIS? 69 . N ALTPROV S ALTPROV=$P(^GMR(120.8,ALTTMP,0),U,5) ; SOURCE PROVIDER IEN 70 . I ALTPROV'="" D ; PROVIDER PROVIDEED 71 . . S @ALTVMAP@("ALERTSOURCEID")="ACTORPROVIDER_"_ALTPROV 72 . E S @ALTVMAP@("ALERTSOURCEID")="" ; SOURCE NULL - SHOULD NOT HAPPEN 73 . W "RUNNING ALERTS, PROVIDER: ",@ALTVMAP@("ALERTSOURCEID"),! 74 . N ACGL1,ACGFI,ACIEN,ACVUID,ACNM,ACTMP 75 . S ACGL1=$P(@ALTG@(ALTTMP),U,9) ; ADDRESS OF THE REACTANT XX;GLB(YY.Z, 76 . S ACGFI=$$PRSGLB($P(ACGL1,";",2)) ; FILE NUMBER 77 . S ACIEN=$P(ACGL1,";",1) ; IEN OF REACTANT 78 . S ACVUID=$$GET1^DIQ(ACGFI,ACIEN,"VUID") ; VUID OF THE REACTANT 79 . S @ALTVMAP@("ALERTAGENTPRODUCTOBJECTID")="PRODUCT_"_ACIEN ; IE OF REACTANT 80 . S @ALTVMAP@("ALERTAGENTPRODUCTSOURCEID")="" ; WHERE DO WE GET THIS? 81 . S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT 82 . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM 83 . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION 84 . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE 85 . I ACVUID'="" D ; IF VUID IS NOT NULL 86 . . S ZC=$$CODE^C0CUTIL(ACVUID) 87 . . S ZCD=$P(ZC,"^",1) ; CODE TO USE 88 . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID 89 . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION 90 . E D ; IF REACTANT CODE VALUE IS NULL 91 . . I $G(DUZ("AG"))="I" D ; IF WE ARE RUNNING ON RPMS 92 . . . S ACTMP=$O(^C0CCODES(176.112,"C",ACNM,0)) ; 93 . . . W "RPMS NAME FOUND",ACNM," ",ACTMP,! 94 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="" 95 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="" 96 . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ZCD 97 . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=ZCDS 98 . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM_" "_ZCDS_": "_ZCD 99 . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT_" "_ZCDS_": "_ZCD 100 . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW 101 . N ARTMP,ARIEN,ARDES,ARVUID 102 . S (ARTMP,ARDES,ARVUID)="" 103 . I $D(@ALTG@(ALTTMP,"S",1)) D ; IF REACTION EXISTS 104 . . S ARTMP=@ALTG@(ALTTMP,"S",1) 105 . . W "REACTION:",ARTMP,! 106 . . S ARIEN=$P(ARTMP,";",2) 107 . . S ARDES=$P(ARTMP,";",1) 108 . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID") 109 . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES 110 . I ARVUID'="" D ; IF REACTION VUID IS NOT NULL 111 . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID 112 . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID" 113 . E D ; IF IT IS NULL DON'T SET CODE SYSTEM 114 . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")="" 115 . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="" 116 . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) 117 . ; NOW GO TO THE GLOBAL TO GET THE DATE/TIME AND BETTER DESCRIPTION 118 . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL 119 . D GETN1^C0CRNF("C0CG1",120.8,ALTTMP,"") ;GET VALUES BY NAME 120 . S C0CT=$$ZVALUEI^C0CRNF("ORIGINATION DATE/TIME","C0CG1") 121 . S @ALTVMAP@("ALERTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CT,"DT") 122 . K @ALTARYTMP 123 . D MAP^C0CXPATH(ALTXML,ALTVMAP,ALTARYTMP) 124 . I ALTCNT=1 D CP^C0CXPATH(ALTARYTMP,ALTOUTXML) 125 . I ALTCNT>1 D INSINNER^C0CXPATH(ALTOUTXML,ALTARYTMP) 126 . S ALTCNT=ALTCNT+1 127 S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS 128 Q 129 PRSGLB(INGLB) ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER 130 ; INGLB IS OF THE FORM: PSNDF(50.6, 131 ; RETURN 50.6 132 Q $P($P(INGLB,"(",2),",",1) ; -
ccr/branches/ohum/p/C0CBAT.m
r1342 r1428 1 C0CBAT 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 STOP 24 25 26 27 28 29 30 31 32 33 34 35 START 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 EN 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 BLDHOT(ZHB) 149 150 151 152 153 154 155 156 157 158 COUNT(ZB) 159 160 161 162 163 164 165 166 UPDIEVARPTR(ZVAR,ZTYP) 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 UPDIE 189 190 191 192 193 194 195 196 197 198 199 SETFDA(C0CSN,C0CSV) 200 201 202 203 204 205 206 207 208 209 ZFILE(ZFN,ZTAB) 210 211 212 213 214 215 216 217 ZFIELD(ZFN,ZTAB) 218 219 220 221 222 223 224 225 226 ZVALUE(ZFN,ZTAB) 227 228 229 230 231 232 233 234 1 C0CBAT ; CCDCCR/GPL - CCR Batch utilities; 4/21/09 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 Batch Utility Library ",! 21 Q 22 ; 23 STOP ; STOP A CURRENTLY RUNNING BATCH JOB 24 I '$D(^TMP("C0CBAT","RUNNING")) Q ; 25 W !,!,"HALTING CCR BATCH",! 26 S ^TMP("C0CBAT","STOP")="" ; SIGNAL JOB TO TERMINATE 27 H 10 ; WAIT TEN SECONDS FOR SIGNAL TO BE RECEIVED 28 I '$D(^TMP("C0CBAT","STOP")) D ; SIGNAL RECEIVED 29 . W "CCR BATCH JOB TERMINATING",! 30 E D ; 31 . K ^TMP("C0CBAT","STOP") ; STOP SIGNALING 32 . W !,"BATCH PROCESSING APPARENTLY NOT RUNNING",! 33 Q 34 ; 35 START ; STARTS A TAKSMAN CCR BATCH JOB - FOR USE IN A MENU OPTION 36 ; 37 I $D(^TMP("C0CBAT","RUNNING")) D Q ; ONLY ONE ALLOWED AT A TIME 38 . W !,"CCR BATCH ALREADY RUNNING",! 39 . W !,"STOP FIRST WITH STOP^C0CBAT",! 40 N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTIO 41 S ZTRTN="EN^C0CBAT",ZTDESC="CCR Batch" 42 S ZTDTH=$H ; 43 ;S ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10)) 44 S ZTSAVE("C0C")="",ZTSAVE("C0C*")="" 45 S ZTIO="NULL" ; 46 W !,!,"CCR BATCH JOB STARTED",! 47 D ^%ZTLOAD 48 Q 49 ; 50 EN ; BATCH ENTRY POINT 51 ; PROCESSES THE SUBSCRIPTION FILE, EXTRACTING CCR VARIABLES FOR EACH 52 ; PATIENT WITH AN ACTIVE SUBSCRIPTION, AND IF CHECKSUMS INDICATE A CHANGE, 53 ; GENERATES A NEW CCR FOR THE PATIENT 54 ; UPDATES THE E2 CCR ELEMENTS FILE 55 ; 56 S C0CQT=1 ; QUIET MODE 57 I $D(^TMP("C0CBAT","RUNNING")) Q ; ONLY ONE AT A TIME 58 S ^TMP("C0CBAT","RUNNING")="" ; RUNNING SIGNAL 59 S C0CBDT=$$NOW^XLFDT ; DATE OF THIS RUN 60 S C0CBF=177.301 ; FILE NUMBER OF C0C BATCH CONTROL FILE 61 S C0CBFR=177.3013 ; FILE NUMBER OF UPDATE SUBFILE 62 S C0CBB=$NA(^TMP("C0CBATCH",C0CBDT)) ; BATCH WORK AREA 63 I $D(@C0CBB@(0)) D ; ERROR SHOULDN'T EXIST 64 . W "WORK AREA ERROR",! 65 . B 66 S @C0CBB@(0)="V22" ; VERSION USED TO CREATE THIS WORK AREA 67 S C0CBH=$NA(@C0CBB@("HOTLIST")) ; BASE FOR HOT LIST 68 S C0CBS=$NA(^C0CS("B")) ; SUBSCRIPTION LIST BASE 69 ;I $D(^C0CB("B",C0CDT)) D ; BATCH RECORD EXISTS 70 ;. H 10 ; HANG 10 SECONDS 71 ;. S C0CBDT=$$NOW^XLFDT ; NEW DATE FOR THIS RUN 72 ;. I $D(^C0CB("B",C0CDT)) B ;DIDN'T WORK 73 D BLDHOT(C0CBH) ; BUILD THE HOT LIST 74 S C0CHN=$$COUNT(C0CBH) ;COUNT NUMBER IN HOT LIST 75 S C0CSN=$$COUNT(C0CBS) ;COUNT NUMBER OF PATIENTS WITH SUBSCRIPTIONS 76 S C0CFDA(C0CBF,"+1,",.01)=C0CBDT ; DATE KEY OF BATCH CONTROL 77 S C0CFDA(C0CBF,"+1,",.02)=C0CBDT ; BATCH ID IS DATE IN STRING FORM 78 S C0CFDA(C0CBF,"+1,",1)=C0CSN ; TOTAL SUBSCRIPTIONS 79 S C0CFDA(C0CBF,"+1,",2)=C0CHN ; TOTAL HOT LIST 80 D UPDIE ; CREATE THE BATCH RECORD 81 S C0CIEN=$O(^C0CB("B",C0CBDT,"")) 82 S (C0CN,C0CNH)=0 ; COUNTERS FOR TOTAL AND HOT LIST 83 S C0CBCUR="" ; CURRENT PATIENT 84 S C0CSTOP=0 ; STOP FLAG FOR HALTING BATCH SET ^TMP("C0CBAT","STOP")="" 85 ;F S C0CBCUR=$O(@C0CBH@(C0CBCUR),-1) Q:C0CBCUR="" D ; HOT LIST LATEST FIRST 86 F S C0CBCUR=$O(@C0CBH@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="") D ; HOT LIST FIRST 87 . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-900^VITLIMIT:T-900") 88 . I $G(C0CCHK) D ; 89 . . D PUTRIM^C0CFM2(C0CBCUR) 90 . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR 91 . . K C0CFDA 92 . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR 93 . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y" 94 . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR)) 95 . . D UPDIE ; CREATE UPDATE SUBFILE 96 . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL 97 . S C0CNH=C0CNH+1 ; INCREMENT HOT LIST TOTAL 98 . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS 99 . S C0CFDA(C0CBF,C0CIEN_",",2.1)=C0CNH ; UPDATE HOT LIST PROGRESS 100 . S C0CNOW=$$NOW^XLFDT 101 . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD 102 . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS 103 . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME 104 . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME 105 . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME 106 . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START 107 . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME 108 . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; LAST RECORD PROCESSED 109 . D UPDIE ; 110 . I $D(^TMP("C0CBAT","STOP")) D ; IF STOP SIGNAL DETECTED 111 . . S C0CSTOP=1 112 . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED 113 . H 1 ; GIVE OTHERS A CHANCE 114 F S C0CBCUR=$O(@C0CBS@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="") D ; SUBS LIST 115 . I $D(@C0CBH@(C0CBCUR)) Q ; SKIP IF IN HOT LIST - ALREADY DONE 116 . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-760^VITLIMIT:T-760") 117 . I $G(C0CCHK) D ; IF CHECKSUMS HAVE CHANGED 118 . . D PUTRIM^C0CFM2(C0CBCUR) 119 . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR 120 . . K C0CFDA 121 . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR 122 . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y" 123 . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR)) 124 . . D UPDIE ; CREATE UPDATE SUBFILE 125 . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL 126 . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS 127 . S C0CNOW=$$NOW^XLFDT 128 . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD 129 . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS 130 . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME 131 . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME 132 . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME 133 . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START 134 . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME 135 . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; 136 . D UPDIE ; 137 . I $D(^TMP("C0CBAT","STOP")) D ; IF STOP SIGNAL DETECTED 138 . . S C0CSTOP=1 139 . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED 140 . H 1 ; GIVE IT A BREAK 141 I (C0CSTOP) S C0CDISP="KILLED" 142 E S C0CDISP="FINISHED" 143 S C0CFDA(C0CBF,C0CIEN_",",6)=C0CDISP 144 D UPDIE ; SET DISPOSITION FIELD 145 K ^TMP("C0CBAT","RUNNING") 146 Q 147 ; 148 BLDHOT(ZHB) ; BUILD HOT LIST AT GLOBAL ZHB, PASSED BY NAME 149 ; SEARCHS FOR PATIENTS IN THE "AC" INDEX OF THE ORDER FILE 150 N ZDFN 151 S ZDFN="" 152 F S ZDFN=$O(^OR(100,"AC",ZDFN)) Q:ZDFN="" D ; ALL PATIENTS IN THE AC INDX 153 . S ZZDFN=$P(ZDFN,";",1) ; FORMAT IS "N;DPT(" 154 . I '$D(@C0CBS@(ZZDFN)) Q ; SKIP IF NOT IN SUBSCRIPTION LIST 155 . S @ZHB@(ZZDFN)="" ;ADD PATIENT TO THE HOT LIST 156 Q 157 ; 158 COUNT(ZB) ; EXTRINSIC THAT RETURNS THE NUMBER OF ARRAY ELEMENTS 159 N ZI,ZN 160 S ZN=0 161 S ZI="" 162 F S ZI=$O(@ZB@(ZI)) Q:ZI="" D ; 163 . S ZN=ZN+1 164 Q ZN 165 ; 166 UPDIEVARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE 167 ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO 168 ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO 169 ; 170 N ZCCRD,ZVARN,C0CFDA2 171 S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY 172 S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 173 I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT 174 . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE 175 . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! 176 . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE 177 . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE 178 . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN 179 . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY 180 . I $D(ZERR) D ; LAYGO ERROR 181 . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! 182 . E D ; 183 . . D CLEAN^DILF ; CLEAN UP 184 . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 185 . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! 186 Q ZVARN 187 ; 188 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 189 K ZERR 190 D CLEAN^DILF 191 D UPDATE^DIE("","C0CFDA","","ZERR") 192 I $D(ZERR) D ; 193 . W "ERROR",! 194 . ZWR ZERR 195 . B 196 K C0CFDA 197 Q 198 ; 199 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 200 ; TO SET TO VALUE C0CSV. 201 ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE 202 ; C0CSN,C0CSV ARE PASSED BY VALUE 203 ; 204 N C0CSI,C0CSJ 205 S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER 206 S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER 207 S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV 208 Q 209 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 210 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) 211 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 212 I '$D(ZTAB) S ZTAB="C0CA" 213 N ZR 214 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) 215 E S ZR="" 216 Q ZR 217 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 218 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) 219 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 220 I '$D(ZTAB) S ZTAB="C0CA" 221 N ZR 222 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) 223 E S ZR="" 224 Q ZR 225 ; 226 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 227 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) 228 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 229 I '$D(ZTAB) S ZTAB="C0CA" 230 N ZR 231 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) 232 E S ZR="" 233 Q ZR 234 ; -
ccr/branches/ohum/p/C0CCCD.m
r1342 r1428 1 C0CCCD 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 EXPORT 24 25 26 27 28 29 30 31 XPAT(DFN,DIR,FN) 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) 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 INITSTPS(TAB) 149 150 151 152 153 154 155 156 157 SHAVE(SHXML) 158 159 160 161 162 163 164 165 166 167 168 169 170 UNSHAVE(ORIGXML,SHXML) 171 172 173 174 175 176 177 178 179 180 181 182 183 HDRMAP(CXML,DFN,IHDR) 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 ACTLST(AXML,ACTRTN) 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 TEST 228 229 230 231 ZTEST(WHICH) 232 233 234 235 236 237 TLIST 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 1 C0CCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 ; EXPORT A CCR 22 ; 23 EXPORT ; EXPORT ENTRY POINT FOR CCR 24 ; Select a patient. 25 S DIC=2,DIC(0)="AEMQ" D ^DIC 26 I Y<1 Q ; EXIT 27 S DFN=$P(Y,U,1) ; SET THE PATIENT 28 D XPAT(DFN,"","") ; EXPORT TO A FILE 29 Q 30 ; 31 XPAT(DFN,DIR,FN) ; EXPORT ONE PATIENT TO A FILE 32 ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR") 33 ; FN IS FILE NAME, DEFAULTS IF NULL 34 ; N CCDGLO 35 D CCDRPC(.CCDGLO,DFN,"CCD","","","") 36 S OARY=$NA(^TMP("C0CCCR",$J,DFN,"CCD",1)) 37 S ONAM=FN 38 I FN="" S ONAM="PAT_"_DFN_"_CCD_V1.xml" 39 S ODIRGLB=$NA(^TMP("C0CCCR","ODIR")) 40 I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET 41 . S @ODIRGLB="/home/glilly/CCROUT" 42 . ;S @ODIRGLB="/home/cedwards/" 43 . ;S @ODIRGLB="/opt/wv/p/" 44 S ODIR=DIR 45 I DIR="" S ODIR=@ODIRGLB 46 N ZY 47 S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR) 48 W $P(ZY,U,2) 49 Q 50 ; 51 CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) ;RPC ENTRY POINT FOR CCR OUTPUT 52 ; CCRGRTN IS RETURN ARRAY PASSED BY NAME 53 ; DFN IS PATIENT IEN 54 ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART 55 ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC 56 ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL 57 ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME 58 ; - NULL MEANS NOW 59 ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND 60 ; "TO" VARIABLES 61 ; IF NULL WILL DEFAULT TO "FROM" ORGANIZATION AND "TO" DFN 62 I '$D(DEBUG) S DEBUG=0 63 N CCD S CCD=0 ; FLAG FOR PROCESSING A CCD 64 I CCRPART="CCD" S CCD=1 ; WE ARE PROCESSING A CCD 65 S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE 66 I CCD S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCD")) ; GLOBAL FOR THE CCD 67 E S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR 68 S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS 69 ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC 70 S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL 71 I CCD D LOAD^C0CCCD1(TGLOBAL) ; LOAD THE CCR TEMPLATE 72 E D LOAD^C0CCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE 73 D CP^C0CXPATH(TGLOBAL,CCDGLO) ; COPY THE TEMPLATE TO CCR GLOBAL 74 N CAPSAVE,CAPSAVE2 ; FOR HOLDING THE CCD ROOT LINES 75 S CAPSAVE=@TGLOBAL@(3) ; SAVE THE CCD ROOT 76 S CAPSAVE2=@TGLOBAL@(@TGLOBAL@(0)) ; SAVE LAST LINE OF CCD 77 S @CCDGLO@(3)="<ContinuityOfCareRecord>" ; CAP WITH CCR ROOT 78 S @TGLOBAL@(3)=@CCDGLO@(3) ; CAP THE TEMPLATE TOO 79 S @CCDGLO@(@CCDGLO@(0))="</ContinuityOfCareRecord>" ; FINISH CAP 80 S @TGLOBAL@(@TGLOBAL@(0))="</ContinuityOfCareRecord>" ; FINISH CAP TEMP 81 ; 82 ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL 83 ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES 84 D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Body") 85 D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Actors") 86 I 'CCD D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Signatures") 87 I DEBUG F I=1:1:@CCDGLO@(0) W @CCDGLO@(I),! 88 ; 89 I 'CCD D HDRMAP(CCDGLO,DFN,HDRARY) ; MAP HEADER VARIABLES 90 ; MAPPING THE PATIENT PORTION OF THE CDA HEADER 91 S ZZX="//ContinuityOfCareRecord/recordTarget/patientRole/patient" 92 D QUERY^C0CXPATH(CCDGLO,ZZX,"ACTT1") 93 D PATIENT^C0CACTOR("ACTT1",DFN,"ACTORPATIENT_"_DFN,"ACTT2") ; MAP PATIENT 94 I DEBUG D PARY^C0CXPATH("ACTT2") 95 D REPLACE^C0CXPATH(CCDGLO,"ACTT2",ZZX) 96 I DEBUG D PARY^C0CXPATH(CCDGLO) 97 K ACTT1 K ACCT2 98 ; MAPPING THE PROVIDER ORGANIZATION,AUTHOR,INFORMANT,CUSTODIAN CDA HEADER 99 ; FOR NOW, THEY ARE ALL THE SAME AND RESOLVE TO ORGANIZATION 100 D ORG^C0CACTOR(CCDGLO,DFN,"ACTORPATIENTORGANIZATION","ACTT2") ; MAP ORG 101 D CP^C0CXPATH("ACTT2",CCDGLO) 102 ; 103 K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT 104 S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS 105 D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS 106 N I,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD 107 F I=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS 108 . S XI=@CCRXTAB@(I) ; CALL COPONENTS TO PARSE 109 . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL 110 . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL 111 . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE 112 . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS 113 . S IXML="INXML" 114 . I CCD D SHAVE(IXML) ; REMOVE ALL BUT REPEATING PARTS OF TEMPLATE SECTION 115 . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES 116 . ; W OXML,! 117 . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL 118 . W "RUNNING ",CALL,! 119 . X CALL 120 . I @OXML@(0)'=0 D ; THERE IS A RESULT 121 . . I CCD D QUERY^C0CXPATH(TGLOBAL,XPATH,"ITMP") ; XML TO UNSHAVE WITH 122 . . I CCD D UNSHAVE("ITMP",OXML) 123 . . I CCD D UNMARK^C0CXPATH(OXML) ; REMOVE THE CCR MARKUP FROM SECTION 124 . ; NOW INSERT THE RESULTS IN THE CCR BUFFER 125 . D INSERT^C0CXPATH(CCDGLO,OXML,"//ContinuityOfCareRecord/Body") 126 . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),! 127 ; NEED TO ADD BACK IN ACTOR PROCESSING AFTER WE FIGURE OUT LINKAGE 128 ; D ACTLST^C0CCCR(CCDGLO,ACTGLO) ; GEN THE ACTOR LIST 129 ; D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") 130 ; D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2") 131 ; D INSINNER^C0CXPATH(CCDGLO,"ACTT2","//ContinuityOfCareRecord/Actors") 132 N I,J,DONE S DONE=0 133 F I=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE 134 . S J=$$TRIM^C0CXPATH(CCDGLO) ; DELETE EMPTY ELEMENTS 135 . W "TRIMMED",J,! 136 . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE 137 I CCD D ; TURN THE BODY INTO A CCD COMPONENT 138 . N I 139 . F I=1:1:@CCDGLO@(0) D ; SEARCH THROUGH THE ENTIRE ARRAY 140 . . I @CCDGLO@(I)["<Body>" D ; REPLACE BODY MARKUP 141 . . . S @CCDGLO@(I)="<component><structuredBody>" ; WITH CCD EQ 142 . . I @CCDGLO@(I)["</Body>" D ; REPLACE BODY MARKUP 143 . . . S @CCDGLO@(I)="</structuredBody></component>" 144 S @CCDGLO@(3)=CAPSAVE ; UNCAP - TURN IT BACK INTO A CCD 145 S @CCDGLO@(@CCDGLO@(0))=CAPSAVE2 ; UNCAP LAST LINE 146 Q 147 ; 148 INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS 149 ; TAB IS PASSED BY NAME 150 W "TAB= ",TAB,! 151 ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS 152 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")") 153 ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")") 154 I 'CCD D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") 155 Q 156 ; 157 SHAVE(SHXML) ; REMOVES THE 2-6 AND N-1 AND N-2 LINES FROM A COMPONENT 158 ; NEEDED TO EXPOSE THE REPEATING PARTS FOR GENERATION 159 N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST 160 W SHXML,! 161 W @SHXML@(1),! 162 D QUEUE^C0CXPATH("SHBLD",SHXML,1,1) ; THE FIRST LINE IS NEEDED 163 D QUEUE^C0CXPATH("SHBLD",SHXML,7,@SHXML@(0)-3) ; REPEATING PART 164 D QUEUE^C0CXPATH("SHBLD",SHXML,@SHXML@(0),@SHXML@(0)) ; LAST LINE 165 D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST 166 D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION 167 D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY 168 Q 169 ; 170 UNSHAVE(ORIGXML,SHXML) ; REPLACES THE 2-6 AND N-1 AND N-2 LINES FROM TEMPLATE 171 ; NEEDED TO RESTORM FIXED TOP AND BOTTOM OF THE COMPONENT XML 172 N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST 173 W SHXML,! 174 W @SHXML@(1),! 175 D QUEUE^C0CXPATH("SHBLD",ORIGXML,1,6) ; FIRST 6 LINES OF TEMPLATE 176 D QUEUE^C0CXPATH("SHBLD",SHXML,2,@SHXML@(0)-1) ; INS ALL BUT FIRST/LAST 177 D QUEUE^C0CXPATH("SHBLD",ORIGXML,@ORIGXML@(0)-2,@ORIGXML@(0)) ; FROM TEMP 178 D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST 179 D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION 180 D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY 181 Q 182 ; 183 HDRMAP(CXML,DFN,IHDR) ; MAP HEADER VARIABLES: FROM, TO ECT 184 N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER")) 185 ; K @VMAP 186 S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT") 187 I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS 188 . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN 189 . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? 190 . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM 191 . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES 192 . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES 193 . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES 194 . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT 195 I IHDR'="" D ; HEADER VALUES ARE PROVIDED 196 . D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY 197 N CTMP 198 D MAP^C0CXPATH(CXML,VMAP,"CTMP") 199 D CP^C0CXPATH("CTMP",CXML) 200 Q 201 ; 202 ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML 203 ; AXML AND ACTRTN ARE PASSED BY NAME 204 ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 205 ; P1= OBJECTID - ACTORPATIENT_2 206 ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE 207 ;OR INSTITUTION 208 ; OR PERSON(IN PATIENT FILE IE NOK) 209 ; P3= IEN RECORD NUMBER FOR ACTOR - 2 210 N I,J,K,L 211 K @ACTRTN ; CLEAR RETURN ARRAY 212 F I=1:1:@AXML@(0) D ; SCAN ALL LINES 213 . I @AXML@(I)?.E1"<ActorID>".E D ; THERE IS AN ACTOR THIS LINE 214 . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1) 215 . . W "<ActorID>=>",J,! 216 . . I J'="" S K(J)="" ; HASHING ACTOR 217 . . ; TO GET RID OF DUPLICATES 218 S I="" ; GOING TO $O THROUGH THE HASH 219 F J=0:0 D Q:$O(K(I))="" ; 220 . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS 221 . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID 222 . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE 223 . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR 224 . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY 225 Q 226 ; 227 TEST ; RUN ALL THE TEST CASES 228 D TESTALL^C0CUNIT("C0CCCR") 229 Q 230 ; 231 ZTEST(WHICH) ; RUN ONE SET OF TESTS 232 N ZTMP 233 D ZLOAD^C0CUNIT("ZTMP","C0CCCR") 234 D ZTEST^C0CUNIT(.ZTMP,WHICH) 235 Q 236 ; 237 TLIST ; LIST THE TESTS 238 N ZTMP 239 D ZLOAD^C0CUNIT("ZTMP","C0CCCR") 240 D TLIST^C0CUNIT(.ZTMP) 241 Q 242 ; 243 ;;><TEST> 244 ;;><PROBLEMS> 245 ;;>>>K C0C S C0C="" 246 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","","","") 247 ;;>>?@C0C@(@C0C@(0))["</Problems>" 248 ;;><VITALS> 249 ;;>>>K C0C S C0C="" 250 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","","","") 251 ;;>>?@C0C@(@C0C@(0))["</VitalSigns>" 252 ;;><CCR> 253 ;;>>>K C0C S C0C="" 254 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","") 255 ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>" 256 ;;><ACTLST> 257 ;;>>>K C0C S C0C="" 258 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","") 259 ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST") 260 ;;><ACTORS> 261 ;;>>>D ZTEST^C0CCCR("ACTLST") 262 ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") 263 ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3") 264 ;;>>?G3(G3(0))["</Actors>" 265 ;;><TRIM> 266 ;;>>>D ZTEST^C0CCCR("CCR") 267 ;;>>>W $$TRIM^C0CXPATH(CCDGLO) 268 ;;><CCD> 269 ;;>>>K C0C S C0C="" 270 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCD","","","") 271 ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>" 272 ;;></TEST> -
ccr/branches/ohum/p/C0CCCD1.m
r1342 r1428 1 C0CCCD1 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 ZT(ZARY,BAT,LINE) 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 ZLOAD(ZARY,ROUTINE) 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 LOAD(ARY) 61 62 63 64 65 TRMCCD 66 67 MARKUP 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 1 C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 W "This is a CCD TEMPLATE with processing routines",! 22 W ! 23 Q 24 ; 25 ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array 26 ; ZARY IS PASSED BY NAME 27 ; BAT is a string identifying the section 28 ; LINE is a test which will evaluate to true or false 29 ; I '$G(@ZARY) D ; IF ZARY DOES NOT EXIST ' 30 ; . S @ZARY@(0)=0 ; initially there are no elements 31 ; . W "GOT HERE LOADING "_LINE,! 32 N CNT ; count of array elements 33 S CNT=@ZARY@(0) ; contains array count 34 S CNT=CNT+1 ; increment count 35 S @ZARY@(CNT)=LINE ; put the line in the array 36 ; S @ZARY@(BAT,CNT)="" ; index the test by battery 37 S @ZARY@(0)=CNT ; update the array counter 38 Q 39 ; 40 ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference 41 ; ZARY IS PASSED BY NAME 42 ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") 43 ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE 44 K @ZARY S @ZARY="" 45 S @ZARY@(0)=0 ; initialize array count 46 N LINE,LABEL,BODY 47 N INTEST S INTEST=0 ; switch for in the TEMPLATE section 48 N SECTION S SECTION="[anonymous]" ; NO section LABEL 49 ; 50 N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D 51 . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section 52 . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section 53 . I INTEST D ; within the section 54 . . I LINE?." "1";><".E D ; sub-section name found 55 . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name 56 . . I LINE?." "1";;".E D ; line found 57 . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array 58 Q 59 ; 60 LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME 61 D ZLOAD(ARY,"C0CCCD1") 62 ; ZWR @ARY 63 Q 64 ; 65 TRMCCD ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD 66 Q 67 MARKUP ;<MARKUP> 68 ;;<Body> 69 ;;<Problems> 70 ;;</Problems> 71 ;;<FamilyHistory> 72 ;;</FamilyHistory> 73 ;;<SocialHistory> 74 ;;</SocialHistory> 75 ;;<Alerts> 76 ;;</Alerts> 77 ;;<Medications> 78 ;;</Medications> 79 ;;<VitalSigns> 80 ;;</VitalSigns> 81 ;;<Results> 82 ;;</Results> 83 ;;</Body> 84 ;;</ContinuityOfCareRecord> 85 ;</MARKUP> 86 ;;<ClinicalDocument xmlns="urn:hl7-org:v3" xmlns:voc="urn:hl7-org:v3/voc" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="urn:hl7-org:v3 CDA.xsd"> 87 ;;</ClinicalDocument> 88 Q 89 ; 90 ;<TEMPLATE> 91 ;;<?xml version="1.0"?> 92 ;;<?xml-stylesheet type="text/xsl" href="CCD.xsl"?> 93 ;;<ClinicalDocument xmlns="urn:hl7-org:v3" xmlns:voc="urn:hl7-org:v3/voc" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="urn:hl7-org:v3 CDA.xsd"> 94 ;;<typeId root="2.16.840.1.113883.1.3" extension="POCD_HD000040"/> 95 ;;<templateId root="2.16.840.1.113883.10.20.1"/> 96 ;;<id root="db734647-fc99-424c-a864-7e3cda82e703"/> 97 ;;<code code="34133-9" codeSystem="2.16.840.1.113883.6.1" displayName="Summarization of episode note"/> 98 ;;<title>Continuity of Care Document</title> 99 ;;<effectiveTime value="20000407130000+0500"/> 100 ;;<confidentialityCode code="N" codeSystem="2.16.840.1.113883.5.25"/> 101 ;;<languageCode code="en-US"/> 102 ;;<recordTarget> 103 ;;<patientRole> 104 ;;<id extension="@@ACTORIEN@@" root="2.16.840.1.113883.19.5"/> 105 ;;<patient> 106 ;;<name> 107 ;;<given>@@ACTORGIVENNAME@@</given> 108 ;;<family>@@ACTORFAMILYNAME@@</family> 109 ;;<suffix>@@ACTORSUFFIXNAME@@</suffix> 110 ;;</name> 111 ;;<administrativeGenderCode code="@@ACTORGENDER@@" codeSystem="2.16.840.1.113883.5.1"/> 112 ;;<birthTime value="@@ACTORDATEOFBIRTH@@"/> 113 ;;</patient> 114 ;;<providerOrganization> 115 ;;<id root="2.16.840.1.113883.19.5"/> 116 ;;<name>@@ORGANIZATIONNAME@@</name> 117 ;;</providerOrganization> 118 ;;</patientRole> 119 ;;</recordTarget> 120 ;;<author> 121 ;;<time value="20000407130000+0500"/> 122 ;;<assignedAuthor> 123 ;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/> 124 ;;<assignedPerson> 125 ;;<name> 126 ;;<prefix>@@ACTORNAMEPREFIX@@</prefix> 127 ;;<given>@@ACTORGIVENNAME@@</given> 128 ;;<family>@@ACTORFAMILYNAME@@</family> 129 ;;</name> 130 ;;</assignedPerson> 131 ;;<representedOrganization> 132 ;;<id root="2.16.840.1.113883.19.5"/> 133 ;;<name>@@ORGANIZATIONNAME@@</name> 134 ;;</representedOrganization> 135 ;;</assignedAuthor> 136 ;;</author> 137 ;;<informant> 138 ;;<assignedEntity> 139 ;;<id nullFlavor="NI"/> 140 ;;<representedOrganization> 141 ;;<id root="2.16.840.1.113883.19.5"/> 142 ;;<name>@@ORGANIZATIONNAME@@</name> 143 ;;</representedOrganization> 144 ;;</assignedEntity> 145 ;;</informant> 146 ;;<custodian> 147 ;;<assignedCustodian> 148 ;;<representedCustodianOrganization> 149 ;;<id root="2.16.840.1.113883.19.5"/> 150 ;;<name>@@ORGANIZATIONNAME@@</name> 151 ;;</representedCustodianOrganization> 152 ;;</assignedCustodian> 153 ;;</custodian> 154 ;;<legalAuthenticator> 155 ;;<time value="20000407130000+0500"/> 156 ;;<signatureCode code="S"/> 157 ;;<assignedEntity> 158 ;;<id nullFlavor="NI"/> 159 ;;<representedOrganization> 160 ;;<id root="2.16.840.1.113883.19.5"/> 161 ;;<name>@@ORGANIZATIONNAME@@</name> 162 ;;</representedOrganization> 163 ;;</assignedEntity> 164 ;;</legalAuthenticator> 165 ;;<Actors> 166 ;;<ACTOR-NOK> 167 ;;<participant typeCode="IND"> 168 ;;<associatedEntity classCode="NOK"> 169 ;;<id root="4ac71514-6a10-4164-9715-f8d96af48e6d"/> 170 ;;<code code="65656005" codeSystem="2.16.840.1.113883.6.96" displayName="Biiological mother"/> 171 ;;<telecom value="tel:(999)555-1212"/> 172 ;;<associatedPerson> 173 ;;<name> 174 ;;<given>Henrietta</given> 175 ;;<family>Levin</family> 176 ;;</name> 177 ;;</associatedPerson> 178 ;;</associatedEntity> 179 ;;</participant> 180 ;;</ACTOR-NOK> 181 ;;</Actors> 182 ;;<documentationOf> 183 ;;<serviceEvent classCode="PCPR"> 184 ;;<effectiveTime> 185 ;;<high value="@@DATETIME@@"/> 186 ;;</effectiveTime> 187 ;;<performer typeCode="PRF"> 188 ;;<functionCode code="PCP" codeSystem="2.16.840.1.113883.5.88"/> 189 ;;<time> 190 ;;<low value="1990"/> 191 ;;<high value='20000407'/> 192 ;;</time> 193 ;;<assignedEntity> 194 ;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/> 195 ;;<assignedPerson> 196 ;;<name> 197 ;;<prefix>@@ACTORPREFIXNAME@@</prefix> 198 ;;<given>@@ACTORGIVENNAME@@</given> 199 ;;<family>@@ACTORFAMILYNAME@@</family> 200 ;;</name> 201 ;;</assignedPerson> 202 ;;<representedOrganization> 203 ;;<id root="2.16.840.1.113883.19.5"/> 204 ;;<name>@@ORGANIZATIONNAME@@</name> 205 ;;</representedOrganization> 206 ;;</assignedEntity> 207 ;;</performer> 208 ;;</serviceEvent> 209 ;;</documentationOf> 210 ;;<Body> 211 ;;<PROBLEMS-HTML> 212 ;;<text><table border="1" width="100%"><thead><tr><th>Condition</th><th>Effective Dates</th><th>Condition Status</th></tr></thead><tbody> 213 ;;<tr><td>@@PROBLEMDESCRIPTION@@</td> 214 ;;<td>@@PROBLEMDATEOFONSET@@</td> 215 ;;<td>Active</td></tr> 216 ;;</tbody></table></text> 217 ;;</PROBLEMS-HTML> 218 ;;<Problems> 219 ;;<component> 220 ;;<section> 221 ;;<templateId root='2.16.840.1.113883.10.20.1.11'/> 222 ;;<code code="11450-4" codeSystem="2.16.840.1.113883.6.1"/> 223 ;;<title>Problems</title> 224 ;;<entry typeCode="DRIV"> 225 ;;<act classCode="ACT" moodCode="EVN"> 226 ;;<templateId root='2.16.840.1.113883.10.20.1.27'/> 227 ;;<id root="6a2fa88d-4174-4909-aece-db44b60a3abb"/> 228 ;;<code nullFlavor="NA"/> 229 ;;<entryRelationship typeCode="SUBJ"> 230 ;;<observation classCode="OBS" moodCode="EVN"> 231 ;;<templateId root='2.16.840.1.113883.10.20.1.28'/> 232 ;;<id root="d11275e7-67ae-11db-bd13-0800200c9a66"/> 233 ;;<code code="ASSERTION" codeSystem="2.16.840.1.113883.5.4"/> 234 ;;<statusCode code="completed"/> 235 ;;<effectiveTime> 236 ;;<low value="@@PROBLEMDATEOFONSET@@"/> 237 ;;</effectiveTime> 238 ;;<value xsi:type="CD" code="@@PROBLEMCODEVALUE@@" codeSystem="2.16.840.1.113883.6.96" displayName="@@PROBLEMDESCRIPTION@@"/> 239 ;;<entryRelationship typeCode="REFR"> 240 ;;<observation classCode="OBS" moodCode="EVN"> 241 ;;<templateId root='2.16.840.1.113883.10.20.1.50'/> 242 ;;<code code="33999-4" codeSystem="2.16.840.1.113883.6.1" displayName="Status"/> 243 ;;<statusCode code="completed"/> 244 ;;<value xsi:type="CE" code="55561003" codeSystem="2.16.840.1.113883.6.96" displayName="Active"/> 245 ;;</observation> 246 ;;</entryRelationship> 247 ;;</observation> 248 ;;</entryRelationship> 249 ;;</act> 250 ;;</entry> 251 ;;</section> 252 ;;</component> 253 ;;</Problems> 254 ;;<FamilyHistory> 255 ;;</FamilyHistory> 256 ;;<SocialHistory> 257 ;;</SocialHistory> 258 ;;<Alerts> 259 ;;</Alerts> 260 ;;<Medications> 261 ;;</Medications> 262 ;;<VitalSigns> 263 ;;</VitalSigns> 264 ;;<Results> 265 ;;</Results> 266 ;;</Body> 267 ;;</ClinicalDocument> 268 ;</TEMPLATE> -
ccr/branches/ohum/p/C0CCCR.m
r1342 r1428 1 C0CCCR 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 EXPORT 24 25 26 27 28 29 30 31 32 33 34 35 36 XPAT(DFN,XPARMS,DIR,FN) 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 DCCR(DFN) 67 68 69 70 71 72 73 74 75 CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART) 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 INITSTPS(TAB) 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 HDRMAP(CXML,DFN) 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 ACTLST(AXML,ACTRTN) 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 TEST 245 246 247 248 ZTEST(WHICH) 249 250 251 252 253 254 TLIST 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 1 C0CCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 ; EXPORT A CCR 22 ; 23 EXPORT ; EXPORT ENTRY POINT FOR CCR 24 ; Select a patient. 25 S DIC=2,DIC(0)="AEMQ" D ^DIC 26 I Y<1 Q ; EXIT 27 S DFN=$P(Y,U,1) ; SET THE PATIENT 28 ;OHUM/RUT 3120109 commented 29 ;;OHUM/RUT 3120102 To take inputs from user for date limits and notes 30 ;D ^C0CVALID 31 ;;OHUM/RUT 32 ;OHUM/RUT 33 D XPAT(DFN) ; EXPORT TO A FILE 34 Q 35 ; 36 XPAT(DFN,XPARMS,DIR,FN) ; EXPORT ONE PATIENT TO A FILE 37 ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR") 38 ; FN IS FILE NAME, DEFAULTS IF NULL 39 N CCRGLO,UDIR,UFN 40 S C0CNRPC=1 ; FLAG FOR NOT AN RPC CALL - FOR DEBUGGING THE RPC 41 I '$D(DIR) S UDIR="" 42 E S UDIR=DIR 43 I '$D(FN) S UFN="" ; IF FILENAME IS NOT PASSED 44 E S UFN=FN 45 I '$D(XPARMS) S XPARMS="" 46 N C0CRTN ; RETURN ARRAY 47 D CCRRPC(.C0CRTN,DFN,XPARMS,"CCR") 48 S OARY=$NA(^TMP("C0CCUR",$J,DFN,"CCR",1)) 49 S ONAM=UFN 50 I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_0.xml" 51 S ODIRGLB=$NA(^TMP("C0CCCR","ODIR")) 52 S ^TMP("C0CCCR","FNAME",DFN)=ONAM ; FILE NAME FOR BATCH USE 53 I $D(^TMP("GPLCCR","ODIR")) S @ODIRGLB=^TMP("GPLCCR","ODIR") 54 I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET 55 . W "Warning.. please set ^TMP(""C0CCCR"",""ODIR"")=""output path""",! Q 56 . ;S @ODIRGLB="/home/glilly/CCROUT" 57 . ;S @ODIRGLB="/home/cedwards/" 58 . S @ODIRGLB="/opt/wv/p/" 59 S ODIR=UDIR 60 I UDIR="" S ODIR=@ODIRGLB 61 N ZY 62 S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR) 63 W !,$P(ZY,U,2),! 64 Q 65 ; 66 DCCR(DFN) ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED 67 ; 68 N G1 69 S G1=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) 70 I $D(@G1@(0)) D ; CCR EXISTS 71 . D PARY^C0CXPATH(G1) 72 E W "CCR NOT CREATED, RUN D XPAT^C0CCCR(DFN,"""","""") FIRST",! 73 Q 74 ; 75 CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART) ;RPC ENTRY POINT FOR CCR OUTPUT 76 ; CCRGRTN IS RETURN ARRAY PASSED BY REFERENCE 77 ; DFN IS PATIENT IEN 78 ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART 79 ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC 80 ; CCRPARMS ARE PARAMETERS THAT AFFECT THE EXTRACTION 81 ; IN THE FORM "PARM1:VALUE1^PARM2:VALUE2" 82 ; EXAMPLE: "LABLIMIT:T-60" TO LIMIT LAB EXTRACTION TO THE LAST 60 DAYS 83 ; SEE C0CPARMS FOR A COMPLETE LIST OF SUPPORTED PARAMETERS 84 K ^TMP("C0CCCR",$J) ; CLEAN UP THE GLOBAL BEFORE WE USE IT 85 M ^TMP("C0CSAV",$J)=^TMP($J) ; SAVING CALLER'S TMP SETTINGS 86 K ^TMP($J) ; START CLEAN 87 I '$D(DEBUG) S DEBUG=0 88 S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD 89 I '$D(CCRPARMS) S CCRPARMS="" 90 I '$D(CCRPART) S CCRPART="CCR" 91 I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"CALL",DFN)="" 92 D SET^C0CPARMS(CCRPARMS) ;SET PARAMETERS WITH CCRPARMS AS OVERRIDES 93 I '$D(TESTVIT) S TESTVIT=0 ; FLAG FOR TESTING VITALS 94 I '$D(TESTLAB) S TESTLAB=0 ; FLAG FOR TESTING RESULTS SECTION 95 I '$D(TESTALERT) S TESTALERT=1 ; FLAG FOR TESTING ALERTS SECTION 96 I '$D(TESTMEDS) S TESTMEDS=0 ; FLAG FOR TESTING C0CMED SECTION 97 S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE 98 S CCRGLO=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR 99 S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS 100 ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC 101 ;M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART OR ALL 102 D LOAD^C0CCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE 103 D CP^C0CXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL 104 ; 105 ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL 106 ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES 107 D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body") 108 D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") 109 D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") 110 D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Comments") 111 I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! 112 ; 113 D HDRMAP(CCRGLO,DFN) ; MAP HEADER VARIABLES 114 ; 115 K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT 116 S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS 117 D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS 118 N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD 119 F PROCI=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS 120 . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE 121 . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL 122 . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL 123 . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE 124 . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS 125 . S IXML="INXML" 126 . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES 127 . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY 128 . ; W OXML,! 129 . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL 130 . W "RUNNING ",CALL,! 131 . X CALL 132 . ; NOW INSERT THE RESULTS IN THE CCR BUFFER 133 . I $G(@OXML@(0))>0 D ; THERE IS A RESULT 134 . . D INSERT^C0CXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body") 135 . . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),! 136 N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING 137 D ACTLST^C0CCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST 138 D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") 139 D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2") 140 D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors") 141 K ACTT,ACTT2 142 ;D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT") 143 ;D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2") 144 ;D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments") 145 ; gpl - turned off Comments for Certification 146 K CMTT,CMTT2 147 N TRIMI,J,DONE S DONE=0 148 F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE 149 . S J=$$TRIM^C0CXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS 150 . I DEBUG W "TRIMMED",J,! 151 . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE 152 ;S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLOBAL OF PART OR ALL 153 I CCRPART="CCR" M CCRGRTN=@CCRGLO ; ENTIRE CCR 154 E M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART 155 I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"RESULT",CCRGRTN(0))="" 156 K ^TMP("C0CCCR",$J) ; BEGIN TO CLEAN UP 157 K ^TMP($J) ; REALLY CLEAN UP 158 M ^TMP($J)=^TMP("C0CSAV",$J) ; RESTORE CALLER'S $J 159 Q 160 ; 161 INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS 162 ; TAB IS PASSED BY NAME 163 I DEBUG W "TAB= ",TAB,! 164 ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS 165 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")") 166 I TESTALERT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""C0CCCR"",$J,DFN,""ALERTS"")") 167 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")") 168 D PUSH^C0CXPATH(TAB,"MAP;C0CIMMU;//ContinuityOfCareRecord/Body/Immunizations;^TMP(""C0CCCR"",$J,DFN,""IMMUNE"")") 169 I TESTVIT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVIT2;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") 170 E D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") 171 D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")") 172 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROC;//ContinuityOfCareRecord/Body/Procedures;^TMP(""C0CCCR"",$J,DFN,""PROCEDURES"")") 173 ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") 174 ; gpl - turned off Encounters for Certification 175 ;OHUM/RUT 3120109 Changed the condition 176 ;;OHUM/RUT 3111228 Condition for Notes ; It should be included or not 177 ;;I ^TMP("C0CCCR","TIULIMIT")'="" D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") 178 I $P(^C0CPARM(1,2),"^",3)=1 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") 179 ;;OHUM/RUT 180 ;OHUM/RUT 181 Q 182 ; 183 HDRMAP(CXML,DFN) ; MAP HEADER VARIABLES: FROM, TO ECT 184 N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER")) 185 ; K @VMAP 186 S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT") 187 ; I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS 188 D ; ALWAYS MAP THESE VARIABLES 189 . S @VMAP@("CCRDOCOBJECTID")=$$UUID^C0CUTIL ; UUID FOR THIS CCR 190 . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN 191 . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - FROM PROVIDER 192 . ;S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? 193 . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM 194 . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES 195 . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES 196 . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES 197 . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT 198 ;I IHDR'="" D ; HEADER VALUES ARE PROVIDED 199 ;. D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY 200 N CTMP 201 D MAP^C0CXPATH(CXML,VMAP,"CTMP") 202 D CP^C0CXPATH("CTMP",CXML) 203 N HRIMVARS ; 204 S HRIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"HEADER")) ; TO PERSIST VARS 205 M @HRIMVARS@(1)=@VMAP ; PERSIST THE HEADER VARIABLES IN RIM TABLE 206 S @HRIMVARS@(0)=1 ; ONLY ONE SET OF HEADERS PER PATIENT 207 Q 208 ; 209 ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML 210 ; AXML AND ACTRTN ARE PASSED BY NAME 211 ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 212 ; P1= OBJECTID - ACTORPATIENT_2 213 ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE 214 ;OR INSTITUTION 215 ; OR PERSON(IN PATIENT FILE IE NOK) 216 ; P3= IEN RECORD NUMBER FOR ACTOR - 2 217 N I,J,K,L 218 K @ACTRTN ; CLEAR RETURN ARRAY 219 F I=1:1:@AXML@(0) D ; FIRST FIX MISSING LINKS 220 . I @AXML@(I)?.E1"_<".E D ; 221 . . N ZA,ZB 222 . . S ZA=$P(@AXML@(I),">",1)_">" 223 . . S ZB="<"_$P(@AXML@(I),"<",3) 224 . . S @AXML@(I)=ZA_"ACTORORGANIZATION_1"_ZB 225 F I=1:1:@AXML@(0) D ; SCAN ALL LINES 226 . I @AXML@(I)?.E1"<ActorID>".E D ; THERE IS AN ACTOR THIS LINE 227 . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1) 228 . . I $G(LINKDEBUG) W "<ActorID>=>",J,! 229 . . I J'="" S K(J)="" ; HASHING ACTOR 230 . I @AXML@(I)?.E1"<LinkID>".E D ; THERE IS AN ACTOR THIS LINE 231 . . S J=$P($P(@AXML@(I),"<LinkID>",2),"</LinkID>",1) 232 . . I $G(LINKDEBUG) W "<LinkID>=>",J,! 233 . . I J'="" S K(J)="" ; HASHING ACTOR 234 . . ; TO GET RID OF DUPLICATES 235 S I="" ; GOING TO $O THROUGH THE HASH 236 F J=0:0 D Q:$O(K(I))="" 237 . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS 238 . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID 239 . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE 240 . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR 241 . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY 242 Q 243 ; 244 TEST ; RUN ALL THE TEST CASES 245 D TESTALL^C0CUNIT("C0CCCR") 246 Q 247 ; 248 ZTEST(WHICH) ; RUN ONE SET OF TESTS 249 N ZTMP 250 D ZLOAD^C0CUNIT("ZTMP","C0CCCR") 251 D ZTEST^C0CUNIT(.ZTMP,WHICH) 252 Q 253 ; 254 TLIST ; LIST THE TESTS 255 N ZTMP 256 D ZLOAD^C0CUNIT("ZTMP","C0CCCR") 257 D TLIST^C0CUNIT(.ZTMP) 258 Q 259 ; 260 ;;><TEST> 261 ;;><PROBLEMS> 262 ;;>>>K C0C S C0C="" 263 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","") 264 ;;>>?@C0C@(@C0C@(0))["</Problems>" 265 ;;><VITALS> 266 ;;>>>K C0C S C0C="" 267 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","") 268 ;;>>?@C0C@(@C0C@(0))["</VitalSigns>" 269 ;;><CCR> 270 ;;>>>K C0C S C0C="" 271 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","") 272 ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>" 273 ;;><ACTLST> 274 ;;>>>K C0C S C0C="" 275 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","") 276 ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST") 277 ;;><ACTORS> 278 ;;>>>D ZTEST^C0CCCR("ACTLST") 279 ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") 280 ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3") 281 ;;>>?G3(G3(0))["</Actors>" 282 ;;><TRIM> 283 ;;>>>D ZTEST^C0CCCR("CCR") 284 ;;>>>W $$TRIM^C0CXPATH(CCRGLO) 285 ;;><ALERTS> 286 ;;>>>S TESTALERT=1 287 ;;>>>K C0C S C0C="" 288 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","ALERTS","") 289 ;;>>?@C0C@(@C0C@(0))["</Alerts>" 290 291 -
ccr/branches/ohum/p/C0CCCR0.m
r1342 r1428 1 C0CCCR0 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 ZT(ZARY,BAT,LINE) 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 ZLOAD(ZARY,ROUTINE) 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 LOAD(ARY) 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 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 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 435 436 437 438 439 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 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 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 1 C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 W "This is a CCR TEMPLATE with processing routines",! 22 W ! 23 Q 24 ; 25 ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array 26 ; ZARY IS PASSED BY NAME 27 ; BAT is a string identifying the section 28 ; LINE is a test which will evaluate to true or false 29 ; I '$G(@ZARY) D ; 30 ; . S @ZARY@(0)=0 ; initially there are no elements 31 ; . W "GOT HERE LOADING "_LINE,! 32 N CNT ; count of array elements 33 S CNT=@ZARY@(0) ; contains array count 34 S CNT=CNT+1 ; increment count 35 S @ZARY@(CNT)=LINE ; put the line in the array 36 ; S @ZARY@(BAT,CNT)="" ; index the test by battery 37 S @ZARY@(0)=CNT ; update the array counter 38 Q 39 ; 40 ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference 41 ; ZARY IS PASSED BY NAME 42 ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") 43 ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE 44 K @ZARY S @ZARY="" 45 S @ZARY@(0)=0 ; initialize array count 46 N LINE,LABEL,BODY 47 N INTEST S INTEST=0 ; switch for in the TEMPLATE section 48 N SECTION S SECTION="[anonymous]" ; NO section LABEL 49 ; 50 N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D 51 . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section 52 . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section 53 . I INTEST D ; within the section 54 . . I LINE?." "1";><".E D ; sub-section name found 55 . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name 56 . . I LINE?." "1";;".E D ; line found 57 . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array 58 Q 59 ; 60 LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME 61 D ZLOAD(ARY,"C0CCCR0") 62 ; ZWR @ARY 63 Q 64 ; 65 ;<TEMPLATE> 66 ;;<?xml version="1.0" encoding="UTF-8"?> 67 ;;<?xml-stylesheet type="text/xsl" href="ccr.xsl"?> 68 ;;<ContinuityOfCareRecord xmlns="urn:astm-org:CCR"> 69 ;;<CCRDocumentObjectID>@@CCRDOCOBJECTID@@</CCRDocumentObjectID> 70 ;;<Language> 71 ;;<Text>English</Text> 72 ;;</Language> 73 ;;<Version>V1.0</Version> 74 ;;<DateTime> 75 ;;<ExactDateTime>@@DATETIME@@</ExactDateTime> 76 ;;</DateTime> 77 ;;<Patient> 78 ;;<ActorID>@@ACTORPATIENT@@</ActorID> 79 ;;</Patient> 80 ;;<From> 81 ;;<ActorLink> 82 ;;<ActorID>@@ACTORFROM@@</ActorID> 83 ;;</ActorLink> 84 ;;<ActorLink> 85 ;;<ActorID>@@ACTORFROM2@@</ActorID> 86 ;;</ActorLink> 87 ;;</From> 88 ;;<To> 89 ;;<ActorLink> 90 ;;<ActorID>@@ACTORTO@@</ActorID> 91 ;;<ActorRole> 92 ;;<Text>@@ACTORTOTEXT@@</Text> 93 ;;</ActorRole> 94 ;;</ActorLink> 95 ;;</To> 96 ;;<Purpose> 97 ;;<Description> 98 ;;<Text>@@PURPOSEDESCRIPTION@@</Text> 99 ;;</Description> 100 ;;</Purpose> 101 ;;<Body> 102 ;;<Problems> 103 ;;<Problem> 104 ;;<CCRDataObjectID>@@PROBLEMOBJECTID@@</CCRDataObjectID> 105 ;;<DateTime> 106 ;;<ExactDateTime>@@PROBLEMDATEMOD@@</ExactDateTime> 107 ;;</DateTime> 108 ;;<Type> 109 ;;<Text>Problem</Text> 110 ;;</Type> 111 ;;<Description> 112 ;;<Text>@@PROBLEMDESCRIPTION@@</Text> 113 ;;<Code> 114 ;;<Value>@@PROBLEMCODEVALUE@@</Value> 115 ;;<CodingSystem>ICD9CM</CodingSystem> 116 ;;<Version>@@PROBLEMCODINGVERSION@@</Version> 117 ;;</Code> 118 ;;</Description> 119 ;;<Status> 120 ;;<Text>@@PROBLEMSTATUS@@</Text> 121 ;;</Status> 122 ;;<Source> 123 ;;<Actor> 124 ;;<ActorID>@@PROBLEMSOURCEACTORID@@</ActorID> 125 ;;</Actor> 126 ;;</Source> 127 ;;</Problem> 128 ;;</Problems> 129 ;;<Immunizations> 130 ;;<Immunization> 131 ;;<CCRDataObjectID>@@IMMUNEOBJECTID@@</CCRDataObjectID> 132 ;;<DateTime> 133 ;;<Type> 134 ;;<Text>@@IMMUNEDATETIMETYPETEXT@@</Text> 135 ;;</Type> 136 ;;<ExactDateTime>@@IMMUNEDATETIME@@</ExactDateTime> 137 ;;</DateTime> 138 ;;<Source> 139 ;;<Actor> 140 ;;<ActorID>@@IMMUNESOURCEACTORID@@</ActorID> 141 ;;</Actor> 142 ;;</Source> 143 ;;<Product> 144 ;;<ProductName> 145 ;;<Text>@@IMMUNEPRODUCTNAMETEXT@@</Text> 146 ;;<Code> 147 ;;<Value>@@IMMUNEPRODUCTCODE@@</Value> 148 ;;<CodingSystem>@@IMMUNEPRODUCTCODESYSTEM@@</CodingSystem> 149 ;;</Code> 150 ;;</ProductName> 151 ;;</Product> 152 ;;</Immunization> 153 ;;</Immunizations> 154 ;;<FamilyHistory> 155 ;;<FamilyProblemHistory> 156 ;;<CCRDataObjectID>@@FAMILYHISTORYOBJECTID@@</CCRDataObjectID> 157 ;;<Source> 158 ;;<Actor> 159 ;;<ActorID>@@FAMILYHISTORYACTORID@@</ActorID> 160 ;;</Actor> 161 ;;</Source> 162 ;;<FamilyMember> 163 ;;<ActorID>@@FAMILYMEMBERACTORID@@</ActorID> 164 ;;<ActorRole> 165 ;;<Text>@@FAMILYMEMBERACTORROLETEXT@@</Text> 166 ;;</ActorRole> 167 ;;<Source> 168 ;;<Actor> 169 ;;<ActorID>@@FAMILYMEMBERSOURCACTORID@@</ActorID> 170 ;;</Actor> 171 ;;</Source> 172 ;;</FamilyMember> 173 ;;<Problem> 174 ;;<Type> 175 ;;<Text>Problem</Text> 176 ;;</Type> 177 ;;<Description> 178 ;;<Text>@@FAMILYMEMBERPROBLEMDESCRIPTION@@</Text> 179 ;;<Code> 180 ;;<Value>@@FAMILYMEMBERPROBLEMCODE@@</Value> 181 ;;<CodingSystem>@@FAMILYMEMBERCODESYSTEM@@</CodingSystem> 182 ;;<Version>@@FAMILYMEMBERCODEVERSION@@</Version> 183 ;;</Code> 184 ;;</Description> 185 ;;<Source> 186 ;;<Actor> 187 ;;<ActorID>@@FAMILYMEMBERPROBLEMSOURCEID@@</ActorID> 188 ;;</Actor> 189 ;;</Source> 190 ;;</Problem> 191 ;;</FamilyProblemHistory> 192 ;;</FamilyHistory> 193 ;;<SocialHistory> 194 ;;<SocialHistoryElement> 195 ;;<CCRDataObjectID>@@SOCIALHISTORYOBJECTID@@</CCRDataObjectID> 196 ;;<Type> 197 ;;<Text>@@SOCIALHISTORYTYPETEXT@@</Text> 198 ;;</Type> 199 ;;<Description> 200 ;;<Text>@@SOCIALHISTORYDESCRIPTIONTEXT@@</Text> 201 ;;</Description> 202 ;;<Source> 203 ;;<Actor> 204 ;;<ActorID>@@SOCIALHISTORYSOURCACTORID@@</ActorID> 205 ;;</Actor> 206 ;;</Source> 207 ;;</SocialHistoryElement> 208 ;;<SocialHistoryElement> 209 ;;<CCRDataObjectID>BB0005</CCRDataObjectID> 210 ;;<Type> 211 ;;<Text>Ethnic Origin</Text> 212 ;;</Type> 213 ;;<Description> 214 ;;<Text>Not Hispanic or Latino</Text> 215 ;;</Description> 216 ;;<Source> 217 ;;<Actor> 218 ;;<ActorID>AA0001</ActorID> 219 ;;</Actor> 220 ;;</Source> 221 ;;</SocialHistoryElement> 222 ;;<SocialHistoryElement> 223 ;;<CCRDataObjectID>BB0006</CCRDataObjectID> 224 ;;<Type> 225 ;;<Text>Race</Text> 226 ;;</Type> 227 ;;<Description> 228 ;;<Text>White</Text> 229 ;;</Description> 230 ;;<Source> 231 ;;<Actor> 232 ;;<ActorID>AA0001</ActorID> 233 ;;</Actor> 234 ;;</Source> 235 ;;</SocialHistoryElement> 236 ;;<SocialHistoryElement> 237 ;;<CCRDataObjectID>BB0007</CCRDataObjectID> 238 ;;<Type> 239 ;;<Text>Occupation</Text> 240 ;;</Type> 241 ;;<Description> 242 ;;<Text>Physician</Text> 243 ;;</Description> 244 ;;<Source> 245 ;;<Actor> 246 ;;<ActorID>AA0001</ActorID> 247 ;;</Actor> 248 ;;</Source> 249 ;;</SocialHistoryElement> 250 ;;</SocialHistory> 251 ;;<Alerts> 252 ;;<Alert> 253 ;;<CCRDataObjectID>@@ALERTOBJECTID@@</CCRDataObjectID> 254 ;;<DateTime> 255 ;;<ExactDateTime>@@ALERTDATETIME@@</ExactDateTime> 256 ;;</DateTime> 257 ;;<Type> 258 ;;<Text>@@ALERTTYPE@@</Text> 259 ;;</Type> 260 ;;<Status> 261 ;;<Text>@@ALERTSTATUSTEXT@@</Text> 262 ;;</Status> 263 ;;<Description> 264 ;;<Text>@@ALERTDESCRIPTIONTEXT@@</Text> 265 ;;<Code> 266 ;;<Value>@@ALERTCODEVALUE@@</Value> 267 ;;<CodingSystem>@@ALERTCODESYSTEM@@</CodingSystem> 268 ;;</Code> 269 ;;</Description> 270 ;;<Source> 271 ;;<Actor> 272 ;;<ActorID>@@ALERTSOURCEID@@</ActorID> 273 ;;</Actor> 274 ;;</Source> 275 ;;<Agent> 276 ;;<Products> 277 ;;<Product> 278 ;;<CCRDataObjectID>@@ALERTAGENTPRODUCTOBJECTID@@</CCRDataObjectID> 279 ;;<Source> 280 ;;<Actor> 281 ;;<ActorID>@@ALERTSOURCEID@@</ActorID> 282 ;;</Actor> 283 ;;</Source> 284 ;;<Product> 285 ;;<ProductName> 286 ;;<Text>@@ALERTAGENTPRODUCTNAMETEXT@@</Text> 287 ;;<Code> 288 ;;<Value>@@ALERTAGENTPRODUCTCODEVALUE@@</Value> 289 ;;<CodingSystem>@@ALERTAGENTPRODUCTCODESYSTEM@@</CodingSystem> 290 ;;</Code> 291 ;;</ProductName> 292 ;;</Product> 293 ;;</Product> 294 ;;</Products> 295 ;;</Agent> 296 ;;<Reaction> 297 ;;<Description> 298 ;;<Text>@@ALERTREACTIOINDESCRIPTIONTEXT@@</Text> 299 ;;<Code> 300 ;;<Value>@@ALERTREACTIONCODEVALUE@@</Value> 301 ;;<CodingSystem>@@ALERTREACTIONCODESYSTEM@@</CodingSystem> 302 ;;</Code> 303 ;;</Description> 304 ;;</Reaction> 305 ;;</Alert> 306 ;;</Alerts> 307 ;;<Medications> 308 ;;<Medication> 309 ;;<CCRDataObjectID>@@MEDOBJECTID@@</CCRDataObjectID> 310 ;;<DateTime> 311 ;;<Type> 312 ;;<Text>@@MEDISSUEDATETXT@@</Text> 313 ;;</Type> 314 ;;<ExactDateTime>@@MEDISSUEDATE@@</ExactDateTime> 315 ;;</DateTime> 316 ;;<DateTime> 317 ;;<Type> 318 ;;<Text>@@MEDLASTFILLDATETXT@@</Text> 319 ;;</Type> 320 ;;<ExactDateTime>@@MEDLASTFILLDATE@@</ExactDateTime> 321 ;;</DateTime> 322 ;;<IDs> 323 ;;<Type> 324 ;;<Text>@@MEDRXNOTXT@@</Text> 325 ;;</Type> 326 ;;<ID>@@MEDRXNO@@</ID> 327 ;;</IDs> 328 ;;<Type> 329 ;;<Text>@@MEDTYPETEXT@@</Text> 330 ;;</Type> 331 ;;<Description> 332 ;;<Text>@@MEDDETAILUNADORNED@@</Text> 333 ;;</Description> 334 ;;<Status> 335 ;;<Text>@@MEDSTATUSTEXT@@</Text> 336 ;;</Status> 337 ;;<Source> 338 ;;<Actor> 339 ;;<ActorID>@@MEDSOURCEACTORID@@</ActorID> 340 ;;</Actor> 341 ;;</Source> 342 ;;<Product> 343 ;;<ProductName> 344 ;;<Text>@@MEDPRODUCTNAMETEXT@@</Text> 345 ;;<Code> 346 ;;<Value>@@MEDPRODUCTNAMECODEVALUE@@</Value> 347 ;;<CodingSystem>@@MEDPRODUCTNAMECODINGINGSYSTEM@@</CodingSystem> 348 ;;<Version>@@MEDPRODUCTNAMECODEVERSION@@</Version> 349 ;;</Code> 350 ;;</ProductName> 351 ;;<BrandName> 352 ;;<Text>@@MEDBRANDNAMETEXT@@</Text> 353 ;;</BrandName> 354 ;;<Strength> 355 ;;<Value>@@MEDSTRENGTHVALUE@@</Value> 356 ;;<Units> 357 ;;<Unit>@@MEDSTRENGTHUNIT@@</Unit> 358 ;;</Units> 359 ;;</Strength> 360 ;;<Form> 361 ;;<Text>@@MEDFORMTEXT@@</Text> 362 ;;</Form> 363 ;;<Concentration> 364 ;;<Value>@@MEDCONCVALUE@@</Value> 365 ;;<Units> 366 ;;<Unit>@@MEDCONCUNIT@@</Unit> 367 ;;</Units> 368 ;;</Concentration> 369 ;;</Product> 370 ;;<Quantity> 371 ;;<Value>@@MEDQUANTITYVALUE@@</Value> 372 ;;<Units> 373 ;;<Unit>@@MEDQUANTITYUNIT@@</Unit> 374 ;;</Units> 375 ;;</Quantity> 376 ;;<Directions> 377 ;;<Direction> 378 ;;<Description> 379 ;;<Text>@@MEDDIRECTIONDESCRIPTIONTEXT@@</Text> 380 ;;</Description> 381 ;;<DoseIndicator> 382 ;;<Text>@@MEDDOSEINDICATOR@@</Text> 383 ;;</DoseIndicator> 384 ;;<DeliveryMethod> 385 ;;<Text>@@MEDDELIVERYMETHOD@@</Text> 386 ;;</DeliveryMethod> 387 ;;<Dose> 388 ;;<Value>@@MEDDOSEVALUE@@</Value> 389 ;;<Units> 390 ;;<Unit>@@MEDDOSEUNIT@@</Unit> 391 ;;</Units> 392 ;;<Rate> 393 ;;<Value>@@MEDRATEVALUE@@</Value> 394 ;;<Units> 395 ;;<Unit>@@MEDRATEUNIT@@</Unit> 396 ;;</Units> 397 ;;</Rate> 398 ;;</Dose> 399 ;;<Vehicle> 400 ;;<Text>@@MEDVEHICLETEXT@@</Text> 401 ;;</Vehicle> 402 ;;<Route> 403 ;;<Text>@@MEDDIRECTIONROUTETEXT@@</Text> 404 ;;</Route> 405 ;;<Frequency> 406 ;;<Value>@@MEDFREQUENCYVALUE@@</Value> 407 ;;</Frequency> 408 ;;<Interval> 409 ;;<Value>@@MEDINTERVALVALUE@@</Value> 410 ;;<Units> 411 ;;<Unit>@@MEDINTERVALUNIT@@</Unit> 412 ;;</Units> 413 ;;</Interval> 414 ;;<Duration> 415 ;;<Value>@@MEDDURATIONVALUE@@</Value> 416 ;;<Units> 417 ;;<Unit>@@MEDDURATIONUNIT@@</Unit> 418 ;;</Units> 419 ;;</Duration> 420 ;;<Indication> 421 ;;<PRNFlag> 422 ;;<Text>@@MEDPRNFLAG@@</Text> 423 ;;</PRNFlag> 424 ;;<Problem> 425 ;;<CCRDataObjectID>@@MEDPROBLEMOBJECTID@@</CCRDataObjectID> 426 ;;<Type> 427 ;;<Text>@@MEDPROBLEMTYPETXT@@</Text> 428 ;;</Type> 429 ;;<Description> 430 ;;<Text>@@MEDPROBLEMDESCRIPTION@@</Text> 431 ;;<Code> 432 ;;<Value>@@MEDPROBLEMCODEVALUE@@</Value> 433 ;;<CodingSystem>@@MEDPROBLEMCODINGSYSTEM@@</CodingSystem> 434 ;;<Version>@@MEDPROBLEMCODINGVERSION@@</Version> 435 ;;</Code> 436 ;;</Description> 437 ;;<Source> 438 ;;<Actor> 439 ;;<ActorID>@@MEDPROBLEMSOURCEACTORID@@</ActorID> 440 ;;</Actor> 441 ;;</Source> 442 ;;</Problem> 443 ;;</Indication> 444 ;;<StopIndicator> 445 ;;<Text>@@MEDSTOPINDICATOR@@</Text> 446 ;;</StopIndicator> 447 ;;<DirectionSequenceModifier>@@MEDDIRSEQ@@</DirectionSequenceModifier> 448 ;;<MultipleDirectionModifier> 449 ;;<Text>@@MEDMULDIRMOD@@</Text> 450 ;;</MultipleDirectionModifier> 451 ;;</Direction> 452 ;;</Directions> 453 ;;<PatientInstructions> 454 ;;<Instruction> 455 ;;<Text>@@MEDPTINSTRUCTIONS@@</Text> 456 ;;</Instruction> 457 ;;</PatientInstructions> 458 ;;<FullfillmentInstructions> 459 ;;<Text>@@MEDFULLFILLMENTINSTRUCTIONS@@</Text> 460 ;;</FullfillmentInstructions> 461 ;;<Refills> 462 ;;<Refill> 463 ;;<Number>@@MEDRFNO@@</Number> 464 ;;</Refill> 465 ;;</Refills> 466 ;;</Medication> 467 ;;</Medications> 468 ;;<VitalSigns> 469 ;;<Result> 470 ;;<CCRDataObjectID>@@VITALSIGNSDATAOBJECTID@@</CCRDataObjectID> 471 ;;<DateTime> 472 ;;<Type> 473 ;;<Text>@@VITALSIGNSDATETIMETYPETEXT@@</Text> 474 ;;</Type> 475 ;;<ExactDateTime>@@VITALSIGNSEXACTDATETIME@@</ExactDateTime> 476 ;;</DateTime> 477 ;;<Description> 478 ;;<Text>@@VITALSIGNSDESCRIPTIONTEXT@@</Text> 479 ;;</Description> 480 ;;<Source> 481 ;;<Actor> 482 ;;<ActorID>@@VITALSIGNSSOURCEACTORID@@</ActorID> 483 ;;</Actor> 484 ;;</Source> 485 ;;<Test> 486 ;;<CCRDataObjectID>@@VITALSIGNSTESTOBJECTID@@</CCRDataObjectID> 487 ;;<Type> 488 ;;<Text>@@VITALSIGNSTESTTYPETEXT@@</Text> 489 ;;</Type> 490 ;;<Description> 491 ;;<Text>@@VITALSIGNSDESCRIPTIONTEXT@@</Text> 492 ;;<Code> 493 ;;<Value>@@VITALSIGNSDESCCODEVALUE@@</Value> 494 ;;<CodingSystem>@@VITALSIGNSDESCCODINGSYSTEM@@</CodingSystem> 495 ;;<Version>@@VITALSIGNSCODEVERSION@@</Version> 496 ;;</Code> 497 ;;</Description> 498 ;;<Source> 499 ;;<Actor> 500 ;;<ActorID>@@VITALSIGNSTESTSOURCEACTORID@@</ActorID> 501 ;;</Actor> 502 ;;</Source> 503 ;;<TestResult> 504 ;;<Value>@@VITALSIGNSTESTRESULTVALUE@@</Value> 505 ;;<Units> 506 ;;<Unit>@@VITALSIGNSTESTRESULTUNIT@@</Unit> 507 ;;</Units> 508 ;;</TestResult> 509 ;;</Test> 510 ;;</Result> 511 ;;</VitalSigns> 512 ;;<Results> 513 ;;<Result> 514 ;;<CCRDataObjectID>@@RESULTOBJECTID@@</CCRDataObjectID> 515 ;;<DateTime> 516 ;;<Type> 517 ;;<Text>Assessment Time</Text> 518 ;;</Type> 519 ;;<ExactDateTime>@@RESULTASSESSMENTDATETIME@@</ExactDateTime> 520 ;;</DateTime> 521 ;;<Description> 522 ;;<Text>@@RESULTDESCRIPTIONTEXT@@</Text> 523 ;;<Code> 524 ;;<Value>@@RESULTCODE@@</Value> 525 ;;<CodingSystem>@@RESULTCODINGSYSTEM@@</CodingSystem> 526 ;;</Code> 527 ;;</Description> 528 ;;<Status> 529 ;;<Text>@@RESULTSTATUS@@</Text> 530 ;;</Status> 531 ;;<Source> 532 ;;<Actor> 533 ;;<ActorID>@@RESULTSOURCEACTORID@@</ActorID> 534 ;;</Actor> 535 ;;</Source> 536 ;;<Test> 537 ;;<CCRDataObjectID>@@RESULTTESTOBJECTID@@</CCRDataObjectID> 538 ;;<DateTime> 539 ;;<Type> 540 ;;<Text>Assessment Time</Text> 541 ;;</Type> 542 ;;<ExactDateTime>@@RESULTTESTDATETIME@@</ExactDateTime> 543 ;;</DateTime> 544 ;;<Description> 545 ;;<Text>@@RESULTTESTDESCRIPTIONTEXT@@</Text> 546 ;;<Code> 547 ;;<Value>@@RESULTTESTCODEVALUE@@</Value> 548 ;;<CodingSystem>@@RESULTTESTCODINGSYSTEM@@</CodingSystem> 549 ;;</Code> 550 ;;</Description> 551 ;;<Status> 552 ;;<Text>@@RESULTTESTSTATUSTEXT@@</Text> 553 ;;</Status> 554 ;;<Source> 555 ;;<Actor> 556 ;;<ActorID>@@RESULTTESTSOURCEACTORID@@</ActorID> 557 ;;</Actor> 558 ;;</Source> 559 ;;<TestResult> 560 ;;<Value>@@RESULTTESTVALUE@@</Value> 561 ;;<Units> 562 ;;<Unit>@@RESULTTESTUNITS@@</Unit> 563 ;;</Units> 564 ;;</TestResult> 565 ;;<NormalResult> 566 ;;<Normal> 567 ;;<Description> 568 ;;<Text>@@RESULTTESTNORMALDESCTEXT@@</Text> 569 ;;</Description> 570 ;;<Source> 571 ;;<Actor> 572 ;;<ActorID>@@RESULTTESTNORMALSOURCEACTORID@@</ActorID> 573 ;;</Actor> 574 ;;</Source> 575 ;;</Normal> 576 ;;</NormalResult> 577 ;;<Flag> 578 ;;<Text>@@RESULTTESTFLAG@@</Text> 579 ;;</Flag> 580 ;;</Test> 581 ;;</Result> 582 ;;</Results> 583 ;;<Procedures> 584 ;;<Procedure> 585 ;;<CCRDataObjectID>@@PROCOBJECTID@@</CCRDataObjectID> 586 ;;<DateTime> 587 ;;<Type> 588 ;;<Text>@@PROCDATETEXT@@</Text> 589 ;;</Type> 590 ;;<ExactDateTime>@@PROCDATETIME@@</ExactDateTime> 591 ;;</DateTime> 592 ;;<Description> 593 ;;<Text>@@PROCDESCTEXT@@</Text> 594 ;;<ObjectAttribute> 595 ;;<Attribute>@@PROCDESCOBJATTR@@</Attribute> 596 ;;<AttributeValue> 597 ;;<Value>@@PROCDESCOBJATTRVAL@@</Value> 598 ;;<Code> 599 ;;<Value>@@PROCDESCOBJATTRCODE@@</Value> 600 ;;<CodingSystem>@@PROCDESCOBJATTRCODESYS@@</CodingSystem> 601 ;;</Code> 602 ;;</AttributeValue> 603 ;;</ObjectAttribute> 604 ;;<Code> 605 ;;<Value>@@PROCCODE@@</Value> 606 ;;<CodingSystem>@@PROCCODESYS@@</CodingSystem> 607 ;;</Code> 608 ;;</Description> 609 ;;<Status> 610 ;;<Text>@@PROCSTATUS@@</Text> 611 ;;</Status> 612 ;;<Source> 613 ;;<Actor> 614 ;;<ActorID>@@PROCACTOROBJID@@</ActorID> 615 ;;</Actor> 616 ;;</Source> 617 ;;<InternalCCRLink> 618 ;;<LinkID>@@PROCLINKID@@</LinkID> 619 ;;<LinkRelationship>@@PROCLINKREL@@</LinkRelationship> 620 ;;</InternalCCRLink> 621 ;;</Procedure> 622 ;;</Procedures> 623 ;;<Encounters> 624 ;;<Encounter> 625 ;;<CCRDataObjectID>@@ENCOBJECTID@@</CCRDataObjectID> 626 ;;<DateTime> 627 ;;<ExactDateTime>@@ENCDATETIME@@</ExactDateTime> 628 ;;</DateTime> 629 ;;<Type> 630 ;;<Text>@@ENCTYPETXT@@</Text> 631 ;;<Code> 632 ;;<Value>@@ENCTYPECODE@@</Value> 633 ;;<CodingSystem>@@ENCTYPECODESYS@@</CodingSystem> 634 ;;</Code> 635 ;;</Type> 636 ;;<Description> 637 ;;<Text>@@ENCDESCTXT@@</Text> 638 ;;<Code> 639 ;;<Value>@@ENCDESCCODE@@</Value> 640 ;;<CodingSystem>@@ENCDESCCODESYS@@</CodingSystem> 641 ;;</Code> 642 ;;</Description> 643 ;;<Location> 644 ;;<Actor> 645 ;;<ActorID>@@ENCLOCACTORID@@</ActorID> 646 ;;</Actor> 647 ;;</Location> 648 ;;<Practioner> 649 ;;<Actor> 650 ;;<ActorID>@@ENCPRVACTORID@@</ActorID> 651 ;;</Actor> 652 ;;</Practioner> 653 ;;<Indication> 654 ;;<Text>@@ENCINDTXT@@</Text> 655 ;;<Code> 656 ;;<Value>@@ENCINDCODE@@</Value> 657 ;;<CodingSystem>@@ENCINDCODESYS@@</CodingSystem> 658 ;;</Code> 659 ;;</Indication> 660 ;;<Source> 661 ;;<Actor> 662 ;;<ActorID>@@ENCACTORID@@</ActorID> 663 ;;</Actor> 664 ;;</Source> 665 ;;<CommentID>@@ENCCOMMENTID@@</CommentID> 666 ;;</Encounter> 667 ;;</Encounters> 668 ;;<HealthCareProviders> 669 ;;<Provider> 670 ;;<ActorID>AA0005</ActorID> 671 ;;<ActorRole> 672 ;;<Text>Primary Provider</Text> 673 ;;</ActorRole> 674 ;;</Provider> 675 ;;</HealthCareProviders> 676 ;;</Body> 677 ;;<Actors> 678 ;;<ACTOR-PATIENT> 679 ;;<Actor> 680 ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID> 681 ;;<Person> 682 ;;<Name> 683 ;;<CurrentName> 684 ;;<Given>@@ACTORGIVENNAME@@</Given> 685 ;;<Middle>@@ACTORMIDDLENAME@@</Middle> 686 ;;<Family>@@ACTORFAMILYNAME@@</Family> 687 ;;</CurrentName> 688 ;;</Name> 689 ;;<DateOfBirth> 690 ;;<ExactDateTime>@@ACTORDATEOFBIRTH@@</ExactDateTime> 691 ;;</DateOfBirth> 692 ;;<Gender> 693 ;;<Text>@@ACTORGENDER@@</Text> 694 ;;<Code> 695 ;;<Value>@@ACTORGENDERCODE@@</Value> 696 ;;<CodingSystem>HL7 AdministrativeGender</CodingSystem> 697 ;;</Code> 698 ;;</Gender> 699 ;;</Person> 700 ;;<IDs> 701 ;;<Type> 702 ;;<Text>@@ACTORSSNTEXT@@</Text> 703 ;;</Type> 704 ;;<ID>@@ACTORSSN@@</ID> 705 ;;<Source> 706 ;;<Actor> 707 ;;<ActorID>@@ACTORSSNSOURCEID@@</ActorID> 708 ;;</Actor> 709 ;;</Source> 710 ;;</IDs> 711 ;;<Address> 712 ;;<Type> 713 ;;<Text>@@ACTORADDRESSTYPE@@</Text> 714 ;;</Type> 715 ;;<Line1>@@ACTORADDRESSLINE1@@</Line1> 716 ;;<Line2>@@ACTORADDRESSLINE2@@</Line2> 717 ;;<City>@@ACTORADDRESSCITY@@</City> 718 ;;<State>@@ACTORADDRESSSTATE@@</State> 719 ;;<PostalCode>@@ACTORADDRESSZIPCODE@@</PostalCode> 720 ;;</Address> 721 ;;<Telephone> 722 ;;<Value>@@ACTORRESTEL@@</Value> 723 ;;<Type> 724 ;;<Text>@@ACTORRESTELTEXT@@</Text> 725 ;;</Type> 726 ;;</Telephone> 727 ;;<Telephone> 728 ;;<Value>@@ACTORWORKTEL@@</Value> 729 ;;<Type> 730 ;;<Text>@@ACTORWORKTELTEXT@@</Text> 731 ;;</Type> 732 ;;</Telephone> 733 ;;<Telephone> 734 ;;<Value>@@ACTORCELLTEL@@</Value> 735 ;;<Type> 736 ;;<Text>@@ACTORCELLTELTEXT@@</Text> 737 ;;</Type> 738 ;;</Telephone> 739 ;;<EMail> 740 ;;<Value>@@ACTOREMAIL@@</Value> 741 ;;</EMail> 742 ;;<Source> 743 ;;<Actor> 744 ;;<ActorID>@@ACTORADDRESSSOURCEID@@</ActorID> 745 ;;</Actor> 746 ;;</Source> 747 ;;</Actor> 748 ;;</ACTOR-PATIENT> 749 ;;<ACTOR-SYSTEM> 750 ;;<Actor> 751 ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID> 752 ;;<InformationSystem> 753 ;;<Name>@@ACTORINFOSYSNAME@@</Name> 754 ;;<Version>@@ACTORINFOSYSVER@@</Version> 755 ;;</InformationSystem> 756 ;;<Source> 757 ;;<Actor> 758 ;;<ActorID>@@ACTORINFOSYSSOURCEID@@</ActorID> 759 ;;</Actor> 760 ;;</Source> 761 ;;</Actor> 762 ;;</ACTOR-SYSTEM> 763 ;;<ACTOR-NOK> 764 ;;<Actor> 765 ;;<ActorObjectID>AA0003</ActorObjectID> 766 ;;<Person> 767 ;;<Name> 768 ;;<DisplayName>@@ACTORDISPLAYNAME@@</DisplayName> 769 ;;</Name> 770 ;;</Person> 771 ;;<Relation> 772 ;;<Text>@@ACTORRELATION@@</Text> 773 ;;</Relation> 774 ;;<Source> 775 ;;<Actor> 776 ;;<ActorID>@@ACTORRELATIONSOURCEID@@</ActorID> 777 ;;</Actor> 778 ;;</Source> 779 ;;</Actor> 780 ;;</ACTOR-NOK> 781 ;;<ACTOR-PROVIDER> 782 ;;<Actor> 783 ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID> 784 ;;<Person> 785 ;;<Name> 786 ;;<CurrentName> 787 ;;<Given>@@ACTORGIVENNAME@@</Given> 788 ;;<Middle>@@ACTORMIDDLENAME@@</Middle> 789 ;;<Family>@@ACTORFAMILYNAME@@</Family> 790 ;;<Title>@@ACTORTITLE@@</Title> 791 ;;</CurrentName> 792 ;;</Name> 793 ;;</Person> 794 ;;<Specialty> 795 ;;<Text>@@ACTORSPECIALITY@@</Text> 796 ;;</Specialty> 797 ;;<Address> 798 ;;<Type> 799 ;;<Text>@@ACTORADDRESSTYPE@@</Text> 800 ;;</Type> 801 ;;<Line1>@@ACTORADDRESSLINE1@@</Line1> 802 ;;<City>@@ACTORADDRESSCITY@@</City> 803 ;;<State>@@ACTORADDRESSSTATE@@</State> 804 ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode> 805 ;;</Address> 806 ;;<Telephone> 807 ;;<Value>@@ACTORTELEPHONE@@</Value> 808 ;;<Type> 809 ;;<Text>@@ACTORTELEPHONETYPE@@</Text> 810 ;;</Type> 811 ;;</Telephone> 812 ;;<Email> 813 ;;<Value>@@ACTOREMAIL@@</Value> 814 ;;</Email> 815 ;;<Source> 816 ;;<Actor> 817 ;;<ActorID>@@ACTORSOURCEID@@</ActorID> 818 ;;</Actor> 819 ;;</Source> 820 ;;<InternalCCRLink> 821 ;;<LinkID>@@ACTORORGLINK@@</LinkID> 822 ;;<LinkRelationship>representedOrganization</LinkRelationship> 823 ;;</InternalCCRLink> 824 ;;</Actor> 825 ;;</ACTOR-PROVIDER> 826 ;;<ACTOR-ORG> 827 ;;<Actor> 828 ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID> 829 ;;<Organization> 830 ;;<Name>@@ORGANIZATIONNAME@@</Name> 831 ;;</Organization> 832 ;;<Address> 833 ;;<Type> 834 ;;<Text>@@ACTORADDRESSTYPE@@</Text> 835 ;;</Type> 836 ;;<Line1>@@ACTORADDRESSLINE1@@</Line1> 837 ;;<City>@@ACTORADDRESSCITY@@</City> 838 ;;<State>@@ACTORADDRESSSTATE@@</State> 839 ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode> 840 ;;</Address> 841 ;;<Telephone> 842 ;;<Value>@@ACTORTELEPHONE@@</Value> 843 ;;<Type> 844 ;;<Text>@@ACTORTELEPHONETYPE@@</Text> 845 ;;</Type> 846 ;;</Telephone> 847 ;;<Source> 848 ;;<Actor> 849 ;;<ActorID>@@ACTORSOURCEID@@</ActorID> 850 ;;</Actor> 851 ;;</Source> 852 ;;</Actor> 853 ;;</ACTOR-ORG> 854 ;;</Actors> 855 ;;<Signatures> 856 ;;<CCRSignature> 857 ;;<SignatureObjectID>S0001</SignatureObjectID> 858 ;;<ExactDateTime>2008-03-18T23:10:58Z</ExactDateTime> 859 ;;<Source> 860 ;;<ActorID>AA0001</ActorID> 861 ;;</Source> 862 ;;<Signature> 863 ;;<Signature xmlns="http://www.w3.org/2000/09/xmldsig#"> 864 ;;<SignedInfo> 865 ;;<CanonicalizationMethod Algorithm="http://www.w3.org/TR/2001/REC-xml-c14n-20010315"/> 866 ;;<SignatureMethod Algorithm="http://www.w3.org/2000/09/xmldsig#rsa-sha1"/> 867 ;;<Reference URI=""> 868 ;;<Transforms> 869 ;;<Transform Algorithm="http://www.w3.org/2000/09/xmldsig#enveloped-signature"/> 870 ;;</Transforms> 871 ;;<DigestMethod Algorithm="http://www.w3.org/2000/09/xmldsig#sha1"/> 872 ;;<DigestValue>YFveLLyo+75P7rSciv0/m1O6Ot4=</DigestValue> 873 ;;</Reference> 874 ;;</SignedInfo> 875 ;;<SignatureValue>Bj6sACXl74hrlbUYnu8HqnRab5VGy69BOYjOH7dETxgppXMEd7AoVYaePZvgJft78JR4oQY76hbFyGcIslYauPpJxx2hCd5d56xFeaQg01R6AQOvGnhjlq63TbpFdUq0B4tYsmiibJPbQJhTQe+TcWTBvWaQt8Fkk5blO571YvI=</SignatureValue> 876 ;;<KeyInfo> 877 ;;<KeyValue> 878 ;;<RSAKeyValue> 879 ;;<Modulus>meH817QYol+/uUEg6j8Mg89s7GTlaN9B+/CGlzrtnQH+swMigZRnEPxHVO8PhEymP/W9nlhAjTScV/CUzA9yJ9WiaOn17c+KReKhfBqL24DX9BpbJ+kLYVz7mBO5Qydk5AzUT2hFwW93irD8iRKP+/t+2Mi2CjNfj8VTjJpHpm0=</Modulus> 880 ;;<Exponent>AQAB</Exponent> 881 ;;</RSAKeyValue> 882 ;;</KeyValue> 883 ;;</KeyInfo> 884 ;;</Signature> 885 ;;</Signature> 886 ;;</CCRSignature> 887 ;;</Signatures> 888 ;;<Comments> 889 ;;<Comment> 890 ;;<CommentObjectID>@@COMMENTOBJECTID@@</CommentObjectID> 891 ;;<DateTime> 892 ;;<ExactDateTime>@@CMTDATETIME@@</ExactDateTime> 893 ;;</DateTime> 894 ;;<Description> 895 ;;<Text> 896 ;;</Text> 897 ;;</Description> 898 ;;<Source> 899 ;;<Actor> 900 ;;<ActorID>@@ACTORSOURCEID@@</ActorID> 901 ;;</Actor> 902 ;;</Source> 903 ;;</Comment> 904 ;;</Comments> 905 ;;</ContinuityOfCareRecord> 906 ;</TEMPLATE> -
ccr/branches/ohum/p/C0CCMT.m
r1342 r1428 1 C0CCMT 2 ;;1.0;C0C;;May 21, 2010;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(NOTEXML,DFN,NOTEOUT) 25 26 27 28 29 30 31 32 MAP(NOTEXML,C0CNTE,NOTEOUT) 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 CLEAN(INARY) 60 61 62 63 64 65 66 1 C0CCMT ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;Copyright 2010 George Lilly, University of Minnesota and others. 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 W "NO ENTRY FROM TOP",! 22 Q 23 ; 24 EXTRACT(NOTEXML,DFN,NOTEOUT) ; EXTRACT NOTES INTO XML TEMPLATE 25 ; NOTEXML AND NOTEOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED 26 ; 27 D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES 28 ;I '$D(@C0CNTE) Q ; NO NOTES AVAILABLE 29 D MAP(NOTEXML,C0CNTE,NOTEOUT) ;MAP RESULTS FOR NOTES 30 Q 31 ; 32 MAP(NOTEXML,C0CNTE,NOTEOUT) ; MAP PROCEDURES XML 33 ; 34 N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"NOTETEMP")) ;WORK AREA FOR TEMPLATE 35 K @ZTEMP 36 N ZBLD 37 S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"NOTEBLD")) ; BUILD LIST AREA 38 D QUEUE^C0CXPATH(ZBLD,NOTEXML,1,1) ; FIRST LINE 39 N ZINNER 40 D QUERY^C0CXPATH(NOTEXML,"//Comments/Comment","ZINNER") ;ONE NOTE 41 N ZTMP,ZVAR,ZI 42 S ZI="" 43 F S ZI=$O(@C0CNTE@(ZI)) Q:ZI="" D ;FOR EACH NOTE 44 . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS NOTE XML 45 . S ZVAR=$NA(@C0CNTE@(ZI)) ;THIS NOTE VARIABLES 46 . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE 47 . N ZNOTE,ZN 48 . D CLEAN($NA(@C0CNTE@(ZI,"TEXT"))) ;REMOVE CONTROL CHARS AND XML RESERVED 49 . M ZNOTE=@C0CNTE@(ZI,"TEXT") ;THE NOTE TO ADD TO THE BUILD 50 . S ZNOTE(0)=$O(ZNOTE(""),-1) ;LENGTH OF THE NOTE 51 . D INSERT^C0CXPATH(ZTMP,"ZNOTE","//Comment/Description/Text") 52 . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD 53 D QUEUE^C0CXPATH(ZBLD,NOTEXML,@NOTEXML@(0),@NOTEXML@(0)) 54 N ZZTMP 55 D BUILD^C0CXPATH(ZBLD,NOTEOUT) ;BUILD FINAL XML 56 K @ZTEMP,@ZBLD,@C0CNTE 57 Q 58 ; 59 CLEAN(INARY) ; INARY IS PASSED BY NAME 60 ; REMOVE CONTROL CHARACTERS AND XML RESERVED SYMBOLS FROM THE ARRAY 61 N ZI,ZJ S ZI="" 62 F S ZI=$O(@INARY@(ZI)) Q:ZI="" D ; 63 . S @INARY@(ZI)=$$CLEAN^C0CXPATH(@INARY@(ZI)) ; CONTROL CHARS 64 . S @INARY@(ZI)=$$SYMENC^MXMLUTL(@INARY@(ZI)) ; XML RESERVED SYMBOLS 65 Q 66 ; -
ccr/branches/ohum/p/C0CCPT.m
r1342 r1428 1 C0CCPT ;;BSL;RETURN CPT DATA; 2 ;Sequence Managers Software GPL;;;;;Build 2 3 ;Copied into C0C namespace from SQMCPT with permission from 4 ;Brian Lord - and with our thanks. gpl 01/20/2010 5 ENTRY(DFN,STDT,ENDDT,TXT) ;BUILD TOTAL ARRAY OF ALL IEN'S FOR TIU NOTES 6 ;DFN=PATIENT IEN 7 ;STDT=START DATE IN 3100101 FORMAT (VA YEAR YYYMMDD) 8 ;ENDDT=END DATE IN 3100101 FORMAT 9 ;TXT=INCLUDE TEXT FROM ENCOUNTER NOTE 10 ;THAT FALL INSIDE DATA RANGE. IF NO STDT OR ENDDT ASSUME 11 ;ALL INCLUSIVE IN THAT DIRECTION 12 ;LIST OF TIU DOCS IN ^TIU(8925,"ACLPT",3,DFN) 13 ;BUILD INTO NOTE(Y)="" 14 S U="^",X="" 15 F S X=$O(^TIU(8925,"ACLPT",3,DFN,X)) Q:X="" D 16 . S Y="" 17 . F S Y=$O(^TIU(8925,"ACLPT",3,DFN,X,Y)) Q:Y="" D 18 .. S NOTE(Y)="" 19 ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE 20 ;GET DATE OF NOTE 21 ;RUT 3120109 Changing DATE in FILMAN's FORMAT 22 ;;OHUM/RUT 3111228 Date Range for Notes 23 ;S STDT=^TMP("C0CCCR","TIULIMIT") D NOW^%DTC S ENDDT=X 24 N FLAGS1,FLAGS2 25 S FLAGS1=$P(^C0CPARM(1,2),"^",1) S STDT=$$HTOF^C0CVALID(FLAGS1) 26 S FLAGS2=$P(^C0CPARM(1,2),"^",2) S ENDDT=$$HTOF^C0CVALID(FLAGS2) 27 ;S STDT=^TMP("C0CCCR","TIULIMIT"),ENDDT=^TMP("C0CCCR","TIUSTART") 28 ;;OHUM/RUT 29 ;RUT 30 S Z="" 31 F S Z=$O(NOTE(Z)) Q:Z="" D 32 . S DT=$P(^TIU(8925,Z,0),U,7) 33 . I $G(STDT)]"" D 34 .. I STDT>DT S NOTE(Z)="D" ;SET NOTE TO BE DELETED 35 . I $G(ENDDT)]"" D 36 .. I ENDDT<DT S NOTE(Z)="D" 37 . I NOTE(Z)="D" K NOTE(Z) 38 D VISIT 39 Q 40 VISIT ;GET VISIT INFO FOR A GIVEN NOTE. BUILD INTO RETURN ARRAY .VISIT 41 S ILST=1,X0="",X12="",VISIT="",LST="",X811="" 42 S IEN="" F S IEN=$O(NOTE(IEN)) Q:IEN="" D 43 . S X0=^TIU(8925,IEN,0),X12=$G(^(12)) 44 . S VISIT=$P(X12,U,7) 45 . I 'VISIT S VISIT=$P(X0,U,3) 46 . K ^TMP("PXKENC",$J) 47 . Q:VISIT=""!(VISIT'>0) 48 . D ENCEVENT^PXKENC(VISIT,1) 49 . I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q 50 . S IPRV=0 F S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV D 51 .. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0) 52 .. ;Q:$P(X0,U,4)'="P" 53 .. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U) 54 .. S PRIM=($P(X0,U,4)="P") 55 .. S ILST=ILST+1 56 .. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM 57 .. S VISIT(IEN,"PRV",ILST)=CODE_"^^^"_NARR_"^"_PRIM 58 . S IPOV=0 F S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV D 59 .. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811)) 60 .. S CODE=$P(X0,U) 61 .. S:CODE CODE=$P(^ICD9(CODE,0),U) 62 .. S CAT=$P(X802,U) 63 .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) 64 .. S NARR=$P(X0,U,4) 65 .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) 66 .. S PRIM=($P(X0,U,12)="P") 67 .. S PRV=$P(X12,U,4) 68 .. S ILST=ILST+1 69 .. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV 70 .. S VISIT(IEN,"POV",ILST)=CODE_U_CAT_U_NARR_U_PRIM_U_PRV 71 . S ICPT=0 F S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT D 72 .. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811)) 73 .. ;S CODE=$P(X0,U) 74 .. S CODE=$O(^ICPT("B",$P(X0,U),0)) 75 .. S:CODE CODE=$P(^ICPT(CODE,0),U) 76 .. S CAT=$P(X802,U) 77 .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) 78 .. S NARR=$P(X0,U,4) 79 .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) 80 .. S QTY=$P(X0,U,16) 81 .. S PRV=$P(X12,U,4) 82 .. S MCNT=0,MIDX=0,MODS="" 83 .. F S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX D 84 ... S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0)) 85 ... I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN 86 .. I +MCNT S MODS=MCNT_MODS 87 .. S ILST=ILST+1 88 .. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS 89 .. S VISIT(IEN,"CPT",ILST)=CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS 90 . S VISIT(IEN,"DATE",0)=$P($P(^TIU(8925,IEN,0),U,7),".") 91 . S VISIT(IEN,"CLASS")=$$GET1^DIQ(8925,IEN_",",.04) ;GPL 5/21/10 92 . I $G(TXT)=1 D GETNOTE(IEN) 93 Q 94 GETNOTE(IEN) ;GET THE TEXT THAT GOES WITH VISIT 95 ;EXTRACT NOTE TEXT FROM ^TIU(8925,IEN,"TEXT" 96 Q:'$D(VISIT(IEN,"CPT")) 97 S TXTCNT=0 98 F S TXTCNT=TXTCNT+1 Q:'$D(^TIU(8925,IEN,"TEXT",TXTCNT,0)) D 99 . S VISIT(IEN,"TEXT",TXTCNT)=^TIU(8925,IEN,"TEXT",TXTCNT,0) 100 Q 1 C0CCPT ;;BSL;RETURN CPT DATA; 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;Sequence Managers Software GPL;;;;;Build 2 4 ;Copied into C0C namespace from SQMCPT with permission from 5 ;Brian Lord - and with our thanks. gpl 01/20/2010 6 ENTRY(DFN,STDT,ENDDT,TXT) ;BUILD TOTAL ARRAY OF ALL IEN'S FOR TIU NOTES 7 ;DFN=PATIENT IEN 8 ;STDT=START DATE IN 3100101 FORMAT (VA YEAR YYYMMDD) 9 ;ENDDT=END DATE IN 3100101 FORMAT 10 ;TXT=INCLUDE TEXT FROM ENCOUNTER NOTE 11 ;THAT FALL INSIDE DATA RANGE. IF NO STDT OR ENDDT ASSUME 12 ;ALL INCLUSIVE IN THAT DIRECTION 13 ;LIST OF TIU DOCS IN ^TIU(8925,"ACLPT",3,DFN) 14 ;BUILD INTO NOTE(Y)="" 15 S U="^",X="" 16 F S X=$O(^TIU(8925,"ACLPT",3,DFN,X)) Q:X="" D 17 . S Y="" 18 . F S Y=$O(^TIU(8925,"ACLPT",3,DFN,X,Y)) Q:Y="" D 19 .. S NOTE(Y)="" 20 ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE 21 ;GET DATE OF NOTE 22 ;RUT 3120109 Changing DATE in FILMAN's FORMAT 23 ;;OHUM/RUT 3111228 Date Range for Notes 24 ;S STDT=^TMP("C0CCCR","TIULIMIT") D NOW^%DTC S ENDDT=X 25 N FLAGS1,FLAGS2 26 S FLAGS1=$P(^C0CPARM(1,2),"^",1) S STDT=$$HTOF^C0CVALID(FLAGS1) 27 S FLAGS2=$P(^C0CPARM(1,2),"^",2) S ENDDT=$$HTOF^C0CVALID(FLAGS2) 28 ;S STDT=^TMP("C0CCCR","TIULIMIT"),ENDDT=^TMP("C0CCCR","TIUSTART") 29 ;;OHUM/RUT 30 ;RUT 31 S Z="" 32 F S Z=$O(NOTE(Z)) Q:Z="" D 33 . S DT=$P(^TIU(8925,Z,0),U,7) 34 . I $G(STDT)]"" D 35 .. I STDT>DT S NOTE(Z)="D" ;SET NOTE TO BE DELETED 36 . I $G(ENDDT)]"" D 37 .. I ENDDT<DT S NOTE(Z)="D" 38 . I NOTE(Z)="D" K NOTE(Z) 39 D VISIT 40 Q 41 VISIT ;GET VISIT INFO FOR A GIVEN NOTE. BUILD INTO RETURN ARRAY .VISIT 42 S ILST=1,X0="",X12="",VISIT="",LST="",X811="" 43 S IEN="" F S IEN=$O(NOTE(IEN)) Q:IEN="" D 44 . S X0=^TIU(8925,IEN,0),X12=$G(^(12)) 45 . S VISIT=$P(X12,U,7) 46 . I 'VISIT S VISIT=$P(X0,U,3) 47 . K ^TMP("PXKENC",$J) 48 . Q:VISIT=""!(VISIT'>0) 49 . D ENCEVENT^PXKENC(VISIT,1) 50 . I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q 51 . S IPRV=0 F S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV D 52 .. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0) 53 .. ;Q:$P(X0,U,4)'="P" 54 .. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U) 55 .. S PRIM=($P(X0,U,4)="P") 56 .. S ILST=ILST+1 57 .. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM 58 .. S VISIT(IEN,"PRV",ILST)=CODE_"^^^"_NARR_"^"_PRIM 59 . S IPOV=0 F S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV D 60 .. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811)) 61 .. S CODE=$P(X0,U) 62 .. S:CODE CODE=$P(^ICD9(CODE,0),U) 63 .. S CAT=$P(X802,U) 64 .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) 65 .. S NARR=$P(X0,U,4) 66 .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) 67 .. S PRIM=($P(X0,U,12)="P") 68 .. S PRV=$P(X12,U,4) 69 .. S ILST=ILST+1 70 .. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV 71 .. S VISIT(IEN,"POV",ILST)=CODE_U_CAT_U_NARR_U_PRIM_U_PRV 72 . S ICPT=0 F S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT D 73 .. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811)) 74 .. ;S CODE=$P(X0,U) 75 .. S CODE=$O(^ICPT("B",$P(X0,U),0)) 76 .. S:CODE CODE=$P(^ICPT(CODE,0),U) 77 .. S CAT=$P(X802,U) 78 .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) 79 .. S NARR=$P(X0,U,4) 80 .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) 81 .. S QTY=$P(X0,U,16) 82 .. S PRV=$P(X12,U,4) 83 .. S MCNT=0,MIDX=0,MODS="" 84 .. F S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX D 85 ... S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0)) 86 ... I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN 87 .. I +MCNT S MODS=MCNT_MODS 88 .. S ILST=ILST+1 89 .. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS 90 .. S VISIT(IEN,"CPT",ILST)=CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS 91 . S VISIT(IEN,"DATE",0)=$P($P(^TIU(8925,IEN,0),U,7),".") 92 . S VISIT(IEN,"CLASS")=$$GET1^DIQ(8925,IEN_",",.04) ;GPL 5/21/10 93 . I $G(TXT)=1 D GETNOTE(IEN) 94 Q 95 GETNOTE(IEN) ;GET THE TEXT THAT GOES WITH VISIT 96 ;EXTRACT NOTE TEXT FROM ^TIU(8925,IEN,"TEXT" 97 Q:'$D(VISIT(IEN,"CPT")) 98 S TXTCNT=0 99 F S TXTCNT=TXTCNT+1 Q:'$D(^TIU(8925,IEN,"TEXT",TXTCNT,0)) D 100 . S VISIT(IEN,"TEXT",TXTCNT)=^TIU(8925,IEN,"TEXT",TXTCNT,0) 101 Q -
ccr/branches/ohum/p/C0CDIC.m
r1342 r1428 1 C0CDIC 2 ;;0.1;CCDCCR;nopatch;noreleasedate;Build 2 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 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CDOM 2 ;;0.1;C0C;nopatch;noreleasedate;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) 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 84 PARSE(INXML,INDOC) 85 86 87 88 89 90 ISMULT(ZOID) 91 92 93 94 95 96 97 FIRST(ZOID) 98 99 100 PARENT(ZOID) 101 102 103 ATT(RTN,NODE) 104 105 106 107 108 109 TAG(ZOID) 110 111 112 113 114 115 116 117 118 NXTSIB(ZOID) 119 120 121 DATA(ZT,ZOID) 122 123 124 125 126 127 128 OUTXML(ZRTN,INID,NO1ST) 129 130 131 132 133 134 135 136 137 138 139 NDOUT(ZOID) 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 1 C0CDOM ; GPL - DOM PROCESSING ROUTINES ;6/6/11 17:05 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE 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 PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME 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 ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE 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 FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID 98 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) 99 ; 100 PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID 101 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) 102 ; 103 ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID 104 S HANDLE=C0CDOCID 105 K @RTN 106 D GETTXT^MXMLDOM("A") 107 Q 108 ; 109 TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE 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 NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING 119 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) 120 ; 121 DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE 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 OUTXML(ZRTN,INID,NO1ST) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM 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 NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE 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
r1342 r1428 1 C0CDPT 2 ;;1.0;C0C;;May 19, 2009;Build 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 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 FAMILY(DFN) 90 91 92 93 GIVEN(DFN) 94 95 96 97 MIDDLE(DFN) 98 99 100 101 SUFFIX(DFN) 102 103 104 105 DISPNAME(DFN) 106 107 108 109 DOB(DFN) 110 111 112 113 GENDER(DFN) 114 115 SSN(DFN) 116 117 ADDRTYPE(DFN) 118 119 120 ADDR1(DFN) 121 122 ADDR2(DFN) 123 124 125 126 127 128 CITY(DFN) 129 130 STATE(DFN) 131 132 ZIP(DFN) 133 134 COUNTY(DFN) 135 136 COUNTRY(DFN) 137 138 139 RESTEL(DFN) 140 141 WORKTEL(DFN) 142 143 EMAIL(DFN) 144 145 CELLTEL(DFN) 146 147 NOK1FAM(DFN) 148 149 150 151 NOK1GIV(DFN) 152 153 154 155 NOK1MID(DFN) 156 157 158 159 NOK1SUF(DFN) 160 161 162 163 NOK1DISP(DFN) 164 165 166 167 NOK1REL(DFN) 168 169 NOK1ADD1(DFN) 170 171 NOK1ADD2(DFN) 172 173 174 175 176 NOK1CITY(DFN) 177 178 NOK1STAT(DFN) 179 180 NOK1ZIP(DFN) 181 182 NOK1HTEL(DFN) 183 184 NOK1WTEL(DFN) 185 186 NOK1SAME(DFN) 187 188 NOK2FAM(DFN) 189 190 191 192 NOK2GIV(DFN) 193 194 195 196 NOK2MID(DFN) 197 198 199 200 NOK2SUF(DFN) 201 202 203 204 NOK2DISP(DFN) 205 206 207 208 NOK2REL(DFN) 209 210 NOK2ADD1(DFN) 211 212 NOK2ADD2(DFN) 213 214 215 216 217 NOK2CITY(DFN) 218 219 NOK2STAT(DFN) 220 221 NOK2ZIP(DFN) 222 223 NOK2HTEL(DFN) 224 225 NOK2WTEL(DFN) 226 227 NOK2SAME(DFN) 228 229 EMERFAM(DFN) 230 231 232 233 EMERGIV(DFN) 234 235 236 237 EMERMID(DFN) 238 239 240 241 EMERSUF(DFN) 242 243 244 245 EMERDISP(DFN) 246 247 248 249 EMERREL(DFN) 250 251 EMERADD1(DFN) 252 253 EMERADD2(DFN) 254 255 256 257 258 EMERCITY(DFN) 259 260 EMERSTAT(DFN) 261 262 EMERZIP(DFN) 263 264 EMERHTEL(DFN) 265 266 EMERWTEL(DFN) 267 268 EMERSAME(DFN) 269 1 C0CDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ; 4 ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU 5 ; General Public License. 6 ; 7 ; This program is distributed in the hope that it will be useful, 8 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 9 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 10 ; GNU General Public License for more details. 11 ; 12 ; You should have received a copy of the GNU General Public License along 13 ; with this program; if not, write to the Free Software Foundation, Inc., 14 ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 15 ; 16 ; FAMILY Family Name 17 ; GIVEN Given Name 18 ; MIDDLE Middle Name 19 ; SUFFIX Suffix Name 20 ; DISPNAME Display Name 21 ; DOB Date of Birth 22 ; GENDER Get Gender 23 ; SSN Get SSN for ID 24 ; ADDRTYPE Get Home Address 25 ; ADDR1 Get Home Address line 1 26 ; ADDR2 Get Home Address line 2 27 ; CITY Get City for Home Address 28 ; STATE Get State for Home Address 29 ; ZIP Get Zip code for Home Address 30 ; COUNTY Get County for our Address 31 ; COUNTRY Get Country for our Address 32 ; RESTEL Residential Telephone 33 ; WORKTEL Work Telephone 34 ; EMAIL Email Adddress 35 ; CELLTEL Cell Phone 36 ; NOK1FAM Next of Kin 1 (NOK1) Family Name 37 ; NOK1GIV NOK1 Given Name 38 ; NOK1MID NOK1 Middle Name 39 ; NOK1SUF NOK1 Suffi Name 40 ; NOK1DISP NOK1 Display Name 41 ; NOK1REL NOK1 Relationship to the patient 42 ; NOK1ADD1 NOK1 Address 1 43 ; NOK1ADD2 NOK1 Address 2 44 ; NOK1CITY NOK1 City 45 ; NOK1STAT NOK1 State 46 ; NOK1ZIP NOK1 Zip Code 47 ; NOK1HTEL NOK1 Home Telephone 48 ; NOK1WTEL NOK1 Work Telephone 49 ; NOK1SAME Is NOK1's Address the same the patient? 50 ; NOK2FAM NOK2 Family Name 51 ; NOK2GIV NOK2 Given Name 52 ; NOK2MID NOK2 Middle Name 53 ; NOK2SUF NOK2 Suffi Name 54 ; NOK2DISP NOK2 Display Name 55 ; NOK2REL NOK2 Relationship to the patient 56 ; NOK2ADD1 NOK2 Address 1 57 ; NOK2ADD2 NOK2 Address 2 58 ; NOK2CITY NOK2 City 59 ; NOK2STAT NOK2 State 60 ; NOK2ZIP NOK2 Zip Code 61 ; NOK2HTEL NOK2 Home Telephone 62 ; NOK2WTEL NOK2 Work Telephone 63 ; NOK2SAME Is NOK2's Address the same the patient? 64 ; EMERFAM Emergency Contact (EMER) Family Name 65 ; EMERGIV EMER Given Name 66 ; EMERMID EMER Middle Name 67 ; EMERSUF EMER Suffi Name 68 ; EMERDISP EMER Display Name 69 ; EMERREL EMER Relationship to the patient 70 ; EMERADD1 EMER Address 1 71 ; EMERADD2 EMER Address 2 72 ; EMERCITY EMER City 73 ; EMERSTAT EMER State 74 ; EMERZIP EMER Zip Code 75 ; EMERHTEL EMER Home Telephone 76 ; EMERWTEL EMER Work Telephone 77 ; EMERSAME Is EMER's Address the same the NOK? 78 ; 79 W "No Entry at top!" Q 80 ; 81 ;**Revision History** 82 ; - June 15, 08: v0.1 using merged global 83 ; - Oct 3, 08: v0.2 using fileman calls, many formatting changes. 84 ; 85 ; All methods are Public and Extrinsic 86 ; All calls use Fileman file 2 (Patient). 87 ; You can obtain field numbers using the data dictionary 88 ; 89 FAMILY(DFN) ; Family Name 90 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 91 D NAMECOMP^XLFNAME(.NAME) 92 Q NAME("FAMILY") 93 GIVEN(DFN) ; Given Name 94 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 95 D NAMECOMP^XLFNAME(.NAME) 96 Q NAME("GIVEN") 97 MIDDLE(DFN) ; Middle Name 98 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 99 D NAMECOMP^XLFNAME(.NAME) 100 Q NAME("MIDDLE") 101 SUFFIX(DFN) ; Suffi Name 102 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 103 D NAMECOMP^XLFNAME(.NAME) 104 Q NAME("SUFFIX") 105 DISPNAME(DFN) ; Display Name 106 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 107 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 108 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 109 DOB(DFN) ; Date of Birth 110 N DOB S DOB=$$GET1^DIQ(2,DFN,.03,"I") 111 ; Date in FM Date Format. Convert to UTC/ISO 8601. 112 Q $$FMDTOUTC^C0CUTIL(DOB,"D") 113 GENDER(DFN) ; Gender/Sex 114 Q $$GET1^DIQ(2,DFN,.02,"I")_"^"_$$GET1^DIQ(2,DFN,.02,"E") ; 115 SSN(DFN) ; SSN 116 Q $$GET1^DIQ(2,DFN,.09) 117 ADDRTYPE(DFN) ; Address Type 118 ; Vista only stores a home address for the patient. 119 Q "Home" 120 ADDR1(DFN) ; Get Home Address line 1 121 Q $$GET1^DIQ(2,DFN,.111) 122 ADDR2(DFN) ; Get Home Address line 2 123 ; Vista has Lines 2,3; CCR has only line 1,2; so compromise 124 N ADDLN2,ADDLN3 125 S ADDLN2=$$GET1^DIQ(2,DFN,.112),ADDLN3=$$GET1^DIQ(2,DFN,.113) 126 Q:ADDLN3="" ADDLN2 127 Q ADDLN2_", "_ADDLN3 128 CITY(DFN) ; Get City for Home Address 129 Q $$GET1^DIQ(2,DFN,.114) 130 STATE(DFN) ; Get State for Home Address 131 Q $$GET1^DIQ(2,DFN,.115) 132 ZIP(DFN) ; Get Zip code for Home Address 133 Q $$GET1^DIQ(2,DFN,.116) 134 COUNTY(DFN) ; Get County for our Address 135 Q $$GET1^DIQ(2,DFN,.117) 136 COUNTRY(DFN) ; Get Country for our Address 137 ; Unfortunately, it's not stored anywhere in Vista, so the inevitable... 138 Q "USA" 139 RESTEL(DFN) ; Residential Telephone 140 Q $$GET1^DIQ(2,DFN,.131) 141 WORKTEL(DFN) ; Work Telephone 142 Q $$GET1^DIQ(2,DFN,.132) 143 EMAIL(DFN) ; Email Adddress 144 Q $$GET1^DIQ(2,DFN,.133) 145 CELLTEL(DFN) ; Cell Phone 146 Q $$GET1^DIQ(2,DFN,.134) 147 NOK1FAM(DFN) ; Next of Kin 1 (NOK1) Family Name 148 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 149 D NAMECOMP^XLFNAME(.NAME) 150 Q NAME("FAMILY") 151 NOK1GIV(DFN) ; NOK1 Given Name 152 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 153 D NAMECOMP^XLFNAME(.NAME) 154 Q NAME("GIVEN") 155 NOK1MID(DFN) ; NOK1 Middle Name 156 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 157 D NAMECOMP^XLFNAME(.NAME) 158 Q NAME("MIDDLE") 159 NOK1SUF(DFN) ; NOK1 Suffi Name 160 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 161 D NAMECOMP^XLFNAME(.NAME) 162 Q NAME("SUFFIX") 163 NOK1DISP(DFN) ; NOK1 Display Name 164 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 165 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 166 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 167 NOK1REL(DFN) ; NOK1 Relationship to the patient 168 Q $$GET1^DIQ(2,DFN,.212) 169 NOK1ADD1(DFN) ; NOK1 Address 1 170 Q $$GET1^DIQ(2,DFN,.213) 171 NOK1ADD2(DFN) ; NOK1 Address 2 172 N ADDLN2,ADDLN3 173 S ADDLN2=$$GET1^DIQ(2,DFN,.214),ADDLN3=$$GET1^DIQ(2,DFN,.215) 174 Q:ADDLN3="" ADDLN2 175 Q ADDLN2_", "_ADDLN3 176 NOK1CITY(DFN) ; NOK1 City 177 Q $$GET1^DIQ(2,DFN,.216) 178 NOK1STAT(DFN) ; NOK1 State 179 Q $$GET1^DIQ(2,DFN,.217) 180 NOK1ZIP(DFN) ; NOK1 Zip Code 181 Q $$GET1^DIQ(2,DFN,.218) 182 NOK1HTEL(DFN) ; NOK1 Home Telephone 183 Q $$GET1^DIQ(2,DFN,.219) 184 NOK1WTEL(DFN) ; NOK1 Work Telephone 185 Q $$GET1^DIQ(2,DFN,.21011) 186 NOK1SAME(DFN) ; Is NOK1's Address the same the patient? 187 Q $$GET1^DIQ(2,DFN,.2125) 188 NOK2FAM(DFN) ; NOK2 Family Name 189 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 190 D NAMECOMP^XLFNAME(.NAME) 191 Q NAME("FAMILY") 192 NOK2GIV(DFN) ; NOK2 Given Name 193 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 194 D NAMECOMP^XLFNAME(.NAME) 195 Q NAME("GIVEN") 196 NOK2MID(DFN) ; NOK2 Middle Name 197 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 198 D NAMECOMP^XLFNAME(.NAME) 199 Q NAME("MIDDLE") 200 NOK2SUF(DFN) ; NOK2 Suffi Name 201 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 202 D NAMECOMP^XLFNAME(.NAME) 203 Q NAME("SUFFIX") 204 NOK2DISP(DFN) ; NOK2 Display Name 205 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 206 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 207 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 208 NOK2REL(DFN) ; NOK2 Relationship to the patient 209 Q $$GET1^DIQ(2,DFN,.2192) 210 NOK2ADD1(DFN) ; NOK2 Address 1 211 Q $$GET1^DIQ(2,DFN,.2193) 212 NOK2ADD2(DFN) ; NOK2 Address 2 213 N ADDLN2,ADDLN3 214 S ADDLN2=$$GET1^DIQ(2,DFN,.2194),ADDLN3=$$GET1^DIQ(2,DFN,.2195) 215 Q:ADDLN3="" ADDLN2 216 Q ADDLN2_", "_ADDLN3 217 NOK2CITY(DFN) ; NOK2 City 218 Q $$GET1^DIQ(2,DFN,.2196) 219 NOK2STAT(DFN) ; NOK2 State 220 Q $$GET1^DIQ(2,DFN,.2197) 221 NOK2ZIP(DFN) ; NOK2 Zip Code 222 Q $$GET1^DIQ(2,DFN,.2198) 223 NOK2HTEL(DFN) ; NOK2 Home Telephone 224 Q $$GET1^DIQ(2,DFN,.2199) 225 NOK2WTEL(DFN) ; NOK2 Work Telephone 226 Q $$GET1^DIQ(2,DFN,.211011) 227 NOK2SAME(DFN) ; Is NOK2's Address the same the patient? 228 Q $$GET1^DIQ(2,DFN,.21925) 229 EMERFAM(DFN) ; Emergency Contact (EMER) Family Name 230 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 231 D NAMECOMP^XLFNAME(.NAME) 232 Q NAME("FAMILY") 233 EMERGIV(DFN) ; EMER Given Name 234 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 235 D NAMECOMP^XLFNAME(.NAME) 236 Q NAME("GIVEN") 237 EMERMID(DFN) ; EMER Middle Name 238 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 239 D NAMECOMP^XLFNAME(.NAME) 240 Q NAME("MIDDLE") 241 EMERSUF(DFN) ; EMER Suffi Name 242 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 243 D NAMECOMP^XLFNAME(.NAME) 244 Q NAME("SUFFIX") 245 EMERDISP(DFN) ; EMER Display Name 246 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 247 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 248 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 249 EMERREL(DFN) ; EMER Relationship to the patient 250 Q $$GET1^DIQ(2,DFN,.331) 251 EMERADD1(DFN) ; EMER Address 1 252 Q $$GET1^DIQ(2,DFN,.333) 253 EMERADD2(DFN) ; EMER Address 2 254 N ADDLN2,ADDLN3 255 S ADDLN2=$$GET1^DIQ(2,DFN,.334),ADDLN3=$$GET1^DIQ(2,DFN,.335) 256 Q:ADDLN3="" ADDLN2 257 Q ADDLN2_", "_ADDLN3 258 EMERCITY(DFN) ; EMER City 259 Q $$GET1^DIQ(2,DFN,.336) 260 EMERSTAT(DFN) ; EMER State 261 Q $$GET1^DIQ(2,DFN,.337) 262 EMERZIP(DFN) ; EMER Zip Code 263 Q $$GET1^DIQ(2,DFN,.338) 264 EMERHTEL(DFN) ; EMER Home Telephone 265 Q $$GET1^DIQ(2,DFN,.339) 266 EMERWTEL(DFN) ; EMER Work Telephone 267 Q $$GET1^DIQ(2,DFN,.33011) 268 EMERSAME(DFN) ; Is EMER's Address the same the NOK? 269 Q $$GET1^DIQ(2,DFN,.3305) -
ccr/branches/ohum/p/C0CENC.m
r1342 r1428 1 C0CENC 2 ;;1.0;C0C;;May 21, 2010;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(ENCXML,DFN,ENCOUT) 25 26 27 28 29 30 31 32 33 34 TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) 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 GETTYPE(ZARY,ZTXT,ZCDE,ZSYS) 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 ANYTXT(ZVST) 130 131 132 133 134 135 136 137 138 139 140 141 142 143 PRV(IARY) 144 145 146 147 148 149 150 151 DATE(ISTR) 152 153 154 CPT(ISTR) 155 156 157 158 159 160 161 162 163 164 165 166 167 168 MAP(ENCXML,C0CENC,ENCOUT) 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 1 C0CENC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;Copyright 2010 George Lilly, University of Minnesota and others. 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 W "NO ENTRY FROM TOP",! 22 Q 23 ; 24 EXTRACT(ENCXML,DFN,ENCOUT) ; EXTRACT ENCOUNTERS INTO XML TEMPLATE 25 ; ENCXML AND ENCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED 26 ; 27 D SETVARS^C0CPROC ; SET UP VARIABLES FOR PROCEDUCRES, ENCOUNTERS, AND NOTES 28 ;I '$D(@C0CENC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE 29 K @C0CENC 30 D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET ENCOUNTERS 31 D MAP(ENCXML,C0CENC,ENCOUT) ;MAP RESULTS FOR ENCOUNTERS 32 Q 33 ; 34 TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, 35 ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME 36 ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES 37 ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT 38 ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 39 ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM 40 ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS 41 ; 42 ;K VISIT,LST,NOTE 43 I '$D(C0CPRC) D SETVARS^C0CPROC ; INITIALIZE WORK AREAS IF NOT ALREADY THERE 44 I '$D(VISIT) D ENTRY^C0CCPT(DFN,,,1) ; RETURNS VISIT LOCAL VARIABLE 45 ; NEED TO ADD START AND END DATES FROM PARAMETERS 46 N ZI S ZI="" 47 N PREVCPT,PREVDT S (PREVCPT,PREVDT)="" 48 F S ZI=$O(VISIT(ZI),-1) Q:ZI="" D ; REVERSE TIME ORDER - MOST RECENT FIRST 49 . N ZDATE 50 . S ZDATE=$$DATE(VISIT(ZI,"DATE",0)) 51 . S ZPRVARY=$NA(VISIT(ZI,"PRV")) 52 . N ZPRV 53 . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM 54 . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON 55 . ; ENCOBJECTID - ENCOUNTER OBJECT ID 56 . ; ENCDATETIME - ENCOUNTER DATE TIME 57 . ; ENCTYPETXT - ENCOUNTER TYPE (PLANNING TO USE ADMINISTRATIVE CPT IF AVAIL) 58 . ; ENCTYPECODE - CODE OF TYPE - PLANNING CPT CODE 59 . ; ENCTYPECODESYS - CODING SYSTEM OF TYPE - CPT-4 60 . ; ENCDESCTXT - ENCOUNTER DESCRIPTION TEXT 61 . ; ENCDESCCODE - ENCOUNTER DESCRIPTION CODE 62 . ; ENCDESCCODESYS - ENCOUNTER DESCRIPTION CODE SYSTEM 63 . ; ENCLOCACTORID - ENCOUNTER LOCATION ACTOR ID 64 . ; ENCPRVACTORID - ENCOUNTER PRACTIONER ACTOR ID 65 . ; ENCINDTXT - ENCOUNTER INDICATION TEXT 66 . ; ENCINDCODE - ENCOUNTER INDICATION CODE 67 . ; ENCINDCODESYS - ENCOUNTER INDICATION CODE SYSTEM 68 . ; ENCACTORID - ENCOUNTER SOURCE ACTOR ID 69 . ; ENCCOMMENTID - ENCOUNTER COMMENT ID - POINTER TO NOTE IN COMMENT SECTION 70 . S ZRNF("ENCOBJECTID")="ENCOUNTER_"_ZI 71 . S ZRNF("ENCDATETIME")=ZDATE ; ENCOUNTER DATE TIME 72 . S ZRNF("ENCTYPETXT")="" 73 . S ZRNF("ENCTYPECODE")="" 74 . S ZRNF("ENCTYPECODESYS")="" 75 . S ZRNF("ENCDESCTXT")="" 76 . S ZRNF("ENCDESCCODE")="" 77 . S ZRNF("ENCDESCCODESYS")="" 78 . N TYPTXT,TYPCDE,TYPSYS ; WILL BE UPDATED BY GETTYPE CALL 79 . I $$GETTYPE("VISIT(ZI)",.TYPTXT,.TYPCDE,.TYPSYS) D ; RETURNS FALSE IF NO TYPE 80 . . S ZRNF("ENCTYPETXT")=TYPTXT 81 . . S ZRNF("ENCTYPECODE")=TYPCDE 82 . . S ZRNF("ENCTYPECODESYS")=TYPSYS 83 . . S ZRNF("ENCDESCTXT")=TYPTXT ; FOR NOW, DESCRIPTION IS SAME AS TYPE 84 . . S ZRNF("ENCDESCCODE")=TYPCDE ; DESCRIPTION IS REQUIRED (TYPE IS NOT) 85 . . S ZRNF("ENCDESCCODESYS")=TYPSYS ; NEED TO CLARIFY FOR VISTA 86 . S ZRNF("ENCLOCACTORID")="ACTORORGANIZATION_1" 87 . S ZRNF("ENCPRVACTORID")=ZPRV ; PRIMARY PROVIDER LISTED FOR THE ENCOUNTER 88 . S ZRNF("ENCINDTXT")="" ; WE WILL PUT POINTERS TO PROBLEMS HERE 89 . S ZRNF("ENCINDCODE")="" 90 . S ZRNF("ENCINDCODESYS")="" 91 . S ZRNF("ENCACTORID")=ZPRV ; SOURCE WILL BE PRIMARY PROVIDER 92 . S ZRNF("ENCCOMMENTID")="" 93 . I $G(VISIT(ZI,"TEXT",1))'="" D ; THERE IS A NOTE 94 . . M @C0CNTE@(ZI,"TEXT")=VISIT(ZI,"TEXT") ; COPY THE TEXT OF THE NOTE 95 . . S @C0CNTE@(ZI,"COMMENTOBJECTID")="NOTE_"_ZI 96 . . S @C0CNTE@(ZI,"CMTDATETIME")=ZDATE ; DATE OF THE NOTE 97 . . S @C0CNTE@(ZI,"ACTORSOURCEID")=ZPRV ; SOURCE OF THE NOTE 98 . . S ZRNF("ENCCOMMENTID")="NOTE_"_ZI ; POINT TO THE NOTE FROM THE ENCOUNTER 99 . D RNF1TO2^C0CRNF(C0CENC,"ZRNF") ; ADD THIS ROW TO THE ARRAY 100 . ;S PREVCPT=ZCPT 101 . ;S PREVDT=ZDATE 102 N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"ENCOUNTERS")) 103 M @ZRIM=@C0CENC@("V") 104 K VISIT,LST,NOTE 105 Q 106 ; 107 GETTYPE(ZARY,ZTXT,ZCDE,ZSYS) ; EXTRINSIC WHICH RETURNS FALSE IF NO ENCOUNTER TYPE 108 ; UPDATES ZTXT WITH ENCOUNTER TYPE TEXT, ZCDE WITH ENCOUNTER TYPE CODE 109 ; AND ZSYS WITH ENCOUNTER TYPE CODING SYSTEM 110 ; THIS ROUTINE SHOULD BE UPDATED TO SEARCH FOR AN ADMINISTRATIVE CPT CODE 111 ; INSTEAD OF JUST THE FIRST ONE IN THE LIST - GPL 1/23/10 112 N ZS,ZC 113 S ZC="" S ZS="" 114 S (ZTXT,ZCDE,ZSYS)="" 115 F S ZC=$O(@ZARY@("CPT",ZC)) Q:ZC="" D ; TRY AND FIND A "99" CPT CODE 116 . N ZT 117 . S ZT=$$CPT^C0CPROC(@ZARY@("CPT",ZC)) ; VALUES IN A CPT MULTIPLE 118 . I $E($P(ZT,U,1),1,2)="99" S ZS=ZT ; IS IT AN ADMIN CPT CODE? 119 I ZS'="" D ; CODED ENCOUNTER TYPE FOUND 120 . S ZTXT=$P(ZS,U,2)_" "_$P(ZS,U,3) ; USE BOTH PIECES FOR THE TYPE 121 . S ZCDE=$P($$CPT^C0CPROC(ZS),U,1) ; CPT CODE FOR ENCOUTER 122 . S ZSYS="" 123 . I ZCDE'="" S ZSYS="CPT-4" ; ONLY HAVE A CODING SYSTEM IF THERE IS A CODE 124 I ZS="" S ZTXT=$$ANYTXT(ZARY) ; TRY AND GET FREE FORM TEXT FROM CPT MULTIPLES 125 I ZTXT="" Q 0 ; FAILED 126 W !,ZTXT 127 Q 1 ; SUCCESS 128 ; 129 ANYTXT(ZVST) ; EXTRINSIC WHICH RETURNS TEXT FROM THE CPT MULTIPLE 130 ; OF A VISIT ARRAY WITHOUT CHECKING THE CPT CODE (THAT HAVING FAILED) 131 ; ZVST IS THE VISIT ARRAY AND IS PASSED BY NAME 132 ; RETURNS TEXT TO USE AS ENCOUNTER TYPE IF ANY 133 N ZK,ZL 134 S ZK="" S ZL="" 135 F S ZK=$O(@ZVST@("CPT",ZK)) Q:ZK="" D ; LOOK FOR SOME TEXT TO USE 136 . N ZT 137 . S ZT=$G(@ZVST@("CPT",ZK)) ; LOOK AT THIS CPT MULTIPLE 138 . I $P(ZT,U,2)_" "_$P(ZT,U,3)'=" " S ZL=$P(ZT,U,2)_" "_$P(ZT,U,3) 139 . ; CONCATENATE PIECE 2 AND 3 OF THE CPT MULTIPLE FOR A TYPE 140 I ZL="" S ZL=$G(@ZVST@("CLASS")) ; USE THE NOTE DOCUMENT CLASS FOR ENCOUTNER TYPE 141 Q ZL 142 ; 143 PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME 144 N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN="" 145 F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH PRV SEG 146 . I ZR'="" Q ;ONLY WANT THE FIRST PRIMARY PROVIDER 147 . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1) 148 I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR 149 Q ZRTN 150 ; 151 DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT 152 Q $$FMDTOUTC^C0CUTIL(ISTR,"DT") 153 ; 154 CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS 155 ; CPT^CATEGORY^TEXT 156 N Z1,Z2,Z3,ZRTN 157 S Z1=$P(ISTR,U,1) 158 I Z1="" D ; 159 . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1) 160 I Z1'="" D ; IF THERE IS A CPT CODE IN THERE 161 . ;S Z1=$P(ISTR,U,1) 162 . S Z2=$P(ISTR,U,2) 163 . S Z3=$P(ISTR,U,3) 164 . S ZRTN=Z1_U_Z2_U_Z3 165 E S ZRTN="" 166 Q ZRTN 167 ; 168 MAP(ENCXML,C0CENC,ENCOUT) ; MAP PROCEDURES XML 169 ; 170 N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"ENCTEMP")) ;WORK AREA FOR TEMPLATE 171 K @ZTEMP 172 N ZBLD 173 S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"ENCBLD")) ; BUILD LIST AREA 174 D QUEUE^C0CXPATH(ZBLD,ENCXML,1,1) ; FIRST LINE 175 N ZINNER 176 D QUERY^C0CXPATH(ENCXML,"//Encounters/Encounter","ZINNER") ;ONE ENCOUNTER 177 N ZTMP,ZVAR,ZI 178 S ZI="" 179 F S ZI=$O(@C0CENC@("V",ZI)) Q:ZI="" D ;FOR EACH ENCOUNTER 180 . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS ENCOUNTER XML 181 . S ZVAR=$NA(@C0CENC@("V",ZI)) ;THIS ENCOUNTER VARIABLES 182 . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE 183 . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD 184 D QUEUE^C0CXPATH(ZBLD,ENCXML,@ENCXML@(0),@ENCXML@(0)) 185 N ZZTMP 186 D BUILD^C0CXPATH(ZBLD,ENCOUT) ;BUILD FINAL XML 187 K @ZTEMP,@ZBLD,@C0CENC 188 Q 189 ; -
ccr/branches/ohum/p/C0CENV.m
r1342 r1428 1 C0CENV 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 ENV 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 CHECK 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 EXIT 40 41 42 43 44 45 46 47 48 PRE 49 50 51 52 53 54 55 56 POST 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 POST1 74 75 76 77 78 79 80 81 82 83 84 85 POST2 86 87 88 89 90 91 92 93 94 95 96 97 POST3 98 99 100 101 102 103 104 105 106 107 108 109 POST4 110 111 112 113 114 115 116 117 118 119 120 121 POST5 122 123 124 125 126 127 128 129 130 131 132 133 POST6 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 POST7 170 171 172 173 174 175 176 BMES(STR) 177 178 179 180 181 182 183 LOAD(X) 184 185 186 187 188 189 190 191 SAVE(OLD,NEW) 192 193 194 195 1 C0CENV ;WV/JMC - CCD/CCR Environment Check/Install Routine ; Aug 16, 2009 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 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 37 ; 38 ; 39 EXIT ; 40 ; 41 ; 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 ; 50 ; No action needed in pre-install 51 D BMES("No action need for pre-install") 52 ; 53 Q 54 ; 55 ; 56 POST ;Post install 57 ; 58 ; Check for RPMS system with V LAB file. 59 ; 60 I $$VFILE^DILFD(9000010.09)'=1 Q 61 ; 62 S %=$$NEWCP^XPDUTL("RPMS1","POST1^C0CENV") 63 S %=$$NEWCP^XPDUTL("RPMS2","POST2^C0CENV") 64 S %=$$NEWCP^XPDUTL("RPMS3","POST3^C0CENV") 65 S %=$$NEWCP^XPDUTL("RPMS4","POST4^C0CENV") 66 S %=$$NEWCP^XPDUTL("RPMS5","POST5^C0CENV") 67 S %=$$NEWCP^XPDUTL("RPMS6","POST6^C0CENV") 68 S %=$$NEWCP^XPDUTL("RPMS7","POST7^C0CENV") 69 ; 70 Q 71 ; 72 ; 73 POST1 ; Checkpoint call back entry point. 74 ; Add new style ALR1 cross-reference to V LAB file. 75 ; 76 N MSG 77 S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z") 78 D BMES(MSG) 79 D ALR1^C0CLA7DD 80 S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 81 D BMES(MSG) 82 Q 83 ; 84 ; 85 POST2 ; Checkpoint call back entry point. 86 ; Add new style ALR2 cross-reference to V LAB file. 87 ; 88 N MSG 89 S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z") 90 D BMES(MSG) 91 D ALR2^C0CLA7DD 92 S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 93 D BMES(MSG) 94 Q 95 ; 96 ; 97 POST3 ; Checkpoint call back entry point. 98 ; Add new style ALR3 cross-reference to V LAB file. 99 ; 100 N MSG 101 S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z") 102 D BMES(MSG) 103 D ALR3^C0CLA7DD 104 S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 105 D BMES(MSG) 106 Q 107 ; 108 ; 109 POST4 ; Checkpoint call back entry point. 110 ; Add new style ALR4 cross-reference to V LAB file. 111 ; 112 N MSG 113 S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z") 114 D BMES(MSG) 115 D ALR4^C0CLA7DD 116 S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 117 D BMES(MSG) 118 Q 119 ; 120 ; 121 POST5 ; Checkpoint call back entry point. 122 ; Add new style ALR5 cross-reference to V LAB file. 123 ; 124 N MSG 125 S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z") 126 D BMES(MSG) 127 D ALR5^C0CLA7DD 128 S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 129 D BMES(MSG) 130 Q 131 ; 132 ; 133 POST6 ; Checkpoint call back entry point. 134 ; Check for RPMS system and determine LAB patch level 135 ; and need to load in C0C version of LA7 routines. 136 ; 137 N MSG 138 ; 139 ; Load and rename C0CQRY2 to LA7QRY2 if LA*5.2*69 not installed 140 I '$$PATCH^XPDUTL("LA*5.2*69") D 141 . S MSG="This system missing LAB patch LA*5.2*69" 142 . D BMES(MSG) 143 . S MSG="Renaming routine C0CQRY2 to LA7QRY2" 144 . D BMES(MSG) 145 . D LOAD("C0CQRY2") 146 . D SAVE("C0CQRY2","LA7QRY2") 147 ; 148 ; Load and rename C0CVOBX1 to LA7VOBX1 if LA*5.2*64 not installed. 149 I '$$PATCH^XPDUTL("LA*5.2*64") D 150 . S MSG="This system missing LAB patch LA*5.2*64" 151 . D BMES(MSG) 152 . S MSG="Renaming routine C0CVOBX1 to LA7VOBX1" 153 . D BMES(MSG) 154 . D LOAD("C0CVOBX1") 155 . D SAVE("C0CVOBX1","LA7VOBX1") 156 ; 157 ; Load and rename C0CQRY1 to LA7QRY1 if LA*5.2*68 not installed. 158 I '$$PATCH^XPDUTL("LA*5.2*68") D 159 . S MSG="This system missing LAB patch LA*5.2*68" 160 . D BMES(MSG) 161 . S MSG="Renaming routine C0CQRY1 to LA7QRY1" 162 . D BMES(MSG) 163 . D LOAD("C0CQRY1") 164 . D SAVE("C0CQRY1","LA7QRY1") 165 ; 166 Q 167 ; 168 ; 169 POST7 ; Checkpoint call back entry point. 170 ; 171 D REINDEX^C0CLA7DD 172 ; 173 Q 174 ; 175 ; 176 BMES(STR) ; Write BMES^XPDUTL statements 177 ; 178 D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM)) 179 ; 180 Q 181 ; 182 ; 183 LOAD(X) ; load routine X 184 N %N,DIF,XCNP 185 K ^TMP($J,X) 186 S DIF="^TMP($J,X,",XCNP=0 187 X ^%ZOSF("LOAD") 188 Q 189 ; 190 ; 191 SAVE(OLD,NEW) ; restore routine X 192 N %,DIE,X,XCM,XCN,XCS 193 S DIE="^TMP($J,"""_OLD_""",",XCN=0,X=NEW 194 X ^%ZOSF("SAVE") 195 Q -
ccr/branches/ohum/p/C0CEVC.m
r1342 r1428 1 C0CEVC 2 ;;1.0;C0C;;Mar 1, 2010;Build 2 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 1 C0CEVC ; CCDCCR/GPL - SUPPORT FOR EWD VISTCOM PAGES ; 3/1/2010 2 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CEWD 2 ;;0.1;CCDCCR;nopatch;noreleasedate;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 TOKEN() 23 24 25 STORE(ZARY) 26 27 28 29 30 31 32 33 GET(C0ERTN,C0ETOKEN,NOKILL) 34 35 36 37 38 39 40 41 42 URLTOKEN(sessid) 43 44 45 46 47 48 49 50 cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options) 51 52 53 54 55 56 57 58 59 60 61 62 63 64 set1 65 66 67 68 test1(sessid) 69 70 71 1 C0CEWD ; CCDCCR/GPL - CCR EWD utilities; 1/6/11 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 TOKEN() ; EXTRINSIC WHICH RETURNS A NEW RANDOM TOKEN 23 Q $$UUID^C0CUTIL ; USE THE UUID FUNCTION IN THE CCR PACKAGE 24 ; 25 STORE(ZARY) ; STORE AN ARRAY OF VALUES INDEXED BY A NEW TOKEN 26 ; IN ^TMP("C0E","TOKEN") FOR LATER RETRIEVAL FROM INSIDE AN EWD SESSION 27 ; RETURNS THE TOKEN. ZARY IS PASSED BY NAME 28 N ZT 29 S ZT=$$TOKEN ; GET A NEW TOKEN 30 M ^TMP("C0E","TOKEN",ZT)=@ZARY ; 31 Q ZT 32 ; 33 GET(C0ERTN,C0ETOKEN,NOKILL) ; RETRIEVE A STORED ARRAY INDEXED BY ZTOKEN 34 ; KILL THE ARRAY AFTER RETRIEVAL UNLESS NOKILL=1 35 ; C0ERTN IS PASSED BY NAME 36 I '$D(^TMP("C0E","TOKEN",C0ETOKEN)) D Q ; DOESN'T EXIST 37 . S @C0ERTN="" ; PASS BACK NULL 38 M @C0ERTN=^TMP("C0E","TOKEN",C0ETOKEN) ; RETRIEVE 39 I $G(NOKILL)'=1 K ^TMP("C0E","TOKEN",C0ETOKEN) ; DELETE 40 Q 41 ; 42 URLTOKEN(sessid) ; EXTRINSIC WHICH RETRIEVES THE TOKEN PASSED ON THE URL 43 ; IN EWD EXAMPLE: https://example.com/ewd/myApp/index.ewd?token="12345" 44 N token 45 S token="" 46 s token=$$getRequestValue^%zewdAPI("token",sessid) 47 s token=$tr(token,"""") ; strip out quotes 48 Q token 49 ; 50 cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options) 51 ; 52 n maxNo,noFound 53 ; 54 s maxNo=50 55 s noFound=0 56 f s seedValue=$o(^DPT("B",seedValue)) q:seedValue="" q:noFound=maxNo d 57 . s lastSeedValue=seedValue 58 . i prefix'="",$e(seedValue,1,$l(prefix))'=prefix q 59 . s optionNo=optionNo+1 60 . s noFound=noFound+1 61 . s options(optionNo)=seedValue 62 QUIT 63 ; 64 set1 ; 65 s ^zewd("comboPlus","methodMap","test")="cbTestMethod^C0PEREW" 66 q 67 ; 68 test1(sessid) ; 69 d setSessionValue^%zewdAPI("testing","ZZ",sessid) 70 q 0 71 ; -
ccr/branches/ohum/p/C0CEWD1.m
r1342 r1428 1 C0CEWD1 2 ;;0.1;CCDCCR;nopatch;noreleasedate;Build 2 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 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CFM1 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 PUTRIM(DFN,ZWHICH) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 PUTRIM1(DFN,ZZTYP,ZVARS) 40 41 42 43 44 45 46 47 48 PUTELS(DFN,ZTYPE,ZOCC,ZVALS) 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 VARPTR(ZVAR,ZTYP) 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 BLDTYPS 118 119 120 121 122 123 124 125 FIXSEC 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 SETFDA(C0CSN,C0CSV) 143 144 145 146 147 148 149 150 151 152 ZFILE(ZFN,ZTAB) 153 154 155 156 157 158 159 160 ZFIELD(ZFN,ZTAB) 161 162 163 164 165 166 167 168 169 ZVALUE(ZFN,ZTAB) 170 171 172 173 174 175 176 177 1 C0CFM1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 W ! 22 Q 23 ; 24 PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE 25 ; 26 S C0CGLB=$NA(^TMP("GPLRIM","VARS",DFN)) 27 I '$D(ZWHICH) S ZWHICH="ALL" 28 I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED 29 . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) 30 . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION 31 E D ; MULTIPLE SECTIONS 32 . S C0CVARS=$NA(@C0CGLB) 33 . S C0CI="" 34 . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION 35 . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION 36 . . D PUTRIM1(DFN,C0CI,C0CVARSN) 37 Q 38 ; 39 PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS 40 ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" 41 S C0CX=0 42 F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE 43 . W "ZOCC=",C0CX,! 44 . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE 45 . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE 46 Q 47 ; 48 PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE 49 ; ^C0C(171.201, DFN IS THE PATIENT IEN PASSED BY VALUE 50 ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE 51 ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC 52 ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM 53 ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT 54 ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES 55 ; 56 S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 57 ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE 58 N ZF,ZFV S ZF=171.201 S ZFV=171.2012 59 S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS 60 N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER 61 N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) 62 W "ZTYPE: ",ZTYPE," ",ZTYPN,! 63 N ZVARN ; IEN OF VARIABLE BEING PROCESSED 64 ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE 65 S C0CFDA(ZF,"?+1,",.01)=DFN 66 S C0CFDA(ZF,"?+1,",.02)=ZSRC 67 S C0CFDA(ZF,"?+1,",.03)=ZTYPN 68 S C0CFDA(ZF,"?+1,",.04)=ZOCC ;CREATE OCCURANCE 69 K ZERR 70 D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER 71 I $D(ZERR) B ;OOPS 72 K C0CFDA 73 S ZD0=$O(^C0C(ZF,"C",DFN,ZSRC,ZTYPN,ZOCC,"")) 74 W "RECORD NUMBER: ",ZD0,! 75 ;B 76 S ZCNT=0 77 S ZC0CI="" ; 78 F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; 79 . I ZC0CI'="M" D ; NOT A SUBVARIABLE 80 . . S ZCNT=ZCNT+1 ;INCREMENT COUNT 81 . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT 82 . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND 83 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN 84 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) 85 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN 86 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) 87 ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" 88 ;S GT1(170,"?+1,",12)="DIR" 89 ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" 90 ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" 91 D CLEAN^DILF 92 D UPDATE^DIE("","C0CFDA","","ZERR") 93 Q 94 ; 95 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE 96 ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO 97 ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO 98 ; 99 N ZCCRD,ZVARN,C0CFDA2 100 S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY 101 S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 102 I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT 103 . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE 104 . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! 105 . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE 106 . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE 107 . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN 108 . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY 109 . I $D(ZERR) D ; LAYGO ERROR 110 . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! 111 . E D ; 112 . . D CLEAN^DILF ; CLEAN UP 113 . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 114 . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! 115 Q ZVARN 116 ; 117 BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) 118 ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED 119 ; 120 N C0CDIC,C0CNODE ; 121 S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY 122 S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE 123 Q 124 ; 125 FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED 126 ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET 127 ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS 128 ; CONVERSION 129 ;N C0CC,C0CI,C0CJ,C0CN,C0CZX 130 D FIELDS^C0CRNF("C0CC",170) 131 S C0CI="" 132 F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION 133 . S C0CZX="" 134 . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE 135 . . W "SECTION ",C0CI," VAR ",C0CZX 136 . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) 137 . . W " TYPE: ",C0CV,! 138 . . D SETFDA("SECTION",C0CV) 139 . . ;ZWR C0CFDA 140 Q 141 ; 142 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 143 ; TO SET TO VALUE C0CSV. 144 ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE 145 ; C0CSN,C0CSV ARE PASSED BY VALUE 146 ; 147 N C0CSI,C0CSJ 148 S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER 149 S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER 150 S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV 151 Q 152 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 153 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) 154 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 155 I '$D(ZTAB) S ZTAB="C0CA" 156 N ZR 157 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) 158 E S ZR="" 159 Q ZR 160 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 161 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) 162 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 163 I '$D(ZTAB) S ZTAB="C0CA" 164 N ZR 165 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) 166 E S ZR="" 167 Q ZR 168 ; 169 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 170 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) 171 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 172 I '$D(ZTAB) S ZTAB="C0CA" 173 N ZR 174 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) 175 E S ZR="" 176 Q ZR 177 ; -
ccr/branches/ohum/p/C0CFM2.m
r1342 r1428 1 C0CFM2 2 ;;1.0;C0C;;May 19, 2009;Build 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 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 134 135 136 137 138 139 140 141 142 143 144 145 146 147 UPDIE 148 149 150 151 152 153 154 155 156 157 158 CHECK 159 160 161 162 163 164 165 166 167 CHKELS(DFN) 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 DOIT(DFN) 189 190 191 192 193 SETXUP 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 PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) 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 VARPTR(ZVAR,ZTYP) 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 BLDTYPS 303 304 305 306 307 308 309 310 FIXSEC 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 SETFDA(C0CSN,C0CSV) 328 329 330 331 332 333 334 335 336 337 ZFILE(ZFN,ZTAB) 338 339 340 341 342 343 344 345 ZFIELD(ZFN,ZTAB) 346 347 348 349 350 351 352 353 354 ZVALUE(ZFN,ZTAB) 355 356 357 358 359 360 361 362 1 C0CFM2 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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^C0CRIMA ; 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.101, ^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 PATN,ZTYPN,XD0,ZTYP 89 I '$D(ZSRC) S ZSRC=1 ; CCR SOURCE IS ASSUMED, 1 IF NOT SET 90 ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE 91 N C0CFPAT S C0CFPAT=171.101 ; FILE AT PATIENT LEVEL 92 N C0CFSRC S C0CFSRC=171.111 ; FILE AT CCR SOURCE LVL 93 N C0CFTYP S C0CFTYP=171.121 ; FILE AT ELEMENT TYPE LVL 94 N C0CFOCC S C0CFOCC=171.131 ; FILE AT OCCURANCE LVL 95 N C0CFVAR S C0CFVAR=171.1311 ; FILE AT VARIABLE LVL 96 ;FILE IS ^C0CE(PAT,1,SCR,1,TYP,1,OCC,1,VAR,1, ... 97 ; AND WE HAVE TO ADD THEM LEVEL AT A TIME I THINK 98 N C0CFDA 99 S C0CFDA(C0CFPAT,"?+1,",.01)=DFN 100 D UPDIE ; ADD THE PATIENT 101 S PATN=$O(^C0CE("B",DFN,"")) ; IEN FOR THE PATIENT 102 S C0CFDA(C0CFSRC,"?+1,"_PATN_",",.01)=ZSRC 103 D UPDIE ; ADD THE CCR SOURCE 104 N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) ; FIND THE ELE TYPE 105 S C0CFDA(C0CFTYP,"?+1,"_ZSRC_","_PATN_",",.01)=ZTYPN 106 D UPDIE ; ADD THE ELEMENT TYPE 107 S ZTYP=$O(^C0CE(PATN,1,ZSRC,1,"B",ZTYPN,"")) ; IEN OF ELEMENT TYPE 108 S C0CFDA(C0CFOCC,"?+1,"_ZTYP_","_ZSRC_","_PATN_",",.01)=ZOCC ; STRING OCC 109 ; OCC IS PRECEDED BY " " TO FORCE STRING STORAGE AND PRESERVE 110 ; STRING COLLATION ON THE INDEX 111 D UPDIE ; ADD THE OCCURANCE 112 S ZD0=$O(^C0CE(PATN,1,ZSRC,1,ZTYP,1,"B",ZOCC,"")) 113 W "RECORD NUMBER: ",ZD0,! 114 ;I ZD0=32 B 115 ;I ZD0=31 B 116 N ZCNT,ZC0CI,ZVARN,C0CZ1 117 S ZCNT=0 118 S ZC0CI="" ; 119 F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; 120 . I ZC0CI'="M" D ; NOT A SUBVARIABLE 121 . . S ZCNT=ZCNT+1 ;INCREMENT COUNT 122 . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT 123 . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND 124 . . S C0CZ1=ZTYP_","_ZSRC_","_PATN_"," 125 . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,.01)=ZVARN 126 . . S ZZVAL=$TR(@ZVALS@(ZC0CI),"^","|") 127 . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,1)=ZZVAL 128 . E D ; THIS IS A SUBELEMENT 129 . . ;PUT THE FOLLOWING BACK TO USE RECURSION 130 . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV 131 . . ;S ZZCNT=0 132 . . ;S ZZC0CI=0 133 . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE 134 . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE 135 . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR 136 . . ;W "MULTIPLE:",ZZVALS,! 137 . . ;B 138 . . ;F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE 139 . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT 140 . . ;. W "COUNT:",ZZCNT,! 141 . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI)) 142 . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION 143 . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION) 144 D UPDIE ; UPDATE 145 Q 146 ; 147 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 148 K ZERR 149 D CLEAN^DILF 150 D UPDATE^DIE("","C0CFDA","","ZERR") 151 I $D(ZERR) D ; 152 . W "ERROR",! 153 . ZWR ZERR 154 . B 155 K C0CFDA 156 Q 157 ; 158 CHECK ; CHECKSUM EXPERIMENTS 159 ; 160 ;B 161 S ZG=$NA(^C0CE(DA(2),1,DA(1),1,DA)) 162 ;S G2=$NA(^C0CE(8,1,1,1,2,1,6)) 163 S X=$$CHKSUM^XUSESIG1(ZG) 164 W G1,! 165 Q 166 ; 167 CHKELS(DFN) ; CHECKSUM ALL ELEMENTS FOR A PATIENT 168 ; 169 S ZGLB=$NA(^TMP("C0CCHK")) 170 S ZPAT=$O(^C0CE("B",DFN,"")) 171 K @ZGLB@(ZPAT) ; CLEAR PREVIOUS CHECKSUMS 172 S ZSRC="" 173 F S ZSRC=$O(^C0CE(ZPAT,1,"B",ZSRC)) Q:ZSRC="" D ; 174 . W "PAT:",ZPAT," SRC:",ZSRC,! 175 . S ZEL="" 176 . F S ZEL=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL)) Q:ZEL="" D ;ELEMENTS 177 . . W "ELEMENT:",ZEL," " 178 . . S ZELE=$$GET1^DIQ(170.101,ZEL,.01,"E") ;ELEMENT NAME 179 . . W ZELE," " 180 . . S ZELI=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL,"")) 181 . . S ZG=$NA(^C0CE(ZPAT,1,ZSRC,1,ZELI)) 182 . . S ZCHK=$$CHKSUM^XUSESIG1(ZG) ; CHECKSUM FOR THE ELEMENT 183 . . W ZCHK,! 184 . . S @ZGLB@(ZPAT,ZELE,ZSRC)=ZCHK 185 ZWR ^TMP("C0CCHK",ZPAT,*) 186 Q 187 ; 188 DOIT(DFN) ; EXPERIMENT FOR TIMING CALLS USING mumps -dir DOIT^C0CFM2(DFN) 189 D SETXUP 190 D CHKELS(DFN) 191 Q 192 ; 193 SETXUP ; SET UP ENVIRONMENT 194 S DISYS=19 195 S DT=3090325 196 S DTIME=300 197 S DUZ=1 198 S DUZ(0)="@" 199 S DUZ(1)="" 200 S DUZ(2)=7247 201 S DUZ("AG")="I" 202 S DUZ("BUF")=1 203 S DUZ("LANG")="" 204 S IO="/dev/pts/20" 205 S IO(0)="/dev/pts/20" 206 S IO(1,"/dev/pts/20")="" 207 S IO("ERROR")="" 208 S IO("HOME")="344^/dev/pts/20" 209 S IO("ZIO")="/dev/pts/20" 210 S IOBS="$C(8)" 211 S IOF="#,$C(27,91,50,74,27,91,72)" 212 S IOM=80 213 S ION="TELNET" 214 S IOS=344 215 S IOSL=24 216 S IOST="C-VT100" 217 S IOST(0)=9 218 S IOT="VTRM" 219 S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)" 220 S U="^" 221 S X="216;DIC(4.2," 222 S XPARSYS="216;DIC(4.2," 223 S XQXFLG="^^XUP" 224 Q 225 ; 226 PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE 227 ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE 228 ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE 229 ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC 230 ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM 231 ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT 232 ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES 233 ; 234 S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 235 ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE 236 N ZF,ZFV S ZF=171.101 S ZFV=171.1011 237 ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS 238 ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER 239 N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) 240 W "ZTYPE: ",ZTYPE," ",ZTYPN,! 241 N ZVARN ; IEN OF VARIABLE BEING PROCESSED 242 ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE 243 K C0CFDA 244 S C0CFDA(ZF,"?+1,",.01)=DFN 245 S C0CFDA(ZF,"?+1,",.02)=ZSRC 246 S C0CFDA(ZF,"?+1,",.03)=ZTYPN 247 S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE 248 K ZERR 249 ;B 250 D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER 251 I $D(ZERR) B ;OOPS 252 K C0CFDA 253 S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,"")) 254 W "RECORD NUMBER: ",ZD0,! 255 ;B 256 S ZCNT=0 257 S ZC0CI="" ; 258 F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; 259 . I ZC0CI'="M" D ; NOT A SUBVARIABLE 260 . . S ZCNT=ZCNT+1 ;INCREMENT COUNT 261 . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT 262 . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND 263 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN 264 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) 265 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN 266 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) 267 ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" 268 ;S GT1(170,"?+1,",12)="DIR" 269 ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" 270 ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" 271 D CLEAN^DILF 272 D UPDATE^DIE("","C0CFDA","","ZERR") 273 I $D(ZERR) D ; 274 . W "ERROR",! 275 . ZWR ZERR 276 . B 277 K C0CFDA 278 Q 279 ; 280 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE 281 ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO 282 ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO 283 ; 284 N ZCCRD,ZVARN,C0CFDA2 285 S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY 286 S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 287 I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT 288 . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE 289 . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! 290 . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE 291 . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE 292 . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN 293 . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY 294 . I $D(ZERR) D ; LAYGO ERROR 295 . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! 296 . E D ; 297 . . D CLEAN^DILF ; CLEAN UP 298 . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 299 . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! 300 Q ZVARN 301 ; 302 BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) 303 ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED 304 ; 305 N C0CDIC,C0CNODE ; 306 S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY 307 S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE 308 Q 309 ; 310 FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED 311 ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET 312 ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS 313 ; CONVERSION 314 ;N C0CC,C0CI,C0CJ,C0CN,C0CZX 315 D FIELDS^C0CRNF("C0CC",170) 316 S C0CI="" 317 F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION 318 . S C0CZX="" 319 . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE 320 . . W "SECTION ",C0CI," VAR ",C0CZX 321 . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) 322 . . W " TYPE: ",C0CV,! 323 . . D SETFDA("SECTION",C0CV) 324 . . ;ZWR C0CFDA 325 Q 326 ; 327 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 328 ; TO SET TO VALUE C0CSV. 329 ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE 330 ; C0CSN,C0CSV ARE PASSED BY VALUE 331 ; 332 N C0CSI,C0CSJ 333 S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER 334 S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER 335 S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV 336 Q 337 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 338 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) 339 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 340 I '$D(ZTAB) S ZTAB="C0CA" 341 N ZR 342 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) 343 E S ZR="" 344 Q ZR 345 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 346 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) 347 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 348 I '$D(ZTAB) S ZTAB="C0CA" 349 N ZR 350 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) 351 E S ZR="" 352 Q ZR 353 ; 354 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 355 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) 356 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 357 I '$D(ZTAB) S ZTAB="C0CA" 358 N ZR 359 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) 360 E S ZR="" 361 Q ZR 362 ; -
ccr/branches/ohum/p/C0CFM3.m
r1342 r1428 1 C0CFM3 2 ;;0.1;CCDCCR;nopatch;noreleasedate;Build 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 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 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CIM2 2 ;;1.0;C0C;;Feb 16, 2010;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(IMMXML,DFN,IMMOUT) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 GETRPMS(DFN,C0CIMM) 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 IMMUN 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 FORECAST 102 103 104 CONTRA 105 106 107 REFUSE 108 109 110 111 MAP(IMMXML,C0CIMM,IMMOUT) 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 1 C0CIM2 ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;Copyright 2010 George Lilly, University of Minnesota and others. 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 W "NO ENTRY FROM TOP",! 22 Q 23 ; 24 EXTRACT(IMMXML,DFN,IMMOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE 25 ; IMMXML AND IMMOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED 26 ; 27 ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS 28 ; THAT GET PASSED TO *GET ROUTINES 29 ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME)) 30 N C0CIMM 31 S C0CIMM=$NA(^TMP("C0CCCR",$J,DFN,"C0CIMM")) 32 ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS 33 ; THAT GET INSERTED INTO THE XML TEMPLATE 34 ; I '$D(@C0CIMM) D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS IF NOT THERE 35 D GETRPMS(DFN,C0CIMM) ; GET VARS IF NOT THERE 36 ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE 37 ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES 38 D MAP(IMMXML,C0CIMM,IMMOUT) ;MAP RESULTS FOR PROCEDURES 39 Q 40 ; 41 GETRPMS(DFN,C0CIMM) ; CALLS GET^BGOVIMM TO GET IMMUNIZATIONS. 42 ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME 43 ; C0CIMM: IMMUNIZATIONS 44 ; READY TO BE MAPPED TO XML BY MAP^C0CIMM 45 ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 46 ; EXIST. 47 ; 48 ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J)) 49 ; 50 ; SETUP RPC/API CALL HERE 51 ; USE START AND END DATES FROM PARAMETERS IF REQUIRED 52 N IMMA 53 D GET^BGOVIMM(.IMMA,DFN) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE 54 ; PREFORM SORT HERE IF NEEDED 55 ; 56 ; NO SORT REQUIRED FOR IMMUNIZATIONS 57 ; 58 ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY 59 ; RNF1 ARRAY FORMAT: 60 ; VAR("NAME_OF_RIM_VARIABLE")=VALUE 61 ; 62 ; IMMUNIZATIONS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF IMMUNIZATION RESULTS 63 ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD 64 ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS 65 N C0CIM,C0CC,ZRNF 66 S C0CIM="" ; INITIALIZE FOR $O 67 F C0CC=1:1 S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM="" D ; FOR EACH IMMUNE TYPE IN THE LIST 68 . I DEBUG W @IMMA@(C0CIM),! 69 . ; FIGURE OUT WHICH TYPE OF IMMUNIZATION IT IS (IMMUNIZATION, FORECAST, CONTRAINDICATIONS, REFUSALS) 70 . D:$P(@IMMA@(C0CIM),U,1)="I" IMMUN 71 . D:$P(@IMMA@(C0CIM),U,1)="F" FORECAST 72 . D:$P(@IMMA@(C0CIM),U,1)="C" CONTRA 73 . D:$P(@IMMA@(C0CIM),U,1)="R" REFUSE 74 . D RNF1TO2^C0CRNF(C0CIMM,"ZRNF") ;ADD THIS ROW TO THE ARRAY 75 . K ZRNF 76 ; SAVE RIM VARIABLES SEE C0CRIMA 77 N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE")) 78 M @ZRIM=@C0CIMM@("V") 79 Q 80 ; 81 IMMUN ; PARSES IMMUNIZATION TYPE ROWS FOR RPMS 82 ; RPC FORMAT 83 ; I ^ Imm Name [2] ^ Visit Date [3] ^ V File IEN [4] ^ Other Location [5] ^ Group [6] ^ Imm IEN [7] ^ Lot [8] ^ 84 ; Reaction [9] ^ VIS Date [10] ^ Age [11] ^ Visit Date [12] ^ Provider IEN~Name [13] ^ Inj Site [14] ^ 85 ; Volume [15] ^ Visit IEN [16] ^ Visit Category [17] ^ Full Name [18] ^ Location IEN~Name [19] ^ Visit Locked [20] 86 ; RETRIEVE IMMUNIZATION RECORD FROM IMMUNIZATION FILE (9999999.14) FOR THIS IMMUNIZATION 87 D GETN^C0CRNF("C0CZIM",9999999.14,$P(@IMMA@(C0CIM),U,7)) ; GET IMMUNIZATION RECORD 88 ; RETIREVE IMMUNIZATION RECORD FROM V IMMUNIZATION FILE (9000010.11) FOR THIS IMMUNIZATION 89 D GETN^C0CRNF("C0CZVI",9000010.11,$P(@IMMA@(C0CIM),U,4)) ; GET V IMMUNIZATION RECORD 90 S ZRNF("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID 91 S ZRNF("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME 92 S ZRNF("IMMUNEDATETIME")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("EVENT DATE AND TIME","C0CZVI"),"DT") 93 S ZRNF("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_$P($P(@IMMA@(C0CIM),U,13),"~",1) 94 S ZRNF("IMMUNEPRODUCTNAMETEXT")=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD 95 S ZRNF("IMMUNEPRODUCTCODE")=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE 96 I $$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM")'="" S ZRNF("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code" 97 E S ZRNF("IMMUNEPRODUCTCODESYSTEM")="" ;NULL 98 ;CLEANUP FROM C0CRNF CALLS 99 K C0CZIM,C0CZVI 100 Q 101 FORECAST ; PARSES FORECAST TYPE ROWS FOR RPMS 102 ; CURRENTLY DISABLED 103 Q 104 CONTRA ; PARSES FORECAST TYPE ROWS FOR RPMS 105 ; CURRENTLY DISABLED 106 Q 107 REFUSE ; PARSES FORECAST TYPE ROWS FOR RPMS 108 ; CURRENTLY DISABLED 109 Q 110 ; 111 MAP(IMMXML,C0CIMM,IMMOUT) ; MAP IMMUNIZATION XML 112 ; 113 N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"IMMTEMP")) ;WORK AREA FOR TEMPLATE 114 K @ZTEMP 115 N ZBLD 116 S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"IMMBLD")) ; BUILD LIST AREA 117 D QUEUE^C0CXPATH(ZBLD,IMMXML,1,1) ; FIRST LINE 118 N ZINNER 119 ; XPATH NEEDS TO MATCH YOUR SECTION 120 D QUERY^C0CXPATH(IMMXML,"//Immunizations/Immunization","ZINNER") ;ONE PROC 121 N ZTMP,ZVAR,ZI 122 S ZI="" 123 F S ZI=$O(@C0CIMM@("V",ZI)) Q:ZI="" D ;FOR EACH IMMUNIZATION 124 . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS IMMUNIZATION XML 125 . S ZVAR=$NA(@C0CIMM@("V",ZI)) ;THIS IMMUNIZATION VARIABLES 126 . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE IMMUNIZATION 127 . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD 128 D QUEUE^C0CXPATH(ZBLD,IMMXML,@IMMXML@(0),@IMMXML@(0)) 129 N ZZTMP ; IS THIS NEEDED? 130 D BUILD^C0CXPATH(ZBLD,IMMOUT) ;BUILD FINAL XML 131 K @ZTEMP,@ZBLD 132 Q 133 ; -
ccr/branches/ohum/p/C0CIMMU.m
r1342 r1428 1 C0CIMMU 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 MAP(IPXML,DFN,OUTXML) 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 EXTRACT(IPXML,DFN,OUTXML) 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 1 C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 ; 22 ; PROCESS THE IMMUNIZATIONS SECTION OF THE CCR 23 ; 24 MAP(IPXML,DFN,OUTXML) ; MAP IMMUNIZATIONS 25 ; 26 N C0CZV,C0CZVI ; TO STORE MAPPED VARIABLES 27 N C0CZT ; TMP ARRAY OF MAPPED XML 28 S C0CZV=$NA(^TMP("C0CCCR",$J,"IMMUNE")) ; TEMP STORAGE FOR VARIABLES 29 D EXTRACT(IPXML,DFN,OUTXML) ;EXTRACT THE VARIABLES 30 N C0CZI,C0CZIC ; COUNT OF IMMUNIZATIONS 31 S C0CZIC=$G(@C0CZV@(0)) ; TOTAL FROM VARIABLE ARRAY 32 I C0CZIC>0 D ;IMMUNIZATIONS FOUND 33 . F C0CZI=1:1:C0CZIC D ;FOR EACH IMMUNIZATION 34 . . S C0CZVI=$NA(@C0CZV@(C0CZI)) ;THIS IMMUNIZATION 35 . . D MAP^C0CXPATH(IPXML,C0CZVI,"C0CZT") ;MAP THE VARIABLES TO XML 36 . . I C0CZI=1 D ; FIRST ONE 37 . . . D CP^C0CXPATH("C0CZT",OUTXML) ;JUST COPY RESULTS 38 . . E D ;NOT THE FIRST 39 . . . D INSINNER^C0CXPATH(OUTXML,"C0CZT") 40 E S @OUTXML@(0)=0 ; SIGNAL NO IMMUNIZATIONS 41 N IMMUTMP,I 42 D MISSING^C0CXPATH(OUTXML,"IMMUTMP") ; SEARCH XML FOR MISSING VARS 43 I IMMUTMP(0)>0 D ; IF THERE ARE MISSING VARS - 44 . ; STRINGS MARKED AS @@X@@ 45 . W !,"IMMUNE Missing list: ",! 46 . F I=1:1:IMMUTMP(0) W IMMUTMP(I),! 47 Q 48 ; 49 EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT IMMUNIZATIONS INTO VARIABLES 50 ; 51 ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED 52 ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE 53 ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE 54 ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS 55 ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT 56 ; 57 N RPCRSLT,J,K,PTMP,X,VMAP,TBU 58 S TVMAP=$NA(^TMP("C0CCCR",$J,"IMMUNE")) 59 S TARYTMP=$NA(^TMP("C0CCCR",$J,"IMMUARYTMP")) 60 S IMMA=$NA(^TMP("PXI",$J)) ; 61 K @IMMA ; CLEAR OUT PREVIOUS RESULTS 62 K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES 63 D IMMUN^PXRHS03(DFN) ; 64 I $O(@IMMA@(""))="" D Q ; RPC RETURNS NULL 65 . W "NULL RESULT FROM IMMUN^PXRHS03 ",! 66 . S @TVMAP@(0)=0 67 N C0CIM,C0CC,C0CIMD,C0CIEN,C0CT ; 68 S C0CIM="" 69 S C0CC=0 ; COUNT 70 F S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM="" D ; FOR EACH IMMUNE TYPE IN THE LIST 71 . S C0CC=C0CC+1 ;INCREMENT COUNT 72 . S @TVMAP@(0)=C0CC ; SAVE NEW COUNT TO ARRAY 73 . S VMAP=$NA(@TVMAP@(C0CC)) ; THIS IMMUNE ELEMENT 74 . K @VMAP ; MAKE SURE IT IS CLEARED OUT 75 . W C0CIM,! 76 . S C0CIMD="" ; IMMUNE DATE 77 . F S C0CIMD=$O(@IMMA@(C0CIM,C0CIMD)) Q:C0CIMD="" D ; FOR EACH DATE 78 . . S C0CIEN=$O(@IMMA@(C0CIM,C0CIMD,"")) ;IEN OF IMMUNE RECORD 79 . . D GETN^C0CRNF("C0CI",9000010.11,C0CIEN) ; GET THE FILEMAN RECORD FOR IENS 80 . . W C0CIEN,"_",C0CIMD 81 . . S C0CT=$$FMDTOUTC^C0CUTIL(9999999-C0CIMD,"DT") ; FORMAT DATE/TIME 82 . . W C0CT,! 83 . . S @VMAP@("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID 84 . . S @VMAP@("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME 85 . . S @VMAP@("IMMUNEDATETIME")=C0CT ;FORMATTED DATE/TIME 86 . . S C0CIP=$$ZVALUEI^C0CRNF("ENCOUNTER PROVIDER","C0CI") ;IEN OF PROVIDER 87 . . S @VMAP@("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_C0CIP 88 . . S C0CIIEN=$$ZVALUEI^C0CRNF("IMMUNIZATION","C0CI") ;IEN OF IMMUNIZATION 89 . . I $G(DUZ("AG"))="I" D ; RUNNING IN RPMS 90 . . . D GETN^C0CRNF("C0CZIM",9999999.14,C0CIIEN) ;GET IMMUNE RECORD 91 . . . S C0CIN=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD 92 . . . ; FOR LOOKING UP THE CODE 93 . . . ; GET IT FROM THE CODE FILE 94 . . . S C0CICD=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE 95 . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME 96 . . . S @VMAP@("IMMUNEPRODUCTCODE")=C0CICD ; CVX CODE 97 . . . I C0CICD'="" S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code" ; 98 . . . E S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NULL 99 . . E D ; NOT IN RPMS 100 . . . S C0CIN=$$ZVALUE^C0CRNF("IMMUNIZATION","C0CI") ;NAME OF IMMUNIZATION 101 . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME 102 . . . S @VMAP@("IMMUNEPRODUCTCODE")="" ; CVX CODE 103 . . . S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NO CODE 104 N C0CIRIM S C0CIRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE")) 105 M @C0CIRIM=@TVMAP ; PERSIST RIM VARIABLES 106 Q 107 ; -
ccr/branches/ohum/p/C0CIN.m
r1342 r1428 1 C0CIN 2 ;;1.0;C0C;;Sep 20, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 TEST 24 25 26 27 28 29 30 RPCAIN(RTN,DFN,DUZ,SOURCE,TYPE,ARY) 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 ADDSRC(ZSRC) 50 51 52 53 54 55 56 57 58 RPCFIN(RTN,DFN,DUZ,SOURCE,TYPE,FN,FP) 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 RPCLIST(RTN,DFN) 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 RPCDOC(RTN,IEN) 98 99 100 101 102 103 EN(INXML,SOURCE,C0CDFN) 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 GETACCR(AOUT,C0CDFN) 132 133 134 135 136 137 138 TEST64 139 140 141 142 143 144 145 146 147 NORMAL(OUTXML,INXML) 148 149 150 151 152 153 154 155 156 157 158 159 CLEANCR(OUTXML,INXML) 160 161 162 163 164 165 166 167 168 169 LOAD(ZRTN,filepath) 170 171 172 173 174 175 176 177 178 179 180 181 182 183 UPDIE 184 185 186 187 188 189 190 191 192 193 1 C0CIN ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 Import Utility Library ",! 21 Q 22 ; 23 TEST ; TESTS BOTH ROUTINES AT ONCE 24 N ZI,ZJ 25 S ZI="/home/vademo2/CCR" ;directory purposely leaving off the trailing / 26 S ZJ="PAT_358_CCR_V1_0_21.xml" ; random test patient 27 D RPCFIN(.GPL,358,135,"GPLTEST","CCR",ZJ,ZI) 28 Q 29 ; 30 RPCAIN(RTN,DFN,DUZ,SOURCE,TYPE,ARY) ; ARRAY IN RPC - ACCEPT AN XML DOCUMENT 31 ; AND STORE IT IN THE INCOMING XML FILE 32 ; RETURNS THE IEN OF THE RECORD OR TEXT IF THERE IS AN ERROR 33 I $G(DFN)="" S RTN="DFN NOT DEFINED" Q ; 34 N C0CXF S C0CXF=175 ; FILE NUMBER FOR INCOMING XML FILE 35 N C0CFDA,ZX 36 S C0CFDA(C0CXF,"+1,",.01)=DFN ; PATIENT 37 S C0CFDA(C0CXF,"+1,",.02)=DUZ ; PROVIDER CREATING THE RECORD 38 S C0CFDA(C0CXF,"+1,",1)=$$NOW^XLFDT ;DATE 39 S C0CFDA(C0CXF,"+1,",2)=TYPE ;TYPE 40 S C0CFDA(C0CXF,"+1,",3)=$$ADDSRC(SOURCE) ;SOURCE 41 S C0CFDA(C0CXF,"+1,",7)="NEW" ; STATUS OF NEW FOR NOT PROCESSED 42 D UPDIE ; CREATE THE RECORD 43 S ZX=C0CIEN(1) ; CAPTURE THE RECORD NUMBER 44 D WP^DIE(C0CXF,ZX_",",4,,ARY,"ZERR") 45 ;W "RECORD:",ZX,! 46 S RTN=ZX ; RETURN IEN OF THE XML FILE 47 Q 48 ; 49 ADDSRC(ZSRC) ;EXTRISIC TO ADD A SOURCE TO THE CCR SOURCE FILE 50 ; RETURNS RECORD NUMBER. IF SOURCE EXISTS, JUST RETURNS IT'S RECORD NUMBER 51 ; 52 N ZX,ZF,C0CFDA 53 S ZF=171.401 ; FILE NUMBER FOR CCR SOURCE FILE 54 S C0CFDA(ZF,"?+1,",.01)=ZSRC 55 D UPDIE 56 Q $O(^C0C(171.401,"B",ZSRC,"")) 57 ; 58 RPCFIN(RTN,DFN,DUZ,SOURCE,TYPE,FN,FP) ; FILE IN RPC - READ AN XML DOCUMENT 59 ; FROM A HOST FILE AND STORE IT IN THE INCOMING XML FILE 60 N ZX,ZTMP 61 I $E($RE(FP))'="/" S ZX=FP_"/" 62 E S ZX=FP 63 S ZX=ZX_FN 64 D LOAD("ZTMP",ZX) 65 I '$D(ZTMP) D Q ; NO LUCK 66 . W "FILE NOT LOADED",! 67 D RPCAIN(.RTN,DFN,DUZ,SOURCE,TYPE,"ZTMP") 68 N C0CFDA 69 S C0CFDA(175,RTN_",",5)=FN ; FILE NAME 70 S C0CFDA(175,RTN_",",6)=FP ; FILE PATH 71 D UPDIE ; UPDATE WITH FILE NAME AND PATH 72 Q 73 ; 74 RPCLIST(RTN,DFN) ; CCR LIST - LIST XML DOCUMENTS FOR PATIENT DFN 75 ; THAT ARE STORED IN THE INCOMING XML FILE 76 ; RETURNS AN ARRAY OF THE FORM 77 ; RTN(x)="IEN^DATE^TYPE^SOURCE^STATUS^CREATEDBY" WHERE 78 ; IEN IS THE RECORD NUMBER OF THE XML DOCUMENT 79 ; DATE IS THE DATE THE DOCUMENT WAS STORED IN THE FILE 80 ; TYPE IS "CCD" OR "CCR" OR "OTHER" 81 ; SOURCE IS THE NAME OF THE DOCUMENT SOURCE FROM THE CCR SOURCE FILE 82 ; STATUS IS THE STATUS OF THE DOCUMENT (VALUES TO BE DEFINED) 83 ; CREATEDBY IS THE NAME OF THE PROVIDER WHO UPLOADED THE XML 84 N ZF S ZF=175 ; FILE NUMBER OF INCOMING XML FILE 85 N ZI S ZI="" 86 N ZN S ZN=0 87 F S ZI=$O(^C0CIN("B",DFN,ZI),-1) Q:ZI="" D ; FOR EACH RECORD FOR THIS PATIENT 88 . S ZN=ZN+1 ;INCREMENT COUNT OF RETURN ARRAY 89 . S $P(RTN(ZN),"^",1)=ZI ; IEN OF RECORD 90 . S $P(RTN(ZN),"^",2)=$$GET1^DIQ(ZF,ZI_",",1,"E") ;DATE 91 . S $P(RTN(ZN),"^",3)=$$GET1^DIQ(ZF,ZI_",",2,"E") ;TYPE 92 . S $P(RTN(ZN),"^",4)=$$GET1^DIQ(ZF,ZI_",",3,"E") ;SOURCE 93 . S $P(RTN(ZN),"^",5)=$$GET1^DIQ(ZF,ZI_",",7,"I") ; STATUS 94 . S $P(RTN(ZN),"^",6)=$$GET1^DIQ(ZF,ZI_",",.02,"E") ; CREATED BY 95 Q 96 ; 97 RPCDOC(RTN,IEN) ; RETRIEVE DOCUMENT NUMBER IEN FROM THE INCOMING XML FILE 98 ; RETURNED IN ARRAY RTN 99 N ZI 100 S ZI=$$GET1^DIQ(175,IEN_",",4,,"RTN") 101 Q 102 ; 103 EN(INXML,SOURCE,C0CDFN) ; IMPORT A CCR, PASSED BY NAME INXML 104 ; FILE UNDER SOURCE, WHICH IS A POINTER TO THE CCR SOURCE FILE 105 ; FOR PATIENT C0CDFN 106 ;N C0CXP 107 S C0CINB=$NA(^TMP("C0CIN",$J,"VARS",C0CDFN)) 108 S C0CDOCID=$$PARSE^C0CMXML(INXML) ;W !,"DocID: ",C0CDOCID 109 ;S REDUX="//ContinuityOfCareRecord/Body" 110 S REDUX="" 111 D XPATH^C0CMXML(1,"/","C0CIDX","C0CXP",,REDUX) 112 ;D INDEX^C0CXPATH(INXML,"C0CXP",-1) ; GENERATE XPATHS FROM THE CCR 113 ;N ZI,ZJ,ZK 114 S ZI="" 115 F S ZI=$O(C0CXP(ZI)) Q:ZI="" D ; FOR EACH XPATH 116 . D DEMUX^C0CMXP("ZJ",ZI) ; 117 . W ZJ,! 118 . S ZK=$P(ZJ,"^",3) ; PULL OUT THE XPATH 119 . S ZM=$P(ZJ,"^",1) ; PULL OUT THE MULTIPLE 120 . S ZS=$P(ZJ,"^",2) ; PULL OUT THE SUBMULTIPLE 121 . S C0CDICN=$O(^C0CDIC(170,"XPATH",ZK,"")) 122 . I C0CDICN="" D Q ; 123 . . W "MISSING XPATH:",!,ZK,! ; OOPS, XPATH NOT IN C0CDIC 124 . . S MISSING(ZK)="" 125 . ;D GETS^DIQ(170,C0CDICN_",","*",,"C0CFDA") 126 . S C0CVAR=$$GET1^DIQ(170,C0CDICN_",",.01) ; VARIABLE NAME 127 . S C0CSEC=$$GET1^DIQ(170,C0CDICN_",",12) ;ELEMENT TYPE 128 . W C0CSEC,":",C0CVAR,! 129 Q 130 ; 131 GETACCR(AOUT,C0CDFN) ; EXTRACT A CCR FOR PATIENT ADFN AND PUT IT IN ARRAY AOUT 132 ;PASSED BY NAME 133 N ZT 134 D CCRRPC^C0CCCR(.ZT,C0CDFN,"LABLIMIT:T-1000") 135 M @AOUT=ZT 136 Q 137 ; 138 TEST64 ;TEST BASE64 DECODING FOR IMPORTING CCR FROM THE NHIN 139 W $$FTG^%ZISH("/tmp/","base64_encoded_ccr.txt","G64(1)",1) 140 S G=G64(1) 141 S ZI="" 142 F S ZI=$O(G64(1,"OVF",ZI)) Q:ZI="" D ; FOR EVERY OVERFLOW RECORD 143 . S G=G_G64(1,"OVF",ZI) ;HOPE IT'S NOT TOO BIG 144 S G2=$$DECODE^RGUTUU(G) 145 Q 146 ; 147 NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML 148 ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME 149 ; 150 N ZI,ZN,ZTMP 151 S ZN=1 152 S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">" 153 S ZN=ZN+1 154 F S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)="" D ; 155 . S @OUTXML@(ZN)=@OUTXML@(ZN)_">" 156 . S ZN=ZN+1 157 Q 158 ; 159 CLEANCR(OUTXML,INXML) ; USE $C(10) TO SEPARATE THE STRING INXML INTO 160 ;AN ARRAY OUTXML(n) OUTXML AND INXML PASSED BY NAME 161 N ZX,ZY,ZN 162 S ZX=1,ZN=1 163 F S ZY=$F(@INXML,$C(10),ZX) Q:ZY=0 D ; 164 . S @OUTXML@(ZN)=$E(G2,ZX,ZY-2) 165 . I @OUTXML@(ZN)'="" S ZN=ZN+1 166 . S ZX=ZY 167 Q 168 ; 169 LOAD(ZRTN,filepath) ; load an xml file into the ZRTN array, passed by name 170 n i 171 D ; 172 . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)="" 173 . s ztmp=$na(^TMP("C0CLOAD",$J)) 174 . k @ztmp 175 . s zfile=$re($p($re(filepath),"/",1)) ;file name 176 . s zpath=$p(filepath,zfile,1) ; file path 177 . s zok=$$FTG^%ZISH(zpath,zfile,$NA(@ztmp@(1)),3) ; import the file incr sub 3 178 . m @ZRTN=@ztmp 179 . k @ztmp 180 . s i=$o(@ZRTN@(""),-1) ; highest line number 181 q 182 ; 183 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 184 K ZERR,C0CIEN 185 D CLEAN^DILF 186 D UPDATE^DIE("","C0CFDA","C0CIEN","ZERR") 187 I $D(ZERR) D ; 188 . W "ERROR",! 189 . ZWR ZERR 190 . B 191 K C0CFDA 192 Q 193 ; -
ccr/branches/ohum/p/C0CLA7DD.m
r1342 r1428 1 C0CLA7DD 2 ;;1.0;C0C;;May 19, 2009;Build 2 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 251 SENDXQA(MSG) 252 253 254 255 256 257 258 259 1 C0CLA7DD ;WV/JMC - CCD/CCR Post Install DD X-Ref Setup Routine ; Aug 31, 2009 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 SENDXQA(MSG) ; Send alert for reindex status 252 ; 253 N XQA,XQAMSG 254 ; 255 S XQA(DUZ)="" 256 S XQAMSG=MSG 257 D SETUP^XQALERT 258 ; 259 Q -
ccr/branches/ohum/p/C0CLA7Q.m
r1342 r1428 1 C0CLA7Q 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 VCHECK 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 VBUILD 64 65 66 67 68 69 LNCHK 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 TMPCHK 114 115 116 117 118 119 120 121 122 123 124 125 126 VCHK1 127 128 129 130 131 132 133 134 135 136 137 138 VSTORE 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 FINDDT 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 1 C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ; 4 ; 5 Q 6 ; 7 ; 8 LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for Lab Result Query 9 ; 10 ; 11 K ^TMP("C0C-VLAB",$J) 12 ; 13 ; Check and retrieve lab results from LAB DATA file (#63) 14 S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7)) 15 ; 16 ; If V LAB file present then check for lab results that are only in this file 17 ; If results found in V Lab file then build results and add to above results. 18 I $D(^AUPNVLAB) D 19 . D VCHECK 20 . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD 21 ; 22 ;K ^TMP("C0C-VLAB",$J) 23 ; 24 Q C0CDEST 25 ; 26 ; 27 VCHECK ; If V LAB file present then check for lab results that are only in this file. 28 ; 29 N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC 30 ; 31 S LA7PTID=C0CPTID 32 D PATID^LA7QRY2 33 I $D(LA7ERR) Q 34 ; 35 ; Resolve search codes to lab datanames 36 S LA7SC=$G(C0CSC) 37 I $T(SCLIST^LA7QRY2)'="" D 38 . N TMP 39 . S LA7SCRC=$G(C0CSC) 40 . S TMP=$$SCLIST^LA7QRY2(LA7SCRC) 41 . S LA7SC=TMP 42 ; 43 I LA7SC'="*" D CHKSC^LA7QRY1 44 ; 45 ; Convert specimen codes to file #61 Topography entries 46 S LA7SPEC=$G(C0CSPEC) 47 I LA7SPEC'="*" D SPEC^LA7QRY1 48 ; 49 S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0 50 ; 51 F S C0CROOT=$Q(@C0CROOT) Q:C0CROOT="" D Q:C0CEND 52 . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q ; Left x-ref or patient 53 . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q ; Exceeded end date/time 54 . S C0CDA=$QS(C0CROOT,4) 55 . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q ; Already checked during scan of file #63 56 . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q ; Source is LAB DATA file - skip 57 . D VCHK1 58 ; 59 ; 60 Q 61 ; 62 ; 63 VBUILD ; Build results found only in V LAB file into HL7 structure. 64 ; 65 ; 66 Q 67 ; 68 ; 69 LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63. 70 ; Call from LA7QRY2 71 ; 72 N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X 73 ; 74 S DFN=$P(^LR(LRDFN,0),"^",3) 75 S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0) 76 S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5) 77 S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)="" 78 ; 79 ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)="" 80 ; 81 S C0C60="" 82 F S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60 D Q:C0CLN'="" 83 . D FINDDT 84 . I C0CDA<1 Q 85 . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q ; Source is not LAB DATA file - skip 86 . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13) 87 . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8) 88 . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer 89 . I C0CPDA="" S C0CPDA=C0CDA 90 . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2) 91 . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2) 92 . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^") 93 . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2) 94 . S ^TMP("C0C-VLAB",$J,1,C0CDA)="" 95 . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)="" 96 . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST 97 ; 98 S X=$P(LA7X,"^",3) 99 ; If order NLT then update if no order NLT 100 I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64) 101 ; 102 ; If result NLT then update if no result NLT 103 I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64) 104 ; 105 ; If LOINC found then update variable with LN code 106 I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN 107 ; 108 S $P(LA7X,"^",3)=X 109 ; 110 Q 111 ; 112 ; 113 TMPCHK ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments 114 ; Called from LA7VOBX1 115 ; 116 N I,X 117 ; 118 S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)) 119 I X="" Q 120 F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I) 121 S $P(LA7VAL,"^",3)=LA7X 122 ; 123 Q 124 ; 125 ; 126 VCHK1 ; Check the entry in V Lab to determine if it meets criteria 127 ; 128 N C0CVLAB,I 129 ; 130 F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I)) 131 ; 132 ; JMC 04/13/09 - Store anything for now that meets date criteria. 133 D VSTORE 134 ; 135 Q 136 ; 137 ; 138 VSTORE ; Store entry for building in HL7 message when parent is from V LAB file. 139 ; 140 N C0CPDA,C0CPTEST 141 ; 142 ; Determine parent test to use for OBR segment 143 S C0CPDA=$P(C0CVLAB(12),"^",8) 144 I C0CPDA="" S C0CPDA=C0CDA 145 ; 146 ; Determine parent test 147 S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^") 148 ; 149 S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA 150 ; 151 Q 152 ; 153 ; 154 FINDDT ; Find entry in V LAB for the date/time or one close to it. 155 ; RPMS stores related specimen entries under the same date/time. 156 ; Lab file #63 creates unique entries with slightly different times. 157 ; 158 S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0)) 159 I C0CDA>0 Q 160 ; 161 ; If entry found then confirm that specimen type matches. 162 N C0CDTY 163 S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0)) 164 I C0CDTY D 165 . I $P(C0CDT,".")'=$P(C0CDTY,".") Q 166 . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0)) 167 . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA="" 168 ; 169 Q -
ccr/branches/ohum/p/C0CLABS.m
r1342 r1428 1 C0C ALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/082 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 MAP(MIXML,DFN,MOXML) 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 RPCMAP(RTN,DFN,RMIVAR,RMIXML) 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 EXTRACT(ILXML,DFN,OLXML) 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 GHL7 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 LIST 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 LTYP(OSEG,OTYP,OVARA,OC0CQT) 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 LOBX 262 263 264 OUT(DFN) 265 266 267 268 269 270 271 272 SETTBL 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 1 C0CLABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 ; 5/10/12 2:49pm 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 MAP(MIXML,DFN,MOXML) ;TO MAKE THIS COMPATIBLE WITH OLD CALLING FOR EXTRACT 22 ; ASSUMES THAT EXTRACT HAS BEEN RUN AND THE VARIABLES STORED IN MIVAR 23 ; MIXML,MIVAR, AND MOXML ARE PASSED BY NAME 24 ; MIXML IS THE TEMPLATE TO USE 25 ; MOXML IS THE OUTPUT XML ARRAY 26 ; DFN IS THE PATIENT RECORD NUMBER 27 N C0COXML,C0CO,C0CV,C0CIXML 28 I '$D(MIVAR) S C0CV="" ;DEFAULT 29 E S C0CV=MIVAR ;PASSED VARIABLE ARRAY 30 I '$D(MIXML) S C0CIXML="" ;DEFAULT 31 E S C0CIXML=MIXML ;PASSED INPUT XML 32 D RPCMAP(.C0COXML,DFN,C0CV,C0CIXML) ; CALL RPC TO DO THE WORK 33 I '$D(MOXML) S C0CO=$NA(^TMP("C0CCCR",$J,DFN,"RESULTS")) ;DEFAULT FOR OUTPUT 34 E S C0CO=MOXML 35 ; ZWR C0COXML 36 M @C0CO=C0COXML ; COPY RESULTS TO OUTPUT 37 Q 38 ; 39 RPCMAP(RTN,DFN,RMIVAR,RMIXML) ; RPC ENTRY POINT FOR MAPPING RESULTS 40 ; RTN IS PASSED BY REFERENCE 41 ;N C0CT0,C0CT,C0CV ; CCR TEMPLATE, RESULTS SUBTEMPLATE, VARIABLES 42 ;N C0CRT,C0CTT ; TEST REQUEST TEMPLATE, TEST RESULT TEMPLATE 43 I '$D(DEBUG) S DEBUG=0 ; DEFAULT NO DEBUGGING 44 I RMIXML="" D ; INPUT XML NOT PASSED 45 . D LOAD^C0CCCR0("C0CT0") ; LOAD ENTIRE CCR TEMPLATE 46 . D QUERY^C0CXPATH("C0CT0","//ContinuityOfCareRecord/Body/Results","C0CT0R") 47 . S C0CT="C0CT0R" ; NAME OF EXTRACTED RESULTS TEMPLATE 48 E S C0CT=RMIXML ; WE ARE PASSED THE RESULTS PART OF THE TEMPLATE 49 I RMIVAR="" D ; LOCATION OF VARIABLES NOT PASSED 50 . S C0CV=$NA(^TMP("C0CCCR",$J,"RESULTS")) ;DEFAULT VARIABLE LOCATION 51 E S C0CV=RMIVAR ; PASSED LOCATIONS OF VARS 52 D CP^C0CXPATH(C0CT,"C0CRT") ; START MAKING TEST REQUEST TEMPLATE 53 D REPLACE^C0CXPATH("C0CRT","","//Results/Result/Test") ; DELETE TEST FROM REQ 54 D QUERY^C0CXPATH(C0CT,"//Results/Result/Test","C0CTT") ; MAKE TEST TEMPLATE 55 I '$D(C0CQT) S C0CQT=0 ; DEFAULT NOT SILENT 56 I 'C0CQT D ; WE ARE DEBUGGING 57 . W "I MAPPED",! 58 . W "VARS:",C0CV,! 59 . W "DFN:",DFN,! 60 . ;D PARY^C0CXPATH("C0CT") ; SECTION TEMPLATE 61 . ;D PARY^C0CXPATH("C0CRT") ;REQUEST TEMPLATE (OCR) 62 . ;D PARY^C0CXPATH("C0CTT") ;TEST TEMPLATE (OCX) 63 D EXTRACT("C0CT",DFN,) ; FIRST CALL EXTRACT 64 I '$D(@C0CV@(0)) D Q ; NO VARS THERE 65 . S RTN(0)=0 ; PASS BACK NO RESULTS INDICATOR 66 I @C0CV@(0)=0 S RTN(0)=0 Q ; NO RESULTS 67 S RIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"RESULTS")) 68 K @RIMVARS 69 M @RIMVARS=@C0CV ; UPDATE RIMVARS SO THEY STAY IN SYNCH 70 N C0CI,C0CJ,C0CMAP,C0CTMAP,C0CTMP 71 S C0CIN=@C0CV@(0) ; COUNT OF RESULTS (OBR) 72 N C0CRTMP ; AREA TO BUILD ONE RESULT REQUEST AND ALL TESTS FOR IT 73 N C0CRBASE S C0CRBASE=$NA(^TMP($J,"TESTTMP")) ;WORK AREA 74 N C0CRBLD ; BUILD LIST FOR XML - THE BUILD IS DELAYED UNTIL THE END 75 ; TO IMPROVE PERFORMANCE 76 D QUEUE^C0CXPATH("C0CRBLD","C0CRT",1,1) ;<Results> 77 F C0CI=1:1:C0CIN D ; LOOP THROUGH VARIABLES 78 . K C0CMAP,C0CTMP ;EMPTY OUT LAST BATCH OF VARIABLES 79 . S C0CRTMP=$NA(@C0CRBASE@(C0CI)) ;PARTITION OF WORK AREA FOR EACH TEST 80 . S C0CMAP=$NA(@C0CV@(C0CI)) ; 81 . I 'C0CQT W "MAPOBR:",C0CMAP,! 82 . ;MAPPING FOR TEST REQUEST GOES HERE 83 . D MAP^C0CXPATH("C0CRT",C0CMAP,C0CRTMP) ; MAP OBR DATA 84 . ;D QOPEN^C0CXPATH("C0CRBLD",C0CRTMP,C0CIS) ;1ST PART OF XML 85 . D QUEUE^C0CXPATH("C0CRBLD",C0CRTMP,2,@C0CRTMP@(0)-4) ;UP TO <Test> 86 . I $D(@C0CMAP@("M","TEST",0)) D ; TESTS EXIST 87 . . S C0CJN=@C0CMAP@("M","TEST",0) ; NUMBER OF TESTS 88 . . K C0CTO ; CLEAR OUTPUT VARIABLE 89 . . F C0CJ=1:1:C0CJN D ;FOR EACH TEST RESULT 90 . . . K C0CTMAP ; EMPTY MAPS FOR TEST RESULTS 91 . . . S C0CTMP=$NA(@C0CRBASE@(C0CI,C0CJ)) ;WORK AREA FOR TEST RESULTS 92 . . . S C0CTMAP=$NA(@C0CMAP@("M","TEST",C0CJ)) ; 93 . . . I 'C0CQT W "MAPOBX:",C0CTMAP,! 94 . . . D MAP^C0CXPATH("C0CTT",C0CTMAP,C0CTMP) ; MAP TO TMP 95 . . . I C0CJ=1 S C0CJS=2 E S C0CJS=1 ;FIRST TIME,SKIP THE <Test> 96 . . . I C0CJ=C0CJN S C0CJE=@C0CTMP@(0)-1 E S C0CJE=@C0CTMP@(0) ;</Test> 97 . . . S C0CJS=1 S C0CJE=@C0CTMP@(0) ; INSERT ALL OF THE TEXT XML 98 . . . D QUEUE^C0CXPATH("C0CRBLD",C0CTMP,C0CJS,C0CJE) ; ADD TO BUILD LIST 99 . . . ;I C0CJ=1 D ; FIRST TIME, JUST COPY 100 . . . ;. D CP^C0CXPATH("C0CTMP","C0CTO") ; START BUILDING TEST XML 101 . . . ;E D INSINNER^C0CXPATH("C0CTO","C0CTMP") 102 . . . ; 103 . . . ;D PUSHA^C0CXPATH("C0CTO",C0CTMP) ;ADD THE TEST TO BUFFER 104 . . ; I 'C0CQT D PARY^C0CXPATH("C0CTO") 105 . . ;D INSINNER^C0CXPATH(C0CRTMP,"C0CTO","//Results/Result/Test") ;INSERT TST 106 . ;D QCLOSE^C0CXPATH("C0CRBLD",C0CRTMP,"//Results/Result/Test") ;END OF XML 107 . D QUEUE^C0CXPATH("C0CRBLD","C0CRT",C0CRT(0)-1,C0CRT(0)-1) ;</Result> 108 . ;I C0CI=1 D ; FIRST TIME, COPY INSTEAD OF INSERT 109 . . ;D CP^C0CXPATH(C0CRTMP,"RTN") ; 110 . ;E D INSINNER^C0CXPATH("RTN",C0CRTMP) ; INSERT THIS TEST REQUEST 111 D QUEUE^C0CXPATH("C0CRBLD","C0CRT",C0CRT(0),C0CRT(0)) ;</Results> 112 D BUILD^C0CXPATH("C0CRBLD","RTN") ;RENDER THE XML 113 K @C0CRBASE ; CLEAR OUT TEMPORARY STURCTURE 114 Q 115 ; 116 EXTRACT(ILXML,DFN,OLXML) ; EXTRACT LABS INTO THE C0CLVAR GLOBAL 117 ; 118 ; LABXML AND LABOUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED 119 ; 120 ; 121 ; 122 N C0CNSSN ; IS THERE AN SSN FLAG 123 S C0CNSSN=0 124 S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS 125 D GHL7 ; GET HL7 MESSAGE FOR THIS PATIENT 126 I C0CNSSN=1 D Q ; NO SSN, CAN'T GET HL7 FOR THIS PATIENT 127 . S @C0CLB@(0)=0 128 K @C0CLB ; CLEAR OUT OLD VARS IF ANY 129 N QTSAV S QTSAV=C0CQT ;SAVE QUIET FLAG 130 S C0CQT=1 ; SURPRESS LISTING 131 D LIST ; EXTRACT THE VARIABLES 132 ; FOR CERTIFICATION, SEE IF THERE ARE OTHER RESULTS TO ADD 133 D EN^C0CORSLT(C0CLB,DFN) ; LOOKS FOR ECG TESTS 134 S C0CQT=QTSAV ; RESET SILENT FLAG 135 K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT 136 I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^C0CLABS 137 Q 138 ; 139 GHL7 ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT 140 ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR 141 ; SET UP FOR LAB API CALL 142 S C0CPTID=$$SSN^C0CDPT(DFN) ; GET THE SSN FOR THIS PATIENT 143 I C0CPTID="" D Q ; NO SSN, COMPLAIN AND QUIT 144 . W "LAB LOOKUP FAILED, NO SSN",! 145 . S C0CNSSN=1 ; SET NO SSN FLAG 146 S C0CSPC="*" ; LOOKING FOR ALL LABS 147 ;I $D(^TMP("C0CCCR","RPMS")) D ; RUNNING RPMS 148 ;. D DT^DILF(,"T-365",.C0CSDT) ; START DATE ONE YEAR AGO TO LIMIT VOLUME 149 ;E D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING 150 ;D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY 151 S C0CLLMT=$$GET^C0CPARMS("LABLIMIT") ; GET THE LIMIT PARM 152 S C0CLSTRT=$$GET^C0CPARMS("LABSTART") ; GET START PARM 153 D DT^DILF(,C0CLLMT,.C0CSDT) ; 154 W "LAB LIMIT: ",C0CLLMT,! 155 D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM 156 S C0CEDT=$$NOW^XLFDT ; PULL LABS STARTING NOW 157 S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP 158 Q 159 ; 160 LIST ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB 161 ; 162 ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR 163 I '$D(C0CLB) S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS 164 I '$D(C0CQT) S C0CQT=0 165 I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT 166 I '$D(^TMP("C0CCCR","LABTBL",0)) D SETTBL ;INITIALIZE LAB TABLE 167 I ^TMP("C0CCCR","LABTBL",0)'="V3" D SETTBL ;NEED NEWEST VERSION 168 I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE 169 S C0CTAB=$NA(^TMP("C0CCCR","LABTBL")) ; BASE OF OBX TABLE 170 S C0CHB=$NA(^TMP("HLS",$J)) 171 S C0CI="" 172 S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT 173 F S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI="" D ; FOR ALL RECORDS IN HL7 MSG 174 . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES 175 . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) 176 . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT) 177 . I $G(C0CVAR("RESULTCODINGSYSTEM"))="LN" D ; gpl - for certification 178 . . S C0CVAR("RESULTCODINGSYSTEM")="LOINC" ; NEED TO SPELL IT OUT 179 . . N C0CRDT S C0CRDT=C0CVAR("RESULTDESCRIPTIONTEXT") ; THE DESCRIPTION 180 . . N C0CRCD S C0CRCD=C0CVAR("RESULTCODE") ; THE LOINC CODE 181 . . S C0CVAR("RESULTDESCRIPTIONTEXT")=C0CRDT_" LOINC: "_C0CRCD 182 . M XV=C0CVAR ; 183 . I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION 184 . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT 185 . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT 186 . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS 187 . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI 188 . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR 189 . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1) 190 . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT 191 . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL 192 . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME 193 . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS 194 . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION 195 . I C0CTYP="OBX" D ; SPECIAL CASE FOR OBX3 196 . . ; RESULTTESTCODEVALUE 197 . . ; RESULTTESTDESCRIPTIONTEXT 198 . . I C0CVAR("C3")="LN" D ; PRIMARY CODE IS LOINC 199 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE 200 . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC 201 . . . ;S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESC TXT 202 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2")_" LOINC: "_C0CVAR("C1") 203 . . E I C0CVAR("C6")="LN" D ; SECONDARY CODE IS LOINC 204 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE 205 . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC 206 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT 207 . . E I C0CVAR("C6")'="" D ; NO LOINC CODES, USE SECONDARY IF PRESENT 208 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE 209 . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME 210 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT 211 . . E D ; NO SECONDARY, USE PRIMARY 212 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE 213 . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME 214 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT 215 . . N C0CZG S C0CZG=XV("RESULTTESTNORMALDESCTEXT") ; 216 . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH 217 . . ;S XV("RESULTTESTNORMALDESCTEXT")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE 218 . . S XV("RESULTTESTNORMALDESCTEXT")=C0CZG 219 . . S C0CZG=XV("RESULTTESTVALUE") 220 . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH 221 . . ;S XV("RESULTTESTVALUE")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE 222 . . S XV("RESULTTESTVALUE")=C0CZG 223 . I C0CTYP="OBX" D ; PROCESS TEST RESULTS 224 . . I C0CLOBX=0 D ; FIRST TEST RESULT FOR THIS SECTION 225 . . . S C0CLB2=$NA(@C0CLB@(C0CLI,"M","TEST")) ; INDENT FOR TEST RESULTS 226 . . S C0CLOBX=C0CLOBX+1 ; INCREMENT TEST COUNT 227 . . S @C0CLB2@(0)=C0CLOBX ; STORE THE TEST COUNT 228 . . S XV("RESULTTESTOBJECTID")="RESULTTEST_"_C0CLI_"_"_C0CLOBX 229 . . S C0CX1=XV("RESULTTESTSOURCEACTORID") ; TEST SOURCE 230 . . S C0CX2=$P($P(C0CX1,"^",1),"-",1) ; PULL OUT STATION NUMBER 231 . . S XV("RESULTTESTSOURCEACTORID")="ACTORORGANIZATION_"_C0CX2 232 . . S XV("RESULTTESTNORMALSOURCEACTORID")=XV("RESULTTESTSOURCEACTORID") 233 . . S C0CX1=XV("RESULTTESTDATETIME") ;DATE TIME IN HL7 FORMAT 234 . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL 235 . . S XV("RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME 236 . . ; I 'C0CQT ZWR XV 237 . . M @C0CLB2@(C0CLOBX)=XV ; PERSIST THE TEST RESULT VARIABLES 238 . I 'C0CQT D ; 239 . . W C0CI," ",C0CTYP,! 240 . ; S C0CI=$O(@C0CHB@(C0CI)) 241 ;K ^TMP("C0CRIM","VARS",DFN,"RESULTS") 242 ;M ^TMP("C0CRIM","VARS",DFN,"RESULTS")=@C0CLB 243 Q 244 LTYP(OSEG,OTYP,OVARA,OC0CQT) ; 245 S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE 246 I '$D(OC0CQT) S C0CQT=0 ; NOT C0CQT IS DEFAULT 247 E S C0CQT=OC0CQT ; ACCEPT C0CQT FLAG 248 I 1 D ; FOR HL7 SEGMENT TYPE 249 . S OI="" ; INDEX INTO FIELDS IN SEG 250 . F S OI=$O(@OTAB@(OI)) Q:OI="" D ; FOR EACH FIELD OF THE SEGMENT 251 . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX 252 . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED 253 . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE 254 . . I $P(OI,";",2)'="" D ; THIS IS DEFINING A SUB-VALUE 255 . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX 256 . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE 257 . . I OVAR'="" S OVARA(OVAR)=OV ; PASS BACK VARIABLE AND VALUE 258 . . I 'C0CQT D ; PRINT OUTPUT IF C0CQT IS FALSE 259 . . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,! 260 Q 261 LOBX ; 262 Q 263 ; 264 OUT(DFN) ; WRITE OUT A CCR THAT HAS JUST BEEN PROCESSED (FOR TESTING) 265 N GA,GF,GD 266 S GA=$NA(^TMP("C0CCCR",$J,DFN,"CCR",1)) 267 S GF="RPMS_CCR_"_DFN_"_"_DT_".xml" 268 S GD=^TMP("C0CCCR","ODIR") 269 W $$OUTPUT^C0CXPATH(GA,GF,GD) 270 Q 271 ; 272 SETTBL ; 273 K X ; CLEAR X 274 S X("PID","PID1")="1^00104^Set ID - Patient ID" 275 S X("PID","PID2")="2^00105^Patient ID (External ID)" 276 S X("PID","PID3")="3^00106^Patient ID (Internal ID)" 277 S X("PID","PID4")="4^00107^Alternate Patient ID" 278 S X("PID","PID5")="5^00108^Patient's Name" 279 S X("PID","PID6")="6^00109^Mother's Maiden Name" 280 S X("PID","PID7")="7^00110^Date of Birth" 281 S X("PID","PID8")="8^00111^Sex" 282 S X("PID","PID9")="9^00112^Patient Alias" 283 S X("PID","PID10")="10^00113^Race" 284 S X("PID","PID11")="11^00114^Patient Address" 285 S X("PID","PID12")="12^00115^County Code" 286 S X("PID","PID13")="13^00116^Phone Number - Home" 287 S X("PID","PID14")="14^00117^Phone Number - Business" 288 S X("PID","PID15")="15^00118^Language - Patient" 289 S X("PID","PID16")="16^00119^Marital Status" 290 S X("PID","PID17")="17^00120^Religion" 291 S X("PID","PID18")="18^00121^Patient Account Number" 292 S X("PID","PID19")="19^00122^SSN Number - Patient" 293 S X("PID","PID20")="20^00123^Drivers License - Patient" 294 S X("PID","PID21")="21^00124^Mother's Identifier" 295 S X("PID","PID22")="22^00125^Ethnic Group" 296 S X("PID","PID23")="23^00126^Birth Place" 297 S X("PID","PID24")="24^00127^Multiple Birth Indicator" 298 S X("PID","PID25")="25^00128^Birth Order" 299 S X("PID","PID26")="26^00129^Citizenship" 300 S X("PID","PID27")="27^00130^Veteran.s Military Status" 301 S X("PID","PID28")="28^00739^Nationality" 302 S X("PID","PID29")="29^00740^Patient Death Date/Time" 303 S X("PID","PID30")="30^00741^Patient Death Indicator" 304 S X("NTE","NTE1")="1^00573^Set ID - NTE" 305 S X("NTE","NTE2")="2^00574^Source of Comment" 306 S X("NTE","NTE3")="3^00575^Comment" 307 S X("ORC","ORC1")="1^00215^Order Control" 308 S X("ORC","ORC2")="2^00216^Placer Order Number" 309 S X("ORC","ORC3")="3^00217^Filler Order Number" 310 S X("ORC","ORC4")="4^00218^Placer Order Number" 311 S X("ORC","ORC5")="5^00219^Order Status" 312 S X("ORC","ORC6")="6^00220^Response Flag" 313 S X("ORC","ORC7")="7^00221^Quantity/Timing" 314 S X("ORC","ORC8")="8^00222^Parent" 315 S X("ORC","ORC9")="9^00223^Date/Time of Transaction" 316 S X("ORC","ORC10")="10^00224^Entered By" 317 S X("ORC","ORC11")="11^00225^Verified By" 318 S X("ORC","ORC12")="12^00226^Ordering Provider" 319 S X("ORC","ORC13")="13^00227^Enterer's Location" 320 S X("ORC","ORC14")="14^00228^Call Back Phone Number" 321 S X("ORC","ORC15")="15^00229^Order Effective Date/Time" 322 S X("ORC","ORC16")="16^00230^Order Control Code Reason" 323 S X("ORC","ORC17")="17^00231^Entering Organization" 324 S X("ORC","ORC18")="18^00232^Entering Device" 325 S X("ORC","ORC19")="19^00233^Action By" 326 S X("OBR","OBR1")="1^00237^Set ID - Observation Request" 327 S X("OBR","OBR2")="2^00216^Placer Order Number" 328 S X("OBR","OBR3")="3^00217^Filler Order Number" 329 S X("OBR","OBR4")="4^00238^Universal Service ID" 330 S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE" 331 S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT" 332 S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE^RESULTCODINGSYSTEM" 333 S X("OBR","OBR5")="5^00239^Priority" 334 S X("OBR","OBR6")="6^00240^Requested Date/Time" 335 S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME" 336 S X("OBR","OBR8")="8^00242^Observation End Date/Time" 337 S X("OBR","OBR9")="9^00243^Collection Volume" 338 S X("OBR","OBR10")="10^00244^Collector Identifier" 339 S X("OBR","OBR11")="11^00245^Specimen Action Code" 340 S X("OBR","OBR12")="12^00246^Danger Code" 341 S X("OBR","OBR13")="13^00247^Relevant Clinical Info." 342 S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time" 343 S X("OBR","OBR15")="15^00249^Specimen Source" 344 S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID" 345 S X("OBR","OBR17")="17^00250^Order Callback Phone Number" 346 S X("OBR","OBR18")="18^00251^Placers Field 1" 347 S X("OBR","OBR19")="19^00252^Placers Field 2" 348 S X("OBR","OBR20")="20^00253^Filler Field 1" 349 S X("OBR","OBR21")="21^00254^Filler Field 2" 350 S X("OBR","OBR22")="22^00255^Results Rpt./Status Change" 351 S X("OBR","OBR23")="23^00256^Charge to Practice" 352 S X("OBR","OBR24")="24^00257^Diagnostic Service Sect" 353 S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS" 354 S X("OBR","OBR26")="26^00259^Parent Result" 355 S X("OBR","OBR27")="27^00221^Quantity/Timing" 356 S X("OBR","OBR28")="28^00260^Result Copies to" 357 S X("OBR","OBR29")="29^00261^Parent Number" 358 S X("OBR","OBR30")="30^00262^Transportation Mode" 359 S X("OBR","OBR31")="31^00263^Reason for Study" 360 S X("OBR","OBR32")="32^00264^Principal Result Interpreter" 361 S X("OBR","OBR33")="33^00265^Assistant Result Interpreter" 362 S X("OBR","OBR34")="34^00266^Technician" 363 S X("OBR","OBR35")="35^00267^Transcriptionist" 364 S X("OBR","OBR36")="36^00268^Scheduled Date/Time" 365 S X("OBR","OBR37")="37^01028^Number of Sample Containers" 366 S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample" 367 S X("OBR","OBR39")="39^01030^Collector.s Comment" 368 S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility" 369 S X("OBR","OBR41")="41^01032^Transport Arranged" 370 S X("OBR","OBR42")="42^01033^Escort Required" 371 S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment" 372 S X("OBX","OBX1")="1^00559^Set ID - OBX" 373 S X("OBX","OBX2")="2^00676^Value Type" 374 S X("OBX","OBX3")="3^00560^Observation Identifier" 375 S X("OBX","OBX3;C1")="3;1^00560^Observation Identifier^C1" 376 S X("OBX","OBX3;C2")="3;2^00560^Observation Identifier^C2" 377 S X("OBX","OBX3;C3")="3;3^00560^Observation Identifier^C3" 378 S X("OBX","OBX3;C4")="3;4^00560^Observation Identifier^C4" 379 S X("OBX","OBX3;C5")="3;5^00560^Observation Identifier^C5" 380 S X("OBX","OBX3;C6")="3;6^00560^Observation Identifier^C6" 381 S X("OBX","OBX4")="4^00769^Observation Sub-Id" 382 S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE" 383 S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS" 384 S X("OBX","OBX7")="7^00563^Reference Range^RESULTTESTNORMALDESCTEXT" 385 S X("OBX","OBX8")="8^00564^Abnormal Flags^RESULTTESTFLAG" 386 S X("OBX","OBX9")="9^00639^Probability" 387 S X("OBX","OBX10")="10^00565^Nature of Abnormal Test" 388 S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT" 389 S X("OBX","OBX12")="12^00567^Date Last Normal Value" 390 S X("OBX","OBX13")="13^00581^User Defined Access Checks" 391 S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME" 392 S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID" 393 S X("OBX","OBX16")="16^00584^Responsible Observer" 394 S X("OBX","OBX17")="17^00936^Observation Method" 395 K ^TMP("C0CCCR","LABTBL") 396 M ^TMP("C0CCCR","LABTBL")=X ; SET VALUES IN LAB TBL 397 S ^TMP("C0CCCR","LABTBL",0)="V3" 398 Q 399 ; -
ccr/branches/ohum/p/C0CMAIL.m
r1342 r1428 1 C0CMAIL 2 V ;;0.1;C0C;nopatch;noreleasedate;Build 23 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 1 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr 2 V ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr2 ;;0.1;C0C;nopatch;noreleasedate;Build 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 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 1 C0CMAIL2 ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr ; 5/10/12 2:50pm 2 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr2 ;;0.1;C0C;nopatch;noreleasedate;Build 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 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 1 C0CMAIL3 ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr ; 5/10/12 2:51pm 2 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CMCCD 2 ;;0.1;C0C;nopatch;noreleasedate;Build 2 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 283 UPDIE 284 285 286 287 288 289 290 291 292 293 1 C0CMCCD ; GPL - MXML based CCD utilities;12/04/09 17:05 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 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
r1342 r1428 1 C0CMED 2 ;;1.0;C0C;;May 19, 2009;Build 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 EXTRACT(MEDXML,DFN,MEDOUTXML) 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 RPMS 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 VISTA 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 1 C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 ; 26 Q 27 EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template 28 ; DFN passed by reference 29 ; MEDXML and MEDOUTXML are passed by Name 30 ; MEDXML is the input template 31 ; MEDOUTXML is the output template 32 ; Both of them refer to ^TMP globals where the XML documents are stored 33 ; 34 ; -- This ep is the driver for extracting medications into the provided XML template 35 ; 1. VA Outpatient Meds are in C0CMED1 36 ; 2. VA Pending Meds are in C0CMED2 37 ; 3. VA non-VA Meds are in C0CMED3 38 ; 4. VA Inpatient IV Meds are in C0CMED4 (not functional) 39 ; 5. VA Inpatient UD Meds are in C0CMED5 (doesn't exist yet)--March 2009 40 ; 6. RPMS Meds are in C0CMED6. Need to create other routines for subdivisions of RPMS Meds is not known at this time. 41 ; 42 ; --Get parameters for meds 43 S @MEDOUTXML@(0)=0 ; By default, empty. 44 N C0CMFLAG 45 S C0CMFLAG=$$GET^C0CPARMS("MEDALL")_"^"_$$GET^C0CPARMS("MEDLIMIT")_"^"_$$GET^C0CPARMS("MEDACTIVE")_"^"_$$GET^C0CPARMS("MEDPENDING") 46 W:$G(DEBUG) "Med Parameters: ",! 47 W:$G(DEBUG) "ALL: ",+C0CMFLAG,! 48 W:$G(DEBUG) "LIMIT: ",$P(C0CMFLAG,U,2),! 49 W:$G(DEBUG) "ACTIVE: ",$P(C0CMFLAG,U,3),! 50 W:$G(DEBUG) "PEND: ",$P(C0CMFLAG,U,4),! 51 ; --Find out what system we are on and branch out... 52 W:$G(DEBUG) "Agenecy: ",$G(DUZ("AG")) 53 I $$RPMS^C0CUTIL() D RPMS QUIT 54 I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT 55 RPMS 56 ;D EXTRACT^C0CMED6(MEDXML,DFN,MEDOUTXML,C0CMFLAG) QUIT 57 N MEDCOUNT S MEDCOUNT=0 58 K ^TMP($J,"MED") 59 N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed 60 N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds 61 S @HIST@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors) 62 D EXTRACT^C0CMED6(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds 63 D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds 64 I @HIST@(0)>0 D 65 . D CP^C0CXPATH(HIST,MEDOUTXML) 66 . W:$G(DEBUG) "HAS ACTIVE OP MEDS",! 67 I @NVA@(0)>0 D 68 . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,NVA) 69 . ;E D CP^C0CXPATH(NVA,MEDOUTXML) 70 . W:$G(DEBUG) "HAS NON-VA MEDS",! 71 Q 72 VISTA 73 N MEDCOUNT S MEDCOUNT=0 74 K ^TMP($J,"MED") 75 N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed 76 N PEND S PEND=$NA(^TMP($J,"MED","PEND")) ; Pending Meds 77 N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds 78 K @HIST K @PEND K @NVA ; MAKE SURE THEY ARE EMPTY 79 S @HIST@(0)=0,@PEND@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors) 80 ; N IPIV ; Inpatient IV Meds 81 N IPUD S IPUD=$NA(^TMP($J,"MED","IPUD")) ; Inpatient UD Meds 82 K @IPUD 83 S @IPUD@(0)=0 84 ; 85 D EXTRACT^C0CMED1(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds 86 D:$P(C0CMFLAG,U,4) EXTRACT^C0CMED2(MEDXML,DFN,PEND,.MEDCOUNT) ; Pending Meds 87 ;D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds 88 D EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds GPL 89 D EXTRACT^C0CNMED4(MEDXML,DFN,IPUD,.MEDCOUNT) ; inpatient gpl 90 I @HIST@(0)>0 D 91 . D CP^C0CXPATH(HIST,MEDOUTXML) 92 . W:$G(DEBUG) "HAS ACTIVE OP MEDS",! 93 I @PEND@(0)>0 D 94 . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,PEND) ;Add Pending to Historical 95 . E D CP^C0CXPATH(PEND,MEDOUTXML) ; No historical, just copy 96 . W:$G(DEBUG) "HAS OP PENDING MEDS",! 97 I @NVA@(0)>0 D 98 . I @HIST@(0)>0!(@PEND@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,NVA) 99 . E D CP^C0CXPATH(NVA,MEDOUTXML) 100 . W:$G(DEBUG) "HAS NON-VA MEDS",! 101 I @IPUD@(0)>0 D 102 . I @HIST@(0)>0!(@PEND@(0)>0)!(@NVA@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,IPUD) 103 . E D CP^C0CXPATH(IPUD,MEDOUTXML) 104 . W:$G(DEBUG) "HAS INPATIENT MEDS",! 105 N ZI 106 S ZI=$NA(^TMP("C0CCCR",$J,"MEDMAP")) 107 M ^TMP("C0CRIM","VARS",DFN,"MEDS")=@ZI ; PERSIST MEDS VARIABLES 108 K @ZI ; CLEAN UP MED MAP AFTER - GPL 10/10 109 K @PEND 110 K @HIST 111 K @NVA 112 K @IPUD 113 Q 114 -
ccr/branches/ohum/p/C0CMED1.m
r1342 r1428 1 C0CMED1 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) 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 1 C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;;Last modified Sat Jan 10 21:42:27 PST 2009 4 ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU 5 ; General Public License 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 W "NO ENTRY FROM TOP",! 22 Q 23 ; 24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE 25 ; 26 ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED 27 ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE 28 ; 29 ; MEDS is return array from RPC. 30 ; MAP is a mapping variable map (store result) for each med 31 ; MED is holds each array element from MEDS(J), one medicine 32 ; MEDCOUNT is a counter passed by Reference. 33 ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool) 34 ; FLAGS are set-up in C0CMED. 35 ; 36 ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all 37 ; med data available. 38 ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf 39 ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). 40 ; D PARY^C0CXPATH(MINXML) 41 N MEDS,MAP 42 K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! 43 N ALL S ALL=+FLAGS 44 N ACTIVE S ACTIVE=$P(FLAGS,U,3) 45 ; Below, X1 is today; X2 is the number of days we want to go back 46 ; X is the result of this calculation using C^%DTC. 47 N X,X1,X2 48 S X1=DT 49 S X2=-$P($P(FLAGS,U,2),"-",2) 50 D C^%DTC 51 ; I discovered that I shouldn't put an ending date (last parameter) 52 ; because it seems that it will get meds whose beginning is after X but 53 ; whose exipriation is before the ending date. 54 D RX^PSO52API(DFN,"CCDCCR","","","",X,"") 55 M MEDS=^TMP($J,"CCDCCR",DFN) 56 ; @(0) contains the number of meds or -1^NO DATA FOUND 57 ; If it is -1, we quit. 58 I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 Q 59 ZWRITE:$G(DEBUG) MEDS 60 N RXIEN S RXIEN=0 61 F S RXIEN=$O(MEDS(RXIEN)) Q:$G(RXIEN)="" D ; FOR EACH MEDICATION IN THE LIST 62 . N MED M MED=MEDS(RXIEN) 63 . I 'ALL,ACTIVE,$P(MED(100),U,2)'="ACTIVE" QUIT 64 . S MEDCOUNT=MEDCOUNT+1 65 . W:$G(DEBUG) "RXIEN IS ",RXIEN,! 66 . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) 67 . ; K @MAP DO NOT KILL HERE, WAS CLEARED IN C0CMED 68 . W:$G(DEBUG) "MAP= ",MAP,! 69 . S @MAP@("MEDOBJECTID")="MED"_MEDCOUNT ; MEDCOUNT FOR ID 70 . ; S @MAP@("MEDOBJECTID")="MED"_MED(.01) ;Rx Number 71 . S @MAP@("MEDISSUEDATETXT")="Issue Date" 72 . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($P(MED(1),U)) 73 . S @MAP@("MEDLASTFILLDATETXT")="Last Fill Date" 74 . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P($G(MED(101)),U)) 75 . S @MAP@("MEDRXNOTXT")="Prescription Number" 76 . S @MAP@("MEDRXNO")=MED(.01) 77 . S @MAP@("MEDTYPETEXT")="Medication" 78 . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses 79 . S @MAP@("MEDSTATUSTEXT")=$P(MED(100),U,2) 80 . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(4),U) 81 . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(6),U,2) 82 . ; 12/30/08: I will be using RxNorm for coding... 83 . ; 176.001 is the file for Concepts; 176.003 is the file for 84 . ; sources (i.e. for RxNorm Version) 85 . ; 86 . ; We need the VUID first for the National Drug File entry first 87 . ; We get the VUID of the drug, by looking up the VA Product entry 88 . ; (file 50.68) using the call NDF^PSS50, returned in node 22. 89 . ; Field 99.99 is the VUID. 90 . ; 91 . ; We use the VUID to look up the RxNorm in file 176.001; same idea. 92 . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by 93 . ; $$GET1^DIQ. 94 . ; 95 . ; I get the RxNorm name and version from the RxNorm Sources (file 96 . ; 176.003), by searching for "RXNORM", then get the data. 97 . N MEDIEN S MEDIEN=$P(MED(6),U) 98 . D NDF^PSS50(MEDIEN,,,,,"NDF") 99 . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) 100 . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) 101 . N VAPROD S VAPROD=$P(NDFDATA(22),U) 102 . ; 103 . ; NDFIEN is not necessarily defined; it won't be if the drug 104 . ; is not matched to the national drug file (e.g. if the drug is 105 . ; new on the market, compounded, or is a fake drug [blue pill]. 106 . ; To protect against failure, I will put an if/else block 107 . ; 108 . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER 109 . I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. 110 . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) 111 . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") 112 . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) 113 . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") 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 . ; 123 . S @MAP@("MEDBRANDNAMETEXT")=MED(6.5) 124 . D DOSE^PSS50(MEDIEN,,,,,"DOSE") 125 . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) 126 . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) 127 . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) 128 . ; Units, concentration, etc, come from another call 129 . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit 130 . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters 131 . ; NDF Entry IEN, and VA Product IEN 132 . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") 133 . ; These have been collected above. 134 . N CONCDATA 135 . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" 136 . ; and this will crash the call. So... 137 . I NDFIEN="" S CONCDATA="" 138 . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) 139 . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) 140 . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) 141 . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) 142 . S @MAP@("MEDQUANTITYVALUE")=MED(7) 143 . ; Oddly, there is no easy place to find the dispense unit. 144 . ; It's not included in the original call, so we have to go to the drug file. 145 . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") 146 . ; Node 14.5 is the Dispense Unit 147 . D DATA^PSS50(MEDIEN,,,,,"QTY") 148 . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) 149 . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) 150 . ; 151 . ; --- START OF DIRECTIONS --- 152 . ; Sig data not in any API :-( Oh yes, you can get the whole thing, but... 153 . ; we want the compoenents. 154 . ; It's in node 6 of ^PSRX(IEN) 155 . ; So, here we go again 156 . ; ^PSRX(D0,6,D1,0)= (#.01) DOSAGE ORDERED [1F] ^ (#1) DISPENSE UNITS PER DOSE 157 . ; ==>[2N] ^ (#2) UNITS [3P:50.607] ^ (#3) NOUN [4F] ^ (#4) 158 . ; ==>DURATION [5F] ^ (#5) CONJUNCTION [6S] ^ (#6) ROUTE 159 . ; ==>[7P:51.2] ^ (#7) SCHEDULE [8F] ^ (#8) VERB [9F] ^ 160 . ; 161 . N DIRNUM S DIRNUM=0 ; Sigline number 162 . S DIRCNT=0 ; COUNT OF MULTIPLE DIRECTIONS 163 . F S DIRNUM=$O(^PSRX(RXIEN,6,DIRNUM)) Q:DIRNUM="" D 164 . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT 165 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. 166 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. 167 . . N SIGDATA S SIGDATA=^PSRX(RXIEN,6,DIRNUM,0) 168 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=$P(SIGDATA,U,9) 169 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=$P(SIGDATA,U,1) 170 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") 171 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient 172 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient 173 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient 174 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=$$GET1^DIQ(51.2,$P(SIGDATA,U,7),.01) 175 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=$P(SIGDATA,U,8) 176 . . ; Invervals... again another call. 177 . . ; In the wisdom of the original programmers, the schedule is a free text field 178 . . ; However, it gets translated by a call to the administration schedule file 179 . . ; to see if that schedule exists. 180 . . ; That's the same thing I am going to do. 181 . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). 182 . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- 183 . . ; I looked), PSSFT is the name, and list is the ^TMP name to store the data in. 184 . . ; So... 185 . . D AP^PSS51P1("PSJ",$P(SIGDATA,U,8),,,"SCHEDULE") 186 . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") 187 . . N INTERVAL 188 . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" 189 . . E D 190 . . . N SUB S SUB=$O(SCHEDATA(0)) 191 . . . S INTERVAL=SCHEDATA(SUB,2) 192 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL 193 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" 194 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$P(SIGDATA,U,5) 195 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")="" 196 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=$P(SIGDATA,U,8)["PRN" 197 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" 198 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" 199 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" 200 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" 201 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" 202 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" 203 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" 204 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" 205 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM 206 . . N DIRMOD S DIRMOD=$P(SIGDATA,U,6) 207 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=$S(DIRMOD="T":"THEN",DIRMOD="A":"AND",DIRMOD="X":"EXCEPT",1:"") 208 . ; 209 . ; --- END OF DIRECTIONS --- 210 . ; 211 . ; ^PSRX(22,"INS1",1,0)="FOR BLOOD PRESSURE" 212 . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"INS1",1,0)) 213 . ; ^PSRX(22,"PRC",1,0)="Pharmacist: you must obey my command" 214 . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PRC",1,0)) 215 . S @MAP@("MEDRFNO")=MED(9) 216 . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) 217 . K @RESULT 218 . D MAP^C0CXPATH(MINXML,MAP,RESULT) 219 . ; MAPPING DIRECTIONS 220 . N DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE 221 . N DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT 222 . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) 223 . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") 224 . ; N MDZ1,MDZNA 225 . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS 226 . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION 227 . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) 228 . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) 229 . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") 230 . I MEDCOUNT=1 D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy 231 . E D INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML 232 N MEDTMP,MEDI 233 D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS 234 I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 235 . W "MEDICATION MISSING ",! 236 . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! 237 Q 238 ; -
ccr/branches/ohum/p/C0CMED2.m
r1342 r1428 1 C0CMED2 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) 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 1 C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;;Last Modified Sat Jan 10 21:41:14 PST 2009 4 ; Copyright 2008 WorldVistA. Licensed under the terms of the GNU 5 ; General Public License 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 W "NO ENTRY FROM TOP",! 22 Q 23 ; 24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE 25 ; 26 ; MINXML is the Input XML Template, passed by name 27 ; DFN is Patient IEN (by Value) 28 ; OUTXML is the resultant XML (by Name) 29 ; MEDCOUNT is the current count of extracted meds, passed by Reference 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, one medicine 34 ; 35 ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending 36 ; meds data available. 37 ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf 38 ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). 39 ; File for pending meds is 52.41 40 ; Unfortuantely, API does not supply us with any useful info beyond 41 ; the IEN in 52.41, and the Med Name, and route. 42 ; So, most of the info is going to get pulled from 52.41. 43 N MEDS,MAP 44 K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! 45 D PEN^PSO5241(DFN,"CCDCCR") 46 M MEDS=^TMP($J,"CCDCCR",DFN) 47 ; @(0) contains the number of meds or -1^NO DATA FOUND 48 ; If it is -1, we quit. 49 I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT 50 ZWRITE:$G(DEBUG) MEDS 51 N RXIEN S RXIEN=0 52 N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED IN THIS SECTION FOR MERGING 53 F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B" D ; FOR EACH MEDICATION IN THE LIST 54 . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT ; Dont' want refill request as a "pending" order 55 . S MEDCOUNT=MEDCOUNT+1 56 . I DEBUG W "RXIEN IS ",RXIEN,! 57 . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) 58 . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN C0CMED 59 . I DEBUG W "MAP= ",MAP,! 60 . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM 61 . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID 62 . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN 63 . S @MAP@("MEDISSUEDATETXT")="Issue Date" 64 . ; Field 6 is "Effective date", and we pull it in timson format w/ I 65 . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($$GET1^DIQ(52.41,RXIEN,6,"I"),"DT") 66 . ; Med never filled; next 4 fields are not applicable. 67 . S @MAP@("MEDLASTFILLDATETXT")="" 68 . S @MAP@("MEDLASTFILLDATE")="" 69 . S @MAP@("MEDRXNOTXT")="" 70 . S @MAP@("MEDRXNO")="" 71 . S @MAP@("MEDTYPETEXT")="Medication" 72 . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses 73 . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds 74 . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I") 75 . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2) 76 . ; NDC not supplied in API, but is rather trivial to obtain 77 . ; MED(11) piece 1 has the IEN of the drug (file 50) 78 . ; IEN is field 31 in the drug file. 79 . ; 80 . ; MEDIEN (node 11 in the returned output) might not necessarily be defined 81 . ; It is not defined when a dose in not chosen in CPRS. There is a long 82 . ; series of fields that depend on it. We will use If and Else to deal 83 . ; with that 84 . N MEDIEN S MEDIEN=$P(MED(11),U) 85 . I +MEDIEN>0 D ; start of if/else block 86 . . ; 12/30/08: I will be using RxNorm for coding... 87 . . ; 176.001 is the file for Concepts; 176.003 is the file for 88 . . ; sources (i.e. for RxNorm Version) 89 . . ; 90 . . ; We need the VUID first for the National Drug File entry first 91 . . ; We get the VUID of the drug, by looking up the VA Product entry 92 . . ; (file 50.68) using the call NDF^PSS50, returned in node 22. 93 . . ; Field 99.99 is the VUID. 94 . . ; 95 . . ; We use the VUID to look up the RxNorm in file 176.001; same idea. 96 . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by 97 . . ; $$GET1^DIQ. 98 . . ; 99 . . ; I get the RxNorm name and version from the RxNorm Sources (file 100 . . ; 176.003), by searching for "RXNORM", then get the data. 101 . . D NDF^PSS50(MEDIEN,,,,,"NDF") 102 . . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) 103 . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) 104 . . N VAPROD S VAPROD=$P(NDFDATA(22),U) 105 . . ; 106 . . ; NDFIEN is not necessarily defined; it won't be if the drug 107 . . ; is not matched to the national drug file (e.g. if the drug is 108 . . ; new on the market, compounded, or is a fake drug [blue pill]. 109 . . ; To protect against failure, I will put an if/else block 110 . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER 111 . . I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. 112 . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) 113 . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") 114 . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) 115 . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") 116 . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) 117 . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) 118 . . ; 119 . . E S (RXNORM,RXNNAME,RXNVER)="" 120 . . ; End if/else block 121 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM 122 . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME 123 . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER 124 . . ; 125 . . S @MAP@("MEDBRANDNAMETEXT")="" 126 . . D DOSE^PSS50(MEDIEN,,,,,"DOSE") 127 . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) 128 . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) 129 . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) 130 . . ; Units, concentration, etc, come from another call 131 . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit 132 . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters 133 . . ; NDF Entry IEN, and VA Product Name 134 . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") 135 . . ; Documented in the same manual; executed above. 136 . . N CONCDATA 137 . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" 138 . . ; and this will crash the call. So... 139 . . I NDFIEN="" S CONCDATA="" 140 . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) 141 . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) 142 . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) 143 . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) 144 . . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12) 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 . . D DATA^PSS50(MEDIEN,,,,,"QTY") 150 . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) 151 . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) 152 . E D 153 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")="" 154 . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" 155 . . S @MAP@("MEDPRODUCTNAMECODEVERSION")="" 156 . . S @MAP@("MEDBRANDNAMETEXT")="" 157 . . S @MAP@("MEDSTRENGTHVALUE")="" 158 . . S @MAP@("MEDSTRENGTHUNIT")="" 159 . . S @MAP@("MEDFORMTEXT")="" 160 . . S @MAP@("MEDCONCVALUE")="" 161 . . S @MAP@("MEDCONCUNIT")="" 162 . . S @MAP@("MEDSIZETEXT")="" 163 . . S @MAP@("MEDQUANTITYVALUE")="" 164 . . S @MAP@("MEDQUANTITYUNIT")="" 165 . ; end of if/else block 166 . ; 167 . ; --- START OF DIRECTIONS --- 168 . ; Sig data is not in any API. We obtain it using the IEN from 169 . ; the PEN API to file 52.41. It's in field 3, which is a multiple. 170 . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT) 171 . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call 172 . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG") 173 . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman. 174 . ; FMSIGNUM gets outputted as "IEN,RXIEN,". 175 . ; DIRNUM will be first piece for IEN. 176 . ; DIRNUM is the proper Sigline numer. 177 . ; SIGDATA is the simplfied array. Subscripts are really field numbers 178 . ; in subfile 52.413. 179 . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS 180 . F S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM="" D 181 . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",") 182 . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT 183 . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM) 184 . . ; If this is an order for a refill; it's not really a new order; move on to next 185 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. 186 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. 187 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13) 188 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8) 189 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") 190 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient 191 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient 192 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient 193 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10) 194 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1) 195 . . ; Invervals... again another call. 196 . . ; The schedule is a free text field 197 . . ; However, it gets translated by a call to the administration 198 . . ; schedule file to see if that schedule exists. 199 . . ; That's the same thing I am going to do. 200 . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). 201 . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- 202 . . ; I looked), PSSFT is the name, 203 . . ; and list is the ^TMP name to store the data in. 204 . . ; Also, freqency may have "PRN" in it, so strip that out 205 . . N FREQ S FREQ=SIGDATA(1) 206 . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp 207 . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE") 208 . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") 209 . . N INTERVAL 210 . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" 211 . . E D 212 . . . N SUB S SUB=$O(SCHEDATA(0)) 213 . . . S INTERVAL=SCHEDATA(SUB,2) 214 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL 215 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" 216 . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months 217 . . N DUR S DUR=SIGDATA(2) 218 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR)) 219 . . N DURUNIT S DURUNIT=$E(DUR) 220 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"") 221 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN" 222 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" 223 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" 224 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" 225 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" 226 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" 227 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" 228 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" 229 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field 230 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM 231 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6) 232 . ; 233 . ; --- END OF DIRECTIONS --- 234 . ; 235 . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" 236 . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL 237 . ; W @MAP@("MEDPTINSTRUCTIONS"),! 238 . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9" 239 . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL 240 . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),! 241 . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13) 242 . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) 243 . K @RESULT 244 . D MAP^C0CXPATH(MINXML,MAP,RESULT) 245 . ; D PARY^C0CXPATH(RESULT) 246 . ; MAPPING DIRECTIONS 247 . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE 248 . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT 249 . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) 250 . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") 251 . ; N MDZ1,MDZNA 252 . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS 253 . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION 254 . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) 255 . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) 256 . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") 257 . I MEDFIRST D ; 258 . . S MEDFIRST=0 ; RESET FIRST FLAG 259 . . D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy 260 . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER 261 N MEDTMP,MEDI 262 D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS 263 I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 264 . W "Pending Medication MISSING ",! 265 . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! 266 Q 267 ; -
ccr/branches/ohum/p/C0CMED3.m
r1342 r1428 1 C0CMED3 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) 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 308 309 310 1 C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;;Last Modified: Sun Jan 11 05:45:03 UTC 2009 4 ; Copyright 2009 WorldVistA. Licensed under the terms of the GNU 5 ; General Public License 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 W "NO ENTRY FROM TOP",! 22 Q 23 ; 24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml template 25 ; 26 ; MINXML is the Input XML Template, (passed by name) 27 ; DFN is Patient IEN (passed by value) 28 ; OUTXML is the resultant XML (passed by name) 29 ; MEDCOUNT is the number of Meds extracted so far (passed by reference) 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, one medicine 34 ; 35 ; Non-VA meds don't have an API. They are stored in file 55, subfile 52.2 36 ; Discontinued meds are indicated by the presence of a value in fields 37 ; 5 or 6 (STATUS 1 or 2, and DISCONTINUED DATE) 38 ; Will use Fileman API GETS^DIQ 39 ; 40 N MEDS,MAP 41 K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! 42 N NVA 43 D GETS^DIQ(55,DFN,"52.2*","IE","NVA") ; Output in NVA in FDA array format. 44 ; If NVA does not exist, then patient has no non-VA meds 45 I $D(NVA)=0 S @OUTXML@(0)=0 QUIT 46 ; Otherwise, we go on... 47 M MEDS=NVA(55.05) 48 ; We are done with NVA 49 K NVA 50 ; 51 I DEBUG ZWRITE MEDS 52 N FDAIEN S FDAIEN=0 ; For use in $Order in the MEDS array. 53 N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED PROCESSED HERE 54 F S FDAIEN=$O(MEDS(FDAIEN)) Q:FDAIEN="" D ; FOR EACH MEDICATION IN THE LIST 55 . N MED M MED=MEDS(FDAIEN) 56 . I MED(5,"I")!MED(6,"I") QUIT ; If disconinued, we don't want to pull it. 57 . S MEDCOUNT=MEDCOUNT+1 58 . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) 59 . N RXIEN S RXIEN=$P(FDAIEN,",") ; First piece of FDAIEN is the number of the med for this patient 60 . I DEBUG W "RXIEN IS ",RXIEN,! 61 . I DEBUG W "MAP= ",MAP,! 62 . S @MAP@("MEDOBJECTID")="MED_OUTSIDE"_MEDCOUNT ; MEDCOUNT FOR ID 63 . S @MAP@("MEDISSUEDATETXT")="Documented Date" 64 . ; Field 6 is "Effective date", and we pull it in timson format w/ I 65 . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL(MED(11,"I"),"DT") 66 . ; Med never filled; next 4 fields are not applicable. 67 . S @MAP@("MEDLASTFILLDATETXT")="" 68 . S @MAP@("MEDLASTFILLDATE")="" 69 . S @MAP@("MEDRXNOTXT")="" 70 . S @MAP@("MEDRXNO")="" 71 . S @MAP@("MEDTYPETEXT")="Medication" 72 . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses 73 . S @MAP@("MEDSTATUSTEXT")="Active" ; nearest status for pending meds 74 . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I") 75 . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E") 76 . ; NDC is field 31 in the drug file. 77 . ; The actual drug entry in the drug file (MEDIEN) is not necessarily supplied. 78 . ; It' node 1, internal form. 79 . N MEDIEN S MEDIEN=MED(1,"I") 80 . I +MEDIEN D ; start of if/else block 81 . . ; 12/30/08: I will be using RxNorm for coding... 82 . . ; 176.001 is the file for Concepts; 176.003 is the file for 83 . . ; sources (i.e. for RxNorm Version) 84 . . ; 85 . . ; We need the VUID first for the National Drug File entry first 86 . . ; We get the VUID of the drug, by looking up the VA Product entry 87 . . ; (file 50.68) using the call NDF^PSS50, returned in node 22. 88 . . ; Field 99.99 is the VUID. 89 . . ; 90 . . ; We use the VUID to look up the RxNorm in file 176.001; same idea. 91 . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by 92 . . ; $$GET1^DIQ. 93 . . ; 94 . . ; I get the RxNorm name and version from the RxNorm Sources (file 95 . . ; 176.003), by searching for "RXNORM", then get the data. 96 . . ; NDF^PSS50 ONLY EXISTS ON VISTA 97 . . N NDFDATA,NDFIEN,VAPROD 98 . . S NDFIEN="" 99 . . I '$$RPMS^C0CUTIL() D 100 . . . D NDF^PSS50(MEDIEN,,,,,"NDF") 101 . . . ;N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) 102 . . . ;N NDFIEN S NDFIEN=$P(NDFDATA(20),U) 103 . . . ;N VAPROD S VAPROD=$P(NDFDATA(22),U) 104 . . . M NDFDATA=^TMP($J,"NDF",MEDIEN) 105 . . . S NDFIEN=$P(NDFDATA(20),U) 106 . . . S VAPROD=$P(NDFDATA(22),U) 107 . . . S @MAP@("MEDPRODUCTNAMETEXT")=$$GET1^DIQ(50.68,VAPROD,.01) ; 108 . . ; GPL - RESET THE NAME TO THE REAL NAME OF THE DRUG NOW THAT WE 109 . . ; HAVE IT. 110 . . ; 111 . . ; NDFIEN is not necessarily defined; it won't be if the drug 112 . . ; is not matched to the national drug file (e.g. if the drug is 113 . . ; new on the market, compounded, or is a fake drug [blue pill]. 114 . . ; To protect against failure, I will put an if/else block 115 . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER 116 . . ; 117 . . ; begin changes for systems that have eRx installed 118 . . ; RxNorm is found in the ^C0P("RXN") global - gpl 119 . . ; 120 . . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION 121 . . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE 122 . . S (RXNORM,RXNNAME,RXNVER)="" ;INITIALIZE 123 . . I NDFIEN,$D(^C0P("RXN")) D ; 124 . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) 125 . . . S ZC=$$CODE^C0CUTIL(VUID) 126 . . . S ZCD=$P(ZC,"^",1) ; CODE TO USE 127 . . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID 128 . . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION 129 . . . S RXNORM=ZCD ; THE CODE 130 . . . S RXNNAME=ZCDS ; THE CODING SYSTEM 131 . . . S RXNVER=ZCDSV ; THE CODING SYSTEM VERSION 132 . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT") 133 . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_ZCDS_": "_ZCD 134 . . E I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. 135 . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) 136 . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") 137 . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) 138 . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") 139 . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) 140 . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) 141 . . ; 142 . . ;E S (RXNORM,RXNNAME,RXNVER)="" 143 . . ; End if/else block 144 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM 145 . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME 146 . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER 147 . . ; 148 . . S @MAP@("MEDBRANDNAMETEXT")="" 149 . . ; DOSE^PSS50 ONLY ESISTS ON VISTA 150 . . I '$$RPMS^C0CUTIL() D 151 . . . D DOSE^PSS50(MEDIEN,,,,,"DOSE") 152 . . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) 153 . . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) 154 . . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) 155 . . E S @MAP@("MEDSTRENGTHVALUE")="" S @MAP@("MEDSTRENGTHUNIT")="" 156 . . ; Units, concentration, etc, come from another call 157 . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit 158 . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters 159 . . ; NDF Entry IEN, and VA Product Name 160 . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") 161 . . ; Documented in the same manual; executed above. 162 . . ; 163 . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" 164 . . ; and this will crash the call. So... 165 . . I NDFIEN="" S CONCDATA="" 166 . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) 167 . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) 168 . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) 169 . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) 170 . . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. 171 . . ; Oddly, there is no easy place to find the dispense unit. 172 . . ; It's not included in the original call, so we have to go to the drug file. 173 . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") 174 . . ; Node 14.5 is the Dispense Unit 175 . . ; PSS50 ONLY EXISTS ON VISTA 176 . . I '$$RPMS^C0CUTIL() D 177 . . . D DATA^PSS50(MEDIEN,,,,,"QTY") 178 . . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) 179 . . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) 180 . . E S @MAP@("MEDQUANTITYUNIT")="" 181 . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these 182 . E D 183 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")="" 184 . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" 185 . . S @MAP@("MEDPRODUCTNAMECODEVERSION")="" 186 . . S @MAP@("MEDBRANDNAMETEXT")="" 187 . . S @MAP@("MEDSTRENGTHVALUE")="" 188 . . S @MAP@("MEDSTRENGTHUNIT")="" 189 . . S @MAP@("MEDFORMTEXT")="" 190 . . S @MAP@("MEDCONCVALUE")="" 191 . . S @MAP@("MEDCONCUNIT")="" 192 . . S @MAP@("MEDSIZETEXT")="" 193 . . S @MAP@("MEDQUANTITYVALUE")="" 194 . . S @MAP@("MEDQUANTITYUNIT")="" 195 . ; End If/Else 196 . ; --- START OF DIRECTIONS --- 197 . ; Dosage is field 2, route is 3, schedule is 4 198 . ; These are all free text fields, and don't point to any files 199 . ; For that reason, I will use the field I never used before: 200 . ; MEDDIRECTIONDESCRIPTIONTEXT 201 . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS 202 . ; 203 . ; change for eRx meds - gpl 6/25/2011 204 . ; 205 . N ZERX S ZERX=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") 206 . I ZERX["|" S ZERX=$P(ZERX,"|",2) ; GET RID OF MED NAME 207 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=ZERX 208 . N ZERX2 S ZERX2=$P(MED(2,"E"),"|",2) ; sig for quantity 209 . N ZFDBDRUG S ZFDBDRUG=$P(MED(2,"E"),"|",1) ; FDB DRUG NAME 210 . I @MAP@("MEDPRODUCTNAMETEXT")["FREE TXT" D ; FIX THE DRUG NAME 211 . . S @MAP@("MEDPRODUCTNAMETEXT")=ZFDBDRUG ; USE FDB NAME 212 . . S RXNORM=$P($P($G(MED(14,7)),"RXNORM:",2)," ",1) ; THE RXNORM 213 . . S RXNORM=$$NISTMAP^C0CUTIL(RXNORM) ; CHANGE IF NECESSARY 214 . . I RXNORM'="" D ; 215 . . . W !,"FOUND FREE TEXT RXNORM:",RXNORM 216 . . . S RXNNAME="RXNORM" ; THE CODING SYSTEM 217 . . . S RXNVER="" ; THE CODING SYSTEM VERSION 218 . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT") 219 . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_RXNNAME_": "_RXNORM 220 . . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM 221 . . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME 222 . . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER 223 . . . I RXNORM["979334" D ; PATCH FOR CERTIFICATION 224 . . . . S @MAP@("MEDSTRENGTHVALUE")=650 225 . . . . S @MAP@("MEDSTRENGTHUNIT")="mcg" 226 . . . . S @MAP@("MEDFORMTEXT")="INHALER" 227 . S @MAP@("MEDQUANTITYUNIT")=$P(ZERX2," ",3) ; THE UNITS 228 . S @MAP@("MEDQUANTITYVALUE")=$P(ZERX2," ",2) ; THE QUANTITY 229 . I @MAP@("MEDFORMTEXT")="" S @MAP@("MEDFORMTEXT")=$P(ZERX2," ",3) ; 230 . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") 231 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. 232 . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" 233 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" 234 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" 235 . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" 236 . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" 237 . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" 238 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" 239 . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" 240 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" 241 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" 242 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" 243 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" 244 . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" 245 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" 246 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" 247 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" 248 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" 249 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" 250 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" 251 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" 252 . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" 253 . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" 254 . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" 255 . ; 256 . ; --- END OF DIRECTIONS --- 257 . ; 258 . S @MAP@("MEDRFNO")="" 259 . I $D(MED(14,1)) D ; 260 . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field 261 . E S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" 262 . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" ; don't put in these - gpl 263 . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) 264 . K @RESULT 265 . D MAP^C0CXPATH(MINXML,MAP,RESULT) 266 . ; D PARY^C0CXPATH(RESULT) 267 . ; MAPPING DIRECTIONS 268 . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE 269 . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT 270 . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) 271 . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") 272 . N MDZ1,MDZNA 273 . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS 274 . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION 275 . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) 276 . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) 277 . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") 278 . ; 279 . ; MAP PATIENT INSTRUCTIONS - HAVE TO DO THIS AFTER MAPPING DIRECTIONS DUE TO XML SCHEMA VALIDATION 280 . N MEDINT1,INTXML1 S INTXML1="MENINT1" ; VARIABLE AND NAME VARIABLE TEMPLATE 281 . N MEDINT2,INTXML2 S INTXML2="MEDINT2" ; VARIABLE AND NAME VARIABLE RESULT 282 . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/PatientInstructions",INTXML1) 283 . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/PatientInstructions") 284 . ;N MDI1 ; removing the "I" which is not in the protocol gpl 1/2010 285 . ;S MDI1=$NA(@MAP@("I")) 286 . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" 287 . I $D(MED(10,1)) D ; 288 . . ;S @MAP@("I","MEDPTINSTRUCTIONS")=$P(MED(10,1)," ",1) ; WP Field 289 . . S @MAP@("MEDPTINSTRUCTIONS")=$P(MED(10,1)," ",1) ; WP Field 290 . E S @MAP@("MEDPTINSTRUCTIONS")="" 291 . ;E S @MAP@("I","MEDPTINSTRUCTIONS")="" 292 . ;D MAP^C0CXPATH(INTXML1,MDI1,INTXML2) 293 . D MAP^C0CXPATH(INTXML1,MAP,INTXML2) ; JUST MAP WORKS.. GPL 294 . D INSERT^C0CXPATH(RESULT,INTXML2,"//Medications/Medication") 295 . ; 296 . ; FLAG HAS TO BE RESET OUTSIDE THE IF STATMENT. 297 . ;I MEDFIRST D ; 298 . ;. S MEDFIRST=0 ; RESET FIRST FLAG 299 . ;. D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy 300 . ;D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML 301 . D:MEDFIRST CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy 302 . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML 303 . I MEDFIRST S MEDFIRST=0 304 N MEDTMP,MEDI 305 D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS 306 I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 307 . W "MEDICATION MISSING ",! 308 . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! 309 Q 310 ; -
ccr/branches/ohum/p/C0CMED4.m
r1342 r1428 1 C0CMED4 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/082 ;;0.1;CCDCCR;;;Build 2 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 . S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"")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 ; 5/10/12 2:38pm 2 ;;1.2;C0C;;May 11, 2012;Build 46 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($L(MEDIEN):$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
r1342 r1428 1 C0CMED6 2 ;;1.0;C0C;;May 19, 2009;Build 2 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 308 GETRXN(NDC) 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 1 C0CMED6 ; WV/CCDCCR/SMH - Meds from RPMS: Outpatient Meds;01/10/09 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 GETRXN(NDC) ; Extrinsic Function; PUBLIC; NDC to RxNorm 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
r1342 r1428 1 C0CMIME 2 ;;1.0;C0C;;Mar 8, 2011;Build 2 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.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CMXML 2 ;;0.1;C0C;nopatch;noreleasedate;Build 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 TEST 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 TEST2 43 44 45 46 47 TEST3 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 TEST3A 72 73 74 75 76 77 78 79 80 TESTQ 81 82 83 84 85 86 87 88 89 90 91 92 93 TESTQ2 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 TEST4 110 111 112 113 114 115 116 117 118 119 TEST5 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) 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 PARSE(INXML,INDOC) 177 178 179 180 181 182 ISMULT(ZOID) 183 184 185 186 187 188 189 FIRST(ZOID) 190 191 192 PARENT(ZOID) 193 194 195 ATT(RTN,NODE) 196 197 198 199 200 201 TAG(ZOID) 202 203 204 205 206 207 208 209 210 NXTSIB(ZOID) 211 212 213 DATA(ZT,ZOID) 214 215 216 217 218 219 220 OUTXML(ZRTN,INID) 221 222 223 224 225 226 227 228 229 230 NDOUT(ZOID) 231 232 233 234 235 236 237 238 239 240 241 242 243 244 UPDIE 245 246 247 248 249 250 251 252 253 254 1 C0CMXML ; GPL - MXML based XPath utilities;10/13/09 17:05 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 ; THIS FILE CONTAINS THE XPATH CREATOR, THE PARSE CALL TO THE MXML PARSER 22 ; AND THE OUTXML XML GENERATOR THAT OUTPUTS XML FROM AN MXML DOM 23 ; FOR CCD SPECIFIC ROUTINES, SEE C0CMCCD 24 ; FOR TEMPLATE FILE RELATED ROUTINES, SEE C0CMXP 25 ; 26 TEST ; 27 S C0CXMLIN=$NA(^TMP("C0CMXML",$J)) 28 K GARY 29 W $$FTG^%ZISH("/home/vademo2/EHR/p/","mxml-test.xml",$NA(@C0CXMLIN@(1)),3) 30 S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DocID: ",C0CDOCID 31 S REDUX="//ContinuityOfCareRecord/Body" 32 D XPATH(1,"/","GIDX","GARY",,REDUX) 33 D SEPARATE^C0CMCCD("GARY2","GARY") 34 S ZI="" 35 F S ZI=$O(GARY2(ZI)) Q:ZI="" D ; 36 . N GTMP,G2 37 . M G2=GARY2(ZI) 38 . D DEMUX2^C0CMXP("GTMP","G2",2) 39 . M GARY3(ZI)=GTMP 40 Q 41 ; 42 TEST2 ; 43 S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail" 44 D XPATH(1,"/","GIDX","GARY","",REDUX) 45 Q 46 ; 47 TEST3 48 S C0CXMLIN=$NA(^TMP("C0CMXML",$J)) 49 K GARY,GTMP,GIDX 50 K @C0CXMLIN 51 W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3) 52 D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS 53 K @C0CXMLIN 54 M @C0CXMLIN=GTMP 55 K GTMP 56 D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN) 57 K @C0CXMLIN 58 M @C0CXMLIN=GTMP 59 K GTMP 60 S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID 61 S REDUX="//ClinicalDocument/component/structuredBody" 62 D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS 63 D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS 64 D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS 65 D XPATH(1,"/","GIDX","GARY",,REDUX) 66 K C0CCBK("TAG") 67 D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING 68 D TEST3A 69 Q 70 ; 71 TEST3A ; INTERNAL ROUTINE 72 S ZI="" 73 F S ZI=$O(GARY2(ZI)) Q:ZI="" D ; 74 . N GTMP,G2 75 . M G2=GARY2(ZI) 76 . D DEMUX2^C0CMXP("GTMP","G2",2) 77 . M GARY4(ZI)=GTMP 78 Q 79 ; 80 TESTQ ; TEST OF THE QRDA TEMPLATE GPL 7/8/2010 81 S C0CXMLIN=$NA(^TMP("C0CMXML",$J)) 82 K GARY,GTMP,GIDX 83 K @C0CXMLIN 84 W $$FTG^%ZISH("/home/vademo2/","QRDA_CategoryI_WorldVistA1.xml",$NA(@C0CXMLIN@(1)),3) 85 D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS 86 K @C0CXMLIN 87 S GTMP(1)="<"_$P(GTMP(1),"<",2) 88 M @C0CXMLIN=GTMP 89 K GTMP 90 D TESTQ2 91 Q 92 ; 93 TESTQ2 ; SECOND PART OF TESTQ 94 D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN) 95 K @C0CXMLIN 96 M @C0CXMLIN=GTMP 97 K GTMP 98 S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID 99 S REDUX="//ClinicalDocument/component/structuredBody" 100 D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS 101 D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS 102 D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS 103 D XPATH(1,"/","GIDX","GARY",,REDUX) 104 K C0CCBK("TAG") 105 D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING 106 D TEST3A 107 Q 108 ; 109 TEST4 ; TEST OF OUTPUTING AN XML FILE FROM THE DOM .. this one is the CCR 110 ; 111 D TEST ; SET UP THE DOM 112 D START^C0CMXMLB($$TAG(1),,"G") 113 D NDOUT($$FIRST(1)) 114 D END^C0CMXMLB ;END THE DOCUMENT 115 M ZCCR=^TMP("MXMLBLD",$J) 116 ZWR ZCCR 117 Q 118 ; 119 TEST5 ; SAME AS TEST4, BUT THIS TIME THE CCD 120 S C0CXMLIN=$NA(^TMP("C0CMXML",$J)) 121 K GARY,GTMP,GIDX 122 K @C0CXMLIN 123 W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3) 124 D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS 125 K @C0CXMLIN 126 M @C0CXMLIN=GTMP 127 K GTMP 128 D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN) 129 K @C0CXMLIN 130 M @C0CXMLIN=GTMP 131 K GTMP 132 S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DOCID: ",C0CDOCID ;CALL REGULAR PARSER 133 ;D XPATH(1,"/","GIDX2","GARY2",,REDUX) 134 D OUTXML("ZCCD",C0CDOCID) 135 ;D START^C0CMXMLB($$TAG(1),,"G") 136 ;D NDOUT($$FIRST(1)) 137 ;D END^C0CMXMLB ;EOND THE DOCUMENT 138 ;M ZCCD=^TMP("MXMLBLD",$J) 139 ZWR ZCCD(1:30) 140 Q 141 ; 142 XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE 143 ; THE XPATH INDEX ZXIDX, PASSED BY NAME 144 ; THE XPATH ARRAY XPARY, PASSED BY NAME 145 ; ZOID IS THE STARTING OID 146 ; ZPATH IS THE STARTING XPATH, USUALLY "/" 147 ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE 148 ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT 149 I $G(ZREDUX)="" S ZREDUX="" 150 N NEWPATH 151 N NEWNUM S NEWNUM="" 152 I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" 153 S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE 154 I $G(ZREDUX)'="" D ; REDUX PROVIDED? 155 . N GT S GT=$P(NEWPATH,ZREDUX,2) 156 . I GT'="" S NEWPATH=GT 157 S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX 158 N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE 159 I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY 160 E I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY 161 N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD 162 I ZFRST'=0 D ; THERE IS A CHILD 163 . N ZNUM 164 . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE 165 . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD 166 N GNXT S GNXT=$$NXTSIB(ZOID) 167 I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES 168 I GNXT'=0 D ; 169 . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? 170 . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES 171 . . N ZNUM S ZNUM=1 ; 172 . . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB 173 . E D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB 174 Q 175 ; 176 PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME 177 ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW 178 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML 179 ;Q $$EN^MXMLDOM(INXML) 180 Q $$EN^MXMLDOM(INXML,"W") 181 ; 182 ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE 183 N ZN 184 ;I $$TAG(ZOID)["entry" B 185 S ZN=$$NXTSIB(ZOID) 186 I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG 187 Q 0 188 ; 189 FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID 190 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) 191 ; 192 PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID 193 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) 194 ; 195 ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID 196 S HANDLE=C0CDOCID 197 K @RTN 198 D GETTXT^MXMLDOM("A") 199 Q 200 ; 201 TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE 202 ;I ZOID=149 B ;GPLTEST 203 N X,Y 204 S Y="" 205 S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE 206 I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y 207 I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) 208 Q Y 209 ; 210 NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING 211 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) 212 ; 213 DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE 214 ;N ZT,ZN S ZT="" 215 ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) 216 ;Q $G(@C0CDOM@(ZOID,"T",1)) 217 S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) 218 Q 219 ; 220 OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM 221 ; 222 S C0CDOCID=INID 223 D START^C0CMXMLB($$TAG(1),,"G") 224 D NDOUT($$FIRST(1)) 225 D END^C0CMXMLB ;END THE DOCUMENT 226 M @ZRTN=^TMP("MXMLBLD",$J) 227 K ^TMP("MXMLBLD",$J) 228 Q 229 ; 230 NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE 231 N ZI S ZI=$$FIRST(ZOID) 232 I ZI'=0 D ; THERE IS A CHILD 233 . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT 234 . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN 235 E D ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT 236 . ;W "DOING",ZOID,! 237 . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA 238 . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES 239 . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN 240 I $$NXTSIB(ZOID)'=0 D ; THERE IS A SIBLING 241 . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS 242 Q 243 ; 244 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 245 K ZERR 246 D CLEAN^DILF 247 D UPDATE^DIE("","C0CFDA","","ZERR") 248 I $D(ZERR) D ; 249 . W "ERROR",! 250 . ZWR ZERR 251 . B 252 K C0CFDA 253 Q 254 ; -
ccr/branches/ohum/p/C0CMXMLB.m
r1342 r1428 1 MXMLBLD ;;ISF/RWF - Tool to build XML ;07/09/09 16:55 2 ;;8.0;KERNEL;;;Build 2 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 C0CMXMLB ;;ISF/RWF - Tool to build XML ; 5/10/12 2:51pm 2 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CMXP 2 ;;0.1;C0C;nopatch;noreleasedate;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 INITXPF(ARY) 23 24 25 26 27 28 29 30 31 32 33 SETXPF(ARY) 34 35 36 37 38 39 40 41 42 ADDXP(INARY,TID,FARY) 43 44 45 46 47 48 49 50 51 52 53 54 55 FIXICD9 56 57 58 59 60 61 62 63 64 ADDXML(INXML,TEMPID,INFARY) 65 66 67 68 69 70 71 72 73 74 ADDTEMP(INXML,TEMPID,INFARY) 75 76 77 78 79 80 81 82 83 84 GETXML(OUTXML,TEMPID,INFARY) 85 86 87 88 89 90 91 92 93 94 95 GETTEMP(OUTXML,TEMPID,FARY) 96 97 98 99 100 101 102 103 104 105 106 COPYWP(ZFLD,ZSRCREC,ZDESTREC,ZSRCF,ZDESTF) 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 COMPILE(TID,UFARY) 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 MKTPLATE(OUTT,OUTIDX,INXML,REDUX) 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 INVERT(OUTX,INX) 190 191 192 193 194 195 196 DEMUX(OUTX,INX) 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 DEMUXARY(OARY,IARY,DEPTH) 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 DEMUX2(OARY,IARY,DEPTH) 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 DEMUXXP1(OARY,IARY) 249 250 251 252 253 254 255 256 257 258 259 260 261 262 DEMUXXP2(OARY,IARY) 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 UPDIE 283 284 285 286 287 288 289 290 291 292 1 C0CMXP ; GPL - MXML based XPath utilities;12/04/09 17:05 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 INITXPF(ARY) ;INITIAL XML/XPATH FILE ARRAY 23 ; DON'T USE THIS ONE ... USE INITFARY^C0CSOAP("FARY") INSTEAD 24 D INITFARY^C0CSOAP(ARY) ; 25 Q 26 S @ARY@("XML FILE NUMBER")=178.101 27 S @ARY@("XML SOURCE FIELD")=2.1 28 S @ARY@("XML TEMPLATE FIELD")=3 29 S @ARY@("XPATH BINDING SUBFILE")=178.1014 30 S @ARY@("REDUX FIELD")=2.5 31 Q 32 ; 33 SETXPF(ARY) ; SET FILE AND FIELD VARIABLES FROM XPF ARRAY 34 ; 35 S C0CXPF=@ARY@("XML FILE NUMBER") 36 S C0CXFLD=@ARY@("XML") 37 S C0CXTFLD=@ARY@("TEMPLATE XML") 38 S C0CXPBF=@ARY@("BINDING SUBFILE NUMBER") 39 S C0CRDUXF=@ARY@("XPATH REDUCTION STRING") 40 Q 41 ; 42 ADDXP(INARY,TID,FARY) ;ADD XPATH .01 FIELD TO BINDING SUBFILE OF TEMPLATE TID 43 I '$D(FARY) D ; 44 . S FARY="FARY" ; FILE ARRAY 45 . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE 46 D SETXPF(FARY) ;SET FILE VARIABLES 47 N C0CA,C0CB 48 S C0CA="" S C0CB=0 49 F S C0CA=$O(@INARY@(C0CA)) Q:C0CA="" D ; FOR EACH XPATH 50 . S C0CB=C0CB+1 ; COUNT OF XPATHS 51 . S C0CFDA(C0CXPBF,"?+"_C0CB_","_TID_",",.01)=C0CA 52 . D UPDIE ; CREATE THE BINDING SUBFILE FOR THIS XPATH 53 Q 54 ; 55 FIXICD9 ; FIX THE ICD9RESULT XML 56 D GETXML("GPL","ICD9RESULT") ; GET SOME BAD XML OUT OF THE FILE 57 S ZI="" 58 S G="" 59 F S ZI=$O(GPL(ZI)) Q:ZI="" D ; FOR EACH LINE 60 . S G=G_GPL(ZI) ; MAKE ONE BIG STRING OF XML 61 D NORMAL^C0CSOAP("G2","G") ;NO NORMALIZE IT BACK INTO AN ARRAY 62 D ADDXML("G2","ICD9RESULT") ; AND PUT IT BACK 63 Q 64 ADDXML(INXML,TEMPID,INFARY) ;ADD XML TO A TEMPLATE ID TEMPID 65 ; INXML IS PASSED BY NAME 66 I '$D(INFARY) D ; 67 . S INFARY="FARY" ; FILE ARRAY 68 . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE 69 I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME 70 D SETXPF(INFARY) ;SET FILE VARIABLES 71 D WP^DIE(C0CXPF,TEMPID_",",C0CXFLD,,INXML) 72 Q 73 ; 74 ADDTEMP(INXML,TEMPID,INFARY) ;ADD XML TEMPLATE TO TEMPLATE RECORD TEMPID 75 ; 76 I '$D(INFARY) D ; 77 . S INFARY="FARY" ; FILE ARRAY 78 . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE 79 I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME 80 D SETXPF(INFARY) ;SET FILE VARIABLES 81 D WP^DIE(C0CXPF,TEMPID_",",C0CXTFLD,,INXML) 82 Q 83 ; 84 GETXML(OUTXML,TEMPID,INFARY) ;GET THE XML FROM TEMPLATE TEMPID 85 ; 86 I '$D(INFARY) D ; 87 . S INFARY="FARY" ; FILE ARRAY 88 . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE 89 D SETXPF(INFARY) ;SET FILE VARIABLES 90 I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,INFARY) ;RESOLVE TEMPLATE NAME 91 I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXFLD,,OUTXML)'=OUTXML D Q ; 92 . W "ERROR RETRIEVING TEMPLATE",! 93 Q 94 ; 95 GETTEMP(OUTXML,TEMPID,FARY) ;GET THE TEMPLATE XML FROM TEMPLATE TEMPID 96 ; 97 I '$D(FARY) D ; 98 . S FARY="FARY" ; FILE ARRAY 99 . D INITXPF("FARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE 100 D SETXPF(FARY) ;SET FILE VARIABLES 101 I +TEMPID=0 S TEMPID=$$RESTID^C0CSOAP(TEMPID,FARY) ;RESOLVE TEMPLATE NAME 102 I $$GET1^DIQ(C0CXPF,TEMPID_",",C0CXTFLD,,OUTXML)'=OUTXML D Q ; 103 . W "ERROR RETRIEVING TEMPLATE",! 104 Q 105 ; 106 COPYWP(ZFLD,ZSRCREC,ZDESTREC,ZSRCF,ZDESTF) ; COPIES A WORD PROCESSING FIELD 107 ; FROM ONE RECORD TO ANOTHER RECORD 108 ; ZFLD IS EITHER A NUMBERIC FIELD OR A NAME IN ZSRCF 109 ; ZSRCF IS THE SOURCE FILE, IN FILE REDIRECT FORMAT 110 ; IF ZSRCF IS OMMITED, THE DEFAULT C0C XML MISC FILE WILL BE ASSUMED 111 ; ZDESTF IS DESTINATION FILE. IF OMMITED, IS ASSUMED TO BE THE SAME 112 ; A ZSRCF 113 I '$D(ZSRCF) D ; 114 . S ZSRCF="ZSRCF" 115 . D INITFARY^C0CSOAP(ZSRCF) 116 I '$D(ZDESTF) D ; 117 . S ZDESTF="ZDESTF" 118 . M @ZDESTF=@ZSRCF 119 N ZSF,ZDF,ZSFREF,ZDFREF 120 S ZSF=@ZSRCF@("XML FILE NUMBER") 121 S ZSFREF=$$FILEREF^C0CRNF(ZSF) 122 S ZDF=@ZDESTF@("XML FILE NUMBER") 123 S ZDFREF=$$FILEREF^C0CRNF(ZDF) 124 N ZSIEN,ZDIEN 125 S ZSIEN=$O(@ZSFREF@("B",ZSRCREC,"")) 126 I ZSIEN="" W !,"ERROR SOURCE RECORD NOT FOUND" Q ; 127 S ZDIEN=$O(@ZDFREF@("B",ZDESTREC,"")) 128 I ZDIEN="" W !,"ERROR DESTINATION RECORD NOT FOUND" Q ; 129 N ZFLDNUM 130 I +ZFLD=0 S ZFLDNUM=@ZSRCF@(ZFLD) ; IF FIELD IS PASSED BY NAME 131 E S ZFLDNUM=ZFLD ; IF FIELD IS PASSED BY NUMBER 132 N ZWP,ZWPN 133 S ZWPN=$$GET1^DIQ(ZSF,ZSIEN_",",ZFLDNUM,,"ZWP") ; GET WP FROM SOURCE 134 I ZWPN'="ZWP" W !,"ERROR SOURCE FIELD EMPTY" Q ; 135 D WP^DIE(ZDF,ZDIEN_",",ZFLDNUM,,"ZWP") ; PUT WP FIELD TO DEST 136 Q 137 ; 138 COMPILE(TID,UFARY) ; COMPILES AN XML TEMPLATE AND GENERATES XPATH BINDINGS 139 ; UFARY IF SPECIFIED WILL REDIRECT THE XML FILE TO USE 140 ; INTID IS THE IEN OF THE RECORD TO USE IN THE XML FILE 141 ; XML IS PULLED FROM THE "XML" FIELD AND THE COMPILED RESULT PUT 142 ; IN THE "XML TEMPLATE" FIELD. ALL XPATHS USED IN THE TEMPLATE 143 ; WILL BE POPULATED TO THE XPATH BINDINGS SUBFILE AS .01 144 I '$D(UFARY) D ; 145 . S UFARY="DEFFARY" ; FILE ARRAY 146 . ;D INITXPF("UFARY") ;IF FILE ARRAY NOT PASSED, INITIALIZE 147 . D INITFARY^C0CSOAP(UFARY) 148 D SETXPF(UFARY) ;SET FILE VARIABLES 149 I +TID=0 S INTID=$$RESTID^C0CSOAP(TID,UFARY) 150 E S INTID=TID 151 ;B 152 ;N C0CXML,C0CREDUX,C0CTEMP,C0CIDX 153 D GETXML("C0CXML",INTID,UFARY) 154 S C0CREDUX=$$GET1^DIQ(C0CXPF,INTID_",",C0CRDUXF,"E") ;XPATH REDUCTION STRING 155 D MKTPLATE("C0CTEMP","C0CIDX","C0CXML",C0CREDUX) ; CREATE TEMPLATE AND IDX 156 D ADDTEMP("C0CTEMP",INTID,UFARY) ; WRITE THE TEMPLATE TO FILE 157 D ADDXP("C0CIDX",INTID,UFARY) ;CREATE XPATH SUBFILE ENTRIES FOR EVERY XPATH 158 Q 159 ; 160 MKTPLATE(OUTT,OUTIDX,INXML,REDUX) ;MAKE A TEMPLATE FROM INXML, RETURNED IN OUTT 161 ; BOTH PASSED BY NAME. THE REDUX XPATH REDUCTION STRING IS USED IF PASSED 162 ; OUTIDX IS AN ARRAY OF THE XPATHS USED IN MAKING THE TEMPLATE 163 ; 164 S C0CXLOC=$NA(^TMP("C0CXML",$J)) 165 K @C0CXLOC 166 M @C0CXLOC=@INXML 167 S C0CDOCID=$$PARSE^C0CMXML(C0CXLOC,"C0CMKT") 168 K @C0CXLOC 169 S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) 170 ;N GIDX,GIDX2,GARY,GARY2 171 I '$D(REDUX) S REDUX="" 172 D XPATH^C0CMXML(1,"/","GIDX","GARY",,REDUX) 173 D INVERT("GIDX2","GIDX") ;MAKE ARRAY TO LOOK UP XPATH BY NODE 174 N ZI,ZD S ZI="" 175 F S ZI=$O(@C0CDOM@(ZI)) Q:ZI="" D ; FOR EACH NODE IN THE DOM 176 . K ZD ;FOR DATA 177 . D DATA^C0CMXML("ZD",ZI) ;SEE IF THERE IS DATA FOR THIS NODE 178 . ;I $D(ZD(1)) D ; IF YES 179 . I $$FIRST^C0CMXML(ZI)=0 D ; IF THERE ARE NO CHILDREN TO THIS NODE 180 . . ;I ZI<3 B ;W !,ZD(1) 181 . . K @C0CDOM@(ZI,"T") ; KILL THE DATA 182 . . N ZXPATH 183 . . S ZXPATH=$G(GIDX2(ZI)) ;FIND AN XPATH FOR THIS NODE 184 . . S @C0CDOM@(ZI,"T",1)="@@"_ZXPATH_"@@" 185 . . I ZXPATH'="" S @OUTIDX@(ZXPATH)="" ; PASS BACK XPATH USED IN IDX 186 D OUTXML^C0CMXML(OUTT,C0CDOCID) 187 Q 188 ; 189 INVERT(OUTX,INX) ;INVERTS AN XPATH INDEX RETURNING @OUTX@(x)=XPath from 190 ; @INX@(XPath)=x 191 N ZI S ZI="" 192 F S ZI=$O(@INX@(ZI)) Q:ZI="" D ;FOR EACH XPATH IN THE INPUT 193 . S @OUTX@(@INX@(ZI))=ZI ; SET INVERTED ENTRY 194 Q 195 ; 196 DEMUX(OUTX,INX) ;PARSES XPATH PASSED BY VALUE IN INX TO REMOVE [x] MULTIPLES 197 ; RETURNS OUTX: MULTIPLE^SUBMULTIPLE^XPATH 198 N ZX,ZY,ZZ,ZZ1,ZMULT,ZSUB 199 S (ZMULT,ZSUB)="" 200 S ZX=$P(INX,"[",2) 201 I ZX'="" D ; THERE IS A [x] MULTIPLE 202 . S ZY=$P(INX,"[",1) ;FIRST PART OF XPATH 203 . S ZMULT=$P(ZX,"]",1) ; NUMBER OF THE MULTIPLE 204 . S ZX=ZY_$P(ZX,"]",2) ; REST OF THE XPATH 205 . I $P(ZX,"[",2)'="" D ; A SUB MULTIPLE EXISTS 206 . . S ZZ=$P(ZX,"[",1) ; FIRST PART OF XPATH 207 . . S ZX=$P(ZX,"[",2) ; DELETE THE [ 208 . . S ZSUB=$P(ZX,"]",1) ; NUMBER OF THE SUBMULTIPLE 209 . . S ZX=ZZ_$P(ZX,"]",2) ; REST OF THE XPATH 210 E S ZX=INX ;NO MULTIPLE HERE 211 S @OUTX=ZMULT_"^"_ZSUB_"^"_ZX ;RETURN MULTIPLE^SUBMULTIPLE^XPATH 212 Q 213 ; 214 DEMUXARY(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO 215 ; FORMAT @OARY@(x,variablename) where x is the first multiple 216 ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED 217 N ZI,ZJ,ZK,ZL,ZM S ZI="" 218 F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; 219 . D DEMUX^C0CMXP("ZJ",ZI) 220 . S ZK=$P(ZJ,"^",3) 221 . S ZM=$RE($P($RE(ZK),"/",1)) 222 . I $G(DEPTH)=2 D ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME 223 . . S ZM=$RE($P($RE(ZK),"/",2))_ZM 224 . S ZL=$P(ZJ,"^",1) 225 . I ZL="" S ZL=1 226 . I $D(@OARY@(ZL,ZM)) D ;IT'S A DUP 227 . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI) 228 . E S @OARY@(ZL,ZM)=@IARY@(ZI) 229 Q 230 ; 231 DEMUX2(OARY,IARY,DEPTH) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO 232 ; FORMAT @OARY@(x,variablename) where x is the first multiple 233 ; IF DEPTH=2, THE LAST 2 PARTS OF THE XPATH WILL BE USED 234 N ZI,ZJ,ZK,ZL,ZM S ZI="" 235 F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; 236 . D DEMUX^C0CMXP("ZJ",ZI) 237 . S ZK=$P(ZJ,"^",3) 238 . S ZM=$RE($P($RE(ZK),"/",1)) 239 . I $G(DEPTH)=2 D ;LAST TWO PARTS OF XPATH USED FOR THE VARIABLE NAME 240 . . S ZM=$RE($P($RE(ZK),"/",2))_"."_ZM 241 . S ZL=$P(ZJ,"^",1) 242 . I ZL="" S ZL=1 243 . I $D(@OARY@(ZL,ZM)) D ;IT'S A DUP 244 . . S @OARY@(ZL,ZM_"[2]")=@IARY@(ZI) 245 . E S @OARY@(ZL,ZM)=@IARY@(ZI) 246 Q 247 ; 248 DEMUXXP1(OARY,IARY) ;IARY IS INCOMING XPATH ARRAY 249 ; BOTH IARY AND OARY ARE PASSED BY NAME 250 ; RETURNS A SIMPLE XPATH ARRAY WITHOUT MULTIPLES. DUPLICATES ARE REMOVED 251 N ZI,ZJ,ZK 252 S ZI="" 253 F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH XPATH IN IARY 254 . D DEMUX^C0CMXP("ZJ",ZI) 255 . S ZK=$P(ZJ,"^",3) ;THE XPATH 256 . S @OARY@(ZK)=@IARY@(ZI) ;THE RESULT. DUPLICATES WILL NOT SHOW 257 . ; CAUTION, IF THERE ARE MULTIPLES, ONLY THE DATA FOR THE LAST 258 . ; MULTIPLE WILL BE INCLUDED IN THE OUTPUT ARRAY, ASSIGNED TO THE 259 . ; COMMON XPATH 260 Q 261 ; 262 DEMUXXP2(OARY,IARY) ; IARY AND OARY ARE PASSED BY NAME 263 ; IARY IS AN XPATH ARRAY THAT MAY CONTAIN MULTIPLES 264 ; OARY IS THE OUTPUT ARRAY WHERE MULTIPLES ARE RETURNED IN THE FORM 265 ; @OARY@(x,Xpath)=data or @OARY@(x,y,Xpath)=data WHERE x AND y ARE 266 ; THE MULTIPLES AND Xpath IS THE BASE XPATH WITHOUT [x] AND [y] 267 ; 268 N ZI,ZJ,ZK,ZX,ZY,ZP 269 S ZI="" 270 F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH INPUT XPATH 271 . D DEMUX("ZJ",ZI) ; PULL OUT THE MULTIPLES 272 . S ZX=$P(ZJ,"^",1) ;x 273 . S ZY=$P(ZJ,"^",2) ;y 274 . S ZP=$P(ZJ,"^",3) ;Xpath 275 . I ZX="" S ZX=1 ; NO MULTIPLE WILL STORE IN x=1 276 . I ZY'="" D ;IS THERE A y? 277 . . S @OARY@(ZX,ZY,ZP)=@IARY@(ZI) 278 . E D ;NO y 279 . . S @OARY@(ZX,ZP)=@IARY@(ZI) 280 Q 281 ; 282 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 283 K ZERR 284 D CLEAN^DILF 285 D UPDATE^DIE("","C0CFDA","","ZERR") 286 I $D(ZERR) D ; 287 . W "ERROR",! 288 . ZWR ZERR 289 . B 290 K C0CFDA 291 Q 292 ; -
ccr/branches/ohum/p/C0CNHIN.m
r1342 r1428 1 C0CNHIN 2 ;;0.1;C0C;nopatch;noreleasedate;Build 2 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 148 DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) 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 207 PARSE(INXML,INDOC) 208 209 210 211 212 213 ISMULT(ZOID) 214 215 216 217 218 219 220 FIRST(ZOID) 221 222 223 PARENT(ZOID) 224 225 226 ATT(RTN,NODE) 227 228 229 230 231 232 TAG(ZOID) 233 234 235 236 237 238 239 240 241 NXTSIB(ZOID) 242 243 244 DATA(ZT,ZOID) 245 246 247 248 249 250 251 OUTXML(ZRTN,INID) 252 253 254 255 256 257 258 259 260 261 NDOUT(ZOID) 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 1 C0CNHIN ; GPL - PROCESSING FOR OUTPUT OF NHINV ROUTINES;6/3/11 17:05 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE 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 PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME 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 ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE 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 FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID 221 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) 222 ; 223 PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID 224 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) 225 ; 226 ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID 227 S HANDLE=C0CDOCID 228 K @RTN 229 D GETTXT^MXMLDOM("A") 230 Q 231 ; 232 TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE 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 NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING 242 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) 243 ; 244 DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE 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 OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM 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 NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE 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
r1342 r1428 1 C0C MED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 20092 ;;1.0;C0C;;May 19, 2009;Build 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 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 1 C0CNMED2 ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 ; 5/10/12 2:53pm 2 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0C MED4 ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/082 ;;0.1;CCDCCR;;;Build 2 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 C0CNMED4 ; WV/CCDCCR/SMH/gpl - CCR/CCD PROCESSING FOR MEDICATIONS - Inpatient Meds/Unit Dose ;10/13/08 ; 5/10/12 2:54pm 2 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CORSLT 2 ;;1.0;C0C;;Jan 21, 2010;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 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 1 C0CORSLT ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;Copyright 2011 George Lilly. 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 W "NO ENTRY FROM TOP",! 22 Q 23 ; 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
r1342 r1428 1 C0CPARMS 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 SET(INPARMS) 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 58 59 60 61 62 63 64 65 66 67 68 69 70 71 CHECK 72 73 74 75 76 77 GET(WHICHP) 78 79 80 81 82 1 C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 SET(INPARMS) ;INITIALIZE RUNTIME PARMS USING INPARMS TO OVERRIDE DEFAULTS 21 ; PARAMETERS ARE PASSED AS A STRING: "PARM1:VALUE1^PARM2:VALUE2^ETC" 22 ; THE SAME FORMAT IS USED BY RPC AND COMMAND LINE ENTRY POINTS 23 ; 24 N PTMP ; 25 S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;BASE FOR THIS RUN 26 K @C0CPARMS ;START WITH EMPTY PARMS; MAY NOT WANT TO DO THIS KILL 27 I $G(INPARMS)'="" D ; OVERRIDES PROVIDED 28 . N C0CI S C0CI="" 29 . N C0CN S C0CN=1 30 . F S C0CI=$P(INPARMS,"^",C0CN) Q:C0CI="" D ; 31 . . S C0CN=C0CN+1 ;NEXT PARM 32 . . N C1,C2 33 . . S C1=$P(C0CI,":",1) ; PARAMETER 34 . . S C2=$P(C0CI,":",2) ; VALUE 35 . . I C2="" S C2=1 36 . . S @C0CPARMS@(C1)=C2 37 . I C0CN=1 S @C0CPARMS@($P(INPARMS,":",1))=$P(C0CI,":",2) ; ONLY ONE 38 ; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS 39 ; IF THEY FAIL, THE FOLLOWING WILL BE HARDCODED DEFAULTS 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 ;OHUM/RUT 3120109 ; commented all limits 51 ;S @C0CPARMS@("LABLIMIT")=^TMP("C0CCCR","LABLIMIT"),@C0CPARMS@("VITLIMIT")=^TMP("C0CCCR","VITLIMIT"),@C0CPARMS@("TIULIMIT")=^TMP("C0CCCR","TIULIMIT"),@C0CPARMS@("MEDLIMIT")=^TMP("C0CCCR","MEDLIMIT") 52 ;I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY 53 ;I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY 54 ;I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY 55 ;I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES 56 ;I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO 57 ;I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=1 ; NON-PENDING NON-ACTIVE 58 ;;I '$D(@C0CPARMS@("RALIMIT")) S @C0CPARMS@("RALIMIT")="T-36500" ;ONE YR WORTH 59 ;;I '$D(@C0CPARMS@("RASTART")) S @C0CPARMS@("RASTART")="T" ;TODAY 60 ;I '$D(@C0CPARMS@("TIUSTART")) S @C0CPARMS@("TIUSTART")="T" ;TODAY 61 ;;OHUM/RUT 62 S @C0CPARMS@("LABLIMIT")=$P(^C0CPARM(1,0),"^",2),@C0CPARMS@("LABSTART")=$P(^C0CPARM(1,0),"^",3),@C0CPARMS@("VITLIMIT")=$P(^C0CPARM(1,0),"^",4),@C0CPARMS@("VITSTART")=$P(^C0CPARM(1,1),"^",1),@C0CPARMS@("MEDLIMIT")=$P(^C0CPARM(1,1),"^",2),@C0CPARMS@("MEDSTART")=$P(^C0CPARM(1,1),"^",3) 63 I $P(^C0CPARM(1,1),"^",4)="ACT" S @C0CPARMS@("MEDACTIVE")=1 64 I $P(^C0CPARM(1,1),"^",4)="PEN" S @C0CPARMS@("MEDPENDING")=1 65 I $P(^C0CPARM(1,1),"^",4)="ALL" S @C0CPARMS@("MEDALL")=1 66 ;S ^TMP("C0CCCR","TIULIMIT")="",^TMP("C0CCCR","TIUSTART")="" 67 I $P(^C0CPARM(1,2),"^",3)=1 S @C0CPARMS@("TIULIMIT")=$P(^C0CPARM(1,2),"^",1),@C0CPARMS@("TIUSTART")=$P(^C0CPARM(1,2),"^",2) 68 ;OHUM/RUT 69 Q 70 ; 71 CHECK ; CHECK TO SEE IF PARMS ARE PRESENT, ELSE RUN SET 72 ; 73 I '$D(C0CPARMS) S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;SHOULDN'T HAPPEN 74 I '$D(@C0CPARMS) D SET("SETWITHCHECK:1") 75 Q 76 ; 77 GET(WHICHP) ;EXTRINSIC TO RETURN THE VALUE OF PARAMETER WHICHP 78 ; 79 D CHECK ; SHOULDN'T HAPPEN BUT TO BE SAFE 80 N GTMP 81 Q $G(@C0CPARMS@(WHICHP)) ;PULL THE PARM FROM THE TABLE 82 ; -
ccr/branches/ohum/p/C0CPROBS.m
r1342 r1428 1 C0CPROBS 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(IPXML,DFN,OUTXML) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 RPMS 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 VISTA 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 CCD 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 MISSINGVARS 178 179 180 181 182 183 184 185 1 C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 ; 22 ; PROCESS THE PROBLEMS SECTION OF THE CCR 23 ; 24 EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT PROBLEMS INTO PROVIDED XML TEMPLATE 25 ; 26 ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED 27 ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE 28 ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE 29 ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS 30 ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT 31 ; 32 N RPCRSLT,J,K,PTMP,X,VMAP,TBU 33 S TVMAP=$NA(^TMP("C0CCCR",$J,"PROBVALS")) 34 S TARYTMP=$NA(^TMP("C0CCCR",$J,"PROBARYTMP")) 35 K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES 36 I $$RPMS^C0CUTIL() D RPMS ; IF BGOPRB ROUTINE IS MISSING (IE RPMS) 37 I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT 38 Q 39 ; 40 RPMS ; GETS THE PROBLEM LIST FOR RPMS 41 S RPCGLO=$NA(^TMP("BGO",$J)) 42 D GET^BGOPROB(.RPCRSLT,DFN) ; CALL THE PROBLEM LIST RPC 43 ; FORMAT OF RPC: 44 ; Number Code [1] ^ Patient IEN [2] ^ ICD Code [3] ^ Modify Date [4] ^ Class [5] ^ Provider Narrative [6] ^ 45 ; Date Entered [7] ^ Status [8] ^ Date Onset [9] ^ Problem IEN [10] ^ Notes [11] ^ ICD9 IEN [12] ^ 46 ; ICD9 Short Name [13] ^ Provider [14] ^ Facility IEN [15] ^ Priority [16] 47 I '$D(@RPCGLO) W "NULL RESULT FROM GET^BGOPROB ",! S @OUTXML@(0)=0 Q 48 S J="" 49 F S J=$O(@RPCGLO@(J)) Q:J="" D ; FOR EACH PROBLEM IN THE LIST 50 . S VMAP=$NA(@TVMAP@(J)) 51 . K @VMAP 52 . I DEBUG W "VMAP= ",VMAP,! 53 . S PTMP=@RPCRSLT@(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY 54 . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL 55 . D GETN1^C0CRNF("C0CG1",9000011,$P(PTMP,U,10),"") ;GET VALUES BY NAME 56 . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM 57 . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,10) 58 . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,8)="A":"Active",$P(PTMP,U,8)="I":"Inactive",1:"") 59 . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,6) 60 . S @VMAP@("PROBLEMCODINGVERSION")="" 61 . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,3) 62 . ; FOR CERTIFICATION - GPL 63 . I @VMAP@("PROBLEMCODEVALUE")=493.90 S @VMAP@("PROBLEMCODEVALUE")=493 64 . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT") 65 . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT") 66 . ;S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) ;UNKNOWN NOT MAPPED IN C0CCCR0 67 . ;S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) ;UNKNOWN NOT MAPPED IN C0CCCR0 68 . ;S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) ;NOT MAPPED IN C0CCCR0 69 . ;S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) ;NOT MAPPED IN C0CCCR0 70 . ;S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) ;NOT MAPPED IN C0CCCR0 71 . ;S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) ;NOT MAPPED IN C0CCCR0 72 . ;S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER 73 . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$$ZVALUEI^C0CRNF("RECORDING PROVIDER","C0CG1") 74 . ;S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) ;NOT MAPPED IN C0CCCR0 75 . ;S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) ;NOT MAPPED IN C0CCCR0 76 . ;S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") ;NOT MAPPED IN C0CCCR0 77 . ;S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") ;NOT MAPPED IN C0CCCR0 78 . S ARYTMP=$NA(@TARYTMP@(J)) 79 . ; W "ARYTMP= ",ARYTMP,! 80 . K @ARYTMP 81 . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ; 82 . I J=1 D ; FIRST ONE IS JUST A COPY 83 . . ; W "FIRST ONE",! 84 . . D CP^C0CXPATH(ARYTMP,OUTXML) 85 . . ; W "OUTXML ",OUTXML,! 86 . I J>1 D ; AFTER THE FIRST, INSERT INNER XML 87 . . D INSINNER^C0CXPATH(OUTXML,ARYTMP) 88 ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*) 89 ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS 90 ; ZWR @OUTXML 91 ; $$HTML^DILF( 92 ; GENERATE THE NARITIVE HTML FOR THE CCD 93 I CCD D CCD ; IF THIS IS FOR A CCD 94 D MISSINGVARS 95 Q 96 ; 97 VISTA ; GETS THE PROBLEM LIST FOR VISTA 98 D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC 99 I '$D(RPCRSLT(1)) D Q ; RPC RETURNS NULL 100 . W "NULL RESULT FROM LIST^ORQQPL3 ",! 101 . S @OUTXML@(0)=0 102 . ; Q 103 ; I DEBUG ZWR RPCRSLT 104 S @TVMAP@(0)=RPCRSLT(0) ; SAVE NUMBER OF PROBLEMS 105 F J=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM IN THE LIST 106 . S VMAP=$NA(@TVMAP@(J)) 107 . K @VMAP 108 . I DEBUG W "VMAP= ",VMAP,! 109 . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY 110 . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM 111 . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1) 112 . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"") 113 . N ZPRIOR S ZPRIOR=$P(PTMP,U,14) ;PRIORITY FLAG 114 . ; turn off acute/chronic for certification gpl 115 . ;S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status 116 . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3) 117 . S @VMAP@("PROBLEMCODINGVERSION")="" 118 . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4) 119 . ; FOR CERTIFICATION - GPL 120 . I @VMAP@("PROBLEMCODEVALUE")["493.90" S @VMAP@("PROBLEMCODEVALUE")=493 121 . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT") 122 . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT") 123 . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) 124 . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) 125 . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) 126 . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) 127 . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) 128 . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) 129 . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER 130 . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1) 131 . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) 132 . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) 133 . S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") 134 . S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") 135 . S ARYTMP=$NA(@TARYTMP@(J)) 136 . ; W "ARYTMP= ",ARYTMP,! 137 . K @ARYTMP 138 . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ; 139 . I J=1 D ; FIRST ONE IS JUST A COPY 140 . . ; W "FIRST ONE",! 141 . . D CP^C0CXPATH(ARYTMP,OUTXML) 142 . . ; W "OUTXML ",OUTXML,! 143 . I J>1 D ; AFTER THE FIRST, INSERT INNER XML 144 . . D INSINNER^C0CXPATH(OUTXML,ARYTMP) 145 ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*) 146 ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS 147 ; ZWR @OUTXML 148 ; $$HTML^DILF( 149 ; GENERATE THE NARITIVE HTML FOR THE CCD 150 I CCD D CCD ; IF THIS IS FOR A CCD 151 D MISSINGVARS 152 Q 153 CCD 154 N HTMP,HOUT,HTMLO,C0CPROBI,ZX 155 F C0CPROBI=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM 156 . S VMAP=$NA(@TVMAP@(C0CPROBI)) 157 . I DEBUG W "VMAP =",VMAP,! 158 . D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Body/PROBLEMS-HTML","HTMP") ; GET THE HTML FROM THE TEMPLATE 159 . D UNMARK^C0CXPATH("HTMP") ; REMOVE <PROBLEMS-HTML> MARKUP 160 . ; D PARY^C0CXPATH("HTMP") ; PRINT IT 161 . D MAP^C0CXPATH("HTMP",VMAP,"HOUT") ; MAP THE VARIABLES 162 . ; D PARY^C0CXPATH("HOUT") ; PRINT IT AGAIN 163 . I C0CPROBI=1 D ; FIRST ONE IS JUST A COPY 164 . . D CP^C0CXPATH("HOUT","HTMLO") 165 . I C0CPROBI>1 D ; AFTER THE FIRST, INSERT INNER HTML 166 . . I DEBUG W "DOING INNER",! 167 . . N HTMLBLD,HTMLTMP 168 . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",1,HTMLO(0)-1) 169 . . D QUEUE^C0CXPATH("HTMLBLD","HOUT",2,HOUT(0)-1) 170 . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",HTMLO(0),HTMLO(0)) 171 . . D BUILD^C0CXPATH("HTMLBLD","HTMLTMP") 172 . . D CP^C0CXPATH("HTMLTMP","HTMLO") 173 . . ; D INSINNER^C0CXPATH("HOUT","HTMLO","//") 174 I DEBUG D PARY^C0CXPATH("HTMLO") 175 D INSB4^C0CXPATH(OUTXML,"HTMLO") ; INSERT AT TOP OF SECTION 176 Q 177 MISSINGVARS 178 N PROBSTMP,I 179 D MISSING^C0CXPATH(ARYTMP,"PROBSTMP") ; SEARCH XML FOR MISSING VARS 180 I PROBSTMP(0)>0 D ; IF THERE ARE MISSING VARS - 181 . ; STRINGS MARKED AS @@X@@ 182 . W !,"PROBLEMS Missing list: ",! 183 . F I=1:1:PROBSTMP(0) W PROBSTMP(I),! 184 Q 185 ; -
ccr/branches/ohum/p/C0CPROC.m
r1342 r1428 1 C0CPROC 2 ;;1.0;C0C;;Jan 21, 2010;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 SETVARS 25 26 27 28 29 30 31 32 EXTRACT(PROCXML,DFN,PROCOUT) 33 34 35 36 37 38 39 40 TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) 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 PRV(IARY) 101 102 103 104 105 106 107 108 DATE(ISTR) 109 110 111 CPT(ISTR) 112 113 114 115 116 117 118 119 120 121 122 123 124 125 MAP(PROCXML,C0CPRC,PROCOUT) 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 1 C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;Copyright 2010 George Lilly, University of Minnesota and others. 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 W "NO ENTRY FROM TOP",! 22 Q 23 ; 24 SETVARS ; SET UP VARIABLES FOR PROCEDURES, ENCOUNTERS, AND NOTES 25 S C0CENC=$NA(^TMP("C0CCCR",$J,"C0CENC",DFN)) 26 S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN)) 27 S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN)) 28 ; ADDITION FOR CERTIFICATION 29 S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN)) 30 Q 31 ; 32 EXTRACT(PROCXML,DFN,PROCOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE 33 ; PROCXML AND PROCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED 34 ; 35 D SETVARS ; SET UP VARIABLES 36 I '$D(@C0CPRC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE 37 D MAP(PROCXML,C0CPRC,PROCOUT) ;MAP RESULTS FOR PROCEDURES 38 Q 39 ; 40 TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, 41 ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME 42 ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES 43 ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT 44 ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 45 ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM 46 ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS 47 ; 48 K VISIT,LST,NOTE,C0CLPRC 49 ; C0CLPRC IS A LOOKUP TABLE FOR USE IN BUILDING ENCOUNTERS 50 ; FORMAT C0CLPRC(VISITIEN,CPT)=PROCOBJECTID FOR BUILDING LINKS TO PROCEDURES 51 D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE 52 ; NEED TO ADD START AND END DATES FROM PARAMETERS 53 N ZI S ZI="" 54 N PREVCPT,PREVDT S (PREVCPT,PREVDT)="" 55 F S ZI=$O(VISIT(ZI),-1) Q:ZI="" D ; REVERSE TIME ORDER - MOST RECENT FIRST 56 . N ZDATE 57 . S ZDATE=$$DATE(VISIT(ZI,"DATE",0)) 58 . S ZPRVARY=$NA(VISIT(ZI,"PRV")) 59 . N ZPRV 60 . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM 61 . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON 62 . N ZJ S ZJ="" 63 . F S ZJ=$O(VISIT(ZI,"CPT",ZJ)) Q:ZJ="" D ;FOR EACH CPT SEG 64 . . N ZRNF 65 . . N ZCPT S ZCPT=$$CPT(VISIT(ZI,"CPT",ZJ)) ;GET CPT CODE AND TEXT 66 . . I ZCPT'="" D ;IF CPT CODE IS PRESENT 67 . . . I (ZCPT=PREVCPT)&(ZDATE=PREVDT) Q ; NO DUPS ALLOWED 68 . . . W !,ZCPT," ",ZDATE," ",ZPRV 69 . . . S ZRNF("PROCACTOROBJID")=ZPRV 70 . . . N PROCCODE S PROCCODE=$P(ZCPT,U,1) 71 . . . S ZRNF("PROCCODE")=PROCCODE 72 . . . S ZRNF("PROCCODESYS")="CPT-4" 73 . . . S ZRNF("PROCDATETEXT")="Procedure Date" 74 . . . S ZRNF("PROCDATETIME")=ZDATE 75 . . . S ZRNF("PROCDESCOBJATTRCODE")="" ;NO PROC ATTRIBUTES YET 76 . . . S ZRNF("PROCDESCOBJATTR")="" 77 . . . S ZRNF("PROCDESCOBJATTRCODESYS")="" ;WE DON'T HAVE PROC ATTRIBUTES 78 . . . S ZRNF("PROCDESCOBJATTRVAL")="" 79 . . . S ZRNF("PROCDESCTEXT")=$P(ZCPT,U,3) 80 . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET 81 . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET 82 . . . ; additions for Certification - need to have EKG in Results 83 . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT 84 . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ 85 . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS 86 . . . S ZRNF("PROCSTATUS")="Completed" ; Is this right? 87 . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE 88 . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY 89 . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl 90 . . . W !,"CPT=",ZCPT 91 . . . I ZCPT["93000" D ; THIS IS AN EKG 92 . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS 93 . . . . M ^GPL("RNF2")=@C0CPRSLT 94 . . . S PREVCPT=ZCPT 95 . . . S PREVDT=ZDATE 96 N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"PROCEDURES")) 97 M @ZRIM=@C0CPRC@("V") 98 Q 99 ; 100 PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME 101 N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN="" 102 F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH PRV SEG 103 . I ZR'="" Q ;ONLY WANT THE FIRST PRIMARY PROVIDER 104 . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1) 105 I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR 106 Q ZRTN 107 ; 108 DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT 109 Q $$FMDTOUTC^C0CUTIL(ISTR,"DT") 110 ; 111 CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS 112 ; CPT^CATEGORY^TEXT 113 N Z1,Z2,Z3,ZRTN 114 S Z1=$P(ISTR,U,1) 115 I Z1="" D ; 116 . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1) 117 I Z1'="" D ; IF THERE IS A CPT CODE IN THERE 118 . ;S Z1=$P(ISTR,U,1) 119 . S Z2=$P(ISTR,U,2) 120 . S Z3=$P(ISTR,U,3) 121 . S ZRTN=Z1_U_Z2_U_Z3 122 E S ZRTN="" 123 Q ZRTN 124 ; 125 MAP(PROCXML,C0CPRC,PROCOUT) ; MAP PROCEDURES XML 126 ; 127 N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"PROCTEMP")) ;WORK AREA FOR TEMPLATE 128 K @ZTEMP 129 N ZBLD 130 S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"PROCBLD")) ; BUILD LIST AREA 131 D QUEUE^C0CXPATH(ZBLD,PROCXML,1,1) ; FIRST LINE 132 N ZINNER 133 D QUERY^C0CXPATH(PROCXML,"//Procedures/Procedure","ZINNER") ;ONE PROC 134 N ZTMP,ZVAR,ZI 135 S ZI="" 136 F S ZI=$O(@C0CPRC@("V",ZI)) Q:ZI="" D ;FOR EACH PROCEDURE 137 . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS PROCEDURE XML 138 . S ZVAR=$NA(@C0CPRC@("V",ZI)) ;THIS PROCEDURE VARIABLES 139 . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE 140 . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD 141 D QUEUE^C0CXPATH(ZBLD,PROCXML,@PROCXML@(0),@PROCXML@(0)) 142 N ZZTMP 143 D BUILD^C0CXPATH(ZBLD,PROCOUT) ;BUILD FINAL XML 144 K @ZTEMP,@ZBLD,@C0CPRC 145 Q 146 ; -
ccr/branches/ohum/p/C0CPXRM.m
r1338 r1428 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 ; 1 C0CPXRM ; 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 ; -
ccr/branches/ohum/p/C0CQRY1.m
r1342 r1428 1 LA7QRY1 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 2 3 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 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 LA7QRY2 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46**;Sep 27, 1994;Build 2 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 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CRIMA 2 ;;1.0;C0C;;May 19, 2009;Build 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 32 33 34 35 36 37 38 39 ANALYZE(BEGDFN,DFNCNT,APARMS) 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 SETATTR(SDFN) 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 RESET 155 156 157 158 159 CLIST 160 161 162 163 164 165 166 167 168 169 170 171 172 173 CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) 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 CHKSUM(CKDFN) 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 CCOUNT 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 CNTLST(INLST) 257 258 259 260 261 262 263 264 265 266 267 268 XCPAT(CPATCAT,CPATPARM) 269 270 271 272 273 274 275 276 277 278 279 280 CPAT(CPATCAT) 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 PATC(DFN) 297 298 299 300 301 302 303 304 305 306 307 308 309 APUSH(AMAP,AVAL) 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 ASETUP 325 326 327 328 329 330 331 AINIT 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 APOST(PRSLT,PTBL,PVAL) 366 367 368 369 370 371 372 373 374 375 376 GETPA(RTN,DFN,ISEC,IVAR) 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 PATD(DFN,ISEC,IVAR) 400 401 402 403 404 405 406 407 CAGET(RTN,IATTR) 408 409 410 411 412 413 PCLST(LSTRTN,IATTR) 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 DCPAT(CATTR) 439 440 441 442 443 444 445 446 447 448 449 450 451 452 RPCGV(RTN,DFN,WHICH) 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 ZGVWRK(ZWHICH) 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 DPATV(DFN,IWHICH) 490 491 492 493 494 495 496 497 498 499 500 RIM2RNF(R2RTN,DFN,RWHICH) 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 RIM2CSV(DFN) 527 528 529 530 531 532 533 1 C0CRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 EXAMINE ONE OR MORE, UP TO ALL, OF THE PATIENTS ON THE 22 ; SYSTEM TO DETERMINE HOW COMPLETE THE RESULTING CCR OR CCD WOULD BE FOR 23 ; THESE PATIENTS. IT BEGINS TO MEASURE "HL7 RIM COHERENCE" WHICH IS HOW USEFUL 24 ; THE VARIABLES WILL BE TO A RIM-MODELED APPLICATION AFTER THEY ARE 25 ; CONVEYED VIA THE CCR OR CCD. 26 ; FACTORS THAT AFFECT RIM COHERENCE INCLUDE: 27 ; 1. THE PRESENSE OF CLINICAL DATA IN A SECTION 28 ; 2. ARE THE DATA ELEMENTS TIME-BOUND 29 ; 3. ARE THE DATA ELEMENTS CODED WITH SNOMED OR LOINC ETC 30 ; 4. ARE SOURCE ACTORS ASSOCIATED WITH THE DATA ELEMENTS 31 ; 5. ARE ACTORS IDENTIFIED REGARDING THEIR ROLE 32 ; .. AND OTHER FACTORS YET TO BE DETERMINED 33 ; 34 ; SINCE THESE MEASUREMENTS ARE DONE AT THE VARIABLE LEVEL, THEY 35 ; REFLECT ON RIM COHERENCE WHETHER THE CCR OR THE CCD IS USED FOR 36 ; CONVEYANCE TO THE RIM APPLICATION. 37 ; 38 ; 39 ANALYZE(BEGDFN,DFNCNT,APARMS) ; RIM COHERANCE ANALYSIS ROUTINE 40 ; BEGINS AT BEGDFN AND GOES FOR DFNCNT PATIENTS 41 ; TO RESUME AT NEXT PATIENT, USE BEGDFN="" 42 ; USE RESET^C0CRIMA TO RESET TO TOP OF PATIENT LIST 43 ; APARMS ARE PARAMETERS TO BE USED IN THE EXTRACTION 44 ; SEE C0CPARMS FOR SUPPORTED PARAMTERS 45 ; 46 N RIMARY,RIMTMP,RIMI,RIMDFN,RATTR 47 N CCRGLO 48 S C0CCHK=0 ; CHECKSUM FLAG 49 D ASETUP ; SET UP VARIABLES AND GLOBALS 50 D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE 51 I '$D(@RIMBASE@("RESUME")) S @RIMBASE@("RESUME")=$O(^DPT(0)) ; FIRST TIME 52 S RESUME=@RIMBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN 53 S RIMDFN=BEGDFN ; BEGIN WITH THE BEGDFN PATIENT 54 I RIMDFN="" S RIMDFN=RESUME 55 I +RIMDFN=0 D Q ; AT THE END OF THE PATIENTS 56 . W "END OF PATIENT LIST, CALL RESET^C0CRIMA",! 57 I '$D(APARMS) S APARMS="" ; DEFAULT NO OVERRIDE PARMS 58 F RIMI=1:1:DFNCNT D Q:+RIMDFN=0 ; FOR DFNCNT NUMBER OF PATIENTS OR END 59 . K @RIMBASE@("VARS",RIMDFN) ; CLEAR OUT OLD VARS 60 . D CCRRPC^C0CCCR(.CCRGLO,RIMDFN,APARMS,"CCR") ;PROCESS THE CCR 61 . W RIMDFN,! 62 . ; 63 . ; COPY ALL THE VARIABLES TO THE RIM MAP AREA INDEXED BY PATIENT 64 . ; 65 . I $D(^TMP("C0CCCR",$J,"PROBVALS",1)) D ; PROBLEM VARS EXISTS 66 . . M @RIMBASE@("VARS",RIMDFN,"PROBLEMS")=^TMP("C0CCCR",$J,"PROBVALS") 67 . . S @RIMBASE@("VARS",RIMDFN,"PROBLEMS",0)=$O(^TMP("C0CCCR",$J,"PROBVALS",""),-1) 68 . I $D(^TMP("C0CCCR",$J,"VITALS",1)) D ; VITALS VARS EXISTS 69 . . M @RIMBASE@("VARS",RIMDFN,"VITALS")=^TMP("C0CCCR",$J,"VITALS") 70 . I $D(^TMP("C0CCCR",$J,"MEDMAP",1)) D ; MEDS VARS EXISTS 71 . . M @RIMBASE@("VARS",RIMDFN,"MEDS")=^TMP("C0CCCR",$J,"MEDMAP") 72 . I $D(^TMP("C0CCCR",$J,"ALERTS",1,"ALERTOBJECTID")) D ; ALERTS EXIST 73 . . W "FOUND ALERT VARS",! 74 . . M @RIMBASE@("VARS",RIMDFN,"ALERTS")=^TMP("C0CCCR",$J,"ALERTS") 75 . I $D(^TMP("C0CCCR",$J,"RESULTS",0)) D ; RESULTS EXIST 76 . . W "FOUND RESULTS VARS",! 77 . . M @RIMBASE@("VARS",RIMDFN,"RESULTS")=^TMP("C0CCCR",$J,"RESULTS") 78 . S C0CCHK=0 79 . I $$CHKSUM(RIMDFN) D ; CHECKSUM HAS CHANGED 80 . . W "CHECKSUM IS NEW OR HAS CHANGED",! 81 . . ;ZWR ^TMP("C0CRIM","CHKSUM",RIMDFN,*) 82 . . S C0CCHK=1 83 . K ^TMP("C0CCCR",$J) ; KILL WORK AREA FOR CCR BUILDING 84 . ; 85 . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP 86 . ; 87 . S RATTR=$$SETATTR(RIMDFN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS 88 . S @RIMBASE@("ATTR",RIMDFN)=RATTR ; SAVE THE ATRIBUTES FOR THIS PAT 89 . ; 90 . ; INCREMENT THE COUNT OF PATIENTS WITH THESE ATTRIBUTES IN ATTRTBL 91 . ; 92 . ; I '$D(@RIMBASE@("ATTRTBL",RATTR)) D ; IF FIRST PAT WITH THESE ATTRS 93 . ; . S @RIMBASE@("ATTRTBL",RATTR)=0 ; DEFAULT VALUE TO BE INCREMENTED 94 . ; S @RIMBASE@("ATTRTBL",RATTR)=@RIMBASE@("ATTRTBL",RATTR)+1 ; INCREMENT 95 . ; 96 . N CATNAME,CATTBL 97 . ; S CATBASE=$NA(@RIMBASE@("ANALYSIS")) 98 . S CATNAME="" 99 . D CPUSH(.CATNAME,RIMBASE,"RIMTBL",RIMDFN,RATTR) ; ADD TO CATEGORY 100 . W "CATEGORY NAME: ",CATNAME,! 101 . ; 102 . F S RIMDFN=$O(^DPT(RIMDFN)) Q:'$$PTST^C0CSYS(RIMDFN) ; NEXT PATIENT 103 . ; PTST TESTS TO SEE IF PATIENT WAS MERGED 104 . ; IF CCRTEST=0, PTST WILL CHECK TO SEE IF THIS IS A TEST PATIENT 105 . ; AND WE SKIP IT 106 . S @RIMBASE@("RESUME")=RIMDFN ; WHERE WE ARE LEAVING OFF THIS RUN 107 ; D PARY^C0CXPATH(@RIMBASE@("ATTRTBL")) 108 Q 109 ; 110 SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS 111 N SBASE,SATTR 112 S SBASE=$NA(@RIMBASE@("VARS",SDFN)) 113 D APOST("SATTR","RIMTBL","HEADER") 114 I $D(@SBASE@("PROBLEMS",1)) D ; 115 . D APOST("SATTR","RIMTBL","PROBLEMS") 116 . ; W "POSTING PROBLEMS",! 117 I $D(@SBASE@("VITALS",1)) D APOST("SATTR","RIMTBL","VITALS") 118 I $D(@SBASE@("IMMUNE",1)) D ;IMMUNIZATIONS PRESENT 119 . D APOST("SATTR","RIMTBL","IMMUNE") 120 . N ZR,ZI 121 . D GETPA(.ZR,SDFN,"IMMUNE","IMMUNEPRODUCTCODE") 122 . I ZR(0)>0 D APOST("SATTR","RIMTBL","IMMUNECODE") ;IMMUNIZATION CODES 123 I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES 124 . D APOST("SATTR","RIMTBL","MEDS") 125 . N ZR,ZI 126 . D GETPA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES 127 . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN 128 . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS 129 . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","MEDSCODE") ;CODES 130 . ; D PATD^C0CRIMA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES 131 I $D(@SBASE@("ALERTS",1)) D ; IF THE PATIENT HAS ALERTS 132 . D APOST("SATTR","RIMTBL","ALERTS") 133 . N ZR,ZI 134 . D GETPA(.ZR,SDFN,"ALERTS","ALERTAGENTPRODUCTCODEVALUE") ;REACTANT CODES 135 . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN 136 . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS 137 . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","ALERTSCODE") ;CODES 138 I $D(@SBASE@("RESULTS",1)) D ; IF THE PATIENT HAS LABS VARIABLES 139 . D APOST("SATTR","RIMTBL","RESULTS") 140 . N ZR,ZI 141 . S ZR(0)=0 ; INITIALIZE TO NONE 142 . D RPCGV(.ZR,SDFN,"RESULTS") ;CHECK FOR LABS CODES 143 . ; D PARY^C0CXPATH("ZR") ; 144 . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN 145 . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS 146 . . . I $P(ZR(ZI),"^",2)="RESULTTESTCODINGSYSTEM" D ; LOINC CODE CHECK 147 . . . . I $P(ZR(ZI),"^",3)="LOINC" D APOST("SATTR","RIMTBL","RESULTSLN") ; 148 ; D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED 149 I $D(@SBASE@("PROCEDURES",1)) D ; 150 . D APOST("SATTR","RIMTBL","PROCEDURES") 151 W "ATTRIBUTES: ",SATTR,! 152 Q SATTR 153 ; 154 RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES 155 K ^TMP("C0CRIM","RESUME") 156 K ^TMP("C0CRIM") 157 Q 158 ; 159 CLIST ; LIST THE CATEGORIES 160 ; 161 I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS 162 N CLBASE,CLNUM,ZI,CLIDX 163 S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS")) 164 S CLNUM=@CLBASE@(0) 165 F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES 166 . S CLIDX=@CLBASE@(ZI) 167 . W "(",$P(@CLBASE@(CLIDX),"^",1) 168 . W ":",$P(@CLBASE@(CLIDX),"^",2),") " 169 . W CLIDX,! 170 ; D PARY^C0CXPATH(CLBASE) 171 Q 172 ; 173 CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES 174 ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT 175 ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE 176 ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME 177 ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, 178 ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" 179 ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES 180 ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY 181 ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING 182 ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY 183 ; NUMBER IE CTBL_X(CDFN)="" 184 ; 185 ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST 186 S CCTBL=$NA(@CBASE@(CTBL,"CATS")) 187 W "CBASE: ",CCTBL,! 188 ; 189 I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY 190 . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY 191 . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY 192 . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT 193 . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY 194 . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME 195 . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 196 ; 197 S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY 198 S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT 199 S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK 200 ; 201 S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED 202 ; 203 S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT 204 W "PATS BASE: ",CPATLIST,! 205 S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST 206 ; 207 Q 208 ; 209 CHKSUM(CKDFN) ; DOES A CHECKSUM AND STORES IT IN MUMPS GLOBALS 210 ; 211 S C0CCKB=$NA(^TMP("C0CRIM","CHKSUM")) ;CHECKSUM BASE 212 S C0CGLB=$NA(^TMP("C0CRIM","VARS")) ;CCR VARIABLE BASE 213 S C0CI="" 214 F S C0CI=$O(@C0CGLB@(CKDFN,C0CI)) Q:C0CI="" D ;FOR EACH DOMAIN 215 . ;W "DFN:",CKDFN," DOMAIN:",C0CI,! 216 . S C0CJ=$NA(@C0CGLB@(CKDFN,C0CI)) 217 . I C0CI="HEADER" D ; HAVE TO TAKE OUT THE "DATE GENERATED" 218 . . S C0CDT=@C0CGLB@(CKDFN,C0CI,1,"DATETIME") 219 . . K @C0CGLB@(CKDFN,C0CI,1,"DATETIME") 220 . S C0CCK(C0CI)=$$CHKSUM^XUSESIG1(C0CJ) 221 . I C0CI="HEADER" D ; PUT IT BACK 222 . . S @C0CGLB@(CKDFN,C0CI,1,"DATETIME")=C0CDT 223 S C0CK="C0CCK" ; 224 S C0CALL=$$CHKSUM^XUSESIG1(C0CK) ;CHECKSUM OF ALL DOMAIN CHECKSUMS 225 S CHKR=0 ; RESULT DEFAULT 226 I $D(^TMP("C0CRIM","CHKSUM",CKDFN,"ALL")) D ; OLD CHECKSUM EXISTS 227 . I @C0CCKB@(CKDFN,"ALL")'=C0CALL S CHKR=1 228 E S CHKR=1 ;CHECKSUM IS NEW 229 S @C0CCKB@(CKDFN,"ALL")=C0CALL 230 M @C0CCKB@(CKDFN,"DOMAIN")=C0CCK 231 ;ZWR ^TMP("C0CRIM","CHKSUM",CKDFN,*) 232 Q CHKR 233 ; 234 CCOUNT ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE 235 ; 236 I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS 237 N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT 238 S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES 239 S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS 240 S ZTOT=0 ; INITIALIZE OVERALL TOTAL 241 F ZI=1:1:@ZCBASE@(0) D ; FOR ALL CATS 242 . S ZCNT=0 243 . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY 244 . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME 245 . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST 246 . ; F ZJ=0:0 D Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS 247 . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT 248 . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,! 249 . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX)) 250 . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT))) 251 . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD 252 . S ZTOT=ZTOT+ZCNT 253 W "TOTAL: ",ZTOT,! 254 Q 255 ; 256 CNTLST(INLST) ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST 257 ; INLST IS PASSED BY NAME 258 N ZI,ZDX,ZCOUNT 259 W INLST,! 260 S ZCOUNT=0 261 S ZDX="" 262 F ZI=$O(@INLST@(ZDX)):0 D Q:$O(@INLST@(ZDX))="" ; LOOP UNTIL THE END 263 . S ZCOUNT=ZCOUNT+1 264 . S ZDX=$O(@INLST@(ZDX)) 265 . W "ZDX:",ZDX," ZCNT:",ZCOUNT,! 266 Q ZCOUNT 267 ; 268 XCPAT(CPATCAT,CPATPARM) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT 269 ; 270 I '$D(CPATPARM) S CPATPARM="" 271 I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS 272 N ZI,ZJ,ZC,ZPATBASE 273 S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) 274 S ZI="" 275 F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END 276 . S ZI=$O(@ZPATBASE@(ZI)) 277 . D XPAT^C0CCCR(ZI,CPATPARM) ; EXPORT THE PATIENT TO A FILE 278 Q 279 ; 280 CPAT(CPATCAT) ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT 281 ; 282 I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS 283 N ZI,ZJ,ZC,ZPATBASE 284 S ZC=0 ; COUNT FOR SPACING THE PRINTOUT 285 S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) 286 S ZI="" 287 F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END 288 . S ZI=$O(@ZPATBASE@(ZI)) 289 . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT 290 . W ZI," " 291 . I ZC=10 D ; NEW LINE 292 . . S ZC=0 293 . . W ! 294 Q 295 ; 296 PATC(DFN) ; DISPLAY THE CATEGORY FOR THIS PATIENT 297 ; 298 N ATTR S ATTR="" 299 I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT 300 . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT 301 S ATTR=^TMP("C0CRIM","ATTR",DFN) 302 I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q ;NO ATTRIBUTES FOUND 303 I $D(^TMP("C0CRIM","RIMTBL","CATS",ATTR)) D ; FOUND A CAT 304 . N CAT 305 . S CAT=$P(^TMP("C0CRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT 306 . W CAT,": ",ATTR,! 307 Q 308 ; 309 APUSH(AMAP,AVAL) ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME) 310 ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT 311 ; AND AMAP(N)=AVAL IS THE NTH AVAL 312 ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE 313 ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE 314 ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED 315 ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED 316 ; 317 I '$D(@AMAP) D ; IF THE MAP DOES NOT EXIST 318 . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS 319 S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT 320 S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY 321 S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF 322 Q 323 ; 324 ASETUP ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL 325 I '$D(RIMBASE) S RIMBASE=$NA(^TMP("C0CRIM")) 326 I '$D(@RIMBASE) S @RIMBASE="" 327 I '$D(RIMTBL) S RIMTBL=$NA(^TMP("C0CRIM","RIMTBL","TABLE")) ; ATTR TABLE 328 S ^TMP("C0CRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES 329 Q 330 ; 331 AINIT ; INITIALIZE ATTRIBUTE TABLE 332 I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS 333 K @RIMTBL 334 D APUSH(RIMTBL,"EXTRACTED") 335 D APUSH(RIMTBL,"NOTEXTRACTED") 336 D APUSH(RIMTBL,"HEADER") 337 D APUSH(RIMTBL,"NOPCP") 338 D APUSH(RIMTBL,"PCP") 339 D APUSH(RIMTBL,"PROBLEMS") 340 D APUSH(RIMTBL,"PROBCODE") 341 D APUSH(RIMTBL,"PROBNOCODE") 342 D APUSH(RIMTBL,"PROBDATE") 343 D APUSH(RIMTBL,"PROBNODATE") 344 D APUSH(RIMTBL,"VITALS") 345 D APUSH(RIMTBL,"VITALSCODE") 346 D APUSH(RIMTBL,"VITALSNOCODE") 347 D APUSH(RIMTBL,"VITALSDATE") 348 D APUSH(RIMTBL,"VITALSNODATE") 349 D APUSH(RIMTBL,"IMMUNE") 350 D APUSH(RIMTBL,"IMMUNECODE") 351 D APUSH(RIMTBL,"MEDS") 352 D APUSH(RIMTBL,"MEDSCODE") 353 D APUSH(RIMTBL,"MEDSNOCODE") 354 D APUSH(RIMTBL,"MEDSDATE") 355 D APUSH(RIMTBL,"MEDSNODATE") 356 D APUSH(RIMTBL,"ALERTS") 357 D APUSH(RIMTBL,"ALERTSCODE") 358 D APUSH(RIMTBL,"RESULTS") 359 D APUSH(RIMTBL,"RESULTSLN") 360 D APUSH(RIMTBL,"PROCEDURES") 361 D APUSH(RIMTBL,"ENCOUNTERS") 362 D APUSH(RIMTBL,"NOTES") 363 Q 364 ; 365 APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL 366 ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING 367 ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES 368 ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) 369 I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING 370 N USETBL 371 I '$D(@RIMBASE@("TABLES",PTBL)) D Q ; NO TABLE 372 . W "ERROR NO SUCH TABLE",! 373 S USETBL=@RIMBASE@("TABLES",PTBL) 374 S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL 375 Q 376 GETPA(RTN,DFN,ISEC,IVAR) ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN 377 ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT") 378 ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2 379 ; IN SECTION "MEDS" 380 ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS 381 ; PENDING FOR MED 2 FOR PATIENT 2 382 ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE 383 ; RETURNED. RTN IS PASSED BY REFERENCE 384 ; 385 S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE 386 I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES 387 S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES 388 I '$D(@ZVBASE@(DFN,ISEC,0)) D Q ; NO VARIABLES IN SECTION 389 . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,! 390 N ZZI,ZZS 391 S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT 392 ; ZWR @ZZS@(1) 393 S RTN(0)=@ZZS@(0) 394 F ZZI=1:1:RTN(0) D ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS) 395 . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE 396 . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE 397 Q 398 ; 399 PATD(DFN,ISEC,IVAR) ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR 400 ; 401 N ZR 402 D GETPA(.ZR,DFN,ISEC,IVAR) 403 I $D(ZR(0)) D PARY^C0CXPATH("ZR") 404 E W "NOTHING RETURNED",! 405 Q 406 ; 407 CAGET(RTN,IATTR) ; 408 ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR 409 ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE 410 ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC 411 Q 412 ; 413 PCLST(LSTRTN,IATTR) ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR 414 ; 415 I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES 416 N ZLST 417 S @LSTRTN@(0)=0 ; DEFAULT RETURN NONE 418 S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES 419 S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS 420 N ZNC ; ZNC IS NUMBER OF CATEGORIES 421 S ZNC=@ZCBASE@(0) 422 I ZNC=0 Q ; NO CATEGORIES TO SEARCH 423 N ZAP ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE 424 S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR) 425 N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT 426 F ZI=1:1:ZNC D ; FOR ALL CATEGORIES 427 . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT 428 . I $P(ZATBL,"^",ZAP)'="" D ; CAT HAS ATTR 429 . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL 430 . . M @LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT 431 S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS 432 S ZPAT=0 ; START AT FIRST PATIENT IN LIST 433 F S ZPAT=$O(@LSTRTN@(ZPAT)) Q:ZPAT="" D ; 434 . S ZCNT=ZCNT+1 435 S @LSTRTN@(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY 436 Q 437 ; 438 DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR 439 ; 440 ;N ZR 441 D PCLST("ZR",CATTR) 442 I ZR(0)=0 D Q ; 443 . W "NO PATIENTS RETURNED",! 444 E D ; 445 . N ZI S ZI=0 446 . F S ZI=$O(ZR(ZI)) Q:ZI="" D ; 447 . . W !,ZI 448 . ;D PARY^C0CXPATH("ZR") ; PRINT ARRAY 449 . W !,"COUNT=",ZR(0) 450 Q 451 ; 452 RPCGV(RTN,DFN,WHICH) ; RPC GET VARS 453 ; RETURNS IN RTN (PASSED BY REFERENCE) THE VARS AND VALUES 454 ; FOUND AT INARY RTN(X)="VAR^VALUE" RTN(0) IS THE COUNT 455 ; DFN IS THE PATIENT NUMBER. 456 ; WHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","IMMUNE" 457 ; OR OTHER SECTIONS AS THEY ARE ADDED 458 ; THIS IS MEANT TO BE AVAILABLE AS AN RPC 459 I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS 460 S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES 461 S RTN(0)=0 ; DEFAULT NOTHING IS RETURNED 462 N ZZGI 463 I WHICH="ALL" D ; VARIABLES FROM ALL SECTIONS 464 . F ZZGI="HEADER","PROBLEMS","VITALS","MEDS","ALERTS","RESULTS","IMMUNE","PROCEDURES" D ; 465 . . D ZGVWRK(ZZGI) ; DO EACH SECTION 466 . . I $G(DEBUG)'="" W "DID ",ZZGI,! 467 E D ZGVWRK(WHICH) ; ONLY ONE SECTION ASKED FOR 468 Q 469 ; 470 ZGVWRK(ZWHICH) ; DO ONE SECTION FOR RPCGV 471 ; 472 N ZZGN ; NAME FOR SECTION VARIABLES 473 S ZZGN=$NA(@ZVBASE@(DFN,ZWHICH)) ; BASE OF VARS FOR SECTION 474 ;I '$D(@ZZGN@(0)) Q ; NO VARS FOR THIS SECTION 475 I $O(@ZZGN@(""),-1)="" D ; 476 E D ; VARS EXIST 477 . N ZGVI,ZGVN 478 . S ZGVN=$O(@ZZGN@(""),-1) ;COUNT OF VARS 479 . F ZGVI=1:1:ZGVN D ; FOR EACH MULTIPLE IN SECTION 480 . . K ZZGA N ZZGA ; TEMP ARRAY FOR SECTION VARS 481 . . K ZZGN2 N ZZGN2 ; NAME FOR MULTIPLE 482 . . S ZZGN2=$NA(@ZZGN@(ZGVI)) 483 . . I $G(DEBUG)'="" W ZZGN2,!,$O(@ZZGN2@("")),! 484 . . D H2ARY^C0CXPATH("ZZGA",ZZGN2,ZGVI) ; CONVERT HASH TO ARRAY 485 . . ; D PARY^C0CXPATH("ZZGA") 486 . . D PUSHA^C0CXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN 487 Q 488 ; 489 DPATV(DFN,IWHICH) ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN C0CRIM 490 ; ALONG WITH SAMPLE VALUES. 491 ; IWHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","HEADER" 492 N GTMP 493 I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT 494 . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES 495 I '$D(IWHICH) S IWHICH="ALL" 496 D RPCGV(.GTMP,DFN,IWHICH) 497 D PARY^C0CXPATH("GTMP") 498 Q 499 ; 500 RIM2RNF(R2RTN,DFN,RWHICH) ; CONVERTS RIM VARIABLES TO RNF2 FORMAT 501 ; RETURN IN R2RTN, WHICH IS PASSED BY NAME 502 ; RWHICH IS RIM SECTION TO RETURN, DEFAULTS TO "ALL" 503 ; 504 I '$D(RWHICH) S RWHICH="ALL" 505 ;N R2TMP 506 I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT 507 . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES 508 D RPCGV(.R2TMP,DFN,RWHICH) ; RETRIEVE ALL THE VARIABLES I AN ARRAY 509 N R2I,R2J,R2X,R2X1,R2X2,R2Y,R2Z 510 F R2I=1:1:R2TMP(0) D ; FOR EVERY LINE OF THE ARRAY 511 . S R2X=$P(R2TMP(R2I),"^",1) ; OCCURANCE 512 . S R2Y=$P(R2TMP(R2I),"^",2) ; VARIABLE NAME 513 . I $L(R2Y)<4 Q ; SKIP SHORT VARIABLES (THEY ARE FOR DEBUGGING) 514 . S R2Z=$P(R2TMP(R2I),"^",3) ; VALUE 515 . I R2X[";" D ; THERES MULTIPLES 516 . . S R2X1=$P(R2X,";",1) ; FIRST INDEX 517 . . S R2X2=$P(R2X,";",2) ; SECOND INDEX 518 . . S R2J=R2Y_"["_R2X2_"]" ; BUILD THE VARIABLE NAME 519 . . S @R2RTN@("F",R2J,1)="" ; PUT VARIABLE NAME IN FIELD MAP 520 . . S @R2RTN@("V",R2X1,R2J,1)=R2Z ; PUT THE VALUE IN THE ARRAY 521 . E D ; NO SUB-MULTIPLES 522 . . S @R2RTN@("F",R2Y,1)="" ; PUT VARIABLE NAME IN FIELD MAP 523 . . S @R2RTN@("V",R2X,R2Y,1)=R2Z ; PUT THE VALUE IN THE ARRAY 524 Q 525 ; 526 RIM2CSV(DFN) ; WRITE THE RIM VARIABLES FOR A PATIENT TO A CSV FILE 527 ; 528 N R2CTMP,R2CARY 529 D RIM2RNF("R2CTMP",DFN) ; CONVERT VARIABLES TO RNF FORMAT 530 D RNF2CSV^C0CRNF("R2CARY","R2CTMP","NV") ; CONVERT RNF TO CSV FORMAT 531 D FILEOUT^C0CRNF("R2CARY","VARS-"_DFN_".csv") 532 Q 533 ; -
ccr/branches/ohum/p/C0CRNF.m
r1342 r1428 1 C0CRNF 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 FIELDS(C0CFRTN,C0CF) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 TESTRNF 47 48 49 50 51 52 53 54 55 56 57 58 RNF1TO2(ZOUT,ZIN) 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 RNF1TO2B(ZOUT,ZIN) 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 GETNOLD(GRTN,GFILE,GIEN,GNN) 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 GETN(GRTN,GFILE,GREF,GNDX,GNN) 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 GETN1(GRTN,GFILE,GREF,GNDX,GNN) 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 GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) 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 ADDNV(GNV,GNVN,GNVF,GNVV) 292 293 294 295 296 297 RNF2CSV(RNRTN,RNIN,RNSTY) 298 299 300 301 302 303 304 305 306 307 308 309 310 NV(RNRTN,RNIN) 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 VN(RNRTN,RNIN) 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 READCSV(PATH,NAME,GLB) 357 358 359 360 FILE2CSV(FNUM,FVN) 361 362 363 364 365 366 367 368 369 370 371 372 373 FILEOUT(FOARY,FONAM) 374 375 376 377 378 FILEREF(FNUM) 379 380 381 382 383 384 385 386 SKIP 387 388 389 390 391 392 393 394 395 396 397 RNF2HNV(ZOUT,ZIN) 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 RNF2HVN(ZOUT,ZIN) 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 ZFILE(ZFN,ZTAB) 442 443 444 445 446 ZFIELD(ZFN,ZTAB) 447 448 449 450 451 ZVALUE(ZFN,ZTAB) 452 453 454 455 456 457 ZVALUEI(ZFN,ZTAB) 458 459 460 461 462 1 C0CRNF ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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) Utility Library ",! 21 W ! 22 Q 23 ; 24 FIELDS(C0CFRTN,C0CF) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF, 25 ; C0CFRTN IS PASSED BY NAME, C0CF IS PASSED BY VALUE 26 ; 27 N C0CFI,C0CFJ ;INNER LOOP, OUTER LOOP 28 N C0CFN ; FIELD NAME 29 S C0CFI=0 S C0CFJ=C0CF 30 K @C0CFRTN ; CLEAR THE RETURN ARRAY 31 F Q:C0CFJ'[C0CF D ; FOR THE C0CF FILE AND ALL SUBFILES INCLUSIVE 32 . ;W "1: "_C0CFJ," ",C0CFI,! 33 . F S C0CFI=$O(^DD(C0CFJ,C0CFI)) Q:+C0CFI=0 D ; EVERY FIELD 34 . . ;W "2: "_C0CFJ," ",C0CFI,! 35 . . S C0CFN=$P($G(^DD(C0CFJ,C0CFI,0)),"^",1) ;PULL FIELD NAME FROM ^DD 36 . . ;W "N: ",C0CFN,! 37 . . ;I C0CFN="STR" W C0CFN," ",C0CFJ,! 38 . . I $D(@C0CFRTN@(C0CFN)) D ; IS THIS A DUPLICATE? 39 . . . I $G(DEBUG) D ; 40 . . . . W "DUPLICATE FOUND! ",C0CFJ," ",C0CFI," ",C0CFN,!,@C0CFRTN@(C0CFN),! 41 . . . S @C0CFRTN@(C0CFN_"_"_C0CFJ)=C0CFJ_"^"_C0CFI 42 . . E S @C0CFRTN@(C0CFN)=C0CFJ_"^"_C0CFI 43 . S C0CFJ=$O(^DD(C0CFJ)) ; NEXT SUBFILE 44 Q 45 ; 46 TESTRNF ; TEST THE RNF1TO2 ROUTINE 47 S G1("ONE")=1 48 S G1("TWO")=2 49 S G1("THREE")=3 50 D RNF1TO2("GPL","G1") 51 S G1("ONE")="NOT1" 52 S G1("TWO")="STILL2" 53 S G1("THREE")=3 54 D RNF1TO2("GPL","G1") 55 ZWR GPL 56 Q 57 ; 58 RNF1TO2(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY 59 ; (ZOUT) BOTH ARE PASSED BY NAME 60 ; RNF1 IS OF THE FORM: 61 ; @ZIN@("VAR1")=VAL1 62 ; @ZIN@("VAR2")=VAL2 63 ; RNF2 IS OF THE FORM: 64 ; @ZOUT@("F","VAR1")="" 65 ; @ZOUT@("F","VAR2")="" 66 ; @ZOUT@("V",n,"VAR1")=VAL1 67 ; @ZOUT@("V",n,"VAR2")=VAL2 68 ; WHERE n IS THE "ROW" OF THE ARRAY 69 N ZI S ZI="" 70 N ZN 71 I '$D(@ZOUT@("V",1)) S ZN=1 72 E S ZN=$O(@ZOUT@("V",""),-1)+1 73 F S ZI=$O(@ZIN@(ZI)) Q:ZI="" D ; 74 . S @ZOUT@("F",ZI)="" 75 . S @ZOUT@("V",ZN,ZI)=@ZIN@(ZI) 76 Q 77 ; 78 RNF1TO2B(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY 79 ; THE "B" ROUTINE SUPPORTS WP FIELDS IN THE ARRAY 80 ; EVERY "V" VARIABLE IS FOLLOWED BY A "1" 81 ; FOR EXAMPLE @G@("V",n,"VAR1",1)="VALUE1" 82 ; USE THIS ROUTINE IF YOU WANT TO CONVERT THE RESULT TO A CSV 83 ; WITH RNF2CSV 84 ; (ZOUT) BOTH ARE PASSED BY NAME 85 ; RNF1 IS OF THE FORM: 86 ; @ZIN@("VAR1")=VAL1 87 ; @ZIN@("VAR2")=VAL2 88 ; RNF2 IS OF THE FORM: 89 ; @ZOUT@("F","VAR1")="" 90 ; @ZOUT@("F","VAR2")="" 91 ; @ZOUT@("V",n,"VAR1",1)=VAL1 92 ; @ZOUT@("V",n,"VAR2",1)=VAL2 93 ; WHERE n IS THE "ROW" OF THE ARRAY 94 N ZI S ZI="" 95 N ZN 96 I '$D(@ZOUT@("V",1)) S ZN=1 97 E S ZN=$O(@ZOUT@("V",""),-1)+1 98 F S ZI=$O(@ZIN@(ZI)) Q:ZI="" D ; 99 . S @ZOUT@("F",ZI)="" 100 . S @ZOUT@("V",ZN,ZI,1)=@ZIN@(ZI) 101 Q 102 ; 103 GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME 104 ; GRTN IS PASSED BY NAME 105 ; 106 N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME 107 I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) 108 E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) 109 S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE 110 D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP 111 D GETS^DIQ(GFILE,C0CREF,"**","I","C0CTMP") 112 D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE 113 S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J ; STRUCTURE SIGNATURE 114 S (C0CI,C0CJ)="" 115 F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES 116 . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE 117 . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS 118 . . ;W C0CJ," ",C0CI,! 119 . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME 120 . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI) ; 121 . . I C0CVALUE["C0CTMP" S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,1) ;1ST LINE OF WP 122 . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 123 I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED 124 . S C0CI="" 125 . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY 126 . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES 127 Q 128 ; 129 GETN(GRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP 130 ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 131 ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL 132 ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN 133 ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP 134 ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" 135 ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP 136 ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE 137 ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE 138 ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP 139 ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP 140 ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE 141 ; IF GREF IS "" THE FIRST RECORD IS OBTAINED 142 ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE 143 ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN 144 ; GREF IS THE VALUE FOR THE INDEX 145 ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED 146 ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN 147 ; 148 ; 149 N GIEN,GF 150 S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE 151 I ('$D(GNDX))!($G(GNDX)="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN 152 E D ; WE ARE USING AN INDEX 153 . ;N ZG 154 . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX 155 . I ZG'="" D ; 156 . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? 157 . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN 158 . . E S GIEN="" ; NOT FOUND IN INDEX 159 . E S GIEN="" ; 160 ;W "IEN: ",GIEN,! 161 ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME 162 I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) 163 E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) 164 S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE 165 D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP 166 K C0CTMP 167 D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") 168 D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE 169 S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE 170 S (C0CI,C0CJ)="" 171 F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES 172 . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE 173 . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS 174 . . ;W C0CJ," ",C0CI,! 175 . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME 176 . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; 177 . . I C0CVALUE["C0CTMP" D ; WP FIELD 178 . . . N ZT,ZWP S ZWP=0 ;ITERATOR 179 . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE 180 . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE 181 . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; 182 . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP 183 . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " 184 . . . . S C0CVALUE=C0CVALUE_ZT ; 185 . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 186 . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) 187 I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED 188 . S C0CI="" 189 . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY 190 . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES 191 Q 192 ; 193 GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP 194 ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 195 ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL 196 ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN 197 ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP 198 ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" 199 ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP 200 ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE 201 ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE 202 ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP 203 ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP 204 ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE 205 ; IF GREF IS "" THE FIRST RECORD IS OBTAINED 206 ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE 207 ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN 208 ; GREF IS THE VALUE FOR THE INDEX 209 ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED 210 ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN 211 ; 212 ; 213 N GIEN,GF 214 S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE 215 I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN 216 E D ; WE ARE USING AN INDEX 217 . ;N ZG 218 . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX 219 . I ZG'="" D ; 220 . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? 221 . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN 222 . . E S GIEN="" ; NOT FOUND IN INDEX 223 . E S GIEN="" ; 224 ;W "IEN: ",GIEN,! 225 ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME 226 I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) 227 E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) 228 S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE 229 D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP 230 K C0CTMP 231 D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") 232 D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE 233 S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE 234 S (C0CI,C0CJ)="" 235 F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES 236 . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE 237 . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS 238 . . ;W C0CJ," ",C0CI,! 239 . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME 240 . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; 241 . . I C0CVALUE["C0CTMP" D ; WP FIELD 242 . . . N ZT,ZWP S ZWP=0 ;ITERATOR 243 . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE 244 . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE 245 . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; 246 . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP 247 . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " 248 . . . . S C0CVALUE=C0CVALUE_ZT ; 249 . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 250 . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) 251 I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED 252 . S C0CI="" 253 . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY 254 . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES 255 Q 256 ; 257 GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES 258 ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP 259 ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#" 260 ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP 261 ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE 262 ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES 263 ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE 264 ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP 265 ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP 266 ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE 267 ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE 268 ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN 269 ; .. OF THE FILE WILL BE USED 270 ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE 271 ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED 272 ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE 273 ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD 274 ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED 275 ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL 276 ;N GATMP,GAI,GAF 277 S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE 278 I '$D(GAIDX) S GAIDX="" ;DEFAULT 279 I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED 280 I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX 281 W GAF,! 282 W $O(@GAF@(0)) ; 283 S GAI=0 ;ITERATOR 284 F S GAI=$O(@GAF@(GAI)) Q:GAI="" D ; 285 . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD 286 . N GAX S GAX=0 287 . F S GAX=$O(GATMP(GAX)) Q:GAX="" D ;PULL OUT THE FIELDS 288 . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN 289 Q 290 ; 291 ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX 292 ; 293 S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD# 294 S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE 295 Q 296 ; 297 RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT 298 ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES 299 ; RNSTY IS STYLE OF THE OUTPUT - 300 ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES 301 ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES 302 ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES 303 N RNR,RNC ;ROW ROOT,COL ROOT 304 N RNI,RNJ,RNX 305 I '$D(RNSTY) S RNSTY="NV" ;DEFAULT 306 I RNSTY="NV" D NV(RNRTN,RNIN) ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION 307 E D VN(RNRTN,RNIN) ; 308 Q 309 ; 310 NV(RNRTN,RNIN) ; 311 S RNR=$NA(@RNIN@("F")) 312 S RNC=$NA(@RNIN@("V")) 313 ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER 314 S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD" 315 S RNI="" 316 F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN 317 . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA 318 S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA 319 D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS 320 S RNI="" 321 F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW 322 . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD 323 . S RNJ="" 324 . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL 325 . . I $D(@RNC@(RNJ,RNI,1)) D ; THIS ROW HAS THIS COLUMN 326 . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA 327 . . E S RNX=RNX_"," ; NUL COLUMN 328 . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA 329 . D PUSH^C0CXPATH(RNRTN,RNX) 330 Q 331 ; 332 VN(RNRTN,RNIN) ; 333 S RNR=$NA(@RNIN@("V")) 334 S RNC=$NA(@RNIN@("F")) 335 ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER 336 S RNX="""ROW"""_"," ; FIRST COLUMN NAME IS "ROW" 337 S RNI="" 338 F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN 339 . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA 340 S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA 341 D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS 342 S RNI="" 343 F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW 344 . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD 345 . S RNJ="" 346 . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL 347 . . I $D(@RNR@(RNI,RNJ,1)) D ; THIS ROW HAS THIS COLUMN 348 . . . S RNV=$TR(@RNR@(RNI,RNJ,1),"""","") 349 . . . S RNV=$TR(RNV,",","") 350 . . . S RNX=RNX_""""_RNV_""""_"," ; ADD THE ELEMENT PLUS A COMMA 351 . . E S RNX=RNX_"," ; NUL COLUMN 352 . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA 353 . D PUSH^C0CXPATH(RNRTN,RNX) 354 Q 355 ; 356 READCSV(PATH,NAME,GLB) ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME 357 ; 358 Q $$FTG^%ZISH(PATH,NAME,GLB,1) 359 ; 360 FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV 361 ; 362 ;N G1,G2 363 I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE 364 S G1=$NA(^TMP($J,"C0CCSV",1)) 365 S G2=$NA(^TMP($J,"C0CCSV",2)) 366 D GETN2(G1,FNUM) ; GET THE MATRIX 367 D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE 368 K @G1 369 D FILEOUT(G2,"FILE_"_FNUM_".csv") 370 K @G2 371 Q 372 ; 373 FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE 374 ; 375 W $$OUTPUT^C0CXPATH($NA(@FOARY@(1)),FONAM,^TMP("C0CCCR","ODIR")) 376 Q 377 ; 378 FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM 379 ; 380 N C0CF 381 S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE 382 S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT 383 I C0CF["()" S C0CF=$P(C0CF,"()",1) 384 Q C0CF 385 ; 386 SKIP ; 387 N TXT,DIERR 388 S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT") 389 I $D(DIERR) D CLEAN^DILF Q 390 W " report_text:",! ;Progress Note Text 391 N LN S LN=0 392 F S LN=$O(TXT(LN)) Q:'LN D 393 . W " text"_LN_": "_TXT(LN),! 394 . Q 395 Q 396 ; 397 RNF2HNV(ZOUT,ZIN) ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME 398 ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT 399 ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END 400 ; THE TABLE WILL BE IN NV FORMAT, ROWS ARE NAMES COLUMNS ARE VALUES 401 D PUSH^C0CXPATH(ZOUT,"<table border=""1"">") 402 N ZI,ZJ,ZV,ZN S ZI="" S ZJ=0 403 D PUSH^C0CXPATH(ZOUT,"<tr><td></td>") ;begin row and leave a blank col 404 F S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0 D ; FOR EACH OCCURANCE 405 . S ZV="<td>"_ZJ_"</td>" ; OCCURANCE AS COLUMNS HEADER 406 . D PUSH^C0CXPATH(ZOUT,ZV) 407 D PUSH^C0CXPATH(ZOUT,"</tr>") ;end of first row 408 S ZI="" 409 F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE 410 . S ZN="<tr><td>"_ZI_"</td>" ; VARIABLE NAME IN FIRST COLUMN 411 . D PUSH^C0CXPATH(ZOUT,ZN) 412 . S ZJ=0 ;RESET TO DO IT AGAIN 413 . F S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0 D ; FOR EACH OCCURANCE 414 . . S ZV="<td>"_$G(@ZIN@("V",ZJ,ZI,1))_"</td>" 415 . . D PUSH^C0CXPATH(ZOUT,ZV) 416 . D PUSH^C0CXPATH(ZOUT,"</tr>") ;END OF ROW 417 D PUSH^C0CXPATH(ZOUT,"</table>") ; end of table 418 Q 419 ; 420 RNF2HVN(ZOUT,ZIN) ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME 421 ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT 422 ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END 423 ; THE TABLE WILL BE IN VN FORMAT, ROWS ARE VALUES COLUMNS ARE NAMES 424 D PUSH^C0CXPATH(ZOUT,"<table border=""1"">") 425 N ZI,ZJ S ZI="" S ZJ=0 426 D PUSH^C0CXPATH(ZOUT,"<tr>") ;new row for column headers 427 F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE 428 . S ZV="<td>"_ZI_"</td>" 429 . D PUSH^C0CXPATH(ZOUT,ZV) ; name 430 D PUSH^C0CXPATH(ZOUT,"</tr>") ; end header row 431 S ZI="" ;RESET TO DO AGAIN 432 F S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0 D ; FOR EACH ROW OF VARIABLES 433 . D PUSH^C0CXPATH(ZOUT,"<tr>") ;begin row 434 . F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE 435 . . S ZV="<td>"_$G(@ZIN@("V",ZJ,ZI,1))_"</td>" ; value 436 . . D PUSH^C0CXPATH(ZOUT,ZV) ; value 437 . D PUSH^C0CXPATH(ZOUT,"</tr>") ; end header 438 D PUSH^C0CXPATH(ZOUT,"</table>") ;end of table 439 Q 440 ; 441 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 442 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN) 443 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 444 I '$D(ZTAB) S ZTAB="C0CA" 445 Q $P(@ZTAB@(ZFN),"^",1) 446 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 447 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN) 448 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 449 I '$D(ZTAB) S ZTAB="C0CA" 450 Q $P(@ZTAB@(ZFN),"^",2) 451 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 452 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) 453 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 454 I '$D(ZTAB) S ZTAB="C0CA" 455 Q $P($G(@ZTAB@(ZFN)),"^",3) 456 ; 457 ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED 458 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) 459 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 460 I '$D(ZTAB) S ZTAB="C0CA" 461 Q $P($G(@ZTAB@(ZFN,"I")),"^",3) 462 ; -
ccr/branches/ohum/p/C0CRNFRP.m
r1342 r1428 1 C0CRNFRP C ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/092 ;;1.0;C0C;;Dec 9, 2009;Build 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 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 C0CRNFRP ; CCDCCR/GPL - Reference Name Format (RNF) RPCs; 12/9/09 ; 5/10/12 2:56pm 2 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CRPMS 2 ;;0.1;CCDCCR;;JUL 16,2008;Build 2 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 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CRXN 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXPAND 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 EXP2 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 CHKNDF 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 SETFDA(C0CSN,C0CSV) 256 257 258 259 260 261 262 263 264 265 ZFILE(ZFN,ZTAB) 266 267 268 269 270 271 272 273 ZFIELD(ZFN,ZTAB) 274 275 276 277 278 279 280 281 282 ZVALUE(ZFN,ZTAB) 283 284 285 286 287 288 289 290 1 C0CRXN ; CCDCCR/GPL - CCR RXN utilities; 12/6/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 RXNORM Utility Library ",! 21 W ! 22 Q 23 ; 24 EXPAND ; MAIN ROUTINE TO CREATE THE C0C RXNORM VUID EXPANSION FILE (176.112) 25 ; READ EACH RECORD FROM 176.111 AND USE THE VUID TO LOOK UP THE RXNORM 26 ; CODE FROM 176.001 (RXNORM CONCEPTS) 27 ; POPULATE ALL FIELDS IN 176.112 AND SET "NEW" TO "Y" IF 176.111 DOES NOT 28 ; ALREADY HAVE AN RXNORM CODE. 29 ; ADD THE RXNORM TEXT FIELD TO EVERY RECORD (NOT PRESENT IN 176.111) 30 ; AND COMPARE THE RXNORM TEXT FIELD WITH THE VUID TEXT FIELD, SETTING THE 31 ; "DIFFERENT TEXT" FIELD TO "Y" IF THERE ARE DIFFERENCES 32 ; USES SUPPORT ROUTINES FROM C0CRNF.m 33 N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR 34 N C0CFVA,C0CFRXN ; CLOSED ROOTS FOR SOURCE FILES 35 N C0CF ; CLOSED ROOT FOR DESTINATION FILE 36 S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE 37 S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE 38 S C0CF=$$FILEREF^C0CRNF(176.112) ; C0C RXNORM VUID MAPPING EXPANSION FILE 39 W C0CVA,C0CFRXN,C0CF,! 40 S C0CZX=0 41 S (HASRXN,NORXN,NOVUID,RXFOUND,RXMATCH,TXTMATCH)=0 ; INITIALIZE COUNTERS 42 F S C0CZX=$O(^C0CCODES(176.111,C0CZX)) Q:+C0CZX=0 D ; FOR EVERY RECORD 43 . K C0CA,C0CB,C0CC ; CLEAR ARRAYS 44 . D FIELDS^C0CRNF("C0CC",176.112) ;GET FIELD NAMES FOR OUTPUT FILE 45 . D GETN1^C0CRNF("C0CA",176.111,C0CZX,"","ALL") ;GET THE FIELDS 46 . I $$ZVALUE("MEDIATION CODE")="" D 47 . . S NORXN=NORXN+1 ; 48 . E D ; PROCESS MEDIATION CODE 49 . . S HASRXN=HASRXN+1 50 . . D SETFDA("MEDIATION CODE",$$ZVALUE("MEDIATION CODE")) ; 51 . I $$ZVALUE("VUID")="" D ; BAD RECORD 52 . . S NOVUID=NOVUID+1 53 . . ;D SETFDA("VUID",$$ZVALUE("VUID")) 54 . E D SETFDA("VUID TEXT",$$ZVALUE("VUID TEXT")) 55 . . ;ZWR C0CA 56 . D GETN1^C0CRNF("C0CB",176.001,$$ZVALUE("VUID"),"VUID","ALL") 57 . I $$ZVALUE("RXCUI","C0CB")'="" D ; RXNORM FOUND 58 . . S RXFOUND=RXFOUND+1 59 . . I $$ZVALUE("MEDIATION CODE")="" D ; THIS IS A NEW CODE 60 . . . D SETFDA("MEDIATION CODE",$$ZVALUE("RXCUI","C0CB")) 61 . . . D SETFDA("NEW","Y") ;FLAG RECORD HAS HAVING NEW RXNORM 62 . . W "RXNORM=",$$ZVALUE("RXCUI","C0CB")," ",$$ZVALUE("STR","C0CB"),! 63 . . W "VUID TEXT: ",$$ZVALUE("VUID TEXT"),! 64 . . I $$ZVALUE("VUID TEXT")=$$ZVALUE("STR","C0CB") S TXTMATCH=TXTMATCH+1 65 . . E D ; 66 . . . S ZZ=$$ZVALUE("VUID TEXT")_"^"_$$ZVALUE("STR","C0CB") 67 . . . D PUSH^GPLXPATH("NOMATCH",ZZ) 68 . . . D SETFDA("RXNORM TEXT",$$ZVALUE("STR","C0CB")) ; 69 . . . D SETFDA("DIFFERENT TEXT","Y") ;FLAG RECORD FOR DIFFERENT TEXT 70 . I $$ZVALUE("MEDIATION CODE")=$$ZVALUE("RXCUI","C0CB") D ; 71 . . S RXMATCH=RXMATCH+1 72 . . W "VUID=",$$ZVALUE("VUID")," MATCH RXNORM=",$$ZVALUE("MEDIATION CODE"),! 73 . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP 74 . S C0CFDA(176.112,"+"_C0CZX_",",.01)=$$ZVALUE("VUID") ; NEW VUID RECORD 75 . D UPDATE^DIE("","C0CFDA") 76 . I $D(^TMP("DIERR",$J)) U $P BREAK 77 W "HAS RXN=",HASRXN,! 78 W "NO RXN=",NORXN,! 79 W "NO VUID=",NOVUID,! 80 W "RXNORM FOUND=",RXFOUND,! 81 W "RXNORM MATCHES:",RXMATCH,! 82 W "TEXT MATCHES:",TXTMATCH,! 83 Q 84 ; 85 EXP2 ; ROUTINE TO CREATE 176.113 C0C RXNORM VUID MAPPING DISCREPANCIES FILE 86 ; CROSS CHECKS THE NATIONAL DRUG FILE AND THE VA MAPPING FILE AGAINST 87 ; THE UMLS RXNORM DATABASE 88 ; THIS ROUTINE HAS BEEN ENHANCED TO ALSO CHECK THE 50.416 DRUG INGREDIENT 89 ; FILE AND TREAT VUIDS FOUND THERE LIKE THE ONES BEING FOUND IN THE NDF 90 ; IF THE VUID EXISISTS IN ALL THREE FILES, THE RXNORM CODE MATCHES IN 91 ; THE VA MAPPING FILE AND THE TEXT STRINGS ARE THE SAME, THE VUID IS INCLUDED 92 ; IN THE FILE BUT NO FLAGS ARE SET 93 ; IF THE VUID IS MISSING FROM THE NATIONAL DRUG FILE NDF=N 94 ; (IF THE VUID IS MISSING FROM THE NDF, IT IS CHECKED IN THE DRUG INGREDIENT 95 ; FILE, AND IF FOUND, THE FLAG IS NOT SET. IN THIS CASE THE TEXT FROM THE 96 ; DRUG INGREDIENT FILE IS USED FOR COMPARISONS) 97 ; IF THE VUID IS MISSING FROM THE VA MAPPING FILE VAMAP=N 98 ; IF THE VUID IS PRESENT IN THE VA MAPPING FILE, BUT THE RXNORM 99 ; CODE IS MISSING IN THAT FILE, VARXN=N 100 ; IF THE TEXT STRINGS DO NOT MATCH EXACTLY, TXTM=N AND ALL THREE STRINGS 101 ; ARE SHOWN; NDF TEXT=NDF TEXT STRING, VA MAP TEXT=VA MAPPING TEXT STRING 102 ; RXNORM TEXT=RXNORM TEXT STRING 103 ; THE FILE IS KEYED ON VUID AND WOULD USUALLY BE SORTED BY VUID 104 ; THE OBJECTIVE IS TO SEE IF NDF (50.68) AND VA MAPPING (176.111) HAVE 105 ; ALL THE VUID CODES THAT ARE IN THE UMLS RXNORM DATABASE 106 N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR 107 N C0CFVA,C0CFRXN ; CLOSED ROOTS FOR SOURCE FILES 108 N C0CF ; CLOSED ROOT FOR DESTINATION FILE 109 S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE 110 S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE 111 ;S C0CF=$$FILEREF^C0CRNF(176.113) ; C0C RXNORM VUID MAPPING ADDITIONAL FILE 112 W C0CVA,C0CFRXN,! ;C0CF,! 113 S C0CZX=0 114 S (NDFVCNT,NDFTCNT,NDFNO)=0 ; COUNTERS FOR NDF TESTS 115 S (VAVCNT,VATCNT,VARCNT,VANO)=0 ; COUNTERS FOR VA MAPPING FILE TESTS 116 F S C0CZX=$O(^C0CRXN(176.001,"VUID",C0CZX)) Q:+C0CZX=0 D ; FOR EVERY VUID 117 . K C0CA,C0CB,C0CC,C0CD ; CLEAR ARRAYS 118 . D FIELDS^C0CRNF("C0CC",176.113) ;GET FIELD NAMES FOR OUTPUT FILE 119 . D GETN1^C0CRNF("C0CA",176.001,C0CZX,"VUID","ALL") ;GET FROM RXNORM FILE 120 . D GETN1^C0CRNF("C0CB",176.111,C0CZX,"B","ALL") ;GET FROM VA MAPPING FILE 121 . D GETN1^C0CRNF("C0CD",50.68,C0CZX,"AVUID","ALL") ;GET FROM NDF 122 . D GETN1^C0CRNF("C0CE",50.416,C0CZX,"AVUID","ALL") ;GET FROM DRUG INGREDIENTS 123 . ;D SETFDA("VUID",$$ZVALUE("CODE")) ;SET THE VUID CODE 124 . D SETFDA("RXNORM",$$ZVALUE("RXCUI")) ;SET THE RXNORM CODE 125 . D SETFDA("RXNORM TEXT",$$ZVALUE("STR")) ;SET THE RXNORM TEXT 126 . ;VA MAPPING FILE TESTS 127 . I $$ZVALUE("VUID","C0CB")=C0CZX D ; VUID FOUND 128 . . S VAVCNT=VAVCNT+1 ;INCREMENT COUNT 129 . . I $$ZVALUE("STR")'=$$ZVALUE("VUID TEXT","C0CB") D ;TEXT MISMATCH 130 . . . S VATCNT=VATCNT+1 ; INCREMENT VA TEXT MISMATCH COUNT 131 . . . D SETFDA("TXTM","N") ;MARK THAT TEXT DOESN'T MATCH 132 . . . D SETFDA("VA MAP TEXT",$$ZVALUE("VUID TEXT","C0CB")) ; SET VA MAP TEXT 133 . E D ; VUID NOT FOUND 134 . . S VANO=VANO+1 135 . . D SETFDA("VAMAP","N") ;MARK AS MISSING FROM VA MAPPING FILE 136 . ; NATIONAL DRUG FILE TESTS 137 . I ($$ZVALUE("VUID","C0CD")=C0CZX)!($$ZVALUE("VUID","C0CE")=C0CZX) D ; 138 . . ;FOUND IN NATIONAL DRUG FILE OR DRUG INGREDIENT FILE 139 . . S NDFVCNT=NDFVCNT+1 ;INCREMENT VUID FOUND COUNT 140 . . I $$ZVALUE("NAME","C0CD")'=$$ZVALUE("STR") D ;NDF TEXT DOESN'T MATCH 141 . . . I $$ZVALUE("NAME","C0CE")'=$$ZVALUE("STR") D ;DRUG ING FILE ALSO 142 . . . . S NDFTCNT=NDFTCNT+1 ; INCREMENT MISMATCHED NDF TEXT COUNT 143 . . . . D SETFDA("TXTM","N") ; SET TEXT MATCH FLAG TO N 144 . . . . D SETFDA("NDF TEXT",$$ZVALUE("NAME","C0CD")) ;POST THE TEXT 145 . . . . D SETFDA("NAT DRUG TEXT",$$ZVALUE("NAME","C0CE")) ;POST TEXT 146 . E D ; 147 . . D SETFDA("NDF","N") ;MARK AS MISSING 148 . . S NDFNO=NDFNO+1 ;INCREMENT MISSING COUNT 149 . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP 150 . S C0CFDA(176.113,"+"_C0CZX_",",.01)=C0CZX ; NEW VUID RECORD 151 . D UPDATE^DIE("","C0CFDA") 152 . I $D(^TMP("DIERR",$J)) U $P BREAK 153 W "VA MAPPING VUID COUNT: ",VAVCNT,! 154 W "VA MAPPING MISSING: ",VANO,! 155 W "VA MAPPING TEXT MISMATCH: ",VATCNT,! 156 W "NDF VUID COUNT: ",NDFVCNT,! 157 W "NDF MISSING: ",NDFNO,! 158 W "NDF TEXT MISMATCH: ",NDFTCNT,! 159 Q 160 CHKNDF ; ROUTINE TO CHECK THE NATIONAL DRUG FILE WITH THE UMLS RXNORM DB 161 ; USING THE AVUID INDEX, READS ALL VUID CODES IN ^PSNDF(50.68), 162 ; CHECKS TO SEE IF THE CODE IS IN 176.001, AND CREATES A RECORD 163 ; IN 176.114 164 ; THE OBJECTIVE IS TO SEE IF ^PSNDF(50.68) HAS ALL THE VUID CODES IN THE 165 ; UMLS RXNORM DATABASE AND IF THE TEXT FIELDS MATCH 166 ; ALSO CAPTURES THE RXNORM CODE MAPPING 167 ; CHKNDF2 WILL CHECK THE OTHER DIRECTION, STARTING WITH THE 176.001 VUID INDEX 168 ; THIS ROUTINE ALSO CHECKS IF THE VUID CODE IS IN 176.111 AND IF NOT 169 ; SETS NOTMAPPED=Y 170 N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR 171 N C0CFVA,C0CFRXN,C0CPSNDF ; CLOSED ROOTS FOR SOURCE FILES 172 N C0CF ; CLOSED ROOT FOR DESTINATION FILE 173 S C0CPSNDF=$$FILEREF^C0CRNF(50.68) ; NDF CLOSED ROOT REFERENCE 174 S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE 175 S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE 176 ;S C0CF=$$FILEREF^C0CRNF(176.113) ; C0C RXNORM VUID MAPPING ADDITIONAL FILE 177 W C0CVA,C0CFRXN,! ;C0CF,! 178 S C0CZX=0 179 S (FOUND,MISSING)=0 180 S (NOVUID,VMATCH,NOMATCH,MISSING,FOUND,TXTMATCH,NOTM,NVAM)=0 ; COUNTERS 181 F S C0CZX=$O(^PSNDF(50.68,"AVUID",C0CZX)) Q:+C0CZX=0 D ; FOR EVERY VUID 182 . K C0CA,C0CB,C0CC,C0CD ; CLEAR ARRAYS 183 . ;D FIELDS^C0CRNF("C0CC",176.113) ;GET FIELD NAMES FOR OUTPUT FILE 184 . D GETN1^C0CRNF("C0CA",50.68,C0CZX,"AVUID","ALL") ;GET THE FIELDS 185 . I $$ZVALUE("VUID")="" D ; ERROR, SHOULD NOT HAPPEN 186 . . S NOVUID=NOVUID+1 ; FLAG THE ERROR 187 . . D PUSH^GPLXPATH("NOVUID",C0CZX) ; RECORD THE VUID 188 . D GETN1^C0CRNF("C0CD",176.001,C0CZX,"VUID","ALL") ;TRY RXNORM DB 189 . I $$ZVALUE("CODE","C0CD")=C0CZX D ; FOUND IN RXNORM 190 . . S VMATCH=VMATCH+1 ; COUNT OF PSNDF VUIDS FOUND IN RXNORM 191 . . I $$ZVALUE("NAME")=$$ZVALUE("STR","C0CD") D ;TEXT MATCHES 192 . . . S TXTMATCH=TXTMATCH+1 ; COUNT IT 193 . . E D ; TEXT DOESN'T MATCH 194 . . . S NOTM=NOTM+1 ;NO TEXT MATCH COUNTER 195 . . . S ZV=$$ZVALUE("NAME")_"^"_$$ZVALUE("STR","C0CD") 196 . . . W ZV,! 197 . . . D PUSH^GPLXPATH("TXTNM",ZV) ; RECORD THE TXT MISMATCH 198 . E S NOMATCH=NOMATCH+1 ; NOT FOUND IN RXNORM 199 . D GETN1^C0CRNF("C0CB",176.111,C0CZX,"B","ALL") ;TRY TO GET FROM 176.111 200 . I $$ZVALUE("VUID","C0CB")="" D ; VUID NOT FOUND 201 . . ;W "NOT FOUND: ",C0CZX," ",$$ZVALUE("STR")," ",$$ZVALUE("RXCUI"),! 202 . . S MISSING=MISSING+1 203 . . D PUSH^GPLXPATH("MISSING",C0CZX) ;MISSING FROM MAPPING FILE 204 . E D ; FOUND IN VA MAPPING FILE 205 . . S FOUND=FOUND+1 206 . . I $$ZVALUE("VUID TEXT","C0CB")'=$$ZVALUE("NAME") D ; TEXT DOESN'T MATCH 207 . . . S NVAM=NVAM+1 ; MAPPING FILE TEXT IS DIFFERENT THAN NDF 208 . . . S ZY=$$ZVALUE("VUID TEXT","C0CB")_"^"_$$ZVALUE("NAME") ;BOTH STRINGS 209 . . . W "VA: ",ZY,! 210 . . . D PUSH^GPLXPATH("NVAM",ZY) ;SAVE IT 211 W "MISSING IN MAPPING FILE: ",MISSING,! 212 W "FOUND IN MAPPING FILE: ",FOUND,! 213 W "FOUND IN RXNORM: ",VMATCH,! 214 W "NOT FOUND IN RXNORM: ",NOMATCH,! 215 W "ERRORS: ",NOVUID,! 216 Q 217 ; 218 . I $$ZVALUE("MEDIATION CODE")="" D 219 . . S NORXN=NORXN+1 ; 220 . E D ; PROCESS MEDIATION CODE 221 . . S HASRXN=HASRXN+1 222 . . D SETFDA("MEDIATION CODE",$$ZVALUE("MEDIATION CODE")) ; 223 . I $$ZVALUE("VUID")="" D ; BAD RECORD 224 . . S NOVUID=NOVUID+1 225 . . ;D SETFDA("VUID",$$ZVALUE("VUID")) 226 . E D SETFDA("VUID TEXT",$$ZVALUE("VUID TEXT")) 227 . . ;ZWR C0CA 228 . D GETN1^C0CRNF("C0CB",176.001,$$ZVALUE("VUID"),"VUID","ALL") 229 . I $$ZVALUE("RXCUI","C0CB")'="" D ; RXNORM FOUND 230 . . S RXFOUND=RXFOUND+1 231 . . I $$ZVALUE("MEDIATION CODE")="" D ; THIS IS A NEW CODE 232 . . . D SETFDA("MEDIATION CODE",$$ZVALUE("RXCUI","C0CB")) 233 . . . D SETFDA("NEW","Y") ;FLAG RECORD HAS HAVING NEW RXNORM 234 . . W "RXNORM=",$$ZVALUE("RXCUI","C0CB")," ",$$ZVALUE("STR","C0CB"),! 235 . . W "VUID TEXT: ",$$ZVALUE("VUID TEXT"),! 236 . . I $$ZVALUE("VUID TEXT")=$$ZVALUE("STR","C0CB") S TXTMATCH=TXTMATCH+1 237 . . E D ; 238 . . . D PUSH^GPLXPATH("NOMATCH",$$ZVALUE("VUID TEXT")_"^"_$$ZVALUE("STR","C0CB")) 239 . . . D SETFDA("RXNORM TEXT",$$ZVALUE("STR","C0CB")) ; 240 . . . D SETFDA("DIFFERENT TEXT","Y") ;FLAG RECORD FOR DIFFERENT TEXT 241 . I $$ZVALUE("MEDIATION CODE")=$$ZVALUE("RXCUI","C0CB") D ; 242 . . S RXMATCH=RXMATCH+1 243 . . W "VUID=",$$ZVALUE("VUID")," MATCH RXNORM=",$$ZVALUE("MEDIATION CODE"),! 244 . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP 245 . S C0CFDA(176.112,"+"_C0CZX_",",.01)=$$ZVALUE("VUID") ; NEW VUID RECORD 246 . D UPDATE^DIE("","C0CFDA") 247 . I $D(^TMP("DIERR",$J)) U $P BREAK 248 W "HAS RXN=",HASRXN,! 249 W "NO RXN=",NORXN,! 250 W "NO VUID=",NOVUID,! 251 W "RXNORM FOUND=",RXFOUND,! 252 W "RXNORM MATCHES:",RXMATCH,! 253 W "TEXT MATCHES:",TXTMATCH,! 254 Q 255 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 256 ; TO SET TO VALUE C0CSV. 257 ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE 258 ; C0CSN,C0CSV ARE PASSED BY VALUE 259 ; 260 N C0CSI,C0CSJ 261 S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER 262 S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER 263 S C0CFDA(C0CSI,"+"_C0CZX_",",C0CSJ)=C0CSV 264 Q 265 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 266 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) 267 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 268 I '$D(ZTAB) S ZTAB="C0CA" 269 N ZR 270 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) 271 E S ZR="" 272 Q ZR 273 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 274 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) 275 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 276 I '$D(ZTAB) S ZTAB="C0CA" 277 N ZR 278 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) 279 E S ZR="" 280 Q ZR 281 ; 282 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 283 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) 284 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 285 I '$D(ZTAB) S ZTAB="C0CA" 286 N ZR 287 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) 288 E S ZR="" 289 Q ZR 290 ; -
ccr/branches/ohum/p/C0CRXNRD.m
r1342 r1428 1 C0CRXNRD 2 ;;0.1;C0C;nopatch;noreleasedate;Build 2 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 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CSNOA 2 ;;0.1;CCDCCR;nopatch;noreleasedate;Build 2 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 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CSOAP 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 TEST1 25 26 27 28 29 INITFARY(ARY) 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 RESTID(INNAM,INFARY) 53 54 55 56 57 58 59 60 61 62 63 TESTSOAP 64 65 66 67 68 69 70 SOAP(C0CRTN,C0CTID,C0CVA,C0CVOR,ALTXML,IFARY) 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 NEW 104 105 106 107 108 109 NOTNEW 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 DEMUXARY(OARY,IARY) 174 175 176 177 178 179 180 181 182 183 184 185 NORMAL(OUTXML,INXML) 186 187 188 189 190 191 192 193 194 195 196 197 MAP(RARY,IVARS,TPTR,INFARY) 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 TESTBIND 215 216 217 218 219 220 221 222 BIND(RARY,IVARS,INTPTR,INFARY) 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 1 C0CSOAP ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 "This is an SOAP utility library",! 21 W ! 22 Q 23 ; 24 TEST1 25 S url="https://ec2-75-101-247-83.compute-1.amazonaws.com:8181/ccr/CCRService?wsdl" 26 D GET1URL^C0CEWD2(url) 27 Q 28 ; 29 INITFARY(ARY) ;initialize the Fileman Field array for SOAP processing 30 ; ARY is passed by name 31 S @ARY@("XML FILE NUMBER")="178.301" 32 S @ARY@("BINDING SUBFILE NUMBER")="178.3014" 33 S @ARY@("MIME TYPE")="2.3" 34 S @ARY@("PROXY SERVER")="2.4" 35 S @ARY@("REPLY TEMPLATE")=".03" 36 S @ARY@("TEMPLATE NAME")=".01" 37 S @ARY@("TEMPLATE XML")="3" 38 S @ARY@("URL")="1" 39 S @ARY@("WSDL URL")="2" 40 S @ARY@("XML")="2.1" 41 S @ARY@("XML HEADER")="2.2" 42 S @ARY@("XPATH REDUCTION STRING")="2.5" 43 S @ARY@("CCR VARIABLE")="4" 44 S @ARY@("FILEMAN FIELD NAME")="1" 45 S @ARY@("FILEMAN FIELD NUMBER")="1.2" 46 S @ARY@("FILEMAN FILE POINTER")="1.1" 47 S @ARY@("INDEXED BY")=".05" 48 S @ARY@("SQLI FIELD NAME")="3" 49 S @ARY@("VARIABLE NAME")="2" 50 Q 51 ; 52 RESTID(INNAM,INFARY) ;EXTRINSIC TO RESOLVE TEMPLATE PASSED BY NAME 53 ; FILE IS IDENTIFIED IN FARY, PASSED BY NAME 54 I '$D(INFARY) D ; NO FILE ARRAY PASSED 55 . S INFARY="FARY" 56 . D INITFARY(INFARY) 57 N ZN,ZREF,ZR 58 S ZN=@INFARY@("XML FILE NUMBER") 59 S ZREF=$$FILEREF^C0CRNF(ZN) 60 S ZR=$O(@ZREF@("B",INNAM,"")) 61 Q ZR 62 ; 63 TESTSOAP ; 64 ; USING ICD9 WEB SERVICE TO TEST SOAP 65 S G("CODE")="E*" 66 S G("CODELN")=3 67 D SOAP("GPL","ICD9","G") 68 Q 69 ; 70 SOAP(C0CRTN,C0CTID,C0CVA,C0CVOR,ALTXML,IFARY) ; MAKES A SOAP CALL FOR 71 ; TEMPLATE ID C0CTID 72 ; RETURNS THE XML RESULT IN C0CRTN, PASSED BY NAME 73 ; C0CVA IS PASSED BY NAME AND IS THE VARIABLE ARRAY TO PASS TO BIND 74 ; C0CVOR IS THE NAME OF A VARIABLE OVERRIDE ARRAY, WHICH IS APPLIED 75 ; BEFORE MAPPING 76 ; IF ALTXML IS PASSED, BIND AND MAP WILL BE SKIPPED AND 77 ; ALTXML WILL BE USED INSTEAD 78 ; 79 ; ARTIFACTS SECTION 80 ; THE FOLLOWING WILL SET UP DEBUGGING ARTIFACTS FOR A POSSIBLE FUTURE 81 ; ONLINE DEBUGGER. IF DEBUG=1, VARIABLES CONTAINING INTERMEDIATE RESULTS 82 ; WILL NOT BE NEWED. 83 I $G(WSDEBUG)="" N C0CV ; CATALOG OF ARTIFACT VARIABLES AND ARRAYS 84 S C0CV(100,"C0CXF","XML TEMPLATE FILE NUMBER")="" 85 S C0CV(200,"C0CHEAD","SOAP HEADER VARIABLE NAME")="" 86 S C0CV(300,"HEADER","SOAP HEADER")="" 87 S C0CV(400,"C0CMIME","MIME TYPE")="" 88 S C0CV(500,"C0CURL","WS URL")="" 89 S C0CV(550,"C0CPURL","PROXY URL")="" 90 S C0CV(600,"C0CXML","XML VARIABLE NAME")="" 91 S C0CV(700,"XML","OUTBOUND XML")="" 92 S C0CV(800,"C0CRSLT","RAW XML RESULT RETURNED FROM WEB SERVICE")="" 93 S C0CV(900,"C0CRHDR","RETURNED HEADER")="" 94 S C0CV(1000,"C0CRXML","XML RESULT NORMALIZED")="" 95 S C0CV(1100,"C0CR","REPLY TEMPLATE")="" 96 S C0CV(1200,"C0CREDUX","REDUX STRING")="" 97 S C0CV(1300,"C0CIDX","RESULT XPATH INDEX")="" 98 S C0CV(1400,"C0CARY","RESULT XPATH ARRAY")="" 99 S C0CV(1500,"C0CNOM","RESULT DOM DOCUMENT NAME")="" 100 S C0CV(1600,"C0CID","RESULT DOM ID")="" 101 I $G(DEBUG)'="" G NOTNEW ; SKIP NEWING THE VARIABLES IF IN DEBUG 102 N ZI,ZJ S ZI="" 103 NEW 104 S ZI=$O(C0CV(ZI)) 105 S ZJ=$O(C0CV(ZI,"")) ; SET UP NEW COMMAND 106 ;W ZJ,! 107 N @ZJ ; NEW THE VARIABLE 108 I $O(C0CV(ZI))'="" G NEW ;LOOP TO GET NEW IN CONTEXT 109 NOTNEW 110 ; END ARTIFACTS 111 ; 112 I '$D(IFARY) D INITFARY("C0CF") ; SET FILE NUMBER AND PARAMATERS 113 E D ; 114 . K C0CF 115 . M C0CF=@IFARY 116 S C0CXF=C0CF("XML FILE NUMBER") ; FILE NUMBER FOR THE XML TEMPLATE FILE 117 I +C0CTID=0 D ; A STRING WAS PASSED FOR THE TEMPLATE NAME 118 . S C0CUTID=$$RESTID(C0CTID,"C0CF") ;RESOLVE TEMPLATE IEN FROM NAME 119 E S C0CUTID=C0CTID ; AN IEN WAS PASSED 120 N XML,TEMPLATE,HEADER 121 N C0CFH S C0CFH=C0CF("XML HEADER") 122 S C0CHEAD=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFH,,"HEADER") 123 N C0CFM S C0CFM=C0CF("MIME TYPE") 124 S C0CMIME=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFM) 125 N C0CFP S C0CFP=C0CF("PROXY SERVER") 126 S C0CPURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFP) 127 N C0CFU S C0CFU=C0CF("URL") 128 S C0CURL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFU) 129 N C0CFX S C0CFX=C0CF("XML") 130 S C0CXML=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFX,,"XML") 131 N C0CFT S C0CFT=C0CF("TEMPLATE XML") 132 S C0CTMPL=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFT,,"TEMPLATE") 133 I C0CTMPL="TEMPLATE" D ; there is a template to process 134 . K XML ; going to replace the xml array 135 . N VARS 136 . I $D(C0CVOR) M @C0CVA=@C0CVOR ; merge in varible overrides 137 . I '$D(ALTXML) D ; if ALTXML is passed in, don't bind 138 . . D BIND("VARS",C0CVA,C0CUTID,"C0CF") 139 . . D MAP("XML","VARS",TPTR,"C0CF") 140 . . K XML(0) 141 . E M XML=@ALTXML ; use ALTXML instead 142 I $G(C0CPROXY) S C0CURL=C0CPURL 143 K C0CRSLT,C0CRHDR 144 B 145 S ok=$$httpPOST^%zewdGTM(C0CURL,.XML,C0CMIME,.C0CRSLT,.HEADER,"",.gpl5,.C0CRHDR) 146 K C0CRXML 147 D NORMAL("C0CRXML","C0CRSLT(1)") ;RETURN XML IN AN ARRAY 148 N C0CFR S C0CFR=$G(C0CF("REPLY TEMPLATE")) 149 S C0CR=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFR,"I") ; REPLY TEMPLATE 150 ; reply templates are optional and are specified by populating a 151 ; template pointer in field 2.5 of the request template 152 ; if specified, the reply template is the source of the REDUX string 153 ; used for XPath on the reply, and for UNBIND processing 154 ; if no reply template is specified, REDUX is obtained from the request 155 ; template and no UNBIND processing is performed. The XPath array is 156 ; returned without variable bindings 157 I C0CR'="" D ; REPLY TEMPLATE EXISTS 158 . I +$G(DEBUG)'=0 W "REPLY TEMPLATE:",C0CR,! 159 . S C0CTID=C0CR ; 160 N C0CFRDX S C0CFRDX=C0CF("XPATH REDUCTION STRING") 161 S C0CREDUX=$$GET1^DIQ(C0CXF,C0CUTID_",",C0CFRDX) ;XPATH REDUCTION STRING 162 K C0CIDX,C0CARY ; XPATH INDEX AND ARRAY VARS 163 S C0CNOM="C0CWS"_$J ; DOCUMENT NAME FOR THE DOM 164 S C0CID=$$PARSE^C0CXEWD("C0CRXML",C0CNOM) ;CALL THE PARSER 165 S C0CID=$$FIRST^C0CXEWD($$ID^C0CXEWD(C0CNOM)) ;ID OF FIRST NODE 166 D XPATH^C0CXEWD(C0CID,"/","C0CIDX","C0CARY","",C0CREDUX) ;XPATH GENERATOR 167 ; Next, call UNBIND to map the reply XPath array to variables 168 ; This is only done if a Reply Template is provided 169 D DEMUXARY(C0CRTN,"C0CARY") 170 ; M @C0CRTN=C0CARY 171 Q 172 ; 173 DEMUXARY(OARY,IARY) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO 174 ; FORMAT @OARY@(x,xpath) where x is the first multiple 175 N ZI,ZJ,ZK,ZL S ZI="" 176 F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; 177 . D DEMUX^C0CMXP("ZJ",ZI) 178 . S ZK=$P(ZJ,"^",3) 179 . S ZK=$RE($P($RE(ZK),"/",1)) 180 . S ZL=$P(ZJ,"^",1) 181 . I ZL="" S ZL=1 182 . S @OARY@(ZL,ZK)=@IARY@(ZI) 183 Q 184 ; 185 NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML 186 ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME 187 ; 188 N ZI,ZN,ZTMP 189 S ZN=1 190 S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">" 191 S ZN=ZN+1 192 F S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)="" D ; 193 . S @OUTXML@(ZN)=@OUTXML@(ZN)_">" 194 . S ZN=ZN+1 195 Q 196 ; 197 MAP(RARY,IVARS,TPTR,INFARY) ;RETURNS MAPPED XML IN RARY PASSED BY NAME 198 ; IVARS IS AN XPATH ARRAY PASSED BY NAME 199 ; TPTR IS A POINT TO THE C0C XML TEMPLATE FILE USED TO RETRIEVE THE TEMPLATE 200 ; 201 N ZT ;THE TEMPLATE 202 K ZT,@RARY 203 I '$D(INFARY) D ; 204 . S INFARY="FARY" 205 . D INITFARY(INFARY) 206 N ZF,ZFT 207 S ZF=@INFARY@("XML FILE NUMBER") 208 S ZFT=@INFARY@("TEMPLATE XML") 209 I $$GET1^DIQ(ZF,TPTR_",",ZFT,,"ZT")'="ZT" D Q ; ERROR GETTING TEMPLATE 210 . W "ERROR RETRIEVING TEMPLATE",! 211 D MAP^C0CXPATH("ZT",IVARS,RARY) ;DO THE MAPPING 212 Q 213 ; 214 TESTBIND ; 215 S G1("TESTONE")=1 216 S G1("TESTTWO")=2 217 D BIND("G","G1","TEST") 218 W ! 219 ZWR G 220 Q 221 ; 222 BIND(RARY,IVARS,INTPTR,INFARY) ;RETURNS AN XPATH ARRAY IN RARY FOR USE WITH MAP 223 ; TO BUILD AN INSTANTIATED TEMPLATE 224 ; TPTR IS THE IEN OF THE XML TEMPATE IN THE C0C XML TEMPLATE FILE 225 ; LOOPS THROUGHT THE BINDING SUBFILE TO PULL OUT XPATHS AND 226 ; EITHER ASSIGNS VARIABLES OR DOES A FILEMAN CALL TO GET VALUES 227 ; VARIABLES ARE IN IVARS WHICH IS PASSED BY NAME 228 I '$D(INFARY) D ; 229 . S INFARY="FARY" 230 . D INITFARY(INFARY) ;INITIALIZE FILE ARRAY IF NOT PASSED 231 I +INTPTR>0 S TPTR=INTPTR 232 E S TPTR=$$RESTID(INTPTR,INFARY) 233 N C0CFF,C0CBF,C0CXI,C0CFREF,C0CXREF 234 S C0CFF=@INFARY@("XML FILE NUMBER") ;fileman file number of XML file 235 S C0CFREF=$$FILEREF^C0CRNF(C0CFF) ; closed file reference to the file 236 S C0CBF=@INFARY@("BINDING SUBFILE NUMBER") ; BINDING SUBFILE NUMBER 237 S C0CXI=$G(@INFARY@("XPATH INDEX")) ; index to the XPath bindings 238 I C0CXI="" S C0CXI="XPATH" ; default is the XPATH index 239 ; this needs to be a whole file index on the XPath subfile with 240 ; the Template IEN perceding the XPath in the index 241 N ZI 242 S ZI="" 243 S C0CXREF=$NA(@C0CFREF@(C0CXI,TPTR)) ; where the xref is 244 ;F S ZI=$O(^C0CX(TPTR,5,"B",ZI)) Q:ZI="" D ; FOR EACH XPATH 245 F S ZI=$O(@C0CXREF@(ZI)) Q:ZI="" D ; for each XPath in this template 246 . ;W !,ZI," ",$O(@C0CXREF@(ZI,TPTR,"")) 247 . N ZIEN,ZFILE,ZFIELD,ZVAR,ZIDX,ZINDEX ; 248 . S ZIEN=$O(@C0CXREF@(ZI,TPTR,"")) ; IEN OF THE BINDING RECORD 249 . N ZFF S ZFF=@INFARY@("FILEMAN FILE POINTER") 250 . S ZFILE=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFF,"I") 251 . N ZFFLD S ZFFLD=@INFARY@("FILEMAN FIELD NUMBER") 252 . S ZFIELD=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFFLD,"I") 253 . N ZFV S ZFV=@INFARY@("VARIABLE NAME") 254 . S ZVAR=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFV,"E") 255 . N ZFX S ZFX=("INDEXED BY") 256 . S ZIDX=$$GET1^DIQ(C0CBF,ZIEN_","_TPTR_",",ZFX,"I") 257 . S ZINDEX="" 258 . I ZIDX="DUZ" S ZINDEX=$G(DUZ) ; FILE IS INDEXED BY DUZ 259 . I ZIDX="DFN" S ZINDEX=$G(DFN) ; BY DFN 260 . E I ZIDX'="" S ZINDEX=$G(@ZIDX) ; index variable 261 . ;I ZIDX="ACCT" S ZINDEX=C0CACCT ; BY ACCOUNT RECORD POINT TO C0C WS ACCT 262 . ;I ZIDX="LOC" S ZINDEX=C0CLOC ; BY LOCATION 263 . I ZVAR'="" D ; VARIABLES TAKE PRESCIDENCE OVER FILEMAN FIELDS 264 . . S @RARY@(ZI)=@IVARS@(ZVAR) ; 265 . E D ; IF NO VARIABLE, TRY ACCESSING FROM FILEMAN 266 . . I (ZFILE="")!(ZFIELD="") Q ;QUIT IF FILE OR FIELD NOT THERE 267 . . D CLEAN^DILF 268 . . S @RARY@(ZI)=$$GET1^DIQ(ZFILE,ZINDEX_",",ZFIELD) ;GET THE VALUE 269 . . I $D(^TMP("DIERR",$J,1)) D B ; 270 . . . W "ERROR!",! 271 . . . ZWR ^TMP("DIERR",$J,*) 272 Q 273 ; -
ccr/branches/ohum/p/C0CSUB1.m
r1342 r1428 1 C0CSUB1 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 CHK1(DFN) 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 SUBALL 46 47 48 49 50 51 52 53 SUB1(DFN,C0CSS) 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 UPDIE 69 70 71 72 73 74 75 76 77 78 79 VARPTR(ZVAR,ZTYP) 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 SETFDA(C0CSN,C0CSV) 102 103 104 105 106 107 108 109 110 111 ZFILE(ZFN,ZTAB) 112 113 114 115 116 117 118 119 ZFIELD(ZFN,ZTAB) 120 121 122 123 124 125 126 127 128 ZVALUE(ZFN,ZTAB) 129 130 131 132 133 134 135 136 1 C0CSUB1 ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 SUBSCRIPTIONN Utility Library ",! 21 Q 22 ; 23 CHK1(DFN) ; ADD THE CHECKSUM FOR ONE PATIENT 24 ; 25 S C0CCHK=$NA(^TMP("C0CRIM","CHKSUM")) 26 S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE 27 S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE 28 S C0CSFC=177.1012 ; FILE NUMBER FOR CHECKSUM SUBFILE 29 S C0CSFDC=177.10121 ; FILE NUMBER FOR DOMAIN CHECKSUMS 30 S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT 31 K C0CFDA 32 S C0CALL=$G(@C0CCHK@(DFN,"ALL")) 33 I C0CALL'="" S C0CFDA(C0CSFC,"?+1,"_C0CPAT_",",.01)=C0CALL 34 E Q ; NO CHECKSUMS FOR THISPATIENT 35 D UPDIE 36 N C0CJ S C0CJ="" 37 F S C0CJ=$O(@C0CCHK@(DFN,"DOMAIN",C0CJ)) Q:C0CJ="" D ; FOR EACH DOMAIN 38 . S C0CD=$O(^C0CDIC(170.101,"B",C0CJ,"")) 39 . W C0CJ," ",C0CD,! 40 . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",.01)=C0CD 41 . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",1)=@C0CCHK@(DFN,"DOMAIN",C0CJ) 42 . D UPDIE 43 Q 44 ; 45 SUBALL ; SUBSCRIBE ALL PATIENTS IN CCR GLOBALS TO SUBCRIBER 1 46 ; 47 S C0CGLB=$NA(^TMP("C0CRIM","VARS")) 48 S C0CI="" 49 F S C0CI=$O(@C0CGLB@(C0CI)) Q:C0CI="" D ; FOR EACH PATIENT 50 . D SUB1(C0CI,1) ;SUBSCIRBE THEM TO EPCRN 51 Q 52 ; 53 SUB1(DFN,C0CSS) ; SUBSCRIBE ONE PATIENT TO SUBSCRIBER C0CSS 54 ; 55 S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE 56 S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE 57 S C0CSFC=177.10121 ; FILE NUMBER FOR CHECKSUMS 58 S C0CSSF=177.201 ; FILE NUMBER FOR SUBSCRIBER FILE 59 K C0CFDA 60 S C0CFDA(C0CSF,"+1,",.01)=DFN 61 D UPDIE ; ADD THE PATIENT 62 S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT 63 S C0CFDA(C0CSFS,"+1,"_C0CPAT_",",.01)=C0CSS ; C0CSS IS A POINTER 64 D UPDIE ; ADD THE SUBSCRIPTION 65 D CHK1(DFN) ; ADD THE CHECKSUMS 66 Q 67 ; 68 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 69 K ZERR 70 D CLEAN^DILF 71 D UPDATE^DIE("","C0CFDA","","ZERR") 72 I $D(ZERR) D ; 73 . W "ERROR",! 74 . ZWR ZERR 75 . B 76 K C0CFDA 77 Q 78 ; 79 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE 80 ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO 81 ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO 82 ; 83 N ZCCRD,ZVARN,C0CFDA2 84 S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY 85 S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 86 I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT 87 . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE 88 . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! 89 . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE 90 . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE 91 . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN 92 . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY 93 . I $D(ZERR) D ; LAYGO ERROR 94 . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! 95 . E D ; 96 . . D CLEAN^DILF ; CLEAN UP 97 . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 98 . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! 99 Q ZVARN 100 ; 101 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 102 ; TO SET TO VALUE C0CSV. 103 ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE 104 ; C0CSN,C0CSV ARE PASSED BY VALUE 105 ; 106 N C0CSI,C0CSJ 107 S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER 108 S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER 109 S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV 110 Q 111 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 112 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) 113 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 114 I '$D(ZTAB) S ZTAB="C0CA" 115 N ZR 116 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) 117 E S ZR="" 118 Q ZR 119 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 120 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) 121 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 122 I '$D(ZTAB) S ZTAB="C0CA" 123 N ZR 124 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) 125 E S ZR="" 126 Q ZR 127 ; 128 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 129 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) 130 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 131 I '$D(ZTAB) S ZTAB="C0CA" 132 N ZR 133 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) 134 E S ZR="" 135 Q ZR 136 ; -
ccr/branches/ohum/p/C0CSYS.m
r1342 r1428 1 C0CSYS 2 ;;1.0;C0C;;May 19, 2009;Build 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 SYSNAME() 30 31 32 33 SYSVER() 34 35 36 PTST(DFN) 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 1 C0CSYS ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 "Enter at appropriate points." Q 21 ; 22 ; Originally, I was going to use VEPERVER, but VEPERVER 23 ; actually kills ^TMP($J), outputs it to the screen in a user-friendly 24 ; manner (press any key to continue), 25 ; and is really a very half finished routine 26 ; 27 ; So for now, I am hard-coding the values. 28 ; 29 SYSNAME() ;Get EHR System Name; PUBLIC; Extrinsic 30 Q:$G(DUZ("AG"))="I" "RPMS" 31 Q "WorldVistA EHR/VOE" 32 ; 33 SYSVER() ;Get EHR System Version; PUBLIC; Extrinsic 34 Q "1.0" 35 ; 36 PTST(DFN) ;TEST TO SEE IF PATIENT MERGED OR A TEST PATIENT 37 ; DFN = IEN of the Patient to be tested 38 ; 1 = Merged or Test Patient 39 ; 0 = Non-test Patient 40 ; 41 I DFN="" Q 0 ; BAD DFN PASSED 42 I $D(^DPT(DFN,-9)) Q 1 ;This patient has been merged 43 I $G(^DPT(DFN,0))="" Q 1 ;Missing zeroth node <---add 44 ; 45 I '$D(CCRTEST) S CCRTEST=1 ; DEFAULT IS THAT WE ARE TESTING 46 I CCRTEST Q 0 ; IF WE ARE TESTING, DON'T REJECT TEST PATIENTS 47 N DIERR,DATA 48 I $$TESTPAT^VADPT(DFN) Q 1 ; QUIT IF IT'S A VA TEST PATIENT 49 S DATA=+$$GET1^DIQ(2,DFN_",",.6,"I") ;Test Patient Indicator 50 ; 1 = Test Patient 51 ; 0 = Non-test Patient 52 I DATA Q DATA 53 S DATA=$$GET1^DIQ(2,DFN_",",.09,"I") ;SSN test 54 D CLEAN^DILF 55 I "Pp"[$E(DATA,$L(DATA),$L(DATA)) Q 0 ;Allow Pseudo SSN 56 I $E(DATA,1,3)="000" Q 1 57 I $E(DATA,1,3)="666" Q 1 58 Q 0 59 ; -
ccr/branches/ohum/p/C0CUNIT.m
r1342 r1428 1 C0CUNIT 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 ZT(ZARY,BAT,TST) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 ZLOAD(ZARY,ROUTINE) 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 ZTEST(ZARY,WHICH) 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 TEST 107 108 109 110 111 112 113 114 115 116 117 GTSTS(GTZARY,RTN) 118 119 120 121 122 123 124 TESTALL(RNM) 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 TLIST(ZARY) 144 145 146 147 148 149 150 151 152 153 154 155 156 157 MEDS 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 PAT 175 176 177 178 179 180 181 182 183 184 185 186 1 C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 "This is a unit testing library",! 21 W ! 22 Q 23 ; 24 ZT(ZARY,BAT,TST) ; private routine to add a test case to the ZARY array 25 ; ZARY IS PASSED BY REFERENCE 26 ; BAT is a string identifying the test battery 27 ; TST is a test which will evaluate to true or false 28 ; I '$G(ZARY) D 29 ; . S ZARY(0)=0 ; initially there are no elements 30 ; W "GOT HERE LOADING "_TST,! 31 N CNT ; count of array elements 32 S CNT=ZARY(0) ; contains array count 33 S CNT=CNT+1 ; increment count 34 S ZARY(CNT)=TST ; put the test in the array 35 I $D(ZARY(BAT)) D ; NOT THE FIRST TEST IN BATTERY 36 . N II,TN ; TEMP FOR ENDING TEST IN BATTERY 37 . S II=$P(ZARY(BAT),"^",2) 38 . S $P(ZARY(BAT),"^",2)=II+1 39 I '$D(ZARY(BAT)) D ; FIRST TEST IN THIS BATTERY 40 . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY 41 . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX 42 . ; S TN=$NA(ZARY("TESTS")) 43 . ; D PUSH^C0CXPATH(TN,BAT) 44 S ZARY(0)=CNT ; update the array counter 45 Q 46 ; 47 ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference 48 ; ZARY IS PASSED BY NAME 49 ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") 50 ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE 51 K @ZARY 52 S @ZARY@(0)=0 ; initialize array count 53 N LINE,LABEL,BODY 54 N INTEST S INTEST=0 ; switch for in the test case section 55 N SECTION S SECTION="[anonymous]" ; test case section 56 ; 57 N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D 58 . I LINE?." "1";;><TEST>".E S INTEST=1 ; entering test section 59 . I LINE?." "1";;><TEMPLATE>".E S INTEST=1 ; entering TEMPLATE section 60 . I LINE?." "1";;></TEST>".E S INTEST=0 ; leaving test section 61 . I LINE?." "1";;></TEMPLATE>".E S INTEST=0 ; leaving TEMPLATE section 62 . I INTEST D ; within the testing section 63 . . I LINE?." "1";;><".E D ; section name found 64 . . . S SECTION=$P($P(LINE,";;><",2),">",1) ; pull out name 65 . . I LINE?." "1";;>>".E D ; test case found 66 . . . D ZT(.@ZARY,SECTION,$P(LINE,";;>>",2)) ; put the test in the array 67 S @ZARY@("ALL")="1"_"^"_@ZARY@(0) ; MAKE A BATTERY FOR ALL 68 Q 69 ; 70 ZTEST(ZARY,WHICH) ; try out the tests using a passed array ZTEST 71 N ZI,ZX,ZR,ZP 72 S DEBUG=0 73 ; I WHICH="ALL" D Q ; RUN ALL THE TESTS 74 ; . W "DOING ALL",! 75 ; . N J,NT 76 ; . S NT=$NA(ZARY("TESTS")) 77 ; . W NT,@NT@(0),! 78 ; . F J=1:1:@NT@(0) D ; 79 ; . . W @NT@(J),! 80 ; . . D ZTEST^C0CUNIT(@ZARY,@NT@(J)) 81 I '$D(ZARY(WHICH)) D Q ; TEST SECTION DOESN'T EXIST 82 . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,! 83 N FIRST,LAST 84 S FIRST=$P(ZARY(WHICH),"^",1) 85 S LAST=$P(ZARY(WHICH),"^",2) 86 F ZI=FIRST:1:LAST D 87 . I ZARY(ZI)?1">"1.E D ; NOT A TEST, JUST RUN THE STATEMENT 88 . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) 89 . . ; W ZP,! 90 . . S ZX=ZP 91 . . W "RUNNING: "_ZP 92 . . X ZX 93 . . W "..SUCCESS: ",WHICH,! 94 . I ZARY(ZI)?1"?"1.E D ; THIS IS A TEST 95 . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) 96 . . S ZX="S ZR="_ZP 97 . . W "TRYING: "_ZP 98 . . X ZX 99 . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),! 100 . . I '$D(TPASSED) D ; NOT INITIALIZED YET 101 . . . S TPASSED=0 S TFAILED=0 102 . . I ZR S TPASSED=TPASSED+1 103 . . I 'ZR S TFAILED=TFAILED+1 104 Q 105 ; 106 TEST ; RUN ALL THE TEST CASES 107 N ZTMP 108 D ZLOAD(.ZTMP) 109 D ZTEST(.ZTMP,"ALL") 110 W "PASSED: ",TPASSED,! 111 W "FAILED: ",TFAILED,! 112 W ! 113 W "THE TESTS!",! 114 ; I DEBUG ZWR ZTMP 115 Q 116 ; 117 GTSTS(GTZARY,RTN) ; return an array of test names 118 N I,J S I="" S I=$O(GTZARY("TESTS",I)) 119 F J=0:0 Q:I="" D 120 . D PUSH^C0CXPATH(RTN,I) 121 . S I=$O(GTZARY("TESTS",I)) 122 Q 123 ; 124 TESTALL(RNM) ; RUN ALL THE TESTS 125 N ZI,J,TZTMP,TSTS,TOTP,TOTF 126 S TOTP=0 S TOTF=0 127 D ZLOAD^C0CUNIT("TZTMP",RNM) 128 D GTSTS(.TZTMP,"TSTS") 129 F ZI=1:1:TSTS(0) D ; 130 . S TPASSED=0 S TFAILED=0 131 . D ZTEST^C0CUNIT(.TZTMP,TSTS(ZI)) 132 . S TOTP=TOTP+TPASSED 133 . S TOTF=TOTF+TFAILED 134 . S $P(TSTS(ZI),"^",2)=TPASSED 135 . S $P(TSTS(ZI),"^",3)=TFAILED 136 F ZI=1:1:TSTS(0) D ; 137 . W "TEST=> ",$P(TSTS(ZI),"^",1) 138 . W " PASSED=>",$P(TSTS(ZI),"^",2) 139 . W " FAILED=>",$P(TSTS(ZI),"^",3),! 140 W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,! 141 Q 142 ; 143 TLIST(ZARY) ; LIST ALL THE TESTS 144 ; THEY ARE MARKED AS ;;><TESTNAME> IN THE TEST CASES 145 ; ZARY IS PASSED BY REFERENCE 146 N I,J,K S I="" S I=$O(ZARY("TESTS",I)) 147 S K=1 148 F J=0:0 Q:I="" D 149 . ; W "I IS NOW=",I,! 150 . W I," " 151 . S I=$O(ZARY("TESTS",I)) 152 . S K=K+1 I K=6 D 153 . . W ! 154 . . S K=1 155 Q 156 ; 157 MEDS 158 N DEBUG S DEBUG=0 159 N DFN S DFN=5685 160 K ^TMP($J) 161 W "Loading CCR Template into T using LOAD^GPLCCR0($NA(^TMP($J,""CCR"")))",!! 162 N T S T=$NA(^TMP($J,"CCR")) D LOAD^GPLCCR0(T) 163 N XPATH S XPATH="//ContinuityOfCareRecord/Body/Medications" 164 W "XPATH is: "_XPATH,! 165 W "Getting Med Template into INXML using",! 166 W "QUERY^GPLXPATH(T,XPATH,""INXML"")",!! 167 D QUERY^GPLXPATH(T,XPATH,"INXML") 168 W "Executing EXTRACT^C0CMED(INXML,DFN,OUTXML)",! 169 W "OUTXML will be ^TMP($J,""OUT"")",! 170 N OUTXML S OUTXML=$NA(^TMP($J,"OUT")) 171 D EXTRACT^C0CMED6("INXML",DFN,OUTXML) 172 D FILEOUT^C0CRNF(OUTXML,"TESTMEDS.xml") 173 Q 174 PAT 175 D ANALYZE^ARJTXRD("C0CDPT",.OUT) ; Analyze a routine in the directory 176 N X,Y 177 ; Select Patient 178 S DIC=2,DIC(0)="AEMQ" D ^DIC 179 ; 180 W "You have selected patient "_Y,!! 181 N I S I=89 F S I=$O(OUT(I)) Q:I="ALINE" D 182 . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" " 183 . W "valued at " 184 . W @("$$"_$P(OUT(I,0),"(DFN)")_"^"_"C0CDPT"_"("_$P(Y,"^")_")") 185 . W ! 186 Q -
ccr/branches/ohum/p/C0CUTIL.m
r1342 r1428 1 C0CUTIL 2 ;;0.1;C0C;;Jun 15, 2008;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 UUID() 25 26 27 28 29 30 OLDUUID() 31 32 33 34 35 36 FMDTOUTC(DATE,FORMAT) 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 SORTDT(V1,V2,ORDR) 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 DA2SNO(RTN,DNAME) 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 DASNO(DANAME) 119 120 121 122 123 124 125 126 127 DASNALL(WHICH) 128 129 130 131 132 133 134 135 136 137 RXNFN() 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 167 RPMS() 168 169 VISTA() 170 171 WV() 172 173 OV() 174 175 1 C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;Copyright 2008-2009 Sam Habiel & George Lilly. 4 ;Licensed under the terms of the GNU 5 ;General Public License 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 W "No Entry at Top!" 22 Q 23 ; 24 UUID() ; thanks to Wally for this. 25 N R,I,J,N 26 S N="",R="" F S N=N_$R(100000) Q:$L(N)>64 27 F I=1:2:64 S R=R_$E("0123456789abcdef",($E(N,I,I+1)#16+1)) 28 Q $E(R,1,8)_"-"_$E(R,9,12)_"-4"_$E(R,14,16)_"-"_$E("89ab",$E(N,17)#4+1)_$E(R,18,20)_"-"_$E(R,21,32) 29 ; 30 OLDUUID() ; GENERATE A RANDOM UUID (Version 4) 31 N I,J,ZS 32 S ZS="0123456789abcdef" S J="" 33 F I=1:1:36 S J=J_$S((I=9)!(I=14)!(I=19)!(I=24):"-",I=15:4,I=20:"a",1:$E(ZS,$R(16)+1)) 34 Q J 35 ; 36 FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic 37 ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time) 38 ; If not passed, or passed incorrectly, it's assumed that it is D. 39 ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied. 40 ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC 41 ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters) 42 N UTC,Y,M,D,H,MM,S,OFF 43 S Y=1700+$E(DATE,1,3) 44 S M=$E(DATE,4,5) 45 S D=$E(DATE,6,7) 46 S H=$E(DATE,9,10) 47 I $L(H)=1 S H="0"_H 48 S MM=$E(DATE,11,12) 49 I $L(MM)=1 S MM="0"_MM 50 S S=$E(DATE,13,14) 51 I $L(S)=1 S S="0"_S 52 S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation. 53 S OFFS=$E(OFF,1,1) 54 S OFF0=$TR(OFF,"+-") 55 S OFF1=$E(OFF0+10000,2,3) 56 S OFF2=$E(OFF0+10000,4,5) 57 S OFF=OFFS_OFF1_":"_OFF2 58 ;S OFF2=$E(OFF,1,2) ; 59 ;S OFF2=$E(100+OFF2,2,3) ; GPL 11/08 CHANGED TO -05:00 FORMAT 60 ;S OFF3=$E(OFF,3,4) ;MINUTES 61 ;S OFF=$S(OFF2="":"00",0:"00",1:OFF2)_"."_$S(OFF3="":"00",1:OFF3) 62 ; If H, MM and S are empty, it means that the FM date didn't supply the time. 63 ; In this case, set H, MM and S to "00" 64 ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING? 65 S:'$L(H) H="00" 66 S:'$L(MM) MM="00" 67 S:'$L(S) S="00" 68 S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds 69 I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time. 70 E Q $P(UTC,"T") 71 ; 72 SORTDT(V1,V2,ORDR) ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT 73 ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE 74 ; DATE AND TIME ORDER. DEFAULT IS FORWARD 75 ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT 76 ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER 77 ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER 78 ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC 79 ; BOTH V1 AND V2 ARE PASSED BY REFERENCE 80 N VSRT ; TEMP FOR HASHING DATES 81 N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2 82 S ZCNT=V2(0) ; COUNTING NUMBER OF DATES 83 F ZI=1:1:ZCNT D ; FOR EACH DATE IN THE ARRAY 84 . I $D(V2(ZI)) D ; IF THE DATE EXISTS 85 . . S ZP1=$P(V2(ZI),".",1) ; THE DATE PIECE 86 . . S ZP2=$P(V2(ZI),".",2) ; THE TIME PIECE 87 . . ; W "DATE: ",ZP1," TIME: ",ZP2,! 88 . . S VSRT(ZP1,ZP2,ZI)=ZI ; INDEX OF DATE, TIME AND COUNT 89 N ZG 90 S ZG=$Q(VSRT("")) 91 F D Q:ZG="" ; 92 . ; W ZG,! 93 . D PUSH^C0CXPATH("V1",@ZG) 94 . S ZG=$Q(@ZG) 95 I ORDR=-1 D ; HAVE TO REVERSE ORDER 96 . N ZG2 97 . F ZI=1:1:V1(0) D ; FOR EACH ELELMENT 98 . . S ZG2(V1(0)-ZI+1)=V1(ZI) ; SET IN REVERSE ORDER 99 . S ZG2(0)=V1(0) 100 . D CP^C0CXPATH("ZG2","V1") ; COPY OVER THE NEW ARRAY 101 Q ZCNT 102 ; 103 DA2SNO(RTN,DNAME) ; LOOK UP DRUG ALLERGY CODE IN ^LEX 104 ; RETURNS AN ARRAY RTN PASSED BY REFERENCE 105 ; THIS ROUTINE CAN BE USED AS AN RPC 106 ; RTN(0) IS THE NUMBER OF ELEMENTS IN THE ARRAY 107 ; RTN(1) IS THE SNOMED CODE FOR THE DRUG ALLERGY 108 ; 109 N LEXIEN 110 I $O(^LEX(757.21,"ADIS",DNAME,""))'="" D ; IEN FOUND FOR THIS DRUG 111 . S LEXIEN=$O(^LEX(757.21,"ADIS",DNAME,"")) ; GET THE IEN IN THE LEXICON 112 . W LEXIEN,! 113 . S RTN(1)=$P(^LEX(757.02,LEXIEN,0),"^",2) ; SNOMED CODE IN P2 114 . S RTN(0)=1 ; ONE THING RETURNED 115 E S RTN(0)=0 ; NOT FOUND 116 Q 117 ; 118 DASNO(DANAME) ; PRINTS THE SNOMED CODE FOR ALLERGY TO DRUG DANAME 119 ; 120 N DARTN 121 D DA2SNO(.DARTN,DANAME) ; CALL THE LOOKUP ROUTINE 122 I DARTN(0)>0 D ; GOT RESULTS 123 . W !,DARTN(1) ;PRINT THE SNOMED CODE 124 E W !,"NOT FOUND",! 125 Q 126 ; 127 DASNALL(WHICH) ; ROUTINE TO EXAMINE THE ADIS INDEX IN LEX AND RETRIEVE ALL 128 ; ASSOCIATED SNOMED CODES 129 N DASTMP,DASIEN,DASNO 130 S DASTMP="" 131 F S DASTMP=$O(^LEX(757.21,WHICH,DASTMP)) Q:DASTMP="" D ; NAME OF MED 132 . S DASIEN=$O(^LEX(757.21,WHICH,DASTMP,"")) ; IEN OF MED 133 . S DASNO=$P(^LEX(757.02,DASIEN,0),"^",2) ; SNOMED CODE FOR ENTRY 134 . W DASTMP,"=",DASNO,! ; PRINT IT OUT 135 Q 136 ; 137 RXNFN() Q 1130590011.001 ; RxNorm Concepts file number 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 RPMS() ; Are we running on an RPMS system rather than Vista? 168 Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service 169 VISTA() ; Are we running on Vanilla Vista? 170 Q $G(DUZ("AG"))="V" ; If User Agency is VA 171 WV() ; Are we running on WorldVista? 172 Q $G(DUZ("AG"))="E" ; Code for WV. 173 OV() ; Are we running on OpenVista? 174 Q $G(DUZ("AG"))="O" ; Code for OpenVista 175 -
ccr/branches/ohum/p/C0CVA200.m
r1342 r1428 1 C0CVA200 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 FAMILY(DUZ) 26 27 28 29 30 31 32 GIVEN(DUZ) 33 34 35 36 37 38 39 MIDDLE(DUZ) 40 41 42 43 44 45 46 SUFFIX(DUZ) 47 48 49 50 51 52 53 TITLE(DUZ) 54 55 56 57 58 59 60 61 NPI(DUZ) 62 63 64 65 66 67 68 69 70 71 72 73 SPEC(DUZ) 74 75 76 77 78 79 80 81 82 83 84 85 ADDTYPE(DUZ) 86 87 88 89 90 ADDLINE1(ADUZ) 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 CITY(ADUZ) 114 115 116 117 118 119 120 121 122 123 124 125 126 STATE(ADUZ) 127 128 129 130 131 132 133 134 135 136 137 138 POSTCODE(ADUZ) 139 140 141 142 143 144 145 146 147 148 149 150 TEL(DUZ) 151 152 153 154 155 156 157 TELTYPE(DUZ) 158 159 160 161 162 EMAIL(DUZ) 163 164 165 166 167 168 1 C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;Copyright 2008 Sam Habiel. 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 Q 20 ; This routine uses Kernel APIs and Direct Global Access to get 21 ; Proivder Data from File 200. 22 ; 23 ; The Global is VA(200,*) 24 ; 25 FAMILY(DUZ) ; Get Family Name; PUBLIC; EXTRINSIC 26 ; INPUT: DUZ (i.e. File 200 IEN) ByVal 27 ; OUTPUT: String 28 N NAME S NAME=$P(^VA(200,DUZ,0),U) 29 D NAMECOMP^XLFNAME(.NAME) 30 Q NAME("FAMILY") 31 ; 32 GIVEN(DUZ) ; Get Given Name; PUBLIC; EXTRINSIC 33 ; INPUT: DUZ ByVal 34 ; OUTPUT: String 35 N NAME S NAME=$P(^VA(200,DUZ,0),U) 36 D NAMECOMP^XLFNAME(.NAME) 37 Q NAME("GIVEN") 38 ; 39 MIDDLE(DUZ) ; Get Middle Name, PUBLIC; EXTRINSIC 40 ; INPUT: DUZ ByVal 41 ; OUTPUT: String 42 N NAME S NAME=$P(^VA(200,DUZ,0),U) 43 D NAMECOMP^XLFNAME(.NAME) 44 Q NAME("MIDDLE") 45 ; 46 SUFFIX(DUZ) ; Get Suffix Name, PUBLIC; EXTRINSIC 47 ; INPUT: DUZ ByVal 48 ; OUTPUT: String 49 N NAME S NAME=$P(^VA(200,DUZ,0),U) 50 D NAMECOMP^XLFNAME(.NAME) 51 Q NAME("SUFFIX") 52 ; 53 TITLE(DUZ) ; Get Title for Proivder, PUBLIC; EXTRINSIC 54 ; INPUT: DUZ ByVal 55 ; OUTPUT: String 56 ; Gets External Value of Title field in New Person File. 57 ; It's actually a pointer to file 3.1 58 ; 200=New Person File; 8 is Title Field 59 Q $$GET1^DIQ(200,DUZ_",",8) 60 ; 61 NPI(DUZ) ; Get NPI Number, PUBLIC; EXTRINSIC 62 ; INPUT: DUZ ByVal 63 ; OUTPUT: Delimited String in format: 64 ; IDType^ID^IDDescription 65 ; If the NPI doesn't exist, "" is returned. 66 ; This routine uses a call documented in the Kernel dev guide 67 ; This call returns as "NPI^TimeEntered^ActiveInactive" 68 ; It returns -1 for NPI if NPI doesn't exist. 69 N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U) 70 Q:NPI=-1 "" 71 Q "NPI^"_NPI_"^HHS" 72 ; 73 SPEC(DUZ) ; Get Provider Specialty, PUBLIC; EXTRINSIC 74 ; INPUT: DUZ ByVal 75 ; OUTPUT: String: ProviderType/Specialty/Subspecialty OR "" 76 ; Uses a Kernel API. Returns -1 if a specialty is not specified 77 ; in file 200. 78 ; Otherwise, returns IEN^Profession^Specialty^Subspecialty^Effect date^Expired date^VA code 79 N STR S STR=$$GET^XUA4A72(DUZ) 80 Q:+STR<0 "" 81 ; Sometimes we have 3 pieces, or 2. Deal with that. 82 Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4) 83 Q $P(STR,U,2)_"-"_$P(STR,U,3) 84 ; 85 ADDTYPE(DUZ) ; Get Address Type, PUBLIC; EXTRINSIC 86 ; INPUT: DUZ, but not needed really... here for future expansion 87 ; OUTPUT: At this point "Work" 88 Q "Work" 89 ; 90 ADDLINE1(ADUZ) ; Get Address associated with this instituation; PUBLIC; EXTRINSIC ; CHANGED PARAMETER TO ADUZ TO KEEP FROM CRASHING GPL 1/09 91 ; INPUT: DUZ ByVal 92 ; Output: String. 93 ; 94 ; First, get site number from the institution file. 95 ; 1st piece returned by $$SITE^VASITE, which gets the system institution 96 N INST S INST=$P($$SITE^VASITE(),U) 97 ; 98 ; Second, get mailing address 99 ; There are two APIs to get the address, one for physical and one for 100 ; mailing. We will check if mailing exists first, since that's the 101 ; one we want to use; then check for physical. If neither exists, 102 ; then we return nothing. We check for the existence of an address 103 ; by the length of the returned string. 104 ; NOTE: API doesn't support Address 2, so I won't even include it 105 ; in the template. 106 N ADD 107 S ADD=$$MADD^XUAF4(INST) ; mailing address 108 Q:$L(ADD) $P(ADD,U) 109 S ADD=$$PADD^XUAF4(INST) ; physical address 110 Q:$L(ADD) $P(ADD,U) 111 Q "" 112 ; 113 CITY(ADUZ) ; Get City for Institution. PUBLIC; EXTRINSIC 114 ;GPL CHANGED PARAMETER TO ADUZ TO KEEP $$SITE^VASITE FROM CRASHING 115 ; INPUT: DUZ ByVal 116 ; Output: String. 117 ; See ADD1 for comments 118 N INST S INST=$P($$SITE^VASITE(),U) 119 N ADD 120 S ADD=$$MADD^XUAF4(INST) ; mailing address 121 Q:$L(ADD) $P(ADD,U,2) 122 S ADD=$$PADD^XUAF4(INST) ; physical address 123 Q:$L(ADD) $P(ADD,U,2) 124 Q "" 125 ; 126 STATE(ADUZ) ; Get State for Institution. PUBLIC; EXTRINSIC 127 ; INPUT: DUZ ByVal 128 ; Output: String. 129 ; See ADD1 for comments 130 N INST S INST=$P($$SITE^VASITE(),U) 131 N ADD 132 S ADD=$$MADD^XUAF4(INST) ; mailing address 133 Q:$L(ADD) $P(ADD,U,3) 134 S ADD=$$PADD^XUAF4(INST) ; physical address 135 Q:$L(ADD) $P(ADD,U,3) 136 Q "" 137 ; 138 POSTCODE(ADUZ) ; Get Postal Code for Institution. PUBLIC; EXTRINSIC 139 ; INPUT: DUZ ByVal 140 ; OUTPUT: String. 141 ; See ADD1 for comments 142 N INST S INST=$P($$SITE^VASITE(),U) 143 N ADD 144 S ADD=$$MADD^XUAF4(INST) ; mailing address 145 Q:$L(ADD) $P(ADD,U,4) 146 S ADD=$$PADD^XUAF4(INST) ; physical address 147 Q:$L(ADD) $P(ADD,U,4) 148 Q "" 149 ; 150 TEL(DUZ) ; Get Office Phone number. PUBLIC; EXTRINSIC 151 ; INPUT: DUZ ByVal 152 ; OUTPUT: String. 153 ; Direct global access 154 N TEL S TEL=$G(^VA(200,DUZ,.13)) 155 Q $P(TEL,U,2) 156 ; 157 TELTYPE(DUZ) ; Get Telephone Type. PUBLIC; EXTRINSIC 158 ; INPUT: DUZ ByVal 159 ; OUTPUT: String. 160 Q "Office" 161 ; 162 EMAIL(DUZ) ; Get Provider's Email. PUBLIC; EXTRINSIC 163 ; INPUT: DUZ ByVal 164 ; OUTPUT: String 165 ; Direct global access 166 N EMAIL S EMAIL=$G(^VA(200,DUZ,.15)) 167 Q $P(EMAIL,U) 168 ; -
ccr/branches/ohum/p/C0CVIT2.m
r1342 r1428 1 C0CVIT2 2 ;;1.0;C0C;;Feb 16, 2010;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(VITXML,DFN,VITOUT) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 GETVISTA(DFN,C0CVIT) 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 GETRPMS(DFN,C0CVIT) 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 HEIGHT 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 WEIGHT 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 BP 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 TMP 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 RESP 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 PULSE 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 PAIN 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 OTHER 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 HEIGHT1(DT,ACTOR,VALUE,UNIT) 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 WEIGHT1(DT,ACTOR,VALUE,UNIT) 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 BP1(DT,ACTOR,VALUE,UNIT) 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 TMP1(DT,ACTOR,VALUE,UNIT) 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 RESP1(DT,ACTOR,VALUE,UNIT) 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 PULSE1(DT,ACTOR,VALUE,UNIT) 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 PAIN1(DT,ACTOR,VALUE,UNIT) 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 OTHER1(DT,TEXT,ACTOR,VALUE,UNIT) 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 VITSORT(VDT) 444 445 446 447 448 449 450 451 452 453 454 455 456 MAP(VITXML,C0CVIT,VITOUT) 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 1 C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;Copyright 2008,2009 George Lilly, University of Minnesota and others. 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 W "NO ENTRY FROM TOP",! 22 Q 23 ; 24 EXTRACT(VITXML,DFN,VITOUT) ; EXTRACT VITAL SIGNS INTO XML TEMPLATE 25 ; VITXML AND VITOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED 26 ; 27 ; USE THE FOLLOWING TEMPLATE FOR THE RNF2 ARRAYS 28 ; THAT GET PASSED TO *GET ROUTINES 29 ;C0C[NAME]=$NA(^TMP("C0CCCR",$J,DFN,"C0C(NAME)) 30 N C0CVIT 31 S C0CVIT=$NA(^TMP("C0CCCR",$J,DFN,"C0CVIT")) 32 ; USE THE FOLLOWING TEMPLATE FOR GETTING/GENERATING THE RNF2 ARRAYS 33 ; THAT GET INSERTED INTO THE XML TEMPLATE 34 ; D GET[VISTA/RPMS](DFN,C0CIMM) ; GET VARS 35 I $$RPMS^C0CUTIL() D GETRPMS(DFN,C0CVIT) ; GET VARS 36 I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D GETVISTA(DFN,C0CVIT) 37 ; USE THE FOLLOWING TEMPATE FOR MAPPING RNF2 ARRAYS TO XML TEMPLATE 38 ; D MAP([NAME]XML,C0C[NAME],[NAME]OUT) ;MAP RESULTS FOR PROCEDURES 39 D MAP(VITXML,C0CVIT,VITOUT) ;MAP RESULTS FOR PROCEDURES 40 Q 41 ; 42 GETVISTA(DFN,C0CVIT) ; CALLS VITALS^ORQQVI TO GET VITAL SIGNS. 43 ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME 44 ; C0CVIT: VITAL SIGNS 45 ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2 46 ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 47 ; EXIST. 48 ; 49 ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J)) 50 ; 51 ; SETUP RPC/API CALL HERE 52 ; USE START AND END DATES FROM PARAMETERS IF REQUIRED 53 ; 54 N VIT,DATA,START,END 55 ; RPC REQUIRES FM DATES NOT T-* DATES 56 D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM 57 D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM 58 ; RPC CALL (ORY,DFN,ORSDT,OREDT): 59 ;ORY: return variable 60 ;DFN: patient identifier from Patient File [#2] 61 ;ORSDT: start date/time in Fileman format 62 ;OREDT: end date/time in Fileman format 63 ; OUTPUT FORMAT: 64 ;vital measurement ien^vital type^rate^date/time taken 65 D VITALS^ORQQVI(.VIT,DFN,START,END) ; RUN QUERY VITALS CALL 66 I '$D(VIT) S @VITOUT@(0)=0 K VIT Q ; RETURN NOT FOUND, KILL ARRAY AND QUIT 67 I $P(VIT(1),U,2)="No vitals found." D Q ; signal no vitals and quit 68 . I $D(VITOUT) S @VITOUT@(0)=0 69 . K VIT 70 ; 71 ; PREFORM SORT HERE IF NEEDED 72 ; 73 ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST 74 ; COPIED SORT LOGIC: 75 N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX 76 D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY 77 S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE 78 ; VSORT IS VITALS IN REVERSE ORDER 79 ; 80 ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY 81 ; RNF1 ARRAY FORMAT: 82 ; VAR("NAME_OF_RIM_VARIABLE")=VALUE 83 ; 84 ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS 85 ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD 86 ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS 87 N C0CVI,C0CC,ZRNF 88 ;S C0CVI="" ; INITIALIZE FOR $O 89 F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D ; FOR EACH VITAL SIGN IN THE LIST 90 . I DEBUG W VIT(C0CVI),! 91 . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER) 92 . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"in") 93 . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"lbs") 94 . D:$P(VIT(C0CVI),U,3)="BP" BP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") 95 . D:$P(VIT(C0CVI),U,3)="T" TMP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"F") 96 . D:$P(VIT(C0CVI),U,3)="R" RESP1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") 97 . D:$P(VIT(C0CVI),U,3)="P" PULSE1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") 98 . D:$P(VIT(C0CVI),U,3)="PN" PAIN1($$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT"),$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"") 99 . D:'$D(ZRNF) OTHER1($$FMDTOUTC^C0CUTIL($P(C0CVI,U,4),"DT"),"OTHER VITAL",$P(^GMR(120.5,$P(VIT(C0CVI),U,1),0),U,6),$P(VIT(C0CVI),U,3),"UNKNOWN") ;IF THE VITAL ISN'T DEFINED IT IS OTHER 100 . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY 101 . K ZRNF 102 ; SAVE RIM VARIABLES SEE C0CRIMA 103 N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS")) 104 M @ZRIM=@C0CVIT@("V") 105 Q 106 ; 107 GETRPMS(DFN,C0CVIT) ; CALLS QUERY^BEHOVM TO GET VITAL SIGNS. 108 ; ERETURNS THEM IN RNF2 ARRAYS PASSED BY NAME 109 ; C0CVIT: VITAL SIGNS 110 ; READY TO BE MAPPED TO XML BY MAP^C0CVIT2 111 ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 112 ; EXIST. 113 ; 114 ; KILL OF ARRAYS IS TAKEN CARE OF IN ^C0CCCR (K ^TMP("C0CCCR",$J)) 115 ; 116 ; SETUP RPC/API CALL HERE 117 ; USE START AND END DATES FROM PARAMETERS IF REQUIRED 118 ; 119 ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE 120 ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE 121 N C0CEDT,C0CSDT,VIT,DATA,START,END 122 ; RPC REQUIRES FM DATES NOT T-* DATES 123 D DT^DILF(,$$GET^C0CPARMS("VITLIMIT"),.END) ; GET THE LIMIT PARM 124 D DT^DILF(,$$GET^C0CPARMS("VITSTART"),.START) ; GET START PARM 125 ; RPC OUTPUT FORMAT: 126 ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric) 127 D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL 128 I '$D(^TMP("CIAVMRPC",$J)) S @VITOUT@(0)=0 K ^TMP("CIAVMRPC",$J) Q ; RETURN NOT FOUND, KILL ARRAY AND QUIT 129 ; MOVE THE ARRAY TO LOCAL VARIABLE 130 M VIT=^TMP("CIAVMRPC",$J,0) 131 ; RPC CLEANUP 132 K ^TMP("CIAVMRPC",$J),VITS,RMAX,START,END,DATA,METRIC,VSTR,VUNT 133 ; 134 ; PREFORM SORT HERE IF NEEDED 135 ; 136 ; SORT IS REQUIRED FOR VITAL SIGNS - LATEST VITALS NEED TO BE LISTED FIRST 137 ; COPIED SORT LOGIC: 138 N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX 139 D VITSORT(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY 140 S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE 141 ; VSORT IS VITALS IN REVERSE ORDER 142 ; 143 ; MAP EACH ROW OF RPC/API TO RNF1 ARRAY 144 ; RNF1 ARRAY FORMAT: 145 ; VAR("NAME_OF_RIM_VARIABLE")=VALUE 146 ; 147 ; VITAL SIGNS ARE DONE DIFFERENTLY DUE TO THE DIFFERENT TYPES OF VITAL SIGNS 148 ; THIS LOOP WILL GET EACH ROW, DETERMINE THE TYPE, AND CALL THE RESPECTIVE PROCESSING METHOD 149 ; THAT WILL DO THE MAPPING TO RNF1 STYLE ARRAYS 150 N C0CVI,C0CC,ZRNF 151 ;S C0CVI="" ; INITIALIZE FOR $O 152 F C0CC=1:1:VSORT(0) S C0CVI=VSORT(C0CC) D ; FOR EACH VITAL SIGN IN THE LIST 153 . I DEBUG W VIT(C0CVI),! 154 . ; FIGURE OUT WHICH TYPE OF VITAL SIGN IT IS (HEIGHT, WEIGHT, BLOOD PRESSURE, TEMPERATURE, RESPIRATION, PULSE, PAIN, OTHER) 155 . D:$P(VIT(C0CVI),U,3)="HT" HEIGHT 156 . D:$P(VIT(C0CVI),U,3)="WT" WEIGHT 157 . D:$P(VIT(C0CVI),U,3)="BP" BP 158 . D:$P(VIT(C0CVI),U,3)="TMP" TMP 159 . D:$P(VIT(C0CVI),U,3)="RS" RESP 160 . D:$P(VIT(C0CVI),U,3)="PU" PULSE 161 . D:$P(VIT(C0CVI),U,3)="PA" PAIN 162 . D:'$D(ZRNF) OTHER ;IF THE VITAL ISN'T DEFINED IT IS OTHER 163 . D RNF1TO2^C0CRNF(C0CVIT,"ZRNF") ;ADD THIS ROW TO THE ARRAY 164 . K ZRNF 165 ; SAVE RIM VARIABLES SEE C0CRIMA 166 N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"VITALS")) 167 M @ZRIM=@C0CVIT@("V") 168 Q 169 ; 170 HEIGHT 171 I DEBUG W "IN VITAL: HEIGHT",! 172 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID 173 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 174 S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") 175 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" 176 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 177 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 178 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 179 S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008" 180 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 181 S ZRNF("VITALSIGNSCODEVERSION")="" 182 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) 183 S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) 184 S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) 185 Q 186 ; 187 WEIGHT 188 I DEBUG W "IN VITAL: WEIGHT",! 189 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 190 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 191 S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") 192 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" 193 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 194 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 195 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 196 S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005" 197 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 198 S ZRNF("VITALSIGNSCODEVERSION")="" 199 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) 200 S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) 201 S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) 202 Q 203 ; 204 BP 205 I DEBUG W "IN VITAL: BLOOD PRESSURE",! 206 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 207 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 208 S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") 209 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" 210 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 211 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 212 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 213 S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002" 214 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 215 S ZRNF("VITALSIGNSCODEVERSION")="" 216 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) 217 S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) 218 S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) 219 Q 220 ; 221 TMP 222 I DEBUG W "IN VITAL: TEMPERATURE",! 223 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 224 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 225 S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") 226 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" 227 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 228 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 229 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 230 S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008" 231 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 232 S ZRNF("VITALSIGNSCODEVERSION")="" 233 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) 234 S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) 235 S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) 236 Q 237 ; 238 RESP 239 I DEBUG W "IN VITAL: RESPIRATION",! 240 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 241 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 242 S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") 243 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" 244 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 245 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 246 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 247 S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009" 248 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 249 S ZRNF("VITALSIGNSCODEVERSION")="" 250 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) 251 S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) 252 S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) 253 Q 254 ; 255 PULSE 256 I DEBUG W "IN VITAL: PULSE",! 257 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 258 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 259 S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") 260 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE" 261 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 262 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 263 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 264 S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006" 265 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 266 S ZRNF("VITALSIGNSCODEVERSION")="" 267 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) 268 S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) 269 S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) 270 Q 271 ; 272 PAIN 273 I DEBUG W "IN VITAL: PAIN",! 274 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 275 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 276 S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") 277 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN" 278 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 279 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 280 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 281 S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000" 282 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 283 S ZRNF("VITALSIGNSCODEVERSION")="" 284 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) 285 S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) 286 S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) 287 Q 288 ; 289 OTHER 290 I DEBUG W "IN VITAL: OTHER",! 291 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 292 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 293 S ZRNF("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VIT(C0CVI),U,4),"DT") 294 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=$P(VIT(C0CVI),U,2) 295 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 296 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 297 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 298 S ZRNF("VITALSIGNSDESCCODEVALUE")="" 299 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="" 300 S ZRNF("VITALSIGNSCODEVERSION")="" 301 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VIT(C0CVI),U,1),12)),U,4) 302 S ZRNF("VITALSIGNSTESTRESULTVALUE")=$P($P(VIT(C0CVI),U,5)," ",1) 303 S ZRNF("VITALSIGNSTESTRESULTUNIT")=$P($P(VIT(C0CVI),U,5)," ",2) 304 Q 305 ; 306 ;TEMPORARY, THINKING ON HOW TO REFACTOR (CJE) 307 HEIGHT1(DT,ACTOR,VALUE,UNIT) 308 I DEBUG W "IN VITAL: HEIGHT",! 309 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC ; UNIQUE OBJID 310 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 311 S ZRNF("VITALSIGNSEXACTDATETIME")=DT 312 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" 313 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 314 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 315 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 316 S ZRNF("VITALSIGNSDESCCODEVALUE")="248327008" 317 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 318 S ZRNF("VITALSIGNSCODEVERSION")="" 319 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR 320 S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE 321 S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT 322 Q 323 ; 324 WEIGHT1(DT,ACTOR,VALUE,UNIT) 325 I DEBUG W "IN VITAL: WEIGHT",! 326 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 327 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 328 S ZRNF("VITALSIGNSEXACTDATETIME")=DT 329 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" 330 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 331 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 332 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 333 S ZRNF("VITALSIGNSDESCCODEVALUE")="107647005" 334 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 335 S ZRNF("VITALSIGNSCODEVERSION")="" 336 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR 337 S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE 338 S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT 339 Q 340 ; 341 BP1(DT,ACTOR,VALUE,UNIT) 342 I DEBUG W "IN VITAL: BLOOD PRESSURE",! 343 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 344 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 345 S ZRNF("VITALSIGNSEXACTDATETIME")=DT 346 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" 347 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 348 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 349 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 350 S ZRNF("VITALSIGNSDESCCODEVALUE")="392570002" 351 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 352 S ZRNF("VITALSIGNSCODEVERSION")="" 353 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR 354 S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE 355 S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT 356 Q 357 ; 358 TMP1(DT,ACTOR,VALUE,UNIT) 359 I DEBUG W "IN VITAL: TEMPERATURE",! 360 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 361 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 362 S ZRNF("VITALSIGNSEXACTDATETIME")=DT 363 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" 364 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 365 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 366 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 367 S ZRNF("VITALSIGNSDESCCODEVALUE")="309646008" 368 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 369 S ZRNF("VITALSIGNSCODEVERSION")="" 370 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR 371 S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE 372 S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT 373 Q 374 ; 375 RESP1(DT,ACTOR,VALUE,UNIT) 376 I DEBUG W "IN VITAL: RESPIRATION",! 377 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 378 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 379 S ZRNF("VITALSIGNSEXACTDATETIME")=DT 380 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" 381 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 382 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 383 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 384 S ZRNF("VITALSIGNSDESCCODEVALUE")="366147009" 385 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 386 S ZRNF("VITALSIGNSCODEVERSION")="" 387 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR 388 S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE 389 S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT 390 Q 391 ; 392 PULSE1(DT,ACTOR,VALUE,UNIT) 393 I DEBUG W "IN VITAL: PULSE",! 394 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 395 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 396 S ZRNF("VITALSIGNSEXACTDATETIME")=DT 397 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PULSE" 398 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 399 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 400 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 401 S ZRNF("VITALSIGNSDESCCODEVALUE")="366199006" 402 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 403 S ZRNF("VITALSIGNSCODEVERSION")="" 404 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR 405 S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE 406 S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT 407 Q 408 ; 409 PAIN1(DT,ACTOR,VALUE,UNIT) 410 I DEBUG W "IN VITAL: PAIN",! 411 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 412 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 413 S ZRNF("VITALSIGNSEXACTDATETIME")=DT 414 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")="PAIN" 415 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 416 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 417 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 418 S ZRNF("VITALSIGNSDESCCODEVALUE")="22253000" 419 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 420 S ZRNF("VITALSIGNSCODEVERSION")="" 421 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR 422 S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE 423 S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT 424 Q 425 ; 426 OTHER1(DT,TEXT,ACTOR,VALUE,UNIT) 427 I DEBUG W "IN VITAL: OTHER",! 428 S ZRNF("VITALSIGNSDATAOBJECTID")="VITAL"_C0CC 429 S ZRNF("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 430 S ZRNF("VITALSIGNSEXACTDATETIME")=DT 431 S ZRNF("VITALSIGNSDESCRIPTIONTEXT")=TEXT 432 S ZRNF("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 433 S ZRNF("VITALSIGNSTESTOBJECTID")="VITALTEST"_C0CC 434 S ZRNF("VITALSIGNSTESTTYPETEXT")="OBSERVED" 435 S ZRNF("VITALSIGNSDESCCODEVALUE")="" 436 S ZRNF("VITALSIGNSDESCCODINGSYSTEM")="" 437 S ZRNF("VITALSIGNSCODEVERSION")="" 438 S ZRNF("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_ACTOR 439 S ZRNF("VITALSIGNSTESTRESULTVALUE")=VALUE 440 S ZRNF("VITALSIGNSTESTRESULTUNIT")=UNIT 441 Q 442 ; 443 VITSORT(VDT) ; RUN DATE SORTING ALGORITHM 444 ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY 445 ; OF DATES IN THE VITALS RESULTS 446 N VDTI,VDTJ,VTDCNT 447 S VTDCNT=0 ; COUNT TO BUILD ARRAY 448 S VDTJ="" ; USED TO VISIT THE RESULTS 449 F VDTI=0:0 D Q:$O(VIT(VDTJ))="" ; VISIT ALL RESULTS 450 . S VDTJ=$O(VIT(VDTJ)) ; NEXT RESULT 451 . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER 452 . S VDT(VTDCNT)=$P(VIT(VDTJ),U,4) ; PULL OUT THE DATE 453 S VDT(0)=VTDCNT 454 Q 455 ; 456 MAP(VITXML,C0CVIT,VITOUT) ; MAP VITAL SIGNS XML 457 ; 458 N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"VITTEMP")) ;WORK AREA FOR TEMPLATE 459 K @ZTEMP 460 N ZBLD 461 S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"VITBLD")) ; BUILD LIST AREA 462 D QUEUE^C0CXPATH(ZBLD,VITXML,1,1) ; FIRST LINE 463 N ZINNER 464 ; XPATH NEEDS TO MATCH YOUR SECTION 465 D QUERY^C0CXPATH(VITXML,"//VitalSigns/Result","ZINNER") ;ONE VITAL SIGN 466 N ZTMP,ZVAR,ZI 467 S ZI="" 468 F S ZI=$O(@C0CVIT@("V",ZI)) Q:ZI="" D ;FOR EACH VITAL SIGN 469 . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS VITAL SIGN XML 470 . S ZVAR=$NA(@C0CVIT@("V",ZI)) ;THIS VITAL SIGN VARIABLES 471 . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE VITAL SIGN 472 . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUEUE FOR BUILD 473 D QUEUE^C0CXPATH(ZBLD,VITXML,@VITXML@(0),@VITXML@(0)) 474 N ZZTMP ; IS THIS NEEDED? 475 D BUILD^C0CXPATH(ZBLD,VITOUT) ;BUILD FINAL XML 476 K @ZTEMP,@ZBLD 477 Q 478 ; -
ccr/branches/ohum/p/C0CVITAL.m
r1342 r1428 1 C0CVITAL 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(VITXML,DFN,VITOUTXML) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 VITVISTA 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 VITRPMS 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 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 VITDRPMS(VDT) 389 390 391 392 393 394 395 396 397 398 399 400 401 VITDVISTA(VDT) 402 403 404 405 406 407 408 409 410 411 412 413 1 C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 3 ;Copyright 2008,2009 George Lilly, University of Minnesota and others. 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 W "NO ENTRY FROM TOP",! 22 Q 23 ; 24 EXTRACT(VITXML,DFN,VITOUTXML) ; EXTRACT VITALS INTO PROVIDED XML TEMPLATE 25 ; 26 ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED 27 ; IVITXML CONTAINS ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE 28 ; 29 N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF,VORDR 30 S C0CVLMT=$$GET^C0CPARMS("VITLIMIT") ; GET THE LIMIT PARM 31 S C0CVSTRT=$$GET^C0CPARMS("VITSTART") ; GET START PARM 32 D DT^DILF(,C0CVLMT,.C0CEDT) ; 33 D DT^DILF(,C0CVSTRT,.C0CSDT) ; 34 ;D DT^DILF(,C0CVLMT,.C0CSDT) ; GPL TESTING 35 ;D DT^DILF(,C0CVSTRT,.C0CEDT) ; 36 W "VITALS START: ",C0CVSTRT," LIMIT: ",C0CVLMT,! 37 I $$RPMS^C0CUTIL() D VITRPMS QUIT 38 I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VITVISTA QUIT 39 ;I $$SYSNAME^C0CSYS()="RPMS" D VITRPMS 40 ;E D VITVISTA 41 Q 42 ; 43 VITVISTA ; EXTRACT VITALS FROM VISTA INTO PROVIDED XML TEMPLATE 44 D FASTVIT^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) ; GPL THIS ONE WORKS FOR AT 45 ; LEAST ONE SET OF VITALS - TO DO, CALL IT REPETIVELY TO GET EARLIER VITALS 46 ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) 47 ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CSDT,C0CEDT) 48 ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CVSTRT,C0CVLMT) ; GPL LET GMR HANDLE THE DATES 49 I '$D(VITRSLT(1)) S @VITOUTXML@(0)=0 Q ; RETURN NOT FOUND AND QUIT 50 I $P(VITRSLT(1),U,2)="No vitals found." D Q ; NULL RESULT FROM RPC 51 . I DEBUG W "NO VITALS FOUND FROM VITALS RPC",! 52 . S @VITOUTXML@(0)=0 53 I $P(VITRSLT(1),U,2)="No vitals found." Q ; QUIT 54 ; ZWR RPCRSLT 55 S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS")) 56 S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP")) 57 K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES 58 N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX 59 D VITDVISTA(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY 60 I DEBUG ZWR VDATES ;DEBUG 61 S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE 62 ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY 63 S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS 64 F J=1:1:VCNT D ; FOR EACH VITAL IN THE LIST 65 . I $D(VITRSLT(VSORT(J))) D 66 . . S VITVMAP=$NA(@VITTVMAP@(J)) 67 . . K @VITVMAP 68 . . I DEBUG W "VMAP= ",VITVMAP,! 69 . . S VITPTMP=VITRSLT(VSORT(J)) ; DATE SORTED VITAL FROM RETURN ARRAY 70 . . I DEBUG W "VITAL ",VSORT(J),! 71 . . I DEBUG W VITRSLT(VSORT(J))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),! 72 . . I DEBUG W $P(VITPTMP,U,4),! 73 . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID 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 . . I $P(VITPTMP,U,2)="HT" D 79 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 80 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 81 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" 82 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 83 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 84 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 85 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" 86 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008" 87 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 88 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 89 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 90 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 91 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in" 92 . . E I $P(VITPTMP,U,2)="WT" D 93 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 94 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 95 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" 96 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 97 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 98 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 99 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" 100 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005" 101 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 102 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 103 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 104 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 105 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs" 106 . . E I $P(VITPTMP,U,2)="BP" D 107 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 108 . . . ;S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 109 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" 110 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 111 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 112 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 113 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" 114 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002" 115 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 116 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 117 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 118 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 119 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" 120 . . E I $P(VITPTMP,U,2)="T" D 121 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 122 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 123 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" 124 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 125 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 126 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 127 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" 128 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008" 129 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 130 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 131 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 132 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 133 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F" 134 . . E I $P(VITPTMP,U,2)="R" D 135 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 136 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 137 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" 138 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 139 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 140 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 141 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" 142 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009" 143 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 144 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 145 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 146 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 147 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" 148 . . E I $P(VITPTMP,U,2)="P" D 149 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 150 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 151 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" 152 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 153 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 154 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 155 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" 156 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006" 157 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 158 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 159 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 160 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 161 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" 162 . . E I $P(VITPTMP,U,2)="PN" D 163 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 164 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 165 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" 166 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 167 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 168 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 169 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" 170 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000" 171 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 172 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 173 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 174 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 175 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" 176 . . E I $P(VITPTMP,U,2)="BMI" D 177 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 178 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 179 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI" 180 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 181 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 182 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 183 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI" 184 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="60621009" 185 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 186 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 187 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 188 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 189 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" 190 . . E D 191 . . . ;W "IN VITAL: OTHER",! 192 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 193 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 194 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER VITAL" 195 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 196 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 197 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="UNKNOWN" 198 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER" 199 . . . ;S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="" 200 . . . ;S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="" 201 . . . ;S @VITVMAP@("VITALSIGNSCODEVERSION")="" 202 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6) 203 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 204 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN" 205 . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; 206 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ; 207 . . S VITARYTMP=$NA(@VITTARYTMP@(J)) 208 . . K @VITARYTMP 209 . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP) 210 . . I J=1 D ; FIRST ONE IS JUST A COPY 211 . . . ; W "FIRST ONE",! 212 . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML) 213 . . . I DEBUG W "VITOUTXML ",VITOUTXML,! 214 . . I J>1 D ; AFTER THE FIRST, INSERT INNER XML 215 . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP) 216 ; ZWR ^TMP($J,"VITALS",*) 217 ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS 218 I DEBUG D PARY^C0CXPATH(VITOUTXML) 219 N VITTMP,I 220 D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS 221 I VITTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 222 . W "VITALS MISSING ",! 223 . F I=1:1:VITTMP(0) W VITTMP(I),! 224 Q 225 ; 226 VITRPMS ; EXTRACT VITALS FROM RPMS INTO PROVIDED XML TEMPLATE 227 ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE 228 ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE 229 N END,START,DATA 230 D DT^DILF("",C0CVLMT,.END) 231 D DT^DILF("",C0CVSTRT,.START) 232 ; RPC OUTPUT FORMAT: 233 ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric) 234 D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL 235 I '$D(^TMP("CIAVMRPC",$J)) S @VITOUTXML@(0)=0 Q ; RETURN NOT FOUND AND QUIT 236 ;ZW ^TMP("CIAVMRPC",$J) 237 S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS")) 238 S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP")) 239 K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES 240 N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX 241 D VITDRPMS(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY 242 S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE 243 ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY 244 S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS 245 F J=1:1:VCNT D ; FOR EACH VITAL IN THE LIST 246 . I $D(^TMP("CIAVMRPC",$J,0,(VSORT(J)))) D 247 . . S VITVMAP=$NA(@VITTVMAP@(J)) 248 . . K @VITVMAP 249 . . I DEBUG W "VMAP= ",VITVMAP,! 250 . . S VITPTMP=^TMP("CIAVMRPC",$J,0,(VSORT(J))) ; DATE SORTED VITAL FROM RETURN ARRAY 251 . . I DEBUG W "VITAL ",VSORT(J),! 252 . . I DEBUG W ^TMP("CIAVMRPC",$J,0,(VSORT(J)))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),! 253 . . I DEBUG W $P(VITPTMP,U,4),! 254 . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID 255 . . I $P(VITPTMP,U,3)="HT" D 256 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 257 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 258 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" 259 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 260 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 261 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 262 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" 263 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008" 264 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 265 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 266 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 267 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 268 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 269 . . E I $P(VITPTMP,U,3)="WT" D 270 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 271 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 272 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" 273 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 274 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 275 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 276 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" 277 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005" 278 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 279 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 280 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 281 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 282 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 283 . . E I $P(VITPTMP,U,3)="BP" D 284 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 285 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 286 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" 287 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 288 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 289 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 290 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" 291 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002" 292 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 293 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 294 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 295 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 296 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 297 . . E I $P(VITPTMP,U,3)="TMP" D 298 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 299 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 300 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" 301 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 302 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 303 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 304 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" 305 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008" 306 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 307 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 308 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 309 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 310 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 311 . . E I $P(VITPTMP,U,3)="RS" D 312 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 313 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 314 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" 315 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 316 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 317 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 318 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" 319 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009" 320 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 321 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 322 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 323 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 324 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 325 . . E I $P(VITPTMP,U,3)="PU" D 326 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 327 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 328 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" 329 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 330 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 331 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 332 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" 333 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006" 334 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 335 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 336 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 337 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 338 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 339 . . E I $P(VITPTMP,U,3)="PA" D 340 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 341 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 342 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" 343 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 344 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 345 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 346 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" 347 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000" 348 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 349 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 350 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 351 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 352 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 353 . . E D 354 . . . ;W "IN VITAL: OTHER",! 355 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 356 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 357 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2) 358 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 359 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 360 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 361 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2) 362 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="" 363 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="" 364 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 365 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 366 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 367 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 368 . . S VITARYTMP=$NA(@VITTARYTMP@(J)) 369 . . K @VITARYTMP 370 . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP) 371 . . I J=1 D ; FIRST ONE IS JUST A COPY 372 . . . ; W "FIRST ONE",! 373 . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML) 374 . . . I DEBUG W "VITOUTXML ",VITOUTXML,! 375 . . I J>1 D ; AFTER THE FIRST, INSERT INNER XML 376 . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP) 377 ; ZWR ^TMP($J,"VITALS",*) 378 ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS 379 I DEBUG D PARY^C0CXPATH(VITOUTXML) 380 N VITTMP,I 381 D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS 382 I VITTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 383 . W "VITALS MISSING ",! 384 . F I=1:1:VITTMP(0) W VITTMP(I),! 385 K ^TMP("CIAVMRPC",$J) 386 Q 387 ; 388 VITDRPMS(VDT) ; RUN DATE SORTING ALGORITHM FOR RPMS 389 ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY 390 ; OF DATES IN THE VITALS RESULTS 391 N VDTI,VDTJ,VTDCNT 392 S VTDCNT=0 ; COUNT TO BUILD ARRAY 393 S VDTJ="" ; USED TO VISIT THE RESULTS 394 F VDTI=0:0 D Q:$O(^TMP("CIAVMRPC",$J,0,VDTJ))="" ; VISIT ALL RESULTS 395 . S VDTJ=$O(^TMP("CIAVMRPC",$J,0,VDTJ)) ; NEXT RESULT 396 . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER 397 . S VDT(VTDCNT)=$P(^TMP("CIAVMRPC",$J,0,VDTJ),U,4) ; PULL OUT THE DATE 398 S VDT(0)=VTDCNT 399 Q 400 ; 401 VITDVISTA(VDT) ; RUN DATE SORTING ALGORITHM FOR VISTA 402 ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY 403 ; OF DATES IN THE VITALS RESULTS 404 N VDTI,VDTJ,VTDCNT 405 S VTDCNT=0 ; COUNT TO BUILD ARRAY 406 S VDTJ="" ; USED TO VISIT THE RESULTS 407 F VDTI=0:0 D Q:$O(VITRSLT(VDTJ))="" ; VISIT ALL RESULTS 408 . S VDTJ=$O(VITRSLT(VDTJ)) ; NEXT RESULT 409 . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER 410 . S VDT(VTDCNT)=$P(VITRSLT(VDTJ),U,4) ; PULL OUT THE DATE 411 S VDT(0)=VTDCNT 412 Q 413 ; -
ccr/branches/ohum/p/C0CVOBX1.m
r1342 r1428 1 LA7VOBX1 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61,63**;Sep 27, 1994;Build 2 3 4 5 CH 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 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 1 LA7VOBX1 ;DALOI/JMC - LAB OBX Segment message builder (CH subscript) cont'd; 04/21/09 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 ; 22 ; If no result NLT or LOINC try to determine from file #60 23 S LA7X=$P(LA7VAL,"^",3) 24 ; WV check for IHS - NLT/LN codes from V LAB file 25 I $D(^AUPNVLAB) D TMPCHK^C0CLA7Q 26 ; 27 I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5)) 28 ; No result NLT code - log error 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
r1342 r1428 1 C0C7VORU ;WV/JMC - Builder of HL7 Lab Results OBR/OBX/NTE based on RPMS V LAB file ;Jun 16, 20092 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994;Build 2 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 ; 5/10/12 5:19pm 2 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CXEWD 2 ;;0.1;C0C;nopatch;noreleasedate;Build 2 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 ;;1.2;C0C;;May 11, 2012;Build 46 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
r1342 r1428 1 C0CXPAT0 2 ;;1.0;C0C;;May 19, 2009;Build 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 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 1 C0CXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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",! 21 Q 22 ; 23 ;;><TEST> 24 ;;><INIT> 25 ;;>>>K C0C S C0C="" 26 ;;>>>D PUSH^C0CXPATH("C0C","FIRST") 27 ;;>>>D PUSH^C0CXPATH("C0C","SECOND") 28 ;;>>>D PUSH^C0CXPATH("C0C","THIRD") 29 ;;>>>D PUSH^C0CXPATH("C0C","FOURTH") 30 ;;>>?C0C(0)=4 31 ;;><INITXML> 32 ;;>>>K GXML S GXML="" 33 ;;>>>D PUSH^C0CXPATH("GXML","<FIRST>") 34 ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>") 35 ;;>>>D PUSH^C0CXPATH("GXML","<THIRD>") 36 ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>@@DATA1@@</FOURTH>") 37 ;;>>>D PUSH^C0CXPATH("GXML","<FIFTH>") 38 ;;>>>D PUSH^C0CXPATH("GXML","@@DATA2@@") 39 ;;>>>D PUSH^C0CXPATH("GXML","</FIFTH>") 40 ;;>>>D PUSH^C0CXPATH("GXML","<SIXTH ID=""SELF"" />") 41 ;;>>>D PUSH^C0CXPATH("GXML","</THIRD>") 42 ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>") 43 ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>") 44 ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>") 45 ;;>>>D PUSH^C0CXPATH("GXML","</FIRST>") 46 ;;><INITXML2> 47 ;;>>>K GXML S GXML="" 48 ;;>>>D PUSH^C0CXPATH("GXML","<FIRST>") 49 ;;>>>D PUSH^C0CXPATH("GXML","<SECOND>") 50 ;;>>>D PUSH^C0CXPATH("GXML","<THIRD>") 51 ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>DATA1</FOURTH>") 52 ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>") 53 ;;>>>D PUSH^C0CXPATH("GXML","DATA2") 54 ;;>>>D PUSH^C0CXPATH("GXML","</FOURTH>") 55 ;;>>>D PUSH^C0CXPATH("GXML","</THIRD>") 56 ;;>>>D PUSH^C0CXPATH("GXML","<_SECOND>") 57 ;;>>>D PUSH^C0CXPATH("GXML","<FOURTH>DATA3</FOURTH>") 58 ;;>>>D PUSH^C0CXPATH("GXML","</_SECOND>") 59 ;;>>>D PUSH^C0CXPATH("GXML","</SECOND>") 60 ;;>>>D PUSH^C0CXPATH("GXML","</FIRST>") 61 ;;><PUSHPOP> 62 ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") 63 ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT") 64 ;;>>?C0C(C0C(0))="FOURTH" 65 ;;>>>D POP^C0CXPATH("C0C",.GX) 66 ;;>>?GX="FOURTH" 67 ;;>>?C0C(C0C(0))="THIRD" 68 ;;>>>D POP^C0CXPATH("C0C",.GX) 69 ;;>>?GX="THIRD" 70 ;;>>?C0C(C0C(0))="SECOND" 71 ;;><MKMDX> 72 ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") 73 ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INIT") 74 ;;>>>S GX="" 75 ;;>>>D MKMDX^C0CXPATH("C0C",.GX) 76 ;;>>?GX="//FIRST/SECOND/THIRD/FOURTH" 77 ;;><XNAME> 78 ;;>>?$$XNAME^C0CXPATH("<FOURTH>DATA1</FOURTH>")="FOURTH" 79 ;;>>?$$XNAME^C0CXPATH("<SIXTH ID=""SELF"" />")="SIXTH" 80 ;;>>?$$XNAME^C0CXPATH("</THIRD>")="THIRD" 81 ;;><INDEX> 82 ;;>>>D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") 83 ;;>>>D ZTEST^C0CUNIT(.ZTMP,"INITXML") 84 ;;>>>D INDEX^C0CXPATH("GXML") 85 ;;>>?GXML("//FIRST/SECOND")="2^12" 86 ;;>>?GXML("//FIRST/SECOND/THIRD")="3^9" 87 ;;>>?GXML("//FIRST/SECOND/THIRD/FIFTH")="5^7" 88 ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^4^@@DATA1@@" 89 ;;>>?GXML("//FIRST/SECOND/THIRD/SIXTH")="8^8^" 90 ;;>>?GXML("//FIRST/SECOND")="2^12" 91 ;;>>?GXML("//FIRST")="1^13" 92 ;;><INDEX2> 93 ;;>>>D ZTEST^C0CXPATH("INITXML2") 94 ;;>>>D INDEX^C0CXPATH("GXML") 95 ;;>>?GXML("//FIRST/SECOND")="2^12" 96 ;;>>?GXML("//FIRST/SECOND/_SECOND")="9^11" 97 ;;>>?GXML("//FIRST/SECOND/_SECOND/FOURTH")="10^10^DATA3" 98 ;;>>?GXML("//FIRST/SECOND/THIRD")="3^8" 99 ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH[1]")="4^4^DATA1" 100 ;;>>?GXML("//FIRST")="1^13" 101 ;;><MISSING> 102 ;;>>>D ZTEST^C0CXPATH("INITXML") 103 ;;>>>S OUTARY="^TMP($J,""MISSINGTEST"")" 104 ;;>>>D MISSING^C0CXPATH("GXML",OUTARY) 105 ;;>>?@OUTARY@(1)="DATA1" 106 ;;>>?@OUTARY@(2)="DATA2" 107 ;;><MAP> 108 ;;>>>D ZTEST^C0CXPATH("INITXML") 109 ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")" 110 ;;>>>S OUTARY="^TMP($J,""MAPTEST"")" 111 ;;>>>S @MAPARY@("DATA2")="VALUE2" 112 ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY) 113 ;;>>?@OUTARY@(6)="VALUE2" 114 ;;><MAP2> 115 ;;>>>D ZTEST^C0CXPATH("INITXML") 116 ;;>>>S MAPARY="^TMP($J,""MAPVALUES"")" 117 ;;>>>S OUTARY="^TMP($J,""MAPTEST"")" 118 ;;>>>S @MAPARY@("DATA1")="VALUE1" 119 ;;>>>S @MAPARY@("DATA2")="VALUE2" 120 ;;>>>S @MAPARY@("DATA3")="VALUE3" 121 ;;>>>S GXML(4)="<FOURTH>@@DATA1@@ AND @@DATA3@@</FOURTH>" 122 ;;>>>D MAP^C0CXPATH("GXML",MAPARY,OUTARY) 123 ;;>>>D PARY^C0CXPATH(OUTARY) 124 ;;>>?@OUTARY@(4)="<FOURTH>VALUE1 AND VALUE3</FOURTH>" 125 ;;><QUEUE> 126 ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",2,3) 127 ;;>>>D QUEUE^C0CXPATH("BTLIST","GXML",4,5) 128 ;;>>?$P(BTLIST(2),";",2)=4 129 ;;><BUILD> 130 ;;>>>D ZTEST^C0CXPATH("INITXML") 131 ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FOURTH","G2") 132 ;;>>>D ZTEST^C0CXPATH("QUEUE") 133 ;;>>>D BUILD^C0CXPATH("BTLIST","G3") 134 ;;><CP> 135 ;;>>>D ZTEST^C0CXPATH("INITXML") 136 ;;>>>D CP^C0CXPATH("GXML","G2") 137 ;;>>?G2(0)=13 138 ;;><QOPEN> 139 ;;>>>K G2,GBL 140 ;;>>>D ZTEST^C0CXPATH("INITXML") 141 ;;>>>D QOPEN^C0CXPATH("GBL","GXML") 142 ;;>>?$P(GBL(1),";",3)=12 143 ;;>>>D BUILD^C0CXPATH("GBL","G2") 144 ;;>>?G2(G2(0))="</SECOND>" 145 ;;><QOPEN2> 146 ;;>>>K G2,GBL 147 ;;>>>D ZTEST^C0CXPATH("INITXML") 148 ;;>>>D QOPEN^C0CXPATH("GBL","GXML","//FIRST/SECOND") 149 ;;>>?$P(GBL(1),";",3)=11 150 ;;>>>D BUILD^C0CXPATH("GBL","G2") 151 ;;>>?G2(G2(0))="</SECOND>" 152 ;;><QCLOSE> 153 ;;>>>K G2,GBL 154 ;;>>>D ZTEST^C0CXPATH("INITXML") 155 ;;>>>D QCLOSE^C0CXPATH("GBL","GXML") 156 ;;>>?$P(GBL(1),";",3)=13 157 ;;>>>D BUILD^C0CXPATH("GBL","G2") 158 ;;>>?G2(G2(0))="</FIRST>" 159 ;;><QCLOSE2> 160 ;;>>>K G2,GBL 161 ;;>>>D ZTEST^C0CXPATH("INITXML") 162 ;;>>>D QCLOSE^C0CXPATH("GBL","GXML","//FIRST/SECOND/THIRD") 163 ;;>>?$P(GBL(1),";",3)=13 164 ;;>>>D BUILD^C0CXPATH("GBL","G2") 165 ;;>>?G2(G2(0))="</FIRST>" 166 ;;>>?G2(1)="</THIRD>" 167 ;;><INSERT> 168 ;;>>>K G2,GBL,G3,G4 169 ;;>>>D ZTEST^C0CXPATH("INITXML") 170 ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2") 171 ;;>>>D INSERT^C0CXPATH("GXML","G2","//FIRST/SECOND/THIRD") 172 ;;>>>D INSERT^C0CXPATH("G3","G2","//") 173 ;;>>?G2(1)=GXML(9) 174 ;;><REPLACE> 175 ;;>>>K G2,GBL,G3 176 ;;>>>D ZTEST^C0CXPATH("INITXML") 177 ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2") 178 ;;>>>D REPLACE^C0CXPATH("GXML","G2","//FIRST/SECOND") 179 ;;>>?GXML(2)="<FIFTH>" 180 ;;><INSINNER> 181 ;;>>>K GXML,G2,GBL,G3 182 ;;>>>D ZTEST^C0CXPATH("INITXML") 183 ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2") 184 ;;>>>D INSINNER^C0CXPATH("GXML","G2","//FIRST/SECOND/THIRD") 185 ;;>>?GXML(10)="<FIFTH>" 186 ;;><INSINNER2> 187 ;;>>>K GXML,G2,GBL,G3 188 ;;>>>D ZTEST^C0CXPATH("INITXML") 189 ;;>>>D QUERY^C0CXPATH("GXML","//FIRST/SECOND/THIRD","G2") 190 ;;>>>D INSINNER^C0CXPATH("G2","G2") 191 ;;>>?G2(8)="<FIFTH>" 192 ;;><PUSHA> 193 ;;>>>K GTMP,GTMP2 194 ;;>>>N GTMP,GTMP2 195 ;;>>>D PUSH^C0CXPATH("GTMP","A") 196 ;;>>>D PUSH^C0CXPATH("GTMP2","B") 197 ;;>>>D PUSH^C0CXPATH("GTMP2","C") 198 ;;>>>D PUSHA^C0CXPATH("GTMP","GTMP2") 199 ;;>>?GTMP(3)="C" 200 ;;>>?GTMP(0)=3 201 ;;><H2ARY> 202 ;;>>>K GTMP,GTMP2 203 ;;>>>S GTMP("TEST1")=1 204 ;;>>>D H2ARY^C0CXPATH("GTMP2","GTMP") 205 ;;>>?GTMP2(0)=1 206 ;;>>?GTMP2(1)="^TEST1^1" 207 ;;><XVARS> 208 ;;>>>K GTMP,GTMP2 209 ;;>>>D PUSH^C0CXPATH("GTMP","<VALUE>@@VAR1@@</VALUE>") 210 ;;>>>D XVARS^C0CXPATH("GTMP2","GTMP") 211 ;;>>?GTMP2(1)="^VAR1^1" 212 ;;></TEST> -
ccr/branches/ohum/p/C0CXPATH.m
r1342 r1428 1 C0CXPATH 2 ;;1.0;C0C;;May 19, 2009;Build 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 OUTPUT(OUTARY,OUTNAME,OUTDIR) 25 26 27 28 29 30 31 32 PUSH(STK,VAL) 33 34 35 36 37 38 39 40 POP(STK,VAL) 41 42 43 44 45 46 47 48 49 50 51 52 PUSHA(ADEST,ASRC) 53 54 55 56 57 58 59 MKMDX(STK,RTN,INREDUX) 60 61 62 63 64 65 66 67 68 69 70 71 72 XNAME(ISTR) 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 XVAL(ISTR) 88 89 90 91 92 93 VDX2VDV(OUTVDV,INVDX) 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 VDX2XPG(OUTXPG,INVDX) 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 XML2XPG(OUTXPG,INXML) 130 131 132 133 134 135 136 137 DO 138 139 140 141 T1 142 143 144 145 146 147 148 149 XPG2XML(OUTXML,INXPG) 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 ZXO(WHAT) 191 192 193 194 195 ZXC(WHAT) 196 197 198 199 200 ZXVAL(WHAT,VAL) 201 202 203 204 INDEX(IZXML,VDX,NOINX,TEMPLATE,REDUX) 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 MKLASD(OUTBUF,INARY) 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 CLEAN(STR,TR) 327 328 329 330 331 332 333 334 335 336 QUERY(IARY,XPATH,OARY) 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 XF(IDX,XPATH) 361 362 363 364 365 XL(IDX,XPATH) 366 367 368 369 370 START(ISTR) 371 372 373 374 375 FINISH(ISTR) 376 377 378 379 ARRAY(ISTR) 380 381 382 383 BUILD(BLIST,BDEST) 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 QUEUE(BLST,ARRAY,FIRST,LAST) 402 403 404 405 406 407 CP(CPSRC,CPDEST) 408 409 410 411 412 413 414 415 416 417 418 419 QOPEN(QOBLIST,QOXML,QOXPATH) 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 QCLOSE(QCBLIST,QCXML,QCXPATH) 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 INSERT(INSXML,INSNEW,INSXPATH) 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 INSINNER(INNXML,INNNEW,INNXPATH) 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 INSB4(XDEST,XNEW) 507 508 509 510 511 512 513 514 515 516 517 REPLACE(REXML,RENEW,REXPATH) 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 DELETE(REXML,REXPATH) 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 MISSING(IXML,OARY) 558 559 560 561 562 563 564 565 566 567 568 569 MAP(IXML,INARY,OXML) 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 DOFLD 600 601 602 603 TRIM(THEXML) 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 UNMARK(XSEC) 642 643 644 645 646 647 648 649 PARY(GLO,ZN) 650 651 652 653 654 655 656 657 H2ARY(IARYRTN,IHASH,IPRE) 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 XVARS(XVRTN,XVIXML) 684 685 686 687 688 689 690 691 692 693 694 DXVARS(DXIN) 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 TEST 711 712 713 714 ZTEST(WHICH) 715 716 717 718 719 720 721 TLIST 722 723 724 725 726 1 C0CXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 2 ;;1.2;C0C;;May 11, 2012;Build 46 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 "This is an XML XPATH utility library",! 21 W ! 22 Q 23 ; 24 OUTPUT(OUTARY,OUTNAME,OUTDIR) ; WRITE AN ARRAY TO A FILE 25 ; 26 N Y 27 S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME) 28 I Y Q 1_U_"WROTE FILE: "_OUTNAME_" TO "_OUTDIR 29 I 'Y Q 0_U_"ERROR WRITING FILE"_OUTNAME_" TO "_OUTDIR 30 Q 31 ; 32 PUSH(STK,VAL) ; pushs VAL onto STK and updates STK(0) 33 ; VAL IS A STRING AND STK IS PASSED BY NAME 34 ; 35 I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE 36 S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH 37 S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY 38 Q 39 ; 40 POP(STK,VAL) ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL 41 ; VAL AND STK ARE PASSED BY REFERENCE 42 ; 43 I @STK@(0)<1 D ; IF ARRAY IS EMPTY 44 . S VAL="" 45 . S @STK@(0)=0 46 I @STK@(0)>0 D ; 47 . S VAL=@STK@(@STK@(0)) 48 . K @STK@(@STK@(0)) 49 . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY 50 Q 51 ; 52 PUSHA(ADEST,ASRC) ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME 53 ; 54 N ZGI 55 F ZGI=1:1:@ASRC@(0) D ; FOR ALL OF THE SOURCE ARRAY 56 . D PUSH(ADEST,@ASRC@(ZGI)) ; PUSH ONE ELEMENT 57 Q 58 ; 59 MKMDX(STK,RTN,INREDUX) ; MAKES A MUMPS INDEX FROM THE ARRAY STK 60 ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS 61 ; REDUX IS A STRING TO REMOVE FROM THE RESULT 62 S RTN="" 63 N I 64 ; W "STK= ",STK,! 65 I @STK@(0)>0 D ; IF THE ARRAY IS NOT EMPTY 66 . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON 67 . I @STK@(0)>1 D ; SUBSEQUENT ELEMENTS NEED A SEMICOLON 68 . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I) 69 I $G(INREDUX)'="" S RTN=$P(RTN,INREDUX,1)_$P(RTN,INREDUX,2) 70 Q 71 ; 72 XNAME(ISTR) ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG 73 ; </NAME> AND <NAME ID=XNAME> WILL RETURN NAME 74 ; ISTR IS PASSED BY VALUE 75 N CUR,TMP 76 I ISTR?.E1"<".E D ; STRIP OFF LEFT BRACKET 77 . S TMP=$P(ISTR,"<",2) 78 I TMP?1"/".E D ; ALSO STRIP OFF SLASH IF PRESENT IE </NAME> 79 . S TMP=$P(TMP,"/",2) 80 S CUR=$P(TMP,">",1) ; EXTRACT THE NAME 81 ; W "CUR= ",CUR,! 82 I CUR?.1"_"1.A1" ".E D ; CONTAINS A BLANK IE NAME ID=TEST> 83 . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER 84 ; W "CUR2= ",CUR,! 85 Q CUR 86 ; 87 XVAL(ISTR) ; EXTRACTS THE VALUE FROM A FRAGMENT OF XML 88 ; <NAME>VALUE</NAME> WILL RETURN VALUE 89 N G 90 S G=$P(ISTR,">",2) ;STRIP OFF <NAME> 91 Q $P(G,"<",1) ; STRIP OFF </NAME> LEAVING VALUE 92 ; 93 VDX2VDV(OUTVDV,INVDX) ; CONVERT AN VDX ARRAY TO VDV 94 ; VDX: @INVDX@(XPATH)=VALUE 95 ; VDV: @OUTVDV@(X1X2X3X4)=VALUE 96 ; THE VDV DATANAMES MIGHT BE MORE CONVENIENT FOR USE IN CODE 97 ; AN INDEX IS PROVIDED TO GO BACK TO VDX FOR CONVERSIONS 98 ; @VDV@("XPATH",X1X2X3X4)="XPATH" 99 N ZA,ZI,ZW 100 S ZI="" 101 F S ZI=$O(@INVDX@(ZI)) Q:ZI="" D ; 102 . S ZW=$TR(ZI,"/","") ; ELIMINATE ALL SLASHES - CAMEL CASE VARIABLE NAME 103 . W ZW,! 104 . S @OUTVDV@(ZW)=@INVDX@(ZI) 105 . S @OUTVDV@("XPATH",ZW)=ZI 106 Q 107 ; 108 VDX2XPG(OUTXPG,INVDX) ; CONVERT AN VDX ARRAY TO XPG 109 ; VDX: @VDX@(XPATH)=VALUE 110 ; XPG: @(VDX(X1,X2,X3,X4))@=VALUE 111 ; THIS IS A STEP TOWARD GENERATING XML FROM A VDX 112 N ZA,ZI,ZW 113 S ZI="" 114 F S ZI=$O(@INVDX@(ZI)) Q:ZI="" D ; 115 . S ZW=$E(ZI,3,$L(ZI)) ; STRIP OFF INITIAL // 116 . S ZW2=$P(ZW,"/",1) 117 . F ZK=1:1:$L(ZW,"/") D PUSH("ZA",$P(ZW,"/",ZK)) 118 . ;ZWR ZA 119 . S ZW2=ZA(1) 120 . F ZK=2:1:ZA(0) D ; 121 . . S ZW2=ZW2_""","""_ZA(ZK) 122 . K ZA 123 . S ZW2=""""_ZW2_"""" 124 . W ZW2,! 125 . S ZN=OUTXPG_"("_ZW2_")" 126 . S @ZN=@INVDX@(ZI) 127 Q 128 ; 129 XML2XPG(OUTXPG,INXML) ; CONVERT AN XML ARRAY, PASSED BY NAME TO AN XPG ARRAY 130 ; XPG MEANS XPATH GLOBAL AND HAS THE FORM @OUTXPG@("X1","X2","X3")=VALUE 131 ; 132 ;N G1 133 D INDEX(INXML,"G1",1) ; PRODUCES A VDX ARRAY IN G1, NO INDEX IS PRODUCED 134 D VDX2XPG(OUTXPG,"G1") ; CONVERTS THE VDX ARRAY TO XPG FORM 135 Q 136 ; 137 DO 138 D XPG2XML("^GPL2B","^GPL2A") 139 Q 140 ; 141 T1 ; TEST OUT THESE ROUTINES 142 D XML2XPG("G2","^GPL") 143 D XPG2XML("G3","G2") 144 K ^GPLOUT 145 M ^GPLOUT=G3 146 W $$OUTPUT^C0CXPATH("^GPLOUT(1)","GPLTEST.xml","/home/vademo2/EHR/p") 147 Q 148 ; 149 XPG2XML(OUTXML,INXPG) ; 150 N C0CN,FWD,ZA,G,GA,ZQ 151 S ZQ=0 ; QUIT FLAG 152 F Q:ZQ=1 D ; LOOP THROUGH EVERYTHING 153 . I '$D(C0CN) D ; FIRST TIME THROUGH 154 . . K @OUTXML ; MAKE SURE OUTPUT ARRAY IS CLEAR 155 . . S FWD=1 ; START OUT GOING FORWARD THROUGH SUBSCRIPTS 156 . . S G=$Q(@INXPG) ; THIS ONE 157 . . S GN=$Q(@G) ; NEXT ONE 158 . . S C0CN=1 ; SUBSCRIPT COUNT 159 . . S ZQ=0 ; QUIT FLAG 160 . . D ZXO("?xml version=""1.0"" encoding=""UTF-8""?") ;MAKE IT REAL XML 161 . . I $QS(G,1)="ContinuityOfCareRecord" D ; 162 . . . D ZXO("?xml-stylesheet type=""text/xsl"" href=""ccr.xsl""?") ; HACK TO MAKE THE CCR STYLESHEET WORK 163 . I FWD D ; GOING FORWARDS 164 . . I C0CN<$QL(G) D ; NOT A DATA NODE 165 . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT 166 . . . D ZXO(ZA) ; AND OPEN AN XML ELEMENT 167 . . . I @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord>" D ; 168 . . . . S @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord xmlns=""urn:astm-org:CCR"">" 169 . . . S C0CN=C0CN+1 ; MOVE TO THE NEXT ONE 170 . . E D ; AT THE DATA NODE 171 . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT 172 . . . D ZXVAL(ZA,@G) ; OUTPUT <X>VAL</X> FOR DATA NODE 173 . . . S FWD=0 ; GO BACKWARDS 174 . I 'FWD D ;GOING BACKWARDS 175 . . S GN=$Q(@G) ;NEXT XPATH 176 . . ;W "NEXT!",GN,! 177 . . S C0CN=C0CN-1 ; PREVIOUS SUBSCRIPT 178 . . I GN'="" D ; 179 . . . I $QS(G,C0CN)'=$QS(GN,C0CN) D ; NEED TO CLOSE OFF ELEMENT 180 . . . . D ZXC($QS(G,C0CN)) ; 181 . . . E I GN'="" D ; MORE ELEMENTS AT THIS LEVEL 182 . . . . S G=$Q(@G) ; ADVANCE TO NEW XPATH 183 . . . . S C0CN=C0CN+1 ; GET READY TO PROCESS NEXT SUBSCRIPT 184 . . . . S FWD=1 ; GOING FORWARD NOW 185 . I (GN="")&(C0CN=1) D Q ; WHEN WE ARE ALL DONE 186 . . D ZXC($QS(G,C0CN)) ; LAST ONE 187 . . S ZQ=1 ; QUIT NOW 188 Q 189 ; 190 ZXO(WHAT) 191 D PUSH("GA",WHAT) 192 D PUSH(OUTXML,"<"_WHAT_">") 193 Q 194 ; 195 ZXC(WHAT) 196 D POP("GA",.TMP) 197 D PUSH(OUTXML,"</"_WHAT_">") 198 Q 199 ; 200 ZXVAL(WHAT,VAL) 201 D PUSH(OUTXML,"<"_WHAT_">"_VAL_"</"_WHAT_">") 202 Q 203 ; 204 INDEX(IZXML,VDX,NOINX,TEMPLATE,REDUX) ; parse XML in IZXML and produce 205 ; an XPATH index; REDUX is a string to be removed from each xpath 206 ; GPL 7/14/09 OPTIONALLY GENERATE AN XML TEMPLATE IF PASSED BY NAME 207 ; TEMPLATE IS IDENTICAL TO THE PARSED XML LINE BY LINE 208 ; EXCEPT THAT DATA VALUES ARE REPLACED WITH @@XPATH@@ FOR THE XPATH OF THE TAG 209 ; GPL 5/24/09 AND OPTIONALLY PRODUCE THE VDX ARRAY PASSED BY NAME 210 ; @VDX@("XPATH")=VALUE 211 ; ex. @IZXML@("XPATH")=FIRSTLINE^LASTLINE 212 ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE 213 ; XML SECTION 214 ; IZXML IS PASSED BY NAME 215 ; IF NOINX IS SET TO 1, NO INDEX WILL BE GENERATED, BUT THE VDX WILL BE 216 N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND,CURVAL,DVDX,LCNT 217 N C0CSTK ; LEAVE OUT FOR DEBUGGING 218 I '$D(REDUX) S REDUX="" 219 I '$D(NOINX) S NOINX=0 ; IF NOT PASSED, GENERATE AN INDEX 220 N ZXML 221 I NOINX S ZXML=$NA(^TMP("C0CINDEX",$J)) ; TEMP PLACE FOR INDEX TO DISCARD 222 E S ZXML=IZXML ; PLACE FOR INDEX TO KEEP 223 I '$D(@IZXML@(0)) D ; IF COUNT NOT IN NODE 0 COUNT THEM 224 . S I="",LCNT=0 225 . F S I=$O(@IZXML@(I)) Q:I="" S LCNT=LCNT+1 226 E S LCNT=@IZXML@(0) ; LINE COUNT PASSED IN ARRAY 227 I LCNT=0 D Q ; NO XML PASSED 228 . W "ERROR IN XML FILE",! 229 S DVDX=0 ; DEFAULT DO NOT PRODUCE VDX INDEX 230 I $D(VDX) S DVDX=1 ; IF NAME PASSED, DO VDX 231 S C0CSTK(0)=0 ; INITIALIZE STACK 232 K LKASD ; KILL LOOKASIDE ARRAY 233 D MKLASD(.LKASD,IZXML) ;MAKE LOOK ASIDE BUFFER FOR MULTIPLES 234 F I=1:1:LCNT D ; PROCESS THE ENTIRE ARRAY 235 . S LINE=@IZXML@(I) 236 . I $D(TEMPLATE) D ;IF TEMPLATE IS REQUESTED 237 . . S @TEMPLATE@(I)=$$CLEAN(LINE) 238 . ;W LINE,! 239 . S FOUND=0 ; INTIALIZED FOUND FLAG 240 . I LINE?.E1"<!".E S FOUND=1 ; SKIP OVER COMMENTS 241 . I FOUND'=1 D 242 . . I (LINE?.E1"<"1.E1"</".E)!(LINE?.E1"<"1.E1"/>".E) D 243 . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS 244 . . . ; ON THE SAME LINE 245 . . . ; W "FOUND ",LINE,! 246 . . . S FOUND=1 ; SET FOUND FLAG 247 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME 248 . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES 249 . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK 250 . . . D MKMDX("C0CSTK",.MDX,REDUX) ; GENERATE THE M INDEX 251 . . . ; W "MDX=",MDX,! 252 . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE 253 . . . . ;I '$D(ZDUP(MDX)) S ZDUP(MDX)=2 254 . . . . ;E S ZDUP(MDX)=ZDUP(MDX)+1 255 . . . . ;W "DUP:",MDX,! 256 . . . . ;I '$D(CURVAL) S CURVAL="" 257 . . . . ;I DVDX S @VDX@(MDX_"["_ZDUP(MDX)_"]")=CURVAL 258 . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER 259 . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE 260 . . . . S @ZXML@(MDX)=I_"^"_I ; ADD INDEX ENTRY-FIRST AND LAST 261 . . . . S CURVAL=$$XVAL(LINE) ; VALUE 262 . . . . S $P(@ZXML@(MDX),"^",3)=CURVAL ; THIRD PIECE 263 . . . . I DVDX S @VDX@(MDX)=CURVAL ; FILL IN VDX ARRAY IF REQUESTED 264 . . . . I $D(TEMPLATE) D ; IF TEMPLATE IS REQUESTED 265 . . . . . S LINE=$$CLEAN(LINE) ; CLEAN OUT CONTROL CHARACTERS 266 . . . . . S @TEMPLATE@(I)=$P(LINE,">",1)_">@@"_MDX_"@@</"_$P(LINE,"</",2) 267 . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK 268 . I FOUND'=1 D ; THE LINE DOESN'T CONTAIN THE START AND END 269 . . I LINE?.E1"</"1.E D ; LINE CONTAINS END OF A SECTION 270 . . . ; W "FOUND ",LINE,! 271 . . . S FOUND=1 ; SET FOUND FLAG 272 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME 273 . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX 274 . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER 275 . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK 276 . . . S TMP=$P(TMP,"[",1) ; REMOVE [X] FROM MULTIPLE 277 . . . I TMP'=CUR D ; MALFORMED XML, END MUST MATCH START 278 . . . . W "MALFORMED XML ",CUR,"LINE "_I_LINE,! 279 . . . . D PARY("C0CSTK") ; PRINT OUT THE STACK FOR DEBUGING 280 . . . . Q 281 . I FOUND'=1 D ; THE LINE MIGHT CONTAIN A SECTION BEGINNING 282 . . I (LINE?.E1"<"1.E)&(LINE'["?>") D ; BEGINNING OF A SECTION 283 . . . ; W "FOUND ",LINE,! 284 . . . S FOUND=1 ; SET FOUND FLAG 285 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME 286 . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES 287 . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK 288 . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX 289 . . . ; W "MDX=",MDX,! 290 . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE 291 . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER 292 . . . . ;B 293 . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE 294 . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX 295 S @ZXML@("INDEXED")="" 296 S @ZXML@("//")="1^"_LCNT ; ROOT XPATH 297 I NOINX K @ZXML ; DELETE UNWANTED INDEX 298 Q 299 ; 300 MKLASD(OUTBUF,INARY) ; CREATE A LOOKASIDE BUFFER FOR MULTILPLES 301 ; 302 N ZI,ZN,ZA,ZLINE,ZLINE2,CUR,CUR2 303 F ZI=1:1:LCNT-1 D ; PROCESS THE ENTIRE ARRAY 304 . S ZLINE=@IZXML@(ZI) 305 . I ZI<LCNT S ZLINE2=@IZXML@(ZI+1) 306 . I ZLINE?.E1"</"1.E D ; NEXT LINE CONTAINS END OF A SECTION 307 . . S CUR=$$XNAME(ZLINE) ; EXTRACT THE NAME 308 . . I (ZLINE2?.E1"<"1.E)&(ZLINE'["?>") D ; BEGINNING OF A SECTION 309 . . . S CUR2=$$XNAME(ZLINE2) ; EXTRACT THE NAME 310 . . . I CUR=CUR2 D ; IF THIS IS A MULTIPLE 311 . . . . S OUTBUF(CUR,ZI+1)="" 312 ;ZWR OUTBUF 313 S ZI="" 314 F S ZI=$O(OUTBUF(ZI)) Q:ZI="" D ; FOR EACH KIND OF MULTIPLE 315 . S ZN=$O(OUTBUF(ZI,"")) ; LINE NUMBER OF SECOND MULTIPLE 316 . F S ZN=$O(@IZXML@(ZN),-1) Q:ZN="" I $E($P(@IZXML@(ZN),"<"_ZI,2),1,1)=">" Q ; 317 . S OUTBUF(ZI,ZN)="" 318 S ZA=1,ZI="",ZN="" 319 F S ZI=$O(OUTBUF(ZI)) Q:ZI="" D ; ADDING THE COUNT FOR THE MULIPLES [x] 320 . S ZN="",ZA=1 321 . F S ZN=$O(OUTBUF(ZI,ZN)) Q:ZN="" D ; 322 . . S OUTBUF(ZI,ZN)="["_ZA_"]" 323 . . S ZA=ZA+1 324 Q 325 ; 326 CLEAN(STR,TR) ; extrinsic function; returns string 327 ;; Removes all non printable characters from a string. 328 ;; STR by Value 329 ;; TR IS OPTIONAL TO IMPROVE PERFORMANCE 330 N TR,I 331 I '$D(TR) D ; 332 . F I=0:1:31 S TR=$G(TR)_$C(I) 333 . S TR=TR_$C(127) 334 QUIT $TR(STR,TR) 335 ; 336 QUERY(IARY,XPATH,OARY) ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION 337 ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD" 338 ; IARY AND OARY ARE PASSED BY NAME 339 I '$D(@IARY@("INDEXED")) D ; INDEX IS NOT PRESENT IN IARY 340 . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML 341 N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN 342 N TMP,I,J,QXPATH 343 S FIRST=1 344 I '$D(@IARY@(0)) D ; LINE COUNT NOT IN ZERO NODE 345 . S @IARY@(0)=$O(@IARY@("//"),-1) ; THIS SHOULD USUALLY WORK 346 S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT 347 I XPATH'="//" D ; NOT A ROOT QUERY 348 . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES 349 . S FIRST=$P(TMP,"^",1) 350 . S LAST=$P(TMP,"^",2) 351 K @OARY 352 S @OARY@(0)=+LAST-FIRST+1 353 S J=1 354 FOR I=FIRST:1:LAST D 355 . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY 356 . S J=J+1 357 ; ZWR OARY 358 Q 359 ; 360 XF(IDX,XPATH) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH 361 ; INDEX WITH TWO PIECES START^FINISH 362 ; IDX IS PASSED BY NAME 363 Q $P(@IDX@(XPATH),"^",1) 364 ; 365 XL(IDX,XPATH) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH 366 ; INDEX WITH TWO PIECES START^FINISH 367 ; IDX IS PASSED BY NAME 368 Q $P(@IDX@(XPATH),"^",2) 369 ; 370 START(ISTR) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX 371 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH 372 ; COMPANION TO FINISH ; IDX IS PASSED BY NAME 373 Q $P(ISTR,";",2) 374 ; 375 FINISH(ISTR) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX 376 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH 377 Q $P(ISTR,";",3) 378 ; 379 ARRAY(ISTR) ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX 380 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH 381 Q $P(ISTR,";",1) 382 ; 383 BUILD(BLIST,BDEST) ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST 384 ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST 385 ; DEST IS CLEARED TO START 386 ; USES PUSH TO DO THE COPY 387 N I 388 K @BDEST 389 F I=1:1:@BLIST@(0) D ; FOR EACH INSTRUCTION IN BLIST 390 . N J,ATMP 391 . S ATMP=$$ARRAY(@BLIST@(I)) 392 . I $G(DEBUG) W "ATMP=",ATMP,! 393 . I $G(DEBUG) W @BLIST@(I),! 394 . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D ; 395 . . ; FOR EACH LINE IN THIS INSTR 396 . . I $G(DEBUG) W "BDEST= ",BDEST,! 397 . . I $G(DEBUG) W "ATMP= ",@ATMP@(J),! 398 . . D PUSH(BDEST,@ATMP@(J)) 399 Q 400 ; 401 QUEUE(BLST,ARRAY,FIRST,LAST) ; ADD AN ENTRY TO A BLIST 402 ; 403 I $G(DEBUG) W "QUEUEING ",BLST,! 404 D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST) 405 Q 406 ; 407 CP(CPSRC,CPDEST) ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME 408 ; KILLS CPDEST FIRST 409 N CPINSTR 410 I $G(DEBUG) W "MADE IT TO COPY",CPSRC,CPDEST,! 411 I @CPSRC@(0)<1 D ; BAD LENGTH 412 . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,! 413 . Q 414 ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT 415 D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY 416 D BUILD("CPINSTR",CPDEST) 417 Q 418 ; 419 QOPEN(QOBLIST,QOXML,QOXPATH) ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST 420 ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD 421 ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT 422 ; USED TO INSERT CHILDREN NODES 423 I @QOXML@(0)<1 D ; MALFORMED XML 424 . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,! 425 . Q 426 I $G(DEBUG) W "DOING QOPEN",! 427 N S1,E1,QOT,QOTMP 428 S S1=1 ; OPEN FROM THE BEGINNING OF THE XML 429 I $D(QOXPATH) D ; XPATH PROVIDED 430 . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX 431 . S E1=$P(@QOXML@(QOXPATH),"^",2)-1 432 I '$D(QOXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT 433 . S E1=@QOXML@(0)-1 434 D QUEUE(QOBLIST,QOXML,S1,E1) 435 ; S QOTMP=QOXML_"^"_S1_"^"_E1 436 ; D PUSH(QOBLIST,QOTMP) 437 Q 438 ; 439 QCLOSE(QCBLIST,QCXML,QCXPATH) ; CLOSE XML AFTER A QOPEN 440 ; ADDS THE LIST LINE OF QCXML TO QCBLIST 441 ; USED TO FINISH INSERTING CHILDERN NODES 442 ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END 443 ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO 444 I @QCXML@(0)<1 D ; MALFORMED XML 445 . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,! 446 I $G(DEBUG) W "GOING TO CLOSE",! 447 N S1,E1,QCT,QCTMP 448 S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML 449 I $D(QCXPATH) D ; XPATH PROVIDED 450 . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX 451 . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML 452 I '$D(QCXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT 453 . S S1=@QCXML@(0) 454 D QUEUE(QCBLIST,QCXML,S1,E1) 455 ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1) 456 Q 457 ; 458 INSERT(INSXML,INSNEW,INSXPATH) ; INSERT INSNEW INTO INSXML AT THE 459 ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS 460 ; OMITTED, INSERTION WILL BE AT THE ROOT 461 ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW 462 ; XML AT THE END OF THE XPATH POINT 463 ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE 464 N INSBLD,INSTMP 465 I $G(DEBUG) W "DOING INSERT ",INSXML,INSNEW,INSXPATH,! 466 I $G(DEBUG) F G1=1:1:@INSXML@(0) W @INSXML@(G1),! 467 I '$D(@INSXML@(1)) D ; INSERT INTO AN EMPTY ARRAY 468 . D CP^C0CXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT 469 I $D(@INSXML@(1)) D ; IF ORIGINAL ARRAY IS NOT EMPTY 470 . I '$D(@INSXML@(0)) S @INSXML@(0)=$O(@INSXML@(""),-1) ;SET LENGTH 471 . I $D(INSXPATH) D ; XPATH PROVIDED 472 . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE 473 . . I $G(DEBUG) D PARY^C0CXPATH("INSBLD") 474 . I '$D(INSXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT 475 . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH 476 . I '$D(@INSNEW@(0)) S @INSNEW@(0)=$O(@INSNEW@(""),-1) ;SIZE OF XML 477 . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML 478 . I $D(INSXPATH) D ; XPATH PROVIDED 479 . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH 480 . I '$D(INSXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT 481 . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH 482 . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST 483 . D CP^C0CXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE 484 Q 485 ; 486 INSINNER(INNXML,INNNEW,INNXPATH) ; INSERT THE INNER XML OF INNNEW 487 ; INTO INNXML AT THE INNXPATH XPATH POINT 488 ; 489 N INNBLD,UXPATH 490 N INNTBUF 491 S INNTBUF=$NA(^TMP($J,"INNTBUF")) 492 I '$D(INNXPATH) D ; XPATH NOT PASSED 493 . S UXPATH="//" ; USE ROOT XPATH 494 I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED 495 I '$D(@INNXML@(0)) D ; INNXML IS EMPTY 496 . D QUEUE^C0CXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER 497 . D BUILD("INNBLD",INNXML) 498 I @INNXML@(0)>0 D ; NOT EMPTY 499 . D QOPEN("INNBLD",INNXML,UXPATH) ; 500 . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML 501 . D QCLOSE("INNBLD",INNXML,UXPATH) 502 . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER 503 . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST 504 Q 505 ; 506 INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST 507 ; BUT XDEST AN XNEW ARE PASSED BY NAME 508 N XBLD,XTMP 509 D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT 510 D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST 511 D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION 512 D BUILD("XBLD","XTMP") ; BUILD THE RESULT 513 D CP("XTMP",XDEST) ; COPY TO THE DESTINATION 514 I $G(DEBUG) D PARY("XDEST") 515 Q 516 ; 517 REPLACE(REXML,RENEW,REXPATH) ; REPLACE THE XML AT THE XPATH POINT 518 ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE 519 ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE 520 ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD") 521 N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP 522 S OLD=$NA(^TMP($J,"REPLACE_OLD")) 523 D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD 524 S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS 525 S XFIRST=$P(XNODE,"^",1) 526 S XLAST=$P(XNODE,"^",2) 527 I RENEW="" D ; WE ARE DELETING A SECTION, MUST SAVE THE TAG 528 . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE 529 . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST 530 I RENEW'="" D ; NEW XML IS NOT NULL 531 . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE 532 . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW 533 . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST 534 I $G(DEBUG) W "REPLACE PREBUILD",! 535 I $G(DEBUG) D PARY("REBLD") 536 D BUILD("REBLD","RTMP") 537 K @REXML ; KILL WHAT WAS THERE 538 D CP("RTMP",REXML) ; COPY IN THE RESULT 539 Q 540 ; 541 DELETE(REXML,REXPATH) ; DELETE THE XML AT THE XPATH POINT 542 ; REXML IS PASSED BY NAME XPATH IS A VALUE 543 N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP 544 S OLD=$NA(^TMP($J,"REPLACE_OLD")) 545 D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD 546 S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS 547 S XFIRST=$P(XNODE,"^",1) 548 S XLAST=$P(XNODE,"^",2) 549 D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE 550 D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST 551 I $G(DEBUG) D PARY("REBLD") 552 D BUILD("REBLD","RTMP") 553 K @REXML ; KILL WHAT WAS THERE 554 D CP("RTMP",REXML) ; COPY IN THE RESULT 555 Q 556 ; 557 MISSING(IXML,OARY) ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY 558 ; W "Reporting on the missing",! 559 ; W OARY 560 I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q 561 N I 562 S @OARY@(0)=0 ; INITIALIZED MISSING COUNT 563 F I=1:1:@IXML@(0) D ; LOOP THROUGH WHOLE ARRAY 564 . I @IXML@(I)?.E1"@@".E D ; MISSING VARIABLE HERE 565 . . D PUSH^C0CXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY 566 . . Q 567 Q 568 ; 569 MAP(IXML,INARY,OXML) ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY 570 ; AND PUT THE RESULTS IN OXML 571 N XCNT 572 I '$D(DEBUG) S DEBUG=0 573 I '$D(IXML) W "MALFORMED XML PASSED TO MAP",! Q 574 I '$D(@IXML@(0)) D ; INITIALIZE COUNT 575 . S XCNT=$O(@IXML@(""),-1) 576 E S XCNT=@IXML@(0) ;COUNT 577 I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q 578 N I,J,TNAM,TVAL,TSTR 579 S @OXML@(0)=XCNT ; TOTAL LINES IN OUTPUT 580 F I=1:1:XCNT D ; LOOP THROUGH WHOLE ARRAY 581 . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT 582 . I @OXML@(I)?.E1"@@".E D ; IS THERE A VARIABLE HERE? 583 . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS 584 . . F J=2:2:10 D Q:$P(@IXML@(I),"@@",J+2)="" ; QUIT IF NO MORE VARS 585 . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,! 586 . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME 587 . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED 588 . . . I $D(@INARY@(TNAM)) D ; IS THE VARIABLE IN THE MAP? 589 . . . . I '$D(@INARY@(TNAM,"F")) D ; NOT A SPECIAL FIELD 590 . . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE 591 . . . . E D DOFLD ; PROCESS A FIELD 592 . . . S TVAL=$$SYMENC^MXMLUTL(TVAL) ;MAKE SURE THE VALUE IS XML SAFE 593 . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER 594 . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES 595 . . I DEBUG W TSTR 596 I DEBUG W "MAPPED",! 597 Q 598 ; 599 DOFLD ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE 600 ; 601 Q 602 ; 603 TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS 604 ; THEXML IS PASSED BY NAME 605 N I,J,TMPXML,DEL,FOUND,INTXT 606 S FOUND=0 607 S INTXT=0 608 I $G(DEBUG) W "DELETING EMPTY ELEMENTS",! 609 F I=1:1:(@THEXML@(0)-1) D ; LOOP THROUGH ENTIRE ARRAY 610 . S J=@THEXML@(I) 611 . I J["<text>" D 612 . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM 613 . . I $G(DEBUG) W "IN HTML SECTION",! 614 . N JM,JP,JPX ; JMINUS AND JPLUS 615 . S JM=@THEXML@(I-1) ; LINE BEFORE 616 . I JM["</text>" S INTXT=0 ; LEFT HTML SECTION,START TRIM 617 . S JP=@THEXML@(I+1) ; LINE AFTER 618 . I INTXT=0 D ; IF NOT IN AN HTML SECTION 619 . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH 620 . . I J=JPX D ; AN EMPTY ELEMENT ON TWO LINES 621 . . . I $G(DEBUG) W I,J,JP,! 622 . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED 623 . . . S DEL(I)="" ; SET LINE TO DELETE 624 . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE 625 . . I J["><" D ; AN EMPTY ELEMENT ON ONE LINE 626 . . . I $G(DEBUG) W I,J,! 627 . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED 628 . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED 629 . . . I JM=JPX D ; 630 . . . . I $G(DEBUG) W I,JM_J_JPX,! 631 . . . . S DEL(I-1)="" 632 . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL 633 ; . I J'["><" D PUSH("TMPXML",J) 634 I FOUND D ; NEED TO DELETE THINGS 635 . F I=1:1:@THEXML@(0) D ; COPY ARRAY LEAVING OUT DELELTED LINES 636 . . I '$D(DEL(I)) D ; IF THE LINE IS NOT DELETED 637 . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY 638 . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY 639 Q FOUND 640 ; 641 UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML 642 ; XSEC IS A SECTION PASSED BY NAME 643 N XBLD,XTMP 644 D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML 645 D BUILD("XBLD","XTMP") ; BUILD THE RESULT 646 D CP("XTMP",XSEC) ; REPLACE PASSED XML 647 Q 648 ; 649 PARY(GLO,ZN) ;PRINT AN ARRAY 650 ; IF ZN=-1 NO LINE NUMBERS 651 N I 652 F I=1:1:@GLO@(0) D ; 653 . I $G(ZN)=-1 W @GLO@(I),! 654 . E W I_" "_@GLO@(I),! 655 Q 656 ; 657 H2ARY(IARYRTN,IHASH,IPRE) ; CONVERT IHASH TO RETURN ARRAY 658 ; IPRE IS OPTIONAL PREFIX FOR THE ELEMENTS. USED FOR MUPTIPLES 1^"VAR"^VALUE 659 I '$D(IPRE) S IPRE="" 660 N H2I S H2I="" 661 ; W $O(@IHASH@(H2I)),! 662 F S H2I=$O(@IHASH@(H2I)) Q:H2I="" D ; FOR EACH ELEMENT OF THE HASH 663 . I $QS(H2I,$QL(H2I))="M" D Q ; SPECIAL CASE FOR MULTIPLES 664 . . ;W H2I_"^"_@IHASH@(H2I),! 665 . . N IH,IHI 666 . . S IH=$NA(@IHASH@(H2I)) ; 667 . . S IH2A=$O(@IH@("")) ; SKIP OVER MULTIPLE DISCRIPTOR 668 . . S IH2=$NA(@IH@(IH2A)) ; PAST THE "M","DIRETIONS" FOR EXAMPLE 669 . . S IHI="" ; INDEX INTO "M" MULTIPLES 670 . . F S IHI=$O(@IH2@(IHI)) Q:IHI="" D ; FOR EACH SUB-MULTIPLE 671 . . . ; W @IH@(IHI) 672 . . . S IH3=$NA(@IH2@(IHI)) 673 . . . ; W "HEY",IH3,! 674 . . . D H2ARY(.IARYRTN,IH3,IPRE_";"_IHI) ; RECURSIVE CALL - INDENTED ELEMENTS 675 . . ; W IH,! 676 . . ; W "C0CZZ",! 677 . . ; W $NA(@IHASH@(H2I)),! 678 . . Q ; 679 . D PUSH(IARYRTN,IPRE_"^"_H2I_"^"_@IHASH@(H2I)) 680 . ; W @IARYRTN@(0),! 681 Q 682 ; 683 XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES 684 ; DEFINED IN INPUT XML XVIXML BY @@VAR@@ 685 ; XVRTN AND XVIXML ARE PASSED BY NAME 686 ; 687 N XVI,XVTMP,XVT 688 F XVI=1:1:@XVIXML@(0) D ; FOR ALL LINES OF THE XML 689 . S XVT=@XVIXML@(XVI) 690 . I XVT["@@" S XVTMP($P(XVT,"@@",2))=XVI 691 D H2ARY(XVRTN,"XVTMP") 692 Q 693 ; 694 DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE 695 ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE 696 ; 697 N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED 698 I DXIN="CCR" D ; NEED TO GO GET CCR TEMPLATE 699 . D LOAD^C0CCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP 700 . S DXUSE="DTMP" ; DXUSE IS NAME 701 E I DXIN="CCD" D ; NEED TO GO GET CCD TEMPLATE 702 . D LOAD^C0CCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP 703 . S DXUSE="DTMP" ; DXUSE IS NAME 704 E S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE 705 N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE 706 D XVARS("DVARS",DXUSE) ; PULL OUT VARS 707 D PARY^C0CXPATH("DVARS") ;AND DISPLAY THEM 708 Q 709 ; 710 TEST ; Run all the test cases 711 D TESTALL^C0CUNIT("C0CXPAT0") 712 Q 713 ; 714 ZTEST(WHICH) ; RUN ONE SET OF TESTS 715 N ZTMP 716 S DEBUG=1 717 D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") 718 D ZTEST^C0CUNIT(.ZTMP,WHICH) 719 Q 720 ; 721 TLIST ; LIST THE TESTS 722 N ZTMP 723 D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") 724 D TLIST^C0CUNIT(.ZTMP) 725 Q 726 ;
Note:
See TracChangeset
for help on using the changeset viewer.